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
This commit is contained in:
Carl Eastlund
parent
bebce2bb3d
commit
07c86de139
|
|
@ -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
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
111
collects/honu/contract.ss
Normal file
111
collects/honu/contract.ss
Normal file
|
|
@ -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?]
|
||||
)
|
||||
|
||||
)
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user