From 07c86de139d35c589b8760f429ea3fbfb6048529 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Wed, 18 Jan 2006 22:54:17 +0000 Subject: [PATCH] Honu: BROKEN (will fix in upcoming checkin) - added current partial changes to todo list - renamed most ast structs (haven't propagated) - added contracts to some ast structs (haven't finished) - removed define,provide,contract helpers from utils.ss - started contracts.ss for those and others - began writing define-structs,provide,contract for defining hierarchies of structs at once svn: r1859 --- collects/honu/ast.ss | 167 ++++++++++++++++++------------------ collects/honu/cce-notes.txt | 4 + collects/honu/contract.ss | 111 ++++++++++++++++++++++++ collects/honu/utils.ss | 60 +------------ 4 files changed, 203 insertions(+), 139 deletions(-) create mode 100644 collects/honu/contract.ss diff --git a/collects/honu/ast.ss b/collects/honu/ast.ss index 121fa0278e..7f5bd4a408 100644 --- a/collects/honu/ast.ss +++ b/collects/honu/ast.ss @@ -1,102 +1,103 @@ (module ast mzscheme + + (require (lib "contract.ss") + "contract.ss" + "utils.ss") - (provide (all-defined)) - - (define-syntax (define-honu-struct stx) - (syntax-case stx () - [(_ (id sup) (field ...)) - (with-syntax [(new-id - (datum->syntax-object - #'id - (string->symbol - (string-append "honu:" (symbol->string (syntax-e #'id)))) #'id #'id)) - (new-sup - (datum->syntax-object - #'sup - (string->symbol - (string-append "honu:" (symbol->string (syntax-e #'sup)))) #'sup #'sup))] - #'(define-struct (new-id new-sup) (field ...) #f))] - [(_ id (field ...)) - (with-syntax [(new-id (datum->syntax-object #'id (string->symbol (string-append "honu:" (symbol->string (syntax-e #'id)))) #'id #'id))] - #'(define-struct new-id (field ...) #f))])) - - (define-honu-struct ast (stx)) ; ensures that all nodes have a stx obj + (define-struct/p/c ast ; parent of AST hierarchy + ([syntax (maybe syntax?)] ; all nodes have syntax information + )) ;; Type AST nodes - (define-honu-struct (type ast) ()) ; used only for type? - (define-honu-struct (type-top type) ()) ; used to represent "void" (i.e. unit) - (define-honu-struct (type-bot type) ()) ; used to represent a term okay in _any_ context (like error) - (define-honu-struct (type-prim type) (name)) ; used to represent primitive types (int, string, char, etc.) - (define-honu-struct (type-tuple type) (args)) ; used to represent a tuple of types - (define-honu-struct (type-func type) (arg ret)) ; used for functions (no dispatch) - (define-honu-struct (type-disp type) (disp arg ret)) ; used for methods (single dispatch) or multi-dispatch (if later added) - (define-honu-struct (type-iface type) (name)) ; used for interface types (except for next two, which are more specific) - (define-honu-struct (type-iface-top type) ()) ; used for the Any type - (define-honu-struct (type-iface-bot type) ()) ; used for the type that null has - - (define-honu-struct (type-select type) (slot type)) ; used only for context type in the typechecker when #n is encountered + (define-struct/p/c (ast:type ast) ()) ; parent of type hierarchy + (define-struct/p/c (ast:type:top ast:type) ()) ; "void" or "unit" type + (define-struct/p/c (ast:type:bot ast:type) ()) ; "bottom" type, used for errors, nontermination, etc. + (define-struct/p/c (ast:type:prim ast:type); primitive types (int, string, char, etc.) + ([name symbol?] ; name of the primitive type + )) + (define-struct/p/c (ast:type:tuple ast:type) ; tuple types + ([elems (listof ast:type?)] ; types of each tuple position + )) + (define-struct/p/c (ast:type:partial-tuple ast:type) ; partial tuple type information + ([position integer?] ; which position of the tuple is known + [type ast:type?] ; the type of the known tuple position + )) + (define-struct/p/c (ast:type:func ast:type) ; function types (non-dispatching) + ([arg ast:type?] ; argument type + [ret ast:type?] ; return type + )) + (define-struct/p/c (ast:type:method ast:type) ; method types (dispatching functions) + ([dispatch ast:type?] ; the static type on which to dispatch + [arg ast:type?] ; argument type + [ret ast:type?] ; return type + )) + (define-struct/p/c (ast:type:iface ast:type) ; standard named interfaces + ([name identifier?] ; interface name + )) + (define-struct/p/c (ast:type:iface-top ast:type) ()) ; special Any interface + (define-struct/p/c (ast:type:iface-bot ast:type) ()) ; special type for null ;; Definition AST nodes - (define-honu-struct (defn ast) ()) ; used for defn? - (define-honu-struct (iface defn) (name supers members)) ; used for interface definitions - (define-honu-struct (class defn) (name type final? impls inits ; used for class definitions - members exports)) - (define-honu-struct (mixin defn) (name type sub-type final? impls ; used for mixin definitions - inits withs super-new - members-before members-after exports)) - (define-honu-struct (subclass defn) (name base mixin)) ; used for subclass definitions + (define-struct/p (ast:defn ast) ()) ; used for defn? + (define-struct/p (ast:defn:iface ast:defn) (name supers members)) ; used for interface definitions + (define-struct/p (ast:defn:class ast:defn) (name type final? impls inits ; used for class definitions + members exports)) + (define-struct/p (ast:defn:mixin ast:defn) (name type sub-type final? impls ; used for mixin definitions + inits withs super-new + members-before members-after exports)) + (define-struct/p (ast:defn:subclass ast:defn) (name base mixin)) ; used for subclass definitions - (define-honu-struct (struct defn) (name type final? impls inits ; used for structs, later replaced with components - members exports)) - (define-honu-struct (substruct defn) (name type base arg-type final? impls ; same, but for structs that are subclasses - inits withs super-new - members-before members-after exports)) + (define-struct/p (ast:defn:struct ast:defn) (name type final? impls inits ; used for structs, later replaced with components + members exports)) + (define-struct/p (ast:defn:substruct ast:defn) (name type base arg-type final? impls ; same, but for structs that are subclasses + inits withs super-new + members-before members-after exports)) - (define-honu-struct (function defn) (name type formals body)) ; used for function definitions - (define-honu-struct (bind-top defn) (names types value)) ; used for top-level definitions + (define-struct/p (ast:defn:function ast:defn) (name type formals body)) ; used for function definitions + (define-struct/p (ast:defn:bind ast:defn) (names types value)) ; used for top-level definitions ;; AST nodes for member declarations (in interfaces) - (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 + (define-struct/p (ast:member-decl ast) (name)) ; member-decl? + (define-struct/p (ast:member-decl:field ast:member-decl) (type)) ; used for field declarations + (define-struct/p (ast:member-decl:method ast:member-decl) (type arg-types)) ; used for method declarations ;; AST nodes for member definitions (in classes/mixins) - (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 + (define-struct/p (ast:member-defn ast) (name)) ; member-defn? + (define-struct/p (ast:member-defn:init-field ast:member-defn) (type value)) ; used for init fields (value can be #f or expression AST) + (define-struct/p (ast:member-defn:field ast:member-defn) (type value)) ; used for fields (value can be #f or expression AST) + (define-struct/p (ast:member-defn:method ast:member-defn) (type formals body)) ; used for methods ;; AST node for super call (just in mixins/subclasses) - (define-honu-struct (super-new ast) (args)) + (define-struct/p (ast:super-new ast) (args)) ;; Expression AST nodes - (define-honu-struct (expr ast) ()) - (define-honu-struct (this expr) ()) - (define-honu-struct (var expr) (name)) - (define-honu-struct (assn expr) (lhs rhs)) - (define-honu-struct (call expr) (func arg)) - (define-honu-struct (lit expr) (type value)) - (define-honu-struct (un-op expr) (op op-stx op-type arg)) - (define-honu-struct (bin-op expr) (op op-stx op-type larg rarg)) - (define-honu-struct (lambda expr) (type formals body)) - (define-honu-struct (if expr) (cond then else)) - (define-honu-struct (cast expr) (obj type)) - (define-honu-struct (isa expr) (obj type)) - (define-honu-struct (member expr) (obj elab name method?)) ;; method is only needed for translation - (define-honu-struct (let expr) (bindings body)) - (define-honu-struct (seq expr) (effects value)) - (define-honu-struct (new expr) (class type args)) - (define-honu-struct (cond expr) (clauses else)) - (define-honu-struct (while expr) (cond body)) - (define-honu-struct (return expr) (body)) - (define-honu-struct (tuple expr) (vals)) - (define-honu-struct (select expr) (slot arg)) + (define-struct/p (ast:expr ast) ()) + (define-struct/p (ast:expr:this ast:expr) ()) + (define-struct/p (ast:expr:var ast:expr) (name)) + (define-struct/p (ast:expr:assn ast:expr) (lhs rhs)) + (define-struct/p (ast:expr:call ast:expr) (func arg)) + (define-struct/p (ast:expr:lit ast:expr) (type value)) + (define-struct/p (ast:expr:un-op ast:expr) (op op-stx op-type arg)) + (define-struct/p (ast:expr:bin-op ast:expr) (op op-stx op-type larg rarg)) + (define-struct/p (ast:expr:lambda ast:expr) (type formals body)) + (define-struct/p (ast:expr:if ast:expr) (cond then else)) + (define-struct/p (ast:expr:cast ast:expr) (obj type)) + (define-struct/p (ast:expr:isa ast:expr) (obj type)) + (define-struct/p (ast:expr:member ast:expr) (obj elab name method?)) ;; method is only needed for translation + (define-struct/p (ast:expr:let ast:expr) (bindings body)) + (define-struct/p (ast:expr:seq ast:expr) (effects value)) + (define-struct/p (ast:expr:new ast:expr) (class type args)) + (define-struct/p (ast:expr:cond ast:expr) (clauses else)) + (define-struct/p (ast:expr:while ast:expr) (cond body)) + (define-struct/p (ast:expr:return ast:expr) (body)) + (define-struct/p (ast:expr:tuple ast:expr) (vals)) + (define-struct/p (ast:expr:select ast:expr) (slot arg)) ;; Miscellaneous AST nodes - (define-honu-struct (binding ast) (names types value)) ; used for bindings in lets - (define-honu-struct (export ast) (type binds)) ; used for export statements - (define-honu-struct exp-bind (old new)) ; used for export bindings - (define-honu-struct (formal ast) (name type)) ; used for formal arguments - (define-honu-struct name-arg (name value)) ; used for by-name arguments (like new) - (define-honu-struct (cond-clause ast) (pred rhs)) ; used for cond clauses + (define-struct/p (ast:binding ast) (names types value)) ; used for bindings in lets + (define-struct/p (ast:export ast) (type binds)) ; used for export statements + (define-struct/p (ast:export-bind ast) (old new)) ; used for export bindings + (define-struct/p (ast:formal ast) (name type)) ; used for formal arguments + (define-struct/p (ast:name-arg ast) (name value)) ; used for by-name arguments (like new) + (define-struct/p (ast:cond-clause ast) (pred rhs)) ; used for cond clauses ) diff --git a/collects/honu/cce-notes.txt b/collects/honu/cce-notes.txt index 47610cb6f8..af74503894 100644 --- a/collects/honu/cce-notes.txt +++ b/collects/honu/cce-notes.txt @@ -1,5 +1,9 @@ Todo: +AST +- changed names in ast.ss, propagate to everywhere else +- added (some) contracts; add the rest and verify what's there +- finish writing, and use, define-structs[/provide[/contract]] Mixin Sealing - move to single, applicative environment Test Suite Improvements diff --git a/collects/honu/contract.ss b/collects/honu/contract.ss new file mode 100644 index 0000000000..ab65e97b83 --- /dev/null +++ b/collects/honu/contract.ss @@ -0,0 +1,111 @@ +(module contract mzscheme + + ;; Provides helpers for contract.ss + + (require (lib "contract.ss")) + (require-for-template (lib "contract.ss")) + + ;; Macro definitions + + (define-syntax (define/provide stx) + (syntax-case stx () + [(_ (NAME . ARGS) BODY ...) + #`(begin + (define (NAME . ARGS) BODY ...) + (provide NAME))] + [(_ NAME BODY ...) + #`(begin + (define NAME BODY ...) + (provide NAME))] + )) + + (define-syntax (define/provide/contract stx) + (syntax-case stx () + [(_ (NAME . ARGS) CONTRACT BODY ...) + #`(begin + (define (NAME . ARGS) BODY ...) + (provide/contract [NAME CONTRACT]))] + [(_ NAME CONTRACT BODY ...) + #`(begin + (define NAME BODY ...) + (provide/contract [NAME CONTRACT]))] + )) + + (define-syntax (define-structs stx) + + (define (build-define-struct struct-stx var-stx) + (syntax-case struct-stx () + [(NAME (FIELD ...) STRUCT ...) + #`(begin + (define-struct NAME (FIELD ...) #,var-stx) + #,(build-define-struct #'STRUCT var-stx) ...)])) + + (syntax-case stx () + [(_ INSPECTOR-EXPR STRUCT ...) + (with-syntax ([(INSPECTOR-VAR) (generate-temporaries #'(INSPECTOR-EXPR))]) + #`(begin + (define INSPECTOR-VAR INSPECTOR-EXPR) + #,(build-define-struct #'STRUCT #'INSPECTOR-VAR) ...))])) + + (define-syntax (define-structs/provide stx) + (syntax-case stx () + [(_ (NAME SUPER) (FIELD ...) REST ...) + #`(begin + (define-struct (NAME SUPER) (FIELD ...) REST ...) + (provide (struct NAME (FIELD ...))))] + [(_ NAME (FIELD ...) REST ...) + #`(begin + (define-struct NAME (FIELD ...) REST ...) + (provide (struct NAME (FIELD ...))))])) + + (define-syntax (define-structs/provide/contract stx) + (syntax-case stx () + [(_ (NAME SUPER) ([FIELD CONTRACT] ...) REST ...) + #`(begin + (define-struct (NAME SUPER) (FIELD ...) REST ...) + (provide/contract (struct NAME ([FIELD CONTRACT] ...))))] + [(_ NAME ([FIELD CONTRACT] ...) REST ...) + #`(begin + (define-struct NAME (FIELD ...) REST ...) + (provide/contract (struct NAME ([FIELD CONTRACT] ...))))])) + + ;; Value definitions + + ;; unknown/c : FlatContract + ;; Rejects everything; use to guarantee a visible error. + (define unknown/c + (not/c any/c)) + + ;; maybe : [Union Predicate FlatContract] -> FlatContract + ;; Accepts either a Value or #f. + (define (maybe value/c) + (union value/c false/c)) + + ;; predicate : Contract + ;; Accepts value predicates. + (define predicate/c + (any/c . -> . boolean?)) + + ;; flat-contract-or-predicate/c : Contract + ;; Accepts flat-contract arguments (flat contracts or predicates). + (define flat-contract-or-predicate/c + (union predicate/c flat-contract?)) + + ;; Macro exports + + (provide + define/p + define/p/c + define-struct/p + define-struct/p/c + ) + + ;; Value exports + + (provide/contract + [predicate/c contract?] + [maybe (flat-contract-or-predicate/c . -> . flat-contract?)] + [flat-contract-or-predicate/c flat-contract?] + ) + + ) \ No newline at end of file diff --git a/collects/honu/utils.ss b/collects/honu/utils.ss index e1131d859f..529cbe9d5d 100644 --- a/collects/honu/utils.ss +++ b/collects/honu/utils.ss @@ -1,69 +1,17 @@ (module utils mzscheme - (require (lib "contract.ss") - (prefix srfi1: (lib "list.ss" "srfi" "1")) + (require (prefix srfi1: (lib "list.ss" "srfi" "1")) (lib "list.ss")) - (require-for-template (lib "contract.ss")) - - (provide define-struct/c - define-struct/p - define/c - define/p - fold-with-rest + (provide fold-with-rest get-first-non-unique-name map-and-fold map-two-values + map-values partition-first unique? curry false?) - - (define-syntax (define/p stx) - (syntax-case stx () - [(_ (NAME . ARGS) BODY ...) - #`(begin - (define (NAME . ARGS) BODY ...) - (provide NAME))] - [(_ NAME BODY ...) - #`(begin - (define NAME BODY ...) - (provide NAME))] - )) - - (define-syntax (define/c stx) - (syntax-case stx () - [(_ (NAME . ARGS) CONTRACT BODY ...) - #`(begin - (define (NAME . ARGS) BODY ...) - (provide/contract [NAME CONTRACT]))] - [(_ NAME CONTRACT BODY ...) - #`(begin - (define NAME BODY ...) - (provide/contract [NAME CONTRACT]))] - )) - - (define-syntax (define-struct/p stx) - (syntax-case stx () - [(_ (NAME SUPER) (FIELD ...) REST ...) - #`(begin - (define-struct (NAME SUPER) (FIELD ...) REST ...) - (provide (struct NAME (FIELD ...))))] - [(_ NAME (FIELD ...) REST ...) - #`(begin - (define-struct NAME (FIELD ...) REST ...) - (provide (struct NAME (FIELD ...))))])) - - (define-syntax (define-struct/c stx) - (syntax-case stx () - [(_ (NAME SUPER) ([FIELD CONTRACT] ...) REST ...) - #`(begin - (define-struct (NAME SUPER) (FIELD ...) REST ...) - (provide/contract (struct NAME ([FIELD CONTRACT] ...))))] - [(_ NAME ([FIELD CONTRACT] ...) REST ...) - #`(begin - (define-struct NAME (FIELD ...) REST ...) - (provide/contract (struct NAME ([FIELD CONTRACT] ...))))])) (define (map-values-rev-accs f lists accs) (cond [(andmap empty? lists) (apply values (map reverse accs))] @@ -71,7 +19,7 @@ [else (call-with-values (lambda () (apply f (map first lists))) (lambda vs (map-values-rev-accs f (map rest lists) (map cons vs accs))))])) - (define/p (map-values f . lists) + (define (map-values f . lists) (cond [(empty? lists) (error 'map-values "expects 1 or more input lists")] [(ormap empty? lists) (error 'map-values "expects non-empty lists")] [else