Reverted changes which broke setup-plt.
svn: r1871
This commit is contained in:
Carl Eastlund
parent
7efb1e0db6
commit
24b9e2f5c7
|
|
@ -1,103 +1,102 @@
|
|||
(module ast mzscheme
|
||||
|
||||
(require (lib "contract.ss")
|
||||
"contract.ss"
|
||||
"utils.ss")
|
||||
|
||||
(define-struct/p/c ast ; parent of AST hierarchy
|
||||
([syntax (maybe syntax?)] ; all nodes have syntax information
|
||||
))
|
||||
(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
|
||||
|
||||
;; Type AST nodes
|
||||
(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
|
||||
(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
|
||||
|
||||
;; Definition AST nodes
|
||||
(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 (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: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 (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: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
|
||||
(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
|
||||
|
||||
;; AST nodes for member declarations (in interfaces)
|
||||
(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
|
||||
(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-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
|
||||
(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-struct/p (ast:super-new ast) (args))
|
||||
(define-honu-struct (super-new ast) (args))
|
||||
|
||||
;; Expression AST nodes
|
||||
(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))
|
||||
(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))
|
||||
|
||||
;; Miscellaneous AST nodes
|
||||
(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
|
||||
(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
|
||||
)
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
|
||||
;; Macro definitions
|
||||
|
||||
(define-syntax (define/provide stx)
|
||||
(define-syntax (define/p stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (NAME . ARGS) BODY ...)
|
||||
#`(begin
|
||||
|
|
@ -19,7 +19,7 @@
|
|||
(provide NAME))]
|
||||
))
|
||||
|
||||
(define-syntax (define/provide/contract stx)
|
||||
(define-syntax (define/c stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (NAME . ARGS) CONTRACT BODY ...)
|
||||
#`(begin
|
||||
|
|
@ -31,97 +31,39 @@
|
|||
(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)
|
||||
|
||||
(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) ...)]))
|
||||
|
||||
(define (build-provide struct-stx)
|
||||
(syntax-case struct-stx ()
|
||||
[(NAME (FIELD ...) STRUCT ...)
|
||||
#`(begin
|
||||
(provide (struct NAME (FIELD ...)))
|
||||
#,(build-provide #'STRUCT) ...)]))
|
||||
|
||||
(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) ...
|
||||
#,(build-provide #'STRUCT) ...))]))
|
||||
|
||||
(define-syntax (define-structs/provide/contract stx)
|
||||
|
||||
(define (build-define-struct struct-stx var-stx)
|
||||
(syntax-case struct-stx ()
|
||||
[(NAME ([FIELD CONTRACT] ...) STRUCT ...)
|
||||
#`(begin
|
||||
(define-struct NAME (FIELD ...) #,var-stx)
|
||||
#,(build-define-struct #'STRUCT var-stx) ...)]))
|
||||
(define inspector-var
|
||||
(with-syntax ([(VAR) (generate-temporaries #'(inspector))]) #'VAR))
|
||||
|
||||
(define (build-provide/contract struct-stx parent-fields)
|
||||
(syntax-case struct-stx ()
|
||||
[(NAME ([FIELD CONTRACT-EXPR] ...) STRUCT ...)
|
||||
(with-syntax ([(PARENT-FIELD ...) parent-fields]
|
||||
[(CONTRACT-VAR ...) (generate-temporaries #'(CONTRACT-EXPR ...))]
|
||||
[FIELDS #'(PARENT-FIELD ... [FIELD CONTRACT-VAR] ...)])
|
||||
#`(begin
|
||||
(define CONTRACT-VAR CONTRACT-EXPR) ...
|
||||
(provide/contract
|
||||
(struct NAME FIELDS))
|
||||
#,(build-provide #'STRUCT #'FIELDS) ...))]))
|
||||
(define (build-define-struct spec-stx)
|
||||
(syntax-case spec-stx ()
|
||||
[(NAME ([FIELD CONTRACT] ...) SPEC ...)
|
||||
#`(begin
|
||||
(define-struct NAME (FIELD ...) #,inspector-var)
|
||||
#,@(map build-define-struct (syntax->list #'(SPEC ...))))]))
|
||||
|
||||
(define (build-provide/contract parent inherit)
|
||||
(lambda (spec-stx)
|
||||
(syntax-case spec-stx ()
|
||||
[(NAME ([FIELD CONTRACT] ...) SPEC ...)
|
||||
(with-syntax ([(CONTRACT-VAR ...) (generate-temporaries #'(CONTRACT ...))]
|
||||
[(INHERIT ...) inherit])
|
||||
(with-syntax ([(CURRENT ...) #'(INHERIT ... [FIELD CONTRACT-VAR] ...)])
|
||||
#`(begin
|
||||
(provide/contract
|
||||
(struct #,(if parent #`(NAME #,parent) #'NAME) (CURRENT ...)))
|
||||
#,@(map (build-provide/contract #'NAME #'(CURRENT ...))
|
||||
(syntax->list #'(SPEC ...))))))])))
|
||||
|
||||
(syntax-case stx ()
|
||||
[(_ INSPECTOR-EXPR STRUCT ...)
|
||||
(with-syntax ([(INSPECTOR-VAR) (generate-temporaries #'(INSPECTOR-EXPR))])
|
||||
[(_ INSPECTOR SPEC ...)
|
||||
(let* ([specs (syntax->list #'(SPEC ...))])
|
||||
#`(begin
|
||||
(define INSPECTOR-VAR INSPECTOR-EXPR)
|
||||
#,(build-define-struct #'STRUCT #'INSPECTOR-VAR) ...
|
||||
#,(build-provide/contract #'STRUCT #'()) ...))]))
|
||||
(define #,inspector-var INSPECTOR)
|
||||
#,@(map build-define-struct specs)
|
||||
#,@(map (build-provide/contract #f #'()) specs)))]))
|
||||
|
||||
(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
|
||||
|
|
@ -148,9 +90,8 @@
|
|||
|
||||
(provide
|
||||
define/p
|
||||
define/p/c
|
||||
define-struct/p
|
||||
define-struct/p/c
|
||||
define/c
|
||||
define-structs/provide/contract
|
||||
)
|
||||
|
||||
;; Value exports
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
(module utils mzscheme
|
||||
|
||||
(require (prefix srfi1: (lib "list.ss" "srfi" "1"))
|
||||
(lib "list.ss"))
|
||||
(lib "list.ss")
|
||||
"contract.ss")
|
||||
|
||||
(provide fold-with-rest
|
||||
get-first-non-unique-name
|
||||
|
|
@ -11,7 +12,9 @@
|
|||
partition-first
|
||||
unique?
|
||||
curry
|
||||
false?)
|
||||
false?
|
||||
define/c
|
||||
define/p)
|
||||
|
||||
(define (map-values-rev-accs f lists accs)
|
||||
(cond [(andmap empty? lists) (apply values (map reverse accs))]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user