Merged 1145:1303 from branches/kathyg (only collects/profj directory)
Changes Beginner to have interfaces; assorted bug fixes svn: r1305
This commit is contained in:
Kathy Gray
parent
3f9d7f4e5a
commit
f5c3b8aa6c
|
|
@ -1,7 +1,5 @@
|
|||
;;Kathy Gray, December 2001
|
||||
;;Abstract syntax tree for Java
|
||||
|
||||
#cs
|
||||
(module ast mzscheme
|
||||
|
||||
;Macro to allow structure definition and provision
|
||||
|
|
|
|||
|
|
@ -533,11 +533,11 @@
|
|||
((ctor?) (has-ctor? m)))
|
||||
|
||||
(unless ctor?
|
||||
(when (and (eq? level 'beginner) (not (memq 'abstract test-mods)))
|
||||
(when (and (eq? level 'beginner) #;(not (memq 'abstract test-mods)))
|
||||
(beginner-ctor-error 'none (header-id info) (id-src (header-id info))))
|
||||
(add-ctor class (lambda (rec) (set! m (cons rec m))) old-methods (header-id info) level))
|
||||
|
||||
(when (and ctor? (eq? level 'beginner) (memq 'abstract test-mods))
|
||||
#;(when (and ctor? (eq? level 'beginner) (memq 'abstract test-mods))
|
||||
(beginner-ctor-error 'abstract (header-id info) (id-src (header-id info))))
|
||||
|
||||
(valid-field-names? (if (memq level '(beginner intermediate advanced))
|
||||
|
|
@ -548,7 +548,7 @@
|
|||
(when (not (memq 'abstract test-mods))
|
||||
(and (class-fully-implemented? super-record super
|
||||
iface-records (header-implements info)
|
||||
m level)
|
||||
m type-recs level)
|
||||
(no-abstract-methods m members level type-recs)))
|
||||
|
||||
(valid-inherited-methods? (cons super-record iface-records)
|
||||
|
|
@ -585,7 +585,7 @@
|
|||
iface))
|
||||
(filter (lambda (iface) (not (null? iface)))
|
||||
(append (map name->list (header-implements info))
|
||||
(map class-record-parents iface-records)
|
||||
(apply append (map class-record-parents iface-records))
|
||||
(class-record-ifaces super-record)))))))
|
||||
(when put-in-table? (send type-recs add-class-record record))
|
||||
|
||||
|
|
@ -721,7 +721,9 @@
|
|||
|
||||
(valid-iface-extend? super-records (header-extends info))
|
||||
|
||||
(let-values (((f m i) (process-members members null iname type-recs level)))
|
||||
(let-values (((f m i) (process-members members (apply append
|
||||
(map class-record-methods super-records))
|
||||
iname type-recs level)))
|
||||
|
||||
(valid-field-names? f members m level type-recs)
|
||||
(valid-method-sigs? m members level type-recs)
|
||||
|
|
@ -815,6 +817,7 @@
|
|||
;find-member: (U field-record method-record) (list member) symbol type-records -> member
|
||||
(define (find-member member-record members level type-recs)
|
||||
(when (null? members)
|
||||
(print-struct #t)
|
||||
(printf "~a~n" member-record)
|
||||
(error 'internal-error "Find-member given a member that is not contained in the member list"))
|
||||
(cond
|
||||
|
|
@ -851,6 +854,20 @@
|
|||
;valid-method-sigs? (list method-record) (list member) symbol type-records -> bool
|
||||
(define (valid-method-sigs? methods members level type-recs)
|
||||
(or (null? methods)
|
||||
(let ((res (same-method-name? (car methods) (cdr methods)))
|
||||
(m (and (not (eq? 'ctor (method-record-rtype (car methods))))
|
||||
(find-member (car methods) members level type-recs)))
|
||||
(class (method-record-class (car methods))))
|
||||
(and res m (memq level '(beginner intermediate))
|
||||
(not (type=? (method-record-rtype (car methods))
|
||||
(method-record-rtype res)))
|
||||
(method-error 'bad-ret
|
||||
(method-name m)
|
||||
(map field-type (method-parms m))
|
||||
(method-record-rtype (car methods))
|
||||
(car class)
|
||||
(method-src m)
|
||||
(method-record-rtype res))))
|
||||
(and (method-member? (car methods) (cdr methods) level)
|
||||
(let ((m (find-member (car methods) members level type-recs))
|
||||
(class (method-record-class (car methods))))
|
||||
|
|
@ -858,14 +875,14 @@
|
|||
(method-error 'inherited-conflict-field
|
||||
(field-name m)
|
||||
null
|
||||
#f
|
||||
(car class)
|
||||
(field-src m)
|
||||
#f)
|
||||
(method-error 'repeated
|
||||
(method-name m)
|
||||
(map field-type #;(lambda (t)
|
||||
(type-spec-to-type (field-type-spec t) class level type-recs))
|
||||
(method-parms m))
|
||||
(map field-type (method-parms m))
|
||||
'void
|
||||
(car class)
|
||||
(method-src m)
|
||||
(eq? (method-record-rtype (car methods)) 'ctor)))))
|
||||
|
|
@ -878,13 +895,14 @@
|
|||
(method-error 'inherited-conflict-field
|
||||
(field-name m)
|
||||
null
|
||||
#f
|
||||
(car class)
|
||||
(field-src m)
|
||||
#f)
|
||||
(method-error 'ctor-ret-value
|
||||
(method-name m)
|
||||
(map field-type #;(lambda (t) (type-spec-to-type (field-type-spec t) class level type-recs))
|
||||
(method-parms m))
|
||||
(map field-type (method-parms m))
|
||||
(type-spec-to-type (method-type) #f level type-recs)
|
||||
(car class)
|
||||
(method-src m)
|
||||
#f))))
|
||||
|
|
@ -897,30 +915,50 @@
|
|||
(method-error 'inherited-conflict-field
|
||||
(field-name m)
|
||||
null
|
||||
#f
|
||||
(car class)
|
||||
(field-src m)
|
||||
#f)
|
||||
(method-error 'class-name
|
||||
(method-name m)
|
||||
(map field-type #;(lambda (t) (type-spec-to-type (field-type-spec t) class level type-recs))
|
||||
(method-parms m))
|
||||
(map field-type (method-parms m))
|
||||
(type-spec-to-type (method-type m) #f level type-recs)
|
||||
(car class)
|
||||
(method-src m)
|
||||
(eq? (method-record-rtype (car methods)) 'ctor)))))
|
||||
(valid-method-sigs? (cdr methods) members level type-recs)))
|
||||
|
||||
;same-method-name? method-record (list method-record) -> (U #f method-record)
|
||||
(define (same-method-name? method methods)
|
||||
(and (not (null? methods))
|
||||
(or (and (equal? (method-record-name method)
|
||||
(method-record-name (car methods)))
|
||||
(car methods))
|
||||
(same-method-name? method (cdr methods)))))
|
||||
|
||||
(define (method-member? method methods level)
|
||||
(and (not (null? methods))
|
||||
(or (and (equal? (method-record-name method)
|
||||
(method-record-name (car methods)))
|
||||
(type=? (method-record-rtype method) (method-record-rtype (car methods)))
|
||||
(or (or (eq? level 'beginner) (eq? level 'intermediate))
|
||||
(or (memq level '(beginner intermediate))
|
||||
(and (= (length (method-record-atypes method))
|
||||
(length (method-record-atypes (car methods))))
|
||||
(andmap type=? (method-record-atypes method)
|
||||
(method-record-atypes (car methods))))))
|
||||
(method-member? method (cdr methods) level))))
|
||||
|
||||
(define (identical-method-member? method methods)
|
||||
(and (not (null? methods))
|
||||
(or (and (equal? (method-record-name method)
|
||||
(method-record-name (car methods)))
|
||||
(type=? (method-record-rtype method) (method-record-rtype (car methods)))
|
||||
(= (length (method-record-atypes method))
|
||||
(length (method-record-atypes (car methods))))
|
||||
(andmap type=? (method-record-atypes method)
|
||||
(method-record-atypes (car methods))))
|
||||
(identical-method-member? method (cdr methods)))))
|
||||
|
||||
;valid-inherited-methods?: (list class-record) (list name) symbol type-records -> bool
|
||||
(define (valid-inherited-methods? records extends level type-recs)
|
||||
(or (null? records)
|
||||
|
|
@ -940,6 +978,7 @@
|
|||
(method-error 'inherit-conflict
|
||||
(method-record-name (car methods))
|
||||
(method-record-atypes (car methods))
|
||||
(method-record-rtype (car methods))
|
||||
(id-string (name-id from))
|
||||
(name-src from)
|
||||
#f))
|
||||
|
|
@ -950,12 +989,13 @@
|
|||
(and (not (null? methods))
|
||||
(or (and (equal? (method-record-name method)
|
||||
(method-record-name (car methods)))
|
||||
(or (or (eq? level 'beginner) (eq? level 'intermediate))
|
||||
(or (memq level '(beginner intermediate))
|
||||
(and (= (length (method-record-atypes method)) (length (method-record-atypes (car methods))))
|
||||
(andmap type=? (method-record-atypes method) (method-record-atypes (car methods)))))
|
||||
(not (type=? (method-record-rtype method) (method-record-rtype (car methods)))))
|
||||
(method-conflicts? method (cdr methods) level))))
|
||||
|
||||
;check-current-methods: (list method-record) (list method) (list member) symbol type-records -> bool
|
||||
(define (check-current-methods records methods members level type-recs)
|
||||
(or (null? records)
|
||||
(and (check-for-conflicts methods (car records) members level type-recs)
|
||||
|
|
@ -972,29 +1012,57 @@
|
|||
(method-error 'inherited-conflict-field
|
||||
(field-name method)
|
||||
null
|
||||
#f
|
||||
(car class)
|
||||
(field-src method)
|
||||
#f)
|
||||
(method-error 'conflict
|
||||
(method-name method)
|
||||
(map field-type #;(lambda (t)
|
||||
(type-spec-to-type (field-type-spec t) class level type-recs))
|
||||
(method-parms method))
|
||||
(map field-type (method-parms method))
|
||||
(type-spec-to-type (method-type method) #f level type-recs)
|
||||
(car class)
|
||||
(method-src method)
|
||||
#f))))
|
||||
(check-for-conflicts (cdr methods) record members level type-recs)))
|
||||
|
||||
;class-fully-implemented? class-record id (list class-record) (list id) (list method) symbol -> bool
|
||||
(define (class-fully-implemented? super super-name ifaces ifaces-name methods level)
|
||||
(define (class-fully-implemented? super super-name ifaces ifaces-name methods type-recs level)
|
||||
(when (memq 'abstract (class-record-modifiers super))
|
||||
(let ((unimplemented-iface-methods (get-unimplemented-methods (class-record-methods super)
|
||||
(class-record-ifaces super)
|
||||
type-recs)))
|
||||
(andmap (lambda (unimp iface)
|
||||
(or (null? unimp)
|
||||
(implements-all? unimp methods iface level)))
|
||||
(car unimplemented-iface-methods) (cadr unimplemented-iface-methods))
|
||||
(implements-all? (get-methods-need-implementing (class-record-methods super))
|
||||
methods super-name level))
|
||||
methods super-name level)))
|
||||
(andmap (lambda (iface iface-name)
|
||||
(implements-all? (class-record-methods iface) methods iface-name level))
|
||||
ifaces
|
||||
ifaces-name))
|
||||
|
||||
;get-unimplemented-methods: (list method-record) (list (list string)) type-recs -> (list (list (list method-record)) (list string(
|
||||
(define (get-unimplemented-methods methods ifaces type-recs)
|
||||
(letrec ((method-req-equal
|
||||
(lambda (mrec1 mrec2)
|
||||
(and (equal? (method-record-name mrec1) (method-record-name mrec2))
|
||||
(type=? (method-record-rtype mrec1) (method-record-rtype mrec2))
|
||||
(= (length (method-record-atypes mrec1)) (length (method-record-atypes mrec2)))
|
||||
(andmap type=? (method-record-atypes mrec1) (method-record-atypes mrec2)))))
|
||||
(method-rec-mem
|
||||
(lambda (mrec mrecs)
|
||||
(and (not (null? mrecs))
|
||||
(or (method-req-equal mrec (car mrecs))
|
||||
(method-rec-mem mrec (cdr mrecs)))))))
|
||||
(list (map (lambda (iface)
|
||||
(let ((iface-rec (send type-recs get-class-record iface)))
|
||||
(filter (lambda (m) (not (method-rec-mem m methods)))
|
||||
(class-record-methods iface-rec))))
|
||||
ifaces)
|
||||
(map (lambda (iface)
|
||||
(make-name (make-id (car iface) #f) (cdr iface) #f)) ifaces))))
|
||||
|
||||
;get-methods-need-implementing: (list method-record) -> (list method-record)
|
||||
(define (get-methods-need-implementing methods)
|
||||
(let ((abstract-methods (filter (lambda (m) (memq 'abstract (method-record-modifiers m))) methods))
|
||||
|
|
@ -1006,10 +1074,11 @@
|
|||
;implements-all? (list method-record) (list method) name symbol -> bool
|
||||
(define (implements-all? inherit-methods methods name level)
|
||||
(or (null? inherit-methods)
|
||||
(and (not (method-member? (car inherit-methods) methods level))
|
||||
(and (not (identical-method-member? (car inherit-methods) methods))
|
||||
(method-error 'not-implement
|
||||
(make-id (method-record-name (car inherit-methods)) #f)
|
||||
(method-record-atypes (car inherit-methods))
|
||||
(method-record-rtype (car inherit-methods))
|
||||
(id-string (name-id name))
|
||||
(id-src (name-id name))
|
||||
#f))
|
||||
|
|
@ -1022,9 +1091,8 @@
|
|||
(class (method-record-class (car methods))))
|
||||
(method-error 'illegal-abstract
|
||||
(method-name method)
|
||||
(map field-type #;(lambda (t)
|
||||
(type-spec-to-type (field-type-spec t) class level type-recs))
|
||||
(method-parms method))
|
||||
(map field-type (method-parms method))
|
||||
(type-spec-to-type (method-type method) #f level type-recs)
|
||||
(car class)
|
||||
(method-src method)
|
||||
#f)))
|
||||
|
|
@ -1298,7 +1366,8 @@
|
|||
(make-valid-mods
|
||||
(lambda (level)
|
||||
(case level
|
||||
((beginner intermediate) '(public abstract))
|
||||
((beginner) '(public))
|
||||
((intermediate) '(public abstract))
|
||||
((advanced) `(public protected private abstract static final))
|
||||
((full) '(public protected private abstract static final synchronized native strictfp))
|
||||
((abstract) '(public protected abstract))
|
||||
|
|
@ -1357,9 +1426,8 @@
|
|||
(define (repeated-def-name-error name class? level src)
|
||||
(let ((n (id->ext-name name)))
|
||||
(raise-error n
|
||||
(format "~a ~a shares a name with another class~a. ~a names may not be repeated"
|
||||
(if class? "Class" "Interface") n (if (eq? level 'beginner) "" " or interface")
|
||||
(if (eq? level 'beginner) "Class" "Class and interface "))
|
||||
(format "~a ~a and another class or interface have the same name. ~a names must be unique."
|
||||
(if class? "Class" "Interface") n (if class? "Class" "Interface"))
|
||||
n src)))
|
||||
|
||||
;modifier-error: symbol modifier -> void
|
||||
|
|
@ -1422,12 +1490,13 @@
|
|||
(format "Only interfaces may be implemented, class ~a has attempted to implement class ~a" n s)))
|
||||
s src)))
|
||||
|
||||
;method-error: symbol id (list type) string src bool -> void
|
||||
(define (method-error kind name parms class src ctor?)
|
||||
;method-error: symbol id (list type) type string src bool -> void
|
||||
(define (method-error kind name parms ret class src ctor?)
|
||||
(if (eq? kind 'inherited-conflict-field)
|
||||
(let ((n (id->ext-name name)))
|
||||
(raise-error n (format "Field ~a conflicts with a method of the same name from ~a" n class) n src))
|
||||
(let ((m-name (method-name->ext-name (id-string name) parms)))
|
||||
(let ((m-name (method-name->ext-name (id-string name) parms))
|
||||
(r-name (type->ext-name ret)))
|
||||
(raise-error
|
||||
m-name
|
||||
(case kind
|
||||
|
|
@ -1436,17 +1505,20 @@
|
|||
"Abstract method ~a is not allowed in non-abstract class ~a, abstract methods must be in abstract classes"
|
||||
m-name class))
|
||||
((repeated)
|
||||
(format "~a ~a has already been written in this class (~a) and cannot be written again"
|
||||
(format "~a ~a has already been written in this class, ~a, and cannot be written again"
|
||||
(if ctor? "Constructor" "Method") m-name class))
|
||||
((inherit-conflict)
|
||||
(format "Inherited method ~a from ~a conflicts with another method of the same name" m-name class))
|
||||
((conflict)
|
||||
(format "Method ~a conflicts with a method inherited from ~a" m-name class))
|
||||
((not-implement) (format "Method ~a from ~a should be implemented and was not" m-name class))
|
||||
((not-implement) (format "Method ~a returning ~a from ~a should be implemented and was not" m-name r-name class))
|
||||
((ctor-ret-value)
|
||||
(format "Constructor ~a for class ~a has a return type, which is not allowed" m-name class))
|
||||
((class-name)
|
||||
(format "Method ~a from ~a has the same name as a class, which is not allowed" m-name class)))
|
||||
(format "Method ~a from ~a has the same name as a class, which is not allowed" m-name class))
|
||||
((bad-ret)
|
||||
(format "Methods with the same name must have the same return type. Found definitions of method ~a in ~a with return types ~a and ~a."
|
||||
m-name class r-name (type->ext-name ctor?))))
|
||||
m-name src))))
|
||||
|
||||
;inherited-overload-error: string (list type) (list type) src -> void
|
||||
|
|
|
|||
|
|
@ -400,7 +400,7 @@
|
|||
(static-env (get-static-fields-env field-env))
|
||||
(setting-fields null)
|
||||
(inherited-fields null))
|
||||
(when (eq? level 'beginner)
|
||||
#;(when (eq? level 'beginner)
|
||||
(let ((parent (send type-recs get-class-record (car (class-record-parents class-record)))))
|
||||
(when (memq 'abstract (class-record-modifiers parent))
|
||||
(set! inherited-fields
|
||||
|
|
@ -451,7 +451,7 @@
|
|||
))))
|
||||
(let ((assigns (get-assigns members level (car c-class)))
|
||||
(static-assigns (get-static-assigns members level)))
|
||||
(when (eq? level 'beginner)
|
||||
#;(when (eq? level 'beginner)
|
||||
(for-each (lambda (f)
|
||||
(andmap (lambda (assign)
|
||||
(inherited-field-set? f assign extend-src))
|
||||
|
|
@ -515,7 +515,7 @@
|
|||
;field-needs-set?: field symbol bool-> bool
|
||||
(define (field-needs-set? field level abst-class?)
|
||||
(cond
|
||||
((and (eq? level 'beginner) (not abst-class?) #t))
|
||||
((and (memq level '(beginner #;intermediate)) (not abst-class?) #t))
|
||||
((memq 'final (map modifier-kind (field-modifiers field))) #t)
|
||||
(else #f)))
|
||||
|
||||
|
|
@ -940,6 +940,7 @@
|
|||
((return? statement)
|
||||
(check-return (return-expr statement)
|
||||
return
|
||||
env
|
||||
check-e-no-change
|
||||
(return-src statement)
|
||||
interactions?
|
||||
|
|
@ -1062,8 +1063,8 @@
|
|||
(send type-recs add-req (make-req "Throwable" (list "java" "lang")))))
|
||||
exp/env))
|
||||
|
||||
;check-return: expression type (expression -> type/env) src bool symbol type-records -> type/env
|
||||
(define (check-return ret-expr return check src interact? level type-recs)
|
||||
;check-return: expression type env (expression -> type/env) src bool symbol type-records -> type/env
|
||||
(define (check-return ret-expr return env check src interact? level type-recs)
|
||||
(cond
|
||||
(interact? (void))
|
||||
((and ret-expr (not (eq? 'void return)))
|
||||
|
|
@ -1074,13 +1075,14 @@
|
|||
((and ret-expr (eq? 'void return) (not (eq? level 'full)))
|
||||
(return-error 'void #f return src))
|
||||
((and (not ret-expr) (not (eq? 'void return)))
|
||||
(return-error 'val #f return src))))
|
||||
(return-error 'val #f return src))
|
||||
(else (make-type/env 'void env))))
|
||||
|
||||
;check-while: type/env src -> void
|
||||
(define (check-while cond/env src check-s loop-body)
|
||||
((check-cond 'while) (type/env-t cond/env) src)
|
||||
(check-s loop-body (type/env-e cond/env) #t #f)
|
||||
(make-type/env 'void cond/env))
|
||||
(make-type/env 'void (type/env-t cond/env)))
|
||||
|
||||
;check-do: (exp env -> type/env) exp src type/env -> type/env
|
||||
(define (check-do check-e exp src loop/env)
|
||||
|
|
@ -2487,7 +2489,9 @@
|
|||
(cond
|
||||
((and (ref-type? exp-type) (ref-type? type)
|
||||
(or (is-eq-subclass? exp-type type type-recs)
|
||||
(is-eq-subclass? type exp-type type-recs))) 'boolean)
|
||||
(is-eq-subclass? type exp-type type-recs)
|
||||
(implements? exp-type type type-recs)
|
||||
(implements? type exp-type type-recs))) 'boolean)
|
||||
((and (ref-type? exp-type) (ref-type? type))
|
||||
(instanceof-error 'not-related-type type exp-type src))
|
||||
((ref-type? exp-type)
|
||||
|
|
@ -2764,8 +2768,7 @@
|
|||
(format "attempted to call method ~a on ~a which does not have methods. ~nOnly values with ~a types have methods"
|
||||
n t
|
||||
(case level
|
||||
((beginner) "class")
|
||||
((intermediate) "class or interface")
|
||||
((beginner intermediate) "class or interface")
|
||||
(else "class, interface, or array")))
|
||||
n src)))
|
||||
|
||||
|
|
@ -2973,7 +2976,7 @@
|
|||
(let ((n (id->ext-name name))
|
||||
(t (get-call-type exp)))
|
||||
(raise-error n
|
||||
(if (memq level '(beginner abstract))
|
||||
(if (memq level '(beginner intermediate abstract))
|
||||
(format "~a does not contain a method named ~a" t n)
|
||||
(case kind
|
||||
((pro)
|
||||
|
|
|
|||
|
|
@ -7,4 +7,4 @@
|
|||
()
|
||||
()
|
||||
()
|
||||
"version2")
|
||||
"version3")
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-ArithmeticException
|
||||
wrap-convert-assert-ArithmeticException
|
||||
dynamic-ArithmeticException/c
|
||||
static-ArithmeticException/c
|
||||
ArithmeticException-ArithmeticException-constructor~generic
|
||||
ArithmeticException-ArithmeticException-constructor-java.lang.String~generic))
|
||||
static-ArithmeticException/c))
|
||||
|
|
|
|||
|
|
@ -6,7 +6,4 @@
|
|||
convert-assert-ArrayIndexOutOfBoundsException
|
||||
wrap-convert-assert-ArrayIndexOutOfBoundsException
|
||||
dynamic-ArrayIndexOutOfBoundsException/c
|
||||
static-ArrayIndexOutOfBoundsException/c
|
||||
ArrayIndexOutOfBoundsException-ArrayIndexOutOfBoundsException-constructor~generic
|
||||
ArrayIndexOutOfBoundsException-ArrayIndexOutOfBoundsException-constructor-java.lang.String~generic
|
||||
ArrayIndexOutOfBoundsException-ArrayIndexOutOfBoundsException-constructor-int~generic))
|
||||
static-ArrayIndexOutOfBoundsException/c))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-ArrayStoreException
|
||||
wrap-convert-assert-ArrayStoreException
|
||||
dynamic-ArrayStoreException/c
|
||||
static-ArrayStoreException/c
|
||||
ArrayStoreException-ArrayStoreException-constructor~generic
|
||||
ArrayStoreException-ArrayStoreException-constructor-java.lang.String~generic))
|
||||
static-ArrayStoreException/c))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-ClassCastException
|
||||
wrap-convert-assert-ClassCastException
|
||||
dynamic-ClassCastException/c
|
||||
static-ClassCastException/c
|
||||
ClassCastException-ClassCastException-constructor~generic
|
||||
ClassCastException-ClassCastException-constructor-java.lang.String~generic))
|
||||
static-ClassCastException/c))
|
||||
|
|
|
|||
|
|
@ -6,9 +6,4 @@
|
|||
convert-assert-ClassNotFoundException
|
||||
wrap-convert-assert-ClassNotFoundException
|
||||
dynamic-ClassNotFoundException/c
|
||||
static-ClassNotFoundException/c
|
||||
ClassNotFoundException-ClassNotFoundException-constructor~generic
|
||||
ClassNotFoundException-ClassNotFoundException-constructor-java.lang.String~generic
|
||||
ClassNotFoundException-ClassNotFoundException-constructor-java.lang.String-java.lang.Throwable~generic
|
||||
ClassNotFoundException-getException~generic
|
||||
ClassNotFoundException-getCause~generic))
|
||||
static-ClassNotFoundException/c))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-CloneNotSupportedException
|
||||
wrap-convert-assert-CloneNotSupportedException
|
||||
dynamic-CloneNotSupportedException/c
|
||||
static-CloneNotSupportedException/c
|
||||
CloneNotSupportedException-CloneNotSupportedException-constructor~generic
|
||||
CloneNotSupportedException-CloneNotSupportedException-constructor-java.lang.String~generic))
|
||||
static-CloneNotSupportedException/c))
|
||||
|
|
|
|||
|
|
@ -7,4 +7,4 @@
|
|||
()
|
||||
()
|
||||
()
|
||||
"version2")
|
||||
"version3")
|
||||
|
|
|
|||
|
|
@ -6,8 +6,4 @@
|
|||
convert-assert-Exception
|
||||
wrap-convert-assert-Exception
|
||||
dynamic-Exception/c
|
||||
static-Exception/c
|
||||
Exception-Exception-constructor~generic
|
||||
Exception-Exception-constructor-java.lang.String~generic
|
||||
Exception-Exception-constructor-java.lang.String-java.lang.Throwable~generic
|
||||
Exception-Exception-constructor-java.lang.Throwable~generic))
|
||||
static-Exception/c))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-IllegalAccessException
|
||||
wrap-convert-assert-IllegalAccessException
|
||||
dynamic-IllegalAccessException/c
|
||||
static-IllegalAccessException/c
|
||||
IllegalAccessException-IllegalAccessException-constructor~generic
|
||||
IllegalAccessException-IllegalAccessException-constructor-java.lang.String~generic))
|
||||
static-IllegalAccessException/c))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-IllegalArgumentException
|
||||
wrap-convert-assert-IllegalArgumentException
|
||||
dynamic-IllegalArgumentException/c
|
||||
static-IllegalArgumentException/c
|
||||
IllegalArgumentException-IllegalArgumentException-constructor~generic
|
||||
IllegalArgumentException-IllegalArgumentException-constructor-java.lang.String~generic))
|
||||
static-IllegalArgumentException/c))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-IllegalMonitorStateException
|
||||
wrap-convert-assert-IllegalMonitorStateException
|
||||
dynamic-IllegalMonitorStateException/c
|
||||
static-IllegalMonitorStateException/c
|
||||
IllegalMonitorStateException-IllegalMonitorStateException-constructor~generic
|
||||
IllegalMonitorStateException-IllegalMonitorStateException-constructor-java.lang.String~generic))
|
||||
static-IllegalMonitorStateException/c))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-IllegalStateException
|
||||
wrap-convert-assert-IllegalStateException
|
||||
dynamic-IllegalStateException/c
|
||||
static-IllegalStateException/c
|
||||
IllegalStateException-IllegalStateException-constructor~generic
|
||||
IllegalStateException-IllegalStateException-constructor-java.lang.String~generic))
|
||||
static-IllegalStateException/c))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-IllegalThreadStateException
|
||||
wrap-convert-assert-IllegalThreadStateException
|
||||
dynamic-IllegalThreadStateException/c
|
||||
static-IllegalThreadStateException/c
|
||||
IllegalThreadStateException-IllegalThreadStateException-constructor~generic
|
||||
IllegalThreadStateException-IllegalThreadStateException-constructor-java.lang.String~generic))
|
||||
static-IllegalThreadStateException/c))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-IndexOutOfBoundsException
|
||||
wrap-convert-assert-IndexOutOfBoundsException
|
||||
dynamic-IndexOutOfBoundsException/c
|
||||
static-IndexOutOfBoundsException/c
|
||||
IndexOutOfBoundsException-IndexOutOfBoundsException-constructor~generic
|
||||
IndexOutOfBoundsException-IndexOutOfBoundsException-constructor-java.lang.String~generic))
|
||||
static-IndexOutOfBoundsException/c))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-InstantiationException
|
||||
wrap-convert-assert-InstantiationException
|
||||
dynamic-InstantiationException/c
|
||||
static-InstantiationException/c
|
||||
InstantiationException-InstantiationException-constructor~generic
|
||||
InstantiationException-InstantiationException-constructor-java.lang.String~generic))
|
||||
static-InstantiationException/c))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-InterruptedException
|
||||
wrap-convert-assert-InterruptedException
|
||||
dynamic-InterruptedException/c
|
||||
static-InterruptedException/c
|
||||
InterruptedException-InterruptedException-constructor~generic
|
||||
InterruptedException-InterruptedException-constructor-java.lang.String~generic))
|
||||
static-InterruptedException/c))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-NegativeArraySizeException
|
||||
wrap-convert-assert-NegativeArraySizeException
|
||||
dynamic-NegativeArraySizeException/c
|
||||
static-NegativeArraySizeException/c
|
||||
NegativeArraySizeException-NegativeArraySizeException-constructor~generic
|
||||
NegativeArraySizeException-NegativeArraySizeException-constructor-java.lang.String~generic))
|
||||
static-NegativeArraySizeException/c))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-NoSuchFieldException
|
||||
wrap-convert-assert-NoSuchFieldException
|
||||
dynamic-NoSuchFieldException/c
|
||||
static-NoSuchFieldException/c
|
||||
NoSuchFieldException-NoSuchFieldException-constructor~generic
|
||||
NoSuchFieldException-NoSuchFieldException-constructor-java.lang.String~generic))
|
||||
static-NoSuchFieldException/c))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-NoSuchMethodException
|
||||
wrap-convert-assert-NoSuchMethodException
|
||||
dynamic-NoSuchMethodException/c
|
||||
static-NoSuchMethodException/c
|
||||
NoSuchMethodException-NoSuchMethodException-constructor~generic
|
||||
NoSuchMethodException-NoSuchMethodException-constructor-java.lang.String~generic))
|
||||
static-NoSuchMethodException/c))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-NullPointerException
|
||||
wrap-convert-assert-NullPointerException
|
||||
dynamic-NullPointerException/c
|
||||
static-NullPointerException/c
|
||||
NullPointerException-NullPointerException-constructor~generic
|
||||
NullPointerException-NullPointerException-constructor-java.lang.String~generic))
|
||||
static-NullPointerException/c))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-NumberFormatException
|
||||
wrap-convert-assert-NumberFormatException
|
||||
dynamic-NumberFormatException/c
|
||||
static-NumberFormatException/c
|
||||
NumberFormatException-NumberFormatException-constructor~generic
|
||||
NumberFormatException-NumberFormatException-constructor-java.lang.String~generic))
|
||||
static-NumberFormatException/c))
|
||||
|
|
|
|||
|
|
@ -17,5 +17,5 @@
|
|||
()
|
||||
(("Object" "java" "lang"))
|
||||
()
|
||||
"version2")
|
||||
"version3")
|
||||
|
||||
|
|
|
|||
|
|
@ -6,8 +6,4 @@
|
|||
convert-assert-RuntimeException
|
||||
wrap-convert-assert-RuntimeException
|
||||
dynamic-RuntimeException/c
|
||||
static-RuntimeException/c
|
||||
RuntimeException-RuntimeException-constructor~generic
|
||||
RuntimeException-RuntimeException-constructor-java.lang.String~generic
|
||||
RuntimeException-RuntimeException-constructor-java.lang.String-java.lang.Throwable~generic
|
||||
RuntimeException-RuntimeException-constructor-java.lang.Throwable~generic))
|
||||
static-RuntimeException/c))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-SecurityException
|
||||
wrap-convert-assert-SecurityException
|
||||
dynamic-SecurityException/c
|
||||
static-SecurityException/c
|
||||
SecurityException-SecurityException-constructor~generic
|
||||
SecurityException-SecurityException-constructor-java.lang.String~generic))
|
||||
static-SecurityException/c))
|
||||
|
|
|
|||
|
|
@ -85,4 +85,4 @@
|
|||
()
|
||||
(("Object" "java" "lang"))
|
||||
(("Serializable" "java" "io") ("Comparable" "java" "lang") ("CharSequence" "java" "lang"))
|
||||
"version2")
|
||||
"version3")
|
||||
|
|
|
|||
|
|
@ -6,7 +6,4 @@
|
|||
convert-assert-StringIndexOutOfBoundsException
|
||||
wrap-convert-assert-StringIndexOutOfBoundsException
|
||||
dynamic-StringIndexOutOfBoundsException/c
|
||||
static-StringIndexOutOfBoundsException/c
|
||||
StringIndexOutOfBoundsException-StringIndexOutOfBoundsException-constructor~generic
|
||||
StringIndexOutOfBoundsException-StringIndexOutOfBoundsException-constructor-java.lang.String~generic
|
||||
StringIndexOutOfBoundsException-StringIndexOutOfBoundsException-constructor-int~generic))
|
||||
static-StringIndexOutOfBoundsException/c))
|
||||
|
|
|
|||
|
|
@ -35,4 +35,4 @@
|
|||
()
|
||||
(("Object" "java" "lang"))
|
||||
(("Serializable" "java" "io"))
|
||||
"version2")
|
||||
"version3")
|
||||
|
|
|
|||
|
|
@ -6,6 +6,4 @@
|
|||
convert-assert-UnsupportedOperationException
|
||||
wrap-convert-assert-UnsupportedOperationException
|
||||
dynamic-UnsupportedOperationException/c
|
||||
static-UnsupportedOperationException/c
|
||||
UnsupportedOperationException-UnsupportedOperationException-constructor~generic
|
||||
UnsupportedOperationException-UnsupportedOperationException-constructor-java.lang.String~generic))
|
||||
static-UnsupportedOperationException/c))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
#cs
|
||||
(module beginner-parser mzscheme
|
||||
|
||||
(require "general-parsing.ss"
|
||||
|
|
@ -56,7 +55,6 @@
|
|||
(- (position-offset (cadr $1)) (position-offset $1-start-pos))
|
||||
(file-path))
|
||||
(car $1))])
|
||||
; [(NULL_LIT) (make-literal 'null (build-src 1) #f)])
|
||||
|
||||
;; 19.4
|
||||
(Type
|
||||
|
|
@ -93,6 +91,9 @@
|
|||
(ClassType
|
||||
[(ClassOrInterfaceType) $1])
|
||||
|
||||
(InterfaceType
|
||||
[(ClassOrInterfaceType) $1])
|
||||
|
||||
;;19.5
|
||||
(Name
|
||||
[(IDENTIFIER) (make-name (make-id $1 (build-src 1)) null (build-src 1))]
|
||||
|
|
@ -113,18 +114,18 @@
|
|||
|
||||
(TypeDeclaration
|
||||
[(ClassDeclaration) $1]
|
||||
[(InterfaceDeclaration) $1]
|
||||
[(INTERACTIONS_BOX) $1]
|
||||
[(EXAMPLE) $1]
|
||||
[(CLASS_BOX) (parse-class-box $1 (build-src 1) 'beginner)]
|
||||
#;[(CLASS_BOX) (parse-class-box $1 (build-src 1) 'beginner)]
|
||||
[(TEST_SUITE) $1]
|
||||
[(SEMI_COLON) #f])
|
||||
|
||||
;; 19.7
|
||||
(Modifiers
|
||||
#;(Modifiers
|
||||
[(Modifier) (list $1)])
|
||||
; [(Modifiers Modifier) (cons $2 $1)])
|
||||
|
||||
(Modifier
|
||||
#;(Modifier
|
||||
[(abstract) (make-modifier 'abstract (build-src 1))])
|
||||
|
||||
(ImportDeclarations
|
||||
|
|
@ -138,31 +139,20 @@
|
|||
|
||||
;; 19.8.1
|
||||
(ClassDeclaration
|
||||
[(class IDENTIFIER Super ClassBody)
|
||||
[(class IDENTIFIER Interface ClassBody)
|
||||
(make-class-def (make-header (make-id $2 (build-src 2 2))
|
||||
(list (make-modifier 'public #f))
|
||||
$3 null null (build-src 3))
|
||||
null $3 null (build-src 3))
|
||||
$4
|
||||
(build-src 1)
|
||||
(build-src 4)
|
||||
(file-path)
|
||||
'beginner
|
||||
null 'top null)]
|
||||
[(abstract class IDENTIFIER Super ClassBody)
|
||||
(make-class-def (make-header (make-id $3 (build-src 3 3))
|
||||
(list (make-modifier 'public #f)
|
||||
(make-modifier 'abstract #f))
|
||||
$4 null null (build-src 4))
|
||||
$5
|
||||
(build-src 2 2)
|
||||
(build-src 5)
|
||||
(file-path)
|
||||
'beginner
|
||||
null 'top null)])
|
||||
|
||||
(Super
|
||||
(Interface
|
||||
[() null]
|
||||
[(extends ClassType) (list $2)])
|
||||
[(implements InterfaceType) (list $2)])
|
||||
|
||||
(ClassBody
|
||||
[(O_BRACE ClassBodyDeclarations C_BRACE) (reverse $2)])
|
||||
|
|
@ -213,22 +203,11 @@
|
|||
#t
|
||||
#f
|
||||
(build-src 2))]
|
||||
[(MethodHeader SEMI_COLON) (make-method (method-modifiers $1)
|
||||
(method-type $1)
|
||||
(method-type-parms $1)
|
||||
(method-name $1)
|
||||
(method-parms $1)
|
||||
(method-throws $1)
|
||||
#f
|
||||
#t
|
||||
#f
|
||||
(build-src 2))])
|
||||
)
|
||||
|
||||
(MethodHeader
|
||||
[(Modifiers Type MethodDeclarator) (construct-method-header (cons (make-modifier 'public #f) $1) null $2 $3 null)]
|
||||
[(Type MethodDeclarator) (construct-method-header (list (make-modifier 'public #f)) null $1 $2 null)])
|
||||
|
||||
|
||||
(MethodDeclarator
|
||||
[(IDENTIFIER O_PAREN FormalParameterList C_PAREN) (list (make-id $1 (build-src 1)) (reverse $3) 0)]
|
||||
[(IDENTIFIER O_PAREN C_PAREN) (list (make-id $1 (build-src 1)) null 0)])
|
||||
|
|
@ -251,9 +230,9 @@
|
|||
[(IDENTIFIER O_PAREN C_PAREN) (list (make-id $1 (build-src 1)) null)])
|
||||
|
||||
(ConstructorBody
|
||||
[(O_BRACE ExplicitConstructorInvocation BlockStatements C_BRACE)
|
||||
#;[(O_BRACE ExplicitConstructorInvocation BlockStatements C_BRACE)
|
||||
(make-block (cons $2 (reverse $3)) (build-src 4))]
|
||||
[(O_BRACE ExplicitConstructorInvocation C_BRACE)
|
||||
#; [(O_BRACE ExplicitConstructorInvocation C_BRACE)
|
||||
(make-block (list $2) (build-src 3))]
|
||||
[(O_BRACE BlockStatements C_BRACE)
|
||||
(make-block
|
||||
|
|
@ -264,7 +243,7 @@
|
|||
(make-block (cons (make-call #f (build-src 2) #f (make-special-name #f #f "super") null #f)
|
||||
null) (build-src 2))])
|
||||
|
||||
(ExplicitConstructorInvocation
|
||||
#;(ExplicitConstructorInvocation
|
||||
[(super O_PAREN ArgumentList C_PAREN SEMI_COLON)
|
||||
(make-call #f (build-src 5)
|
||||
#f (make-special-name #f (build-src 1) "super") (reverse $3) #f)]
|
||||
|
|
@ -272,6 +251,50 @@
|
|||
(make-call #f (build-src 4)
|
||||
#f (make-special-name #f (build-src 1) "super") null #f)])
|
||||
|
||||
;; 19.9.1
|
||||
|
||||
(InterfaceDeclaration
|
||||
[(interface IDENTIFIER ExtendsInterfaces InterfaceBody)
|
||||
(make-interface-def (make-header (make-id $2 (build-src 2 2)) (list (make-modifier 'public #f))
|
||||
$3 null null (build-src 3))
|
||||
$4
|
||||
(build-src 1)
|
||||
(build-src 4)
|
||||
(file-path)
|
||||
'intermedaite
|
||||
null 'top null)]
|
||||
[(interface IDENTIFIER InterfaceBody)
|
||||
(make-interface-def (make-header (make-id $2 (build-src 2 2))(list (make-modifier 'public #f))
|
||||
null null null (build-src 2))
|
||||
$3
|
||||
(build-src 1)
|
||||
(build-src 3)
|
||||
(file-path)
|
||||
'intermdediate
|
||||
null 'top null)])
|
||||
|
||||
(ExtendsInterfaces
|
||||
[(extends InterfaceType) (list $2)]
|
||||
[(ExtendsInterfaces COMMA InterfaceType) (cons $3 $1)])
|
||||
|
||||
(InterfaceBody
|
||||
[(O_BRACE InterfaceMemberDeclarations C_BRACE) $2])
|
||||
|
||||
(InterfaceMemberDeclarations
|
||||
[() null]
|
||||
[(InterfaceMemberDeclarations InterfaceMemberDeclaration)
|
||||
(cond
|
||||
((not $2) $1)
|
||||
((list? $2) (append $2 $1))
|
||||
(else (cons $2 $1)))])
|
||||
|
||||
(InterfaceMemberDeclaration
|
||||
[(AbstractMethodDeclaration) $1]
|
||||
[(SEMI_COLON) #f])
|
||||
|
||||
(AbstractMethodDeclaration
|
||||
[(MethodHeader SEMI_COLON) $1])
|
||||
|
||||
;; 19.11
|
||||
(Block
|
||||
[(O_BRACE Statement C_BRACE) (make-block (list $2) (build-src 3))])
|
||||
|
|
@ -335,11 +358,11 @@
|
|||
(make-call #f (build-src 6) $1 (make-id $3 (build-src 3 3)) (reverse $5) #f)]
|
||||
[(Primary PERIOD IDENTIFIER O_PAREN C_PAREN)
|
||||
(make-call #f (build-src 5) $1 (make-id $3 (build-src 3 3)) null #f)]
|
||||
[(super PERIOD IDENTIFIER O_PAREN ArgumentList C_PAREN)
|
||||
#;[(super PERIOD IDENTIFIER O_PAREN ArgumentList C_PAREN)
|
||||
(make-call #f (build-src 6)
|
||||
(make-special-name #f (build-src 1) "super")
|
||||
(make-id $3 (build-src 3 3)) (reverse $5) #f)]
|
||||
[(super PERIOD IDENTIFIER O_PAREN C_PAREN)
|
||||
#; [(super PERIOD IDENTIFIER O_PAREN C_PAREN)
|
||||
(make-call #f (build-src 5)
|
||||
(make-special-name #f (build-src 1) "super")
|
||||
(make-id $3 (build-src 3 3)) null #f)])
|
||||
|
|
|
|||
|
|
@ -265,7 +265,12 @@
|
|||
(member s (select-words (car args))))))
|
||||
#f))
|
||||
|
||||
(define misspelled-list '((import "mport" "iport" "imort" "imprt" "impot" "impor" "improt")
|
||||
(define (miscapitalized? t key)
|
||||
(let ((s (string-copy (token-value t))))
|
||||
(string-lowercase! s)
|
||||
(equal? s key)))
|
||||
|
||||
(define misspelled-list '((import "mport" "iport" "imort" "imprt" "impot" "impor" "improt" "impourt")
|
||||
(class "lass" "cass" "clss" "clas" "calss")
|
||||
(abstract
|
||||
"bstract" "astract" "abtract" "absract" "abstact" "abstrct" "abstrat" "abstract" "abstarct" "abstracts")
|
||||
|
|
|
|||
|
|
@ -287,11 +287,13 @@
|
|||
srt (get-end next)))))
|
||||
((IDENTIFIER)
|
||||
(if (close-to-keyword? tok 'import)
|
||||
(if (miscapitalized? tok "import")
|
||||
(parse-error "keyword 'import' must be all lower-case letters, and here is not" srt end)
|
||||
(parse-error
|
||||
(format "~a is close to 'import' but is either miscapitalized or mispelled" (token-value tok))
|
||||
srt end)
|
||||
(format "~a is close to keyword 'import' but is mispelled" (token-value tok))
|
||||
srt end))
|
||||
(parse-definition pre cur-tok 'start getter)))
|
||||
((INTERACTIONS_BOX TEST_SUITE CLASS_BOX) (parse-definition cur-tok (getter) 'start getter))
|
||||
((INTERACTIONS_BOX TEST_SUITE) (parse-definition cur-tok (getter) 'start getter))
|
||||
(else
|
||||
(parse-definition pre cur-tok 'start getter))))
|
||||
((semi-colon)
|
||||
|
|
@ -323,6 +325,8 @@
|
|||
((EOF) #t)
|
||||
((class) (parse-definition cur-tok (getter) 'class-id getter))
|
||||
((abstract)
|
||||
(if (beginner?)
|
||||
(parse-error "Expected class or interface definition, 'abstract' not allowed here" srt end)
|
||||
(let* ((next (getter))
|
||||
(next-tok (get-tok next)))
|
||||
(cond
|
||||
|
|
@ -330,17 +334,18 @@
|
|||
((eof? next-tok) (parse-error "abstract should be followed by class definition" srt end))
|
||||
(else
|
||||
(if (close-to-keyword? next-tok 'class)
|
||||
(parse-error (format "expected 'class' after 'abstract,' found ~a which is incorrectly spelled or capitalized"
|
||||
(parse-error (format "expected 'class' after 'abstract', found ~a which is incorrectly spelled or capitalized"
|
||||
(token-value next-tok))
|
||||
srt
|
||||
(get-end next))
|
||||
(parse-error (format "abstract must be immediately followed by 'class' not ~a" (format-out next-tok))
|
||||
srt
|
||||
(get-end next)))))))
|
||||
(get-end next))))))))
|
||||
((interface)
|
||||
(if (or (intermediate?) (advanced?))
|
||||
;(if (or (intermediate?) (advanced?))
|
||||
(parse-definition cur-tok (getter) 'interface-id getter)
|
||||
(parse-error (format "Expected class definition, found ~a which may not be written here" out) srt end)))
|
||||
;(parse-error (format "Expected class definition, found ~a which may not be written here" out) srt end)))
|
||||
)
|
||||
((public)
|
||||
(if (advanced?)
|
||||
(parse-definition cur-tok (getter) 'start getter)
|
||||
|
|
@ -359,10 +364,12 @@
|
|||
(token-value tok))
|
||||
srt end))
|
||||
((close-to-keyword? tok 'abstract)
|
||||
(if (beginner?)
|
||||
(parse-error (format "Excepted class or interface definition, found ~a" (token-value tok)) srt end)
|
||||
(parse-error (format "Expected 'abstract class' or 'class', found ~a which is incorrectly spelled or capitalized"
|
||||
(token-value tok))
|
||||
srt end))
|
||||
((and (or (intermediate?) (advanced?)) (close-to-keyword? tok 'interface))
|
||||
srt end)))
|
||||
((close-to-keyword? tok 'interface)
|
||||
(parse-error (format "Expected 'interface' or 'class', found ~a which is incorrectly spelled or capitalized"
|
||||
(token-value tok)) srt end))
|
||||
((and (advanced?) (close-to-keyword? tok 'public))
|
||||
|
|
@ -393,14 +400,15 @@
|
|||
(next-tok (get-tok next)))
|
||||
(cond
|
||||
((eof? next-tok) (parse-error (format "expected class body after ~a" (token-value tok)) srt end))
|
||||
((extends? next-tok) (parse-definition next (getter) 'extends getter))
|
||||
((and (or (intermediate?) (advanced?)) (implements? next-tok))
|
||||
((and (extends? next-tok) (or (intermediate?) (advanced?)))
|
||||
(parse-definition next (getter) 'extends getter))
|
||||
((implements? next-tok)
|
||||
(parse-definition next (getter) 'implements getter))
|
||||
((o-brace? next-tok) (parse-definition cur-tok next 'class-body getter))
|
||||
((close-to-keyword? next-tok 'extends)
|
||||
((and (or (intermediate?) (advanced?)) (close-to-keyword? next-tok 'extends) )
|
||||
(parse-error (format "found ~a, which is similar to 'extends'" (token-value next-tok))
|
||||
(get-start next) (get-end next)))
|
||||
((and (or (intermediate?) (advanced?)) (close-to-keyword? next-tok 'implements))
|
||||
((close-to-keyword? next-tok 'implements)
|
||||
(parse-error (format "found ~a, which is similar to 'implements'" (token-value next-tok))
|
||||
(get-start next) (get-end next)))
|
||||
((open-separator? next-tok)
|
||||
|
|
@ -411,8 +419,8 @@
|
|||
(get-start next) (get-end next)))
|
||||
(else
|
||||
(parse-error
|
||||
(format "class name must be followed by 'extends' or ~a a { to start class body, found ~a"
|
||||
(if (not (beginner?)) "'implements' clause or " "")
|
||||
(format "class name must be followed by ~a 'implements' or a { to start class body, found ~a"
|
||||
(if (not (beginner?)) "'extends' clause or " "")
|
||||
(format-out next-tok)) srt (get-end next))))))
|
||||
(else
|
||||
(if (java-keyword? tok)
|
||||
|
|
@ -426,7 +434,7 @@
|
|||
(next-tok (get-tok next)))
|
||||
(cond
|
||||
((eof? next-tok) (parse-error (format "Expected interface body after ~a" (token-value tok)) srt end))
|
||||
((extends? next-tok) (parse-definition cur-tok next 'iface-extends getter))
|
||||
((extends? next-tok) (parse-definition next (getter) 'iface-extends getter))
|
||||
((o-brace? next-tok) (parse-definition cur-tok next 'iface-body getter))
|
||||
((close-to-keyword? next-tok 'extends)
|
||||
(parse-error (format "found ~a, which is similar to 'extends'" (token-value next-tok))
|
||||
|
|
@ -450,8 +458,8 @@
|
|||
(cond
|
||||
((eof? tok) (parse-error "Expected parent class after extends" ps pe))
|
||||
((id-token? tok)
|
||||
(if (beginner?)
|
||||
(parse-definition cur-tok (getter) 'class-body getter)
|
||||
;(if (beginner?)
|
||||
; (parse-definition cur-tok (getter) 'class-body getter)
|
||||
(let* ((next (getter))
|
||||
(next-tok (get-tok next)))
|
||||
(cond
|
||||
|
|
@ -459,10 +467,10 @@
|
|||
((close-to-keyword? next-tok 'implements)
|
||||
(parse-error (format "Expected 'implements', found ~a which is close to 'implements'" (token-value next-tok))
|
||||
(get-start next) (get-end next)))
|
||||
(else (parse-definition cur-tok next 'class-body getter))))))
|
||||
(else (parse-definition cur-tok next 'class-body getter)))))
|
||||
((o-brace? tok) (parse-error "Expected a parent name after extends and before the class body starts" srt end))
|
||||
((java-keyword? tok)
|
||||
(parse-error (format "parent may not be named after reserved word ~a" tokN) srt end))
|
||||
(parse-error (format "Expected a name after extends, found reserved word ~a" tokN) srt end))
|
||||
(else (parse-error (format "extends must be followed by parent name, found ~a" out) ps end))))
|
||||
;Intermediate
|
||||
((implements)
|
||||
|
|
@ -473,7 +481,11 @@
|
|||
(next-tok (get-tok next)))
|
||||
(cond
|
||||
((eof? next-tok) (parse-error "Expected more implemented interfaces or class body" srt end))
|
||||
((comma? next-tok) (parse-definition next (getter) 'implements-list getter))
|
||||
((comma? next-tok)
|
||||
(if (beginner?)
|
||||
(parse-error "Only one interface may be implemented, found ',' which should not appear here"
|
||||
(get-start next) (get-end next))
|
||||
(parse-definition next (getter) 'implements-list getter)))
|
||||
((o-brace? next-tok) (parse-definition cur-tok next 'class-body getter))
|
||||
((id-token? next-tok)
|
||||
(parse-error "Implemented interfaces must be separated by a comma" srt (get-end next)))
|
||||
|
|
@ -584,7 +596,6 @@
|
|||
(parse-definition cur-tok next 'start getter))))
|
||||
(else (parse-error (format "Expected a } to close interface body, found ~a" out) ps end)))))))
|
||||
|
||||
|
||||
;parse-type: token token symbol (->token) -> void
|
||||
(define (parse-type pre cur state getter)
|
||||
(let* ((tok (get-tok cur))
|
||||
|
|
@ -657,7 +668,8 @@
|
|||
((eof? tok) cur)
|
||||
((and (c-brace? tok) (not just-method?)) cur)
|
||||
((and (c-brace? tok) just-method?) (parse-error "Encountered extra }" srt end))
|
||||
((abstract? tok) (parse-members cur (getter) 'method getter #t just-method?))
|
||||
((and (or (intermediate?) (advanced?)) (abstract? tok))
|
||||
(parse-members cur (getter) 'method getter #t just-method?))
|
||||
((prim-type? tok) (parse-members cur (getter) 'method-or-field getter #f just-method?))
|
||||
;Intermediate & Advanced
|
||||
((and (or (intermediate?) (advanced?)) (void-token? tok)) (parse-members cur (getter) 'method-id getter #f just-method?))
|
||||
|
|
@ -677,7 +689,7 @@
|
|||
(format "Only fields, methods and a constructor may be within the class body, found ~a" out) srt end))))
|
||||
((member)
|
||||
(cond
|
||||
((eof? tok) (parse-error "Class member may not end here, class body still requires a }" ps pe))
|
||||
((eof? tok) (parse-error "This class may not end here, class body still requires a }" ps pe))
|
||||
((dot? tok)
|
||||
(if (beginner?)
|
||||
(parse-error "The name of a type or class may not contain a '.'" ps end)
|
||||
|
|
@ -749,8 +761,12 @@
|
|||
(format "Fields must be separated by commas, method paramters must be in ()s, ~a not allowed" n-out)
|
||||
(format "Fields must be separatley declared, method paramters must be in ()s, ~a not allowed" n-out))
|
||||
srt ne)))
|
||||
(else (parse-error
|
||||
(format "Expected ';' to end field or abstract method parameter list, found ~a" n-out) srt ne)))))
|
||||
(else
|
||||
(if (or (intermediate?) (advanced?))
|
||||
(parse-error
|
||||
(format "Expected ';' to end field or abstract method parameter list, found ~a" n-out) srt ne)
|
||||
(parse-error
|
||||
(format "Expected ';' to end field. Found ~a" n-out) srt ne))))))
|
||||
(else
|
||||
(if (and (advanced?) (o-bracket? tok))
|
||||
(let* ((next (getter))
|
||||
|
|
@ -1048,7 +1064,11 @@
|
|||
(if abstract-method?
|
||||
(parse-error (format "abstract methods should end with ';', found ~a" next-out) next-start next-end)
|
||||
(parse-error (format "Method body begins with a '{', found ~a" next-out) next-start next-end)))
|
||||
((semi-colon? next-tok) (parse-members next (getter) 'start getter #f just-method?))
|
||||
((semi-colon? next-tok)
|
||||
(cond
|
||||
((or (beginner?) (not abstract-method?))
|
||||
(parse-error "Method must have a body, beginning with '{'. ';' not allowed" next-start next-end))
|
||||
(else (parse-members next (getter) 'start getter #f just-method?))))
|
||||
(else
|
||||
(if abstract-method?
|
||||
(parse-error (format "Expected a ';' to end abstract method, found ~a" next-out) next-start next-end)
|
||||
|
|
@ -1209,9 +1229,11 @@
|
|||
((start)
|
||||
(cond
|
||||
((or (eof? tok) (c-brace? tok)) cur)
|
||||
((abstract? tok) (parse-iface-body cur (getter) 'method-type getter))
|
||||
((and (not (beginner?)) (abstract? tok))
|
||||
(parse-iface-body cur (getter) 'method-type getter))
|
||||
((prim-type? tok) (parse-iface-body cur (getter) 'method-id getter))
|
||||
((void-token? tok) (parse-iface-body cur (getter) 'method-id getter))
|
||||
((and (not (beginner?)) (void-token? tok))
|
||||
(parse-iface-body cur (getter) 'method-id getter))
|
||||
((id-token? tok) (parse-iface-body cur (getter) 'method-id getter))
|
||||
(else
|
||||
(parse-error
|
||||
|
|
@ -1219,7 +1241,9 @@
|
|||
((method-type)
|
||||
(cond
|
||||
((eof? tok) (parse-error "Expected method, and interface body still requires a }" ps pe))
|
||||
((or (prim-type? tok) (void-token? tok)) (parse-iface-body cur (getter) 'method-id getter))
|
||||
((prim-type? tok) (parse-iface-body cur (getter) 'method-id getter))
|
||||
((and (not (beginner?)) (void-token? tok))
|
||||
(parse-iface-body cur (getter) 'method-id getter))
|
||||
((id-token? tok) (parse-iface-body cur (getter) 'method-id getter))
|
||||
((java-keyword? tok)
|
||||
(parse-error
|
||||
|
|
@ -1349,7 +1373,10 @@
|
|||
(case (get-token-name (get-tok cur-tok))
|
||||
((EOF C_BRACE) cur-tok)
|
||||
((super)
|
||||
(parse-ctor-call cur-tok (getter) 'start getter))
|
||||
(if (beginner?)
|
||||
(parse-error "Constructor may only initialize the fields of this class. Found super, which is not allowed"
|
||||
(get-start cur-tok) (get-end cur-tok))
|
||||
(parse-ctor-call cur-tok (getter) 'start getter)))
|
||||
((this)
|
||||
(cond
|
||||
((advanced?) (parse-ctor-call cur-tok (getter) 'start getter))
|
||||
|
|
@ -2075,8 +2102,12 @@
|
|||
(parse-expression cur-tok (getter) 'dot-op-or-end getter statement-ok? stmt-exp?)
|
||||
(parse-error "Expected an expression. null may not be used here" start end)))
|
||||
((TRUE_LIT FALSE_LIT STRING_LIT CHAR_LIT INTEGER_LIT
|
||||
LONG_LIT FLOAT_LIT DOUBLE_LIT this super)
|
||||
LONG_LIT FLOAT_LIT DOUBLE_LIT this)
|
||||
(parse-expression cur-tok (getter) 'dot-op-or-end getter statement-ok? stmt-exp?))
|
||||
((super)
|
||||
(if (beginner?)
|
||||
(parse-error "An expression may not begin with reserved word 'super'" start end)
|
||||
(parse-expression cur-tok (getter) 'dot-op-or-end getter statement-ok? stmt-exp?)))
|
||||
((O_PAREN)
|
||||
(if (or (advanced?) (intermediate?))
|
||||
(parse-expression cur-tok (getter) 'cast-or-parened getter statement-ok? stmt-exp?)
|
||||
|
|
@ -2214,8 +2245,13 @@
|
|||
(next-tok (get-tok next)))
|
||||
(case (get-token-name next-tok)
|
||||
((~ ! - + TRUE_LIT FALSE_LIT STRING_LIT CHAR_LIT INTEGER_LIT
|
||||
LONG_LIT FLOAT_LIT DOUBLE_LIT this O_PAREN new IDENTIFIER super)
|
||||
LONG_LIT FLOAT_LIT DOUBLE_LIT this O_PAREN new IDENTIFIER)
|
||||
(parse-expression cur-tok next 'start getter #f stmt-exp?))
|
||||
((super)
|
||||
(if (beginner?)
|
||||
(parse-error "Reserved word 'super' maynot appear in an expression"
|
||||
(get-start next) (get-end next))
|
||||
(parse-expression cur-tok next 'start getter #f stmt-exp?)))
|
||||
((NULL_LIT)
|
||||
(if (or (advanced?) (intermediate?))
|
||||
(parse-expression cur-tok next 'start getter #f stmt-exp?)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
#cs
|
||||
(module profj-testing mzscheme
|
||||
|
||||
(require (lib "compile.ss" "profj")
|
||||
|
|
@ -6,6 +5,8 @@
|
|||
(lib "tool.ss" "profj")
|
||||
(lib "class.ss"))
|
||||
|
||||
(define report-expected-error-messages (make-parameter #t))
|
||||
|
||||
(define interaction-errors (make-parameter 0))
|
||||
(define execution-errors (make-parameter 0))
|
||||
(define file-errors (make-parameter 0))
|
||||
|
|
@ -61,7 +62,6 @@
|
|||
(build-up (add1 c)))))))
|
||||
(build-up 0)))
|
||||
|
||||
|
||||
;already-seen?: 'a 'a (list 'a) (list 'a)-> bool
|
||||
(define (already-seen? v1 v2 visited-v1 visited-v2)
|
||||
(cond
|
||||
|
|
@ -215,7 +215,6 @@
|
|||
(file-errors 0)
|
||||
(file-msgs null))
|
||||
|
||||
(define report-expected-error-messages (make-parameter #f))
|
||||
|
||||
;report-test-results: -> void
|
||||
(define (report-test-results)
|
||||
|
|
|
|||
|
|
@ -300,109 +300,6 @@
|
|||
|
||||
strongly-connecteds)))
|
||||
|
||||
;This is the old find-dependent-defs: unreliable and known to have inifite-loop causing bugs
|
||||
;find-dependent-defs: (list defs) -> (list (list defs))
|
||||
#;(define (find-dependent-defs defs type-recs)
|
||||
(letrec ((not-found
|
||||
(lambda (def msg tbl)
|
||||
(lambda ()
|
||||
(hash-table-put! tbl def msg) msg)))
|
||||
;completed: maps def -> symbol
|
||||
(completed (make-hash-table))
|
||||
;completed? def -> bool
|
||||
(completed?
|
||||
(lambda (def)
|
||||
(eq? 'completed (hash-table-get completed def (not-found def 'started completed)))))
|
||||
;cycles: (list (list defs))
|
||||
(cycles null)
|
||||
;path maps def -> symbol
|
||||
(cycle (make-hash-table))
|
||||
;in-cycle? def -> bool
|
||||
(in-cycle?
|
||||
(lambda (def)
|
||||
(eq? 'in-cycle (hash-table-get cycle def (not-found def 'not-in-cycle cycle)))))
|
||||
|
||||
;find-cycle: def -> void
|
||||
(find-cycle
|
||||
(lambda (def)
|
||||
;(printf "find-cycle for def ~a with reqs ~a~n" (id-string (def-name def))
|
||||
; (map req-class (def-uses def)))
|
||||
;(printf "find-cycle required defs found were ~a~n"
|
||||
; (map id-string (map def-name (filter (lambda (x) x) (map find (def-uses def))))))
|
||||
(for-each (lambda (reqD)
|
||||
(cond
|
||||
((or (completed? reqD) (in-cycle? reqD)) (void))
|
||||
((or (dependence-on-cycle reqD) (exists-path-to-cycle? reqD null))
|
||||
(hash-table-put! cycle reqD 'in-cycle)
|
||||
(find-cycle reqD))))
|
||||
(filter (lambda (x) x) (map find (def-uses def))))))
|
||||
|
||||
;exists-path-to-cycle: def (list def)-> bool
|
||||
(exists-path-to-cycle?
|
||||
(lambda (def explored-list)
|
||||
;(printf "exists-path-to-cycle? for ~a~n" (id-string (def-name def)))
|
||||
(let ((reqs-in-cycle (filter (lambda (req)
|
||||
;(printf "reqs-in-cycle: looking at ~a~n" (id-string (def-name req)))
|
||||
(and (not (completed? req))
|
||||
(or (in-cycle? req)
|
||||
(and (dependence-on-cycle req)
|
||||
(hash-table-put! cycle req 'in-cycle))
|
||||
(and (not (memq req explored-list))
|
||||
(exists-path-to-cycle? req (cons def explored-list))))))
|
||||
(filter (lambda (x) x) (map find (def-uses def))))))
|
||||
;(printf "exists-path-to-cycle? reqs-in-cycle for ~a is ~a~n" (id-string (def-name def))
|
||||
; (map id-string (map def-name reqs-in-cycle)))
|
||||
(and (not (null? reqs-in-cycle))
|
||||
(hash-table-put! cycle def 'in-cycle)))))
|
||||
|
||||
;dependence-on-cycle: req -> bool
|
||||
(dependence-on-cycle
|
||||
(lambda (reqD)
|
||||
(ormap (lambda (x) x)
|
||||
(hash-table-map cycle (lambda (def v) (and (eq? v 'in-cycle)
|
||||
(dependence? reqD def)))))))
|
||||
|
||||
;to Determine if reqD directly depends on def
|
||||
(dependence?
|
||||
(lambda (reqD def)
|
||||
(member (make-req (id-string (def-name def)) (get-package def type-recs))
|
||||
(def-uses reqD))))
|
||||
|
||||
;find: req -> (U #f def)
|
||||
(find
|
||||
(lambda (req)
|
||||
(letrec ((walker
|
||||
(lambda (defs)
|
||||
(and (not (null? defs))
|
||||
(if (and (equal? (req-path req)
|
||||
(get-package (car defs) type-recs))
|
||||
(equal? (req-class req)
|
||||
(id-string (def-name (car defs)))))
|
||||
(car defs)
|
||||
(walker (cdr defs)))))))
|
||||
(walker defs)))))
|
||||
|
||||
(for-each (lambda (def)
|
||||
(unless (completed? def)
|
||||
;(printf "Started on def ~a~n" (id-string (def-name def)))
|
||||
(set! cycle (make-hash-table))
|
||||
(hash-table-put! cycle def 'in-cycle)
|
||||
(find-cycle def)
|
||||
;(printf "Completed looking for cycle for def ~a~n" (id-string (def-name def)))
|
||||
;(printf "hashtable for def ~a includes ~a~n" (id-string (def-name def))
|
||||
; (hash-table-map cycle (lambda (k v) (cons (id-string (def-name k)) v))))
|
||||
(let ((cyc (filter (lambda (d)
|
||||
(eq? (hash-table-get cycle d) 'in-cycle))
|
||||
(hash-table-map cycle (lambda (k v) k)))))
|
||||
(for-each (lambda (c) (hash-table-put! completed c 'completed))
|
||||
cyc)
|
||||
;(printf "cycle for ~a is ~a~n" (id-string (def-name def)) (map id-string (map def-name cyc)))
|
||||
;(printf "completed table after ~a is ~a" (id-string (def-name def))
|
||||
; (hash-table-map completed (lambda (k v) (list (id-string (def-name k)) v))))
|
||||
(set! cycles (cons cyc cycles)))))
|
||||
defs)
|
||||
cycles))
|
||||
|
||||
;order-defs: (list def) -> (list def)
|
||||
(define (order-defs defs)
|
||||
(reverse
|
||||
|
|
@ -609,23 +506,23 @@
|
|||
(restricted-methods (make-method-names ;(append (accesses-package methods)
|
||||
(accesses-protected methods);)
|
||||
overridden-methods))
|
||||
(make-gen-name
|
||||
#;(make-gen-name
|
||||
(lambda (m)
|
||||
(build-generic-name (class-name)
|
||||
((if (constructor? (id-string (method-name m))) build-constructor-name mangle-method-name)
|
||||
(id-string (method-name m))
|
||||
(method-record-atypes (method-rec m))))))
|
||||
(providable-generics
|
||||
#;(providable-generics
|
||||
(map make-gen-name
|
||||
(append (accesses-public methods)
|
||||
(accesses-package methods)
|
||||
(accesses-protected methods))))
|
||||
(private-generics (map make-gen-name (accesses-private methods)))
|
||||
#;(private-generics (map make-gen-name (accesses-private methods)))
|
||||
(names-for-dynamic (generate-dynamic-names (append (accesses-public methods)
|
||||
(accesses-package methods)
|
||||
(accesses-protected methods))
|
||||
overridden-methods))
|
||||
(dynamic-method-defs (generate-dyn-method-defs names-for-dynamic))
|
||||
#;(dynamic-method-defs (generate-dyn-method-defs names-for-dynamic))
|
||||
(wrapper-classes (append (generate-wrappers (class-name)
|
||||
(parent-name)
|
||||
(filter
|
||||
|
|
@ -654,7 +551,7 @@
|
|||
,@(map build-identifier static-method-names)
|
||||
,@(map build-identifier static-field-names)
|
||||
,@static-field-setters
|
||||
,@(map build-identifier providable-generics)
|
||||
#;,@(map build-identifier providable-generics)
|
||||
,@field-getters/setters)))
|
||||
|
||||
(let ((class-syntax
|
||||
|
|
@ -664,8 +561,10 @@
|
|||
(eq? 'anonymous kind)
|
||||
(eq? 'statement kind))
|
||||
provides)
|
||||
,(create-local-names (append (make-method-names (accesses-private methods) null)
|
||||
restricted-methods))
|
||||
,@(if (null? restricted-methods)
|
||||
null
|
||||
(list (create-local-names (append (make-method-names (accesses-private methods) null)
|
||||
restricted-methods))))
|
||||
(define ,class
|
||||
(,class* ,(if extends-object?
|
||||
(translate-id parent parent-src)
|
||||
|
|
@ -752,7 +651,10 @@
|
|||
|
||||
(define field-accessors ,(build-field-table create-get-name 'get fields))
|
||||
(define field-setters ,(build-field-table create-set-name 'set fields))
|
||||
(define private-methods ,(build-method-table (accesses-private methods) private-generics))
|
||||
(define private-methods
|
||||
,(if (null? (accesses-private methods))
|
||||
'(make-hash-table)
|
||||
(build-method-table (accesses-private methods) null #;private-generics)))
|
||||
|
||||
,@(map (lambda (i) (translate-initialize (initialize-static i)
|
||||
(initialize-block i)
|
||||
|
|
@ -764,7 +666,7 @@
|
|||
|
||||
,@wrapper-classes
|
||||
|
||||
,@(create-generic-methods (append (accesses-public methods)
|
||||
#;,@(create-generic-methods (append (accesses-public methods)
|
||||
(accesses-package methods)
|
||||
(accesses-protected methods)
|
||||
(accesses-private methods)))
|
||||
|
|
@ -860,8 +762,13 @@
|
|||
(dynamic-callables (refine-method-list wrapped-methods)))
|
||||
(list
|
||||
`(define (,(build-identifier (string-append "wrap-convert-assert-" class-name)) obj p n s c)
|
||||
(let ((raise-error
|
||||
(lambda (method-name num-args)
|
||||
(raise (make-exn:fail
|
||||
(format "~a broke the contract with ~a here, expected an object with a method ~a accepting ~a args"
|
||||
n p method-name num-args) s)))))
|
||||
(and ,@(map method->check/error
|
||||
(filter (lambda (m) (not (eq? 'ctor (method-record-rtype m)))) methods)))
|
||||
(filter (lambda (m) (not (eq? 'ctor (method-record-rtype m)))) wrapped-methods))))
|
||||
#;(c:contract ,(methods->contract (filter (lambda (m) (not (eq? 'ctor (method-record-rtype m))))
|
||||
methods)) obj p n s)
|
||||
(make-object ,(add-ca class-name) obj p n s c))
|
||||
|
|
@ -936,9 +843,7 @@
|
|||
`(or (object-method-arity-includes? obj
|
||||
(quote ,(build-identifier m-name))
|
||||
,num-args)
|
||||
(raise (make-exn:fail
|
||||
(format "~a broke the contract with ~a here, expected an object with a method ~a accepting ~a args"
|
||||
n p ,name ,num-args) s)))))
|
||||
(raise-error ,name ,num-args))))
|
||||
|
||||
;convert-value: sexp type boolean -> sexp
|
||||
(define (convert-value value type from-dynamic?)
|
||||
|
|
@ -1256,7 +1161,7 @@
|
|||
|
||||
(list `(begin ,provides
|
||||
(define ,syntax-name (,interface ,(translate-parents (header-extends header))
|
||||
,@(make-method-names (members-method members) null)))
|
||||
,@(make-iface-method-names (members-method members))))
|
||||
,@(create-static-fields static-field-names (members-field members))
|
||||
,@(append (generate-wrappers (class-name)
|
||||
"Object"
|
||||
|
|
@ -1318,6 +1223,21 @@
|
|||
(build-src (method-src method)))))
|
||||
methods))
|
||||
|
||||
;make-iface-method-names: (list method) -> (list symbol)
|
||||
(define (make-iface-method-names methods)
|
||||
(letrec ((mangle-name (lambda (method)
|
||||
(build-identifier
|
||||
(mangle-method-name (method-record-name (method-rec method))
|
||||
(method-record-atypes (method-rec method))))))
|
||||
(maker
|
||||
(lambda (methods)
|
||||
(cond
|
||||
((null? methods) methods)
|
||||
((method-record-override (method-rec (car methods)))
|
||||
(maker (cdr methods)))
|
||||
(else (cons (mangle-name (car methods)) (maker (cdr methods))))))))
|
||||
(maker methods)))
|
||||
|
||||
;make-method-names: (list methods) (list methods) -> (list symbol)
|
||||
(define (make-method-names methods minus-methods)
|
||||
(if (null? methods)
|
||||
|
|
|
|||
|
|
@ -231,7 +231,7 @@
|
|||
;; (list method-records) (list inner-record) (list (list strings)) (list (list strings)))
|
||||
;; After full processing fields and methods should contain all inherited fields
|
||||
;; and methods. Also parents and ifaces should contain all super-classes/ifaces
|
||||
(define-struct class-record (name modifiers class? object? fields methods inners parents ifaces))
|
||||
(define-struct class-record (name modifiers class? object? fields methods inners parents ifaces) (make-inspector))
|
||||
|
||||
(define interactions-record (make-class-record (list "interactions") null #f #f null null null null null))
|
||||
|
||||
|
|
@ -655,7 +655,7 @@
|
|||
;
|
||||
|
||||
|
||||
(define type-version "version2")
|
||||
(define type-version "version3")
|
||||
(define type-length 10)
|
||||
|
||||
;; read-record: path -> (U class-record #f)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user