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

Merged 1145:1303 from branches/kathyg (only collects/profj directory)

Browse Source 
Changes Beginner to have interfaces; assorted bug fixes

svn: r1305
This commit is contained in:
Kathy Gray 2005-11-14 04:51:09 +00:00
parent 3f9d7f4e5a
commit f5c3b8aa6c
38 changed files with 378 additions and 379 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/profj/ast.ss
View File

@ -1,7 +1,5 @@
;;Kathy Gray, December 2001 ;;Kathy Gray, December 2001
;;Abstract syntax tree for Java ;;Abstract syntax tree for Java
#cs
(module ast mzscheme (module ast mzscheme
;Macro to allow structure definition and provision ;Macro to allow structure definition and provision

138
collects/profj/build-info.ss
View File

@ -533,11 +533,11 @@
((ctor?) (has-ctor? m))) ((ctor?) (has-ctor? m)))
(unless ctor? (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)))) (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)) (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)))) (beginner-ctor-error 'abstract (header-id info) (id-src (header-id info))))
(valid-field-names? (if (memq level '(beginner intermediate advanced)) (valid-field-names? (if (memq level '(beginner intermediate advanced))
@ -548,7 +548,7 @@
(when (not (memq 'abstract test-mods)) (when (not (memq 'abstract test-mods))
(and (class-fully-implemented? super-record super (and (class-fully-implemented? super-record super
iface-records (header-implements info) iface-records (header-implements info)
m level) m type-recs level)
(no-abstract-methods m members level type-recs))) (no-abstract-methods m members level type-recs)))
(valid-inherited-methods? (cons super-record iface-records) (valid-inherited-methods? (cons super-record iface-records)
@ -585,7 +585,7 @@
iface)) iface))
(filter (lambda (iface) (not (null? iface))) (filter (lambda (iface) (not (null? iface)))
(append (map name->list (header-implements info)) (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))))))) (class-record-ifaces super-record)))))))
(when put-in-table? (send type-recs add-class-record record)) (when put-in-table? (send type-recs add-class-record record))
@ -721,7 +721,9 @@
(valid-iface-extend? super-records (header-extends info)) (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-field-names? f members m level type-recs)
(valid-method-sigs? m members 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 ;find-member: (U field-record method-record) (list member) symbol type-records -> member
(define (find-member member-record members level type-recs) (define (find-member member-record members level type-recs)
(when (null? members) (when (null? members)
(print-struct #t)
(printf "~a~n" member-record) (printf "~a~n" member-record)
(error 'internal-error "Find-member given a member that is not contained in the member list")) (error 'internal-error "Find-member given a member that is not contained in the member list"))
(cond (cond
@ -851,6 +854,20 @@
;valid-method-sigs? (list method-record) (list member) symbol type-records -> bool ;valid-method-sigs? (list method-record) (list member) symbol type-records -> bool
(define (valid-method-sigs? methods members level type-recs) (define (valid-method-sigs? methods members level type-recs)
(or (null? methods) (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) (and (method-member? (car methods) (cdr methods) level)
(let ((m (find-member (car methods) members level type-recs)) (let ((m (find-member (car methods) members level type-recs))
(class (method-record-class (car methods)))) (class (method-record-class (car methods))))
@ -858,14 +875,14 @@
(method-error 'inherited-conflict-field (method-error 'inherited-conflict-field
(field-name m) (field-name m)
null null
#f
(car class) (car class)
(field-src m) (field-src m)
#f) #f)
(method-error 'repeated (method-error 'repeated
(method-name m) (method-name m)
(map field-type #;(lambda (t) (map field-type (method-parms m))
(type-spec-to-type (field-type-spec t) class level type-recs)) 'void
(method-parms m))
(car class) (car class)
(method-src m) (method-src m)
(eq? (method-record-rtype (car methods)) 'ctor))))) (eq? (method-record-rtype (car methods)) 'ctor)))))
@ -878,13 +895,14 @@
(method-error 'inherited-conflict-field (method-error 'inherited-conflict-field
(field-name m) (field-name m)
null null
#f
(car class) (car class)
(field-src m) (field-src m)
#f) #f)
(method-error 'ctor-ret-value (method-error 'ctor-ret-value
(method-name m) (method-name m)
(map field-type #;(lambda (t) (type-spec-to-type (field-type-spec t) class level type-recs)) (map field-type (method-parms m))
(method-parms m)) (type-spec-to-type (method-type) #f level type-recs)
(car class) (car class)
(method-src m) (method-src m)
#f)))) #f))))
@ -897,30 +915,50 @@
(method-error 'inherited-conflict-field (method-error 'inherited-conflict-field
(field-name m) (field-name m)
null null
#f
(car class) (car class)
(field-src m) (field-src m)
#f) #f)
(method-error 'class-name (method-error 'class-name
(method-name m) (method-name m)
(map field-type #;(lambda (t) (type-spec-to-type (field-type-spec t) class level type-recs)) (map field-type (method-parms m))
(method-parms m)) (type-spec-to-type (method-type m) #f level type-recs)
(car class) (car class)
(method-src m) (method-src m)
(eq? (method-record-rtype (car methods)) 'ctor))))) (eq? (method-record-rtype (car methods)) 'ctor)))))
(valid-method-sigs? (cdr methods) members level type-recs))) (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) (define (method-member? method methods level)
(and (not (null? methods)) (and (not (null? methods))
(or (and (equal? (method-record-name method) (or (and (equal? (method-record-name method)
(method-record-name (car methods))) (method-record-name (car methods)))
(type=? (method-record-rtype method) (method-record-rtype (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)) (and (= (length (method-record-atypes method))
(length (method-record-atypes (car methods)))) (length (method-record-atypes (car methods))))
(andmap type=? (method-record-atypes method) (andmap type=? (method-record-atypes method)
(method-record-atypes (car methods)))))) (method-record-atypes (car methods))))))
(method-member? method (cdr methods) level)))) (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 ;valid-inherited-methods?: (list class-record) (list name) symbol type-records -> bool
(define (valid-inherited-methods? records extends level type-recs) (define (valid-inherited-methods? records extends level type-recs)
(or (null? records) (or (null? records)
@ -940,6 +978,7 @@
(method-error 'inherit-conflict (method-error 'inherit-conflict
(method-record-name (car methods)) (method-record-name (car methods))
(method-record-atypes (car methods)) (method-record-atypes (car methods))
(method-record-rtype (car methods))
(id-string (name-id from)) (id-string (name-id from))
(name-src from) (name-src from)
#f)) #f))
@ -950,12 +989,13 @@
(and (not (null? methods)) (and (not (null? methods))
(or (and (equal? (method-record-name method) (or (and (equal? (method-record-name method)
(method-record-name (car methods))) (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)))) (and (= (length (method-record-atypes method)) (length (method-record-atypes (car methods))))
(andmap type=? (method-record-atypes method) (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))))) (not (type=? (method-record-rtype method) (method-record-rtype (car methods)))))
(method-conflicts? method (cdr methods) level)))) (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) (define (check-current-methods records methods members level type-recs)
(or (null? records) (or (null? records)
(and (check-for-conflicts methods (car records) members level type-recs) (and (check-for-conflicts methods (car records) members level type-recs)
@ -972,29 +1012,57 @@
(method-error 'inherited-conflict-field (method-error 'inherited-conflict-field
(field-name method) (field-name method)
null null
#f
(car class) (car class)
(field-src method) (field-src method)
#f) #f)
(method-error 'conflict (method-error 'conflict
(method-name method) (method-name method)
(map field-type #;(lambda (t) (map field-type (method-parms method))
(type-spec-to-type (field-type-spec t) class level type-recs)) (type-spec-to-type (method-type method) #f level type-recs)
(method-parms method))
(car class) (car class)
(method-src method) (method-src method)
#f)))) #f))))
(check-for-conflicts (cdr methods) record members level type-recs))) (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 ;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)) (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)) (implements-all? (get-methods-need-implementing (class-record-methods super))
methods super-name level)) methods super-name level)))
(andmap (lambda (iface iface-name) (andmap (lambda (iface iface-name)
(implements-all? (class-record-methods iface) methods iface-name level)) (implements-all? (class-record-methods iface) methods iface-name level))
ifaces ifaces
ifaces-name)) 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) ;get-methods-need-implementing: (list method-record) -> (list method-record)
(define (get-methods-need-implementing methods) (define (get-methods-need-implementing methods)
(let ((abstract-methods (filter (lambda (m) (memq 'abstract (method-record-modifiers m))) 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 ;implements-all? (list method-record) (list method) name symbol -> bool
(define (implements-all? inherit-methods methods name level) (define (implements-all? inherit-methods methods name level)
(or (null? inherit-methods) (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 (method-error 'not-implement
(make-id (method-record-name (car inherit-methods)) #f) (make-id (method-record-name (car inherit-methods)) #f)
(method-record-atypes (car inherit-methods)) (method-record-atypes (car inherit-methods))
(method-record-rtype (car inherit-methods))
(id-string (name-id name)) (id-string (name-id name))
(id-src (name-id name)) (id-src (name-id name))
#f)) #f))
@ -1022,9 +1091,8 @@
(class (method-record-class (car methods)))) (class (method-record-class (car methods))))
(method-error 'illegal-abstract (method-error 'illegal-abstract
(method-name method) (method-name method)
(map field-type #;(lambda (t) (map field-type (method-parms method))
(type-spec-to-type (field-type-spec t) class level type-recs)) (type-spec-to-type (method-type method) #f level type-recs)
(method-parms method))
(car class) (car class)
(method-src method) (method-src method)
#f))) #f)))
@ -1298,7 +1366,8 @@
(make-valid-mods (make-valid-mods
(lambda (level) (lambda (level)
(case level (case level
((beginner intermediate) '(public abstract)) ((beginner) '(public))
((intermediate) '(public abstract))
((advanced) `(public protected private abstract static final)) ((advanced) `(public protected private abstract static final))
((full) '(public protected private abstract static final synchronized native strictfp)) ((full) '(public protected private abstract static final synchronized native strictfp))
((abstract) '(public protected abstract)) ((abstract) '(public protected abstract))
@ -1357,9 +1426,8 @@
(define (repeated-def-name-error name class? level src) (define (repeated-def-name-error name class? level src)
(let ((n (id->ext-name name))) (let ((n (id->ext-name name)))
(raise-error n (raise-error n
(format "~a ~a shares a name with another class~a. ~a names may not be repeated" (format "~a ~a and another class or interface have the same name. ~a names must be unique."
(if class? "Class" "Interface") n (if (eq? level 'beginner) "" " or interface") (if class? "Class" "Interface") n (if class? "Class" "Interface"))
(if (eq? level 'beginner) "Class" "Class and interface "))
n src))) n src)))
;modifier-error: symbol modifier -> void ;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))) (format "Only interfaces may be implemented, class ~a has attempted to implement class ~a" n s)))
s src))) s src)))
;method-error: symbol id (list type) string src bool -> void ;method-error: symbol id (list type) type string src bool -> void
(define (method-error kind name parms class src ctor?) (define (method-error kind name parms ret class src ctor?)
(if (eq? kind 'inherited-conflict-field) (if (eq? kind 'inherited-conflict-field)
(let ((n (id->ext-name name))) (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)) (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 (raise-error
m-name m-name
(case kind (case kind
@ -1436,17 +1505,20 @@
"Abstract method ~a is not allowed in non-abstract class ~a, abstract methods must be in abstract classes" "Abstract method ~a is not allowed in non-abstract class ~a, abstract methods must be in abstract classes"
m-name class)) m-name class))
((repeated) ((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)) (if ctor? "Constructor" "Method") m-name class))
((inherit-conflict) ((inherit-conflict)
(format "Inherited method ~a from ~a conflicts with another method of the same name" m-name class)) (format "Inherited method ~a from ~a conflicts with another method of the same name" m-name class))
((conflict) ((conflict)
(format "Method ~a conflicts with a method inherited from ~a" m-name class)) (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) ((ctor-ret-value)
(format "Constructor ~a for class ~a has a return type, which is not allowed" m-name class)) (format "Constructor ~a for class ~a has a return type, which is not allowed" m-name class))
((class-name) ((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)))) m-name src))))
;inherited-overload-error: string (list type) (list type) src -> void ;inherited-overload-error: string (list type) (list type) src -> void

25
collects/profj/check.ss
View File

@ -400,7 +400,7 @@
(static-env (get-static-fields-env field-env)) (static-env (get-static-fields-env field-env))
(setting-fields null) (setting-fields null)
(inherited-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))))) (let ((parent (send type-recs get-class-record (car (class-record-parents class-record)))))
(when (memq 'abstract (class-record-modifiers parent)) (when (memq 'abstract (class-record-modifiers parent))
(set! inherited-fields (set! inherited-fields
@ -451,7 +451,7 @@
)))) ))))
(let ((assigns (get-assigns members level (car c-class))) (let ((assigns (get-assigns members level (car c-class)))
(static-assigns (get-static-assigns members level))) (static-assigns (get-static-assigns members level)))
(when (eq? level 'beginner) #;(when (eq? level 'beginner)
(for-each (lambda (f) (for-each (lambda (f)
(andmap (lambda (assign) (andmap (lambda (assign)
(inherited-field-set? f assign extend-src)) (inherited-field-set? f assign extend-src))
@ -515,7 +515,7 @@
;field-needs-set?: field symbol bool-> bool ;field-needs-set?: field symbol bool-> bool
(define (field-needs-set? field level abst-class?) (define (field-needs-set? field level abst-class?)
(cond (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) ((memq 'final (map modifier-kind (field-modifiers field))) #t)
(else #f))) (else #f)))
@ -940,6 +940,7 @@
((return? statement) ((return? statement)
(check-return (return-expr statement) (check-return (return-expr statement)
return return
env
check-e-no-change check-e-no-change
(return-src statement) (return-src statement)
interactions? interactions?
@ -1062,8 +1063,8 @@
(send type-recs add-req (make-req "Throwable" (list "java" "lang"))))) (send type-recs add-req (make-req "Throwable" (list "java" "lang")))))
exp/env)) exp/env))
;check-return: expression type (expression -> type/env) src bool symbol type-records -> type/env ;check-return: expression type env (expression -> type/env) src bool symbol type-records -> type/env
(define (check-return ret-expr return check src interact? level type-recs) (define (check-return ret-expr return env check src interact? level type-recs)
(cond (cond
(interact? (void)) (interact? (void))
((and ret-expr (not (eq? 'void return))) ((and ret-expr (not (eq? 'void return)))
@ -1074,13 +1075,14 @@
((and ret-expr (eq? 'void return) (not (eq? level 'full))) ((and ret-expr (eq? 'void return) (not (eq? level 'full)))
(return-error 'void #f return src)) (return-error 'void #f return src))
((and (not ret-expr) (not (eq? 'void return))) ((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 ;check-while: type/env src -> void
(define (check-while cond/env src check-s loop-body) (define (check-while cond/env src check-s loop-body)
((check-cond 'while) (type/env-t cond/env) src) ((check-cond 'while) (type/env-t cond/env) src)
(check-s loop-body (type/env-e cond/env) #t #f) (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 ;check-do: (exp env -> type/env) exp src type/env -> type/env
(define (check-do check-e exp src loop/env) (define (check-do check-e exp src loop/env)
@ -2487,7 +2489,9 @@
(cond (cond
((and (ref-type? exp-type) (ref-type? type) ((and (ref-type? exp-type) (ref-type? type)
(or (is-eq-subclass? exp-type type type-recs) (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)) ((and (ref-type? exp-type) (ref-type? type))
(instanceof-error 'not-related-type type exp-type src)) (instanceof-error 'not-related-type type exp-type src))
((ref-type? exp-type) ((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" (format "attempted to call method ~a on ~a which does not have methods. ~nOnly values with ~a types have methods"
n t n t
(case level (case level
((beginner) "class") ((beginner intermediate) "class or interface")
((intermediate) "class or interface")
(else "class, interface, or array"))) (else "class, interface, or array")))
n src))) n src)))
@ -2973,7 +2976,7 @@
(let ((n (id->ext-name name)) (let ((n (id->ext-name name))
(t (get-call-type exp))) (t (get-call-type exp)))
(raise-error n (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) (format "~a does not contain a method named ~a" t n)
(case kind (case kind
((pro) ((pro)

2
collects/profj/libs/java/io/Serializable.jinfo
View File

@ -7,4 +7,4 @@
() ()
() ()
() ()
"version2") "version3")

4
collects/profj/libs/java/lang/ArithmeticException.ss
View File

@ -6,6 +6,4 @@
convert-assert-ArithmeticException convert-assert-ArithmeticException
wrap-convert-assert-ArithmeticException wrap-convert-assert-ArithmeticException
dynamic-ArithmeticException/c dynamic-ArithmeticException/c
static-ArithmeticException/c static-ArithmeticException/c))
ArithmeticException-ArithmeticException-constructor~generic
ArithmeticException-ArithmeticException-constructor-java.lang.String~generic))

5
collects/profj/libs/java/lang/ArrayIndexOutOfBoundsException.ss
View File

@ -6,7 +6,4 @@
convert-assert-ArrayIndexOutOfBoundsException convert-assert-ArrayIndexOutOfBoundsException
wrap-convert-assert-ArrayIndexOutOfBoundsException wrap-convert-assert-ArrayIndexOutOfBoundsException
dynamic-ArrayIndexOutOfBoundsException/c dynamic-ArrayIndexOutOfBoundsException/c
static-ArrayIndexOutOfBoundsException/c static-ArrayIndexOutOfBoundsException/c))
ArrayIndexOutOfBoundsException-ArrayIndexOutOfBoundsException-constructor~generic
ArrayIndexOutOfBoundsException-ArrayIndexOutOfBoundsException-constructor-java.lang.String~generic
ArrayIndexOutOfBoundsException-ArrayIndexOutOfBoundsException-constructor-int~generic))

4
collects/profj/libs/java/lang/ArrayStoreException.ss
View File

@ -6,6 +6,4 @@
convert-assert-ArrayStoreException convert-assert-ArrayStoreException
wrap-convert-assert-ArrayStoreException wrap-convert-assert-ArrayStoreException
dynamic-ArrayStoreException/c dynamic-ArrayStoreException/c
static-ArrayStoreException/c static-ArrayStoreException/c))
ArrayStoreException-ArrayStoreException-constructor~generic
ArrayStoreException-ArrayStoreException-constructor-java.lang.String~generic))

4
collects/profj/libs/java/lang/ClassCastException.ss
View File

@ -6,6 +6,4 @@
convert-assert-ClassCastException convert-assert-ClassCastException
wrap-convert-assert-ClassCastException wrap-convert-assert-ClassCastException
dynamic-ClassCastException/c dynamic-ClassCastException/c
static-ClassCastException/c static-ClassCastException/c))
ClassCastException-ClassCastException-constructor~generic
ClassCastException-ClassCastException-constructor-java.lang.String~generic))

7
collects/profj/libs/java/lang/ClassNotFoundException.ss
View File

@ -6,9 +6,4 @@
convert-assert-ClassNotFoundException convert-assert-ClassNotFoundException
wrap-convert-assert-ClassNotFoundException wrap-convert-assert-ClassNotFoundException
dynamic-ClassNotFoundException/c dynamic-ClassNotFoundException/c
static-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))

4
collects/profj/libs/java/lang/CloneNotSupportedException.ss
View File

@ -6,6 +6,4 @@
convert-assert-CloneNotSupportedException convert-assert-CloneNotSupportedException
wrap-convert-assert-CloneNotSupportedException wrap-convert-assert-CloneNotSupportedException
dynamic-CloneNotSupportedException/c dynamic-CloneNotSupportedException/c
static-CloneNotSupportedException/c static-CloneNotSupportedException/c))
CloneNotSupportedException-CloneNotSupportedException-constructor~generic
CloneNotSupportedException-CloneNotSupportedException-constructor-java.lang.String~generic))

2
collects/profj/libs/java/lang/Comparable.jinfo
View File

@ -7,4 +7,4 @@
() ()
() ()
() ()
"version2") "version3")

6
collects/profj/libs/java/lang/Exception.ss
View File

@ -6,8 +6,4 @@
convert-assert-Exception convert-assert-Exception
wrap-convert-assert-Exception wrap-convert-assert-Exception
dynamic-Exception/c dynamic-Exception/c
static-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))

4
collects/profj/libs/java/lang/IllegalAccessException.ss
View File

@ -6,6 +6,4 @@
convert-assert-IllegalAccessException convert-assert-IllegalAccessException
wrap-convert-assert-IllegalAccessException wrap-convert-assert-IllegalAccessException
dynamic-IllegalAccessException/c dynamic-IllegalAccessException/c
static-IllegalAccessException/c static-IllegalAccessException/c))
IllegalAccessException-IllegalAccessException-constructor~generic
IllegalAccessException-IllegalAccessException-constructor-java.lang.String~generic))

4
collects/profj/libs/java/lang/IllegalArgumentException.ss
View File

@ -6,6 +6,4 @@
convert-assert-IllegalArgumentException convert-assert-IllegalArgumentException
wrap-convert-assert-IllegalArgumentException wrap-convert-assert-IllegalArgumentException
dynamic-IllegalArgumentException/c dynamic-IllegalArgumentException/c
static-IllegalArgumentException/c static-IllegalArgumentException/c))
IllegalArgumentException-IllegalArgumentException-constructor~generic
IllegalArgumentException-IllegalArgumentException-constructor-java.lang.String~generic))

4
collects/profj/libs/java/lang/IllegalMonitorStateException.ss
View File

@ -6,6 +6,4 @@
convert-assert-IllegalMonitorStateException convert-assert-IllegalMonitorStateException
wrap-convert-assert-IllegalMonitorStateException wrap-convert-assert-IllegalMonitorStateException
dynamic-IllegalMonitorStateException/c dynamic-IllegalMonitorStateException/c
static-IllegalMonitorStateException/c static-IllegalMonitorStateException/c))
IllegalMonitorStateException-IllegalMonitorStateException-constructor~generic
IllegalMonitorStateException-IllegalMonitorStateException-constructor-java.lang.String~generic))

4
collects/profj/libs/java/lang/IllegalStateException.ss
View File

@ -6,6 +6,4 @@
convert-assert-IllegalStateException convert-assert-IllegalStateException
wrap-convert-assert-IllegalStateException wrap-convert-assert-IllegalStateException
dynamic-IllegalStateException/c dynamic-IllegalStateException/c
static-IllegalStateException/c static-IllegalStateException/c))
IllegalStateException-IllegalStateException-constructor~generic
IllegalStateException-IllegalStateException-constructor-java.lang.String~generic))

4
collects/profj/libs/java/lang/IllegalThreadStateException.ss
View File

@ -6,6 +6,4 @@
convert-assert-IllegalThreadStateException convert-assert-IllegalThreadStateException
wrap-convert-assert-IllegalThreadStateException wrap-convert-assert-IllegalThreadStateException
dynamic-IllegalThreadStateException/c dynamic-IllegalThreadStateException/c
static-IllegalThreadStateException/c static-IllegalThreadStateException/c))
IllegalThreadStateException-IllegalThreadStateException-constructor~generic
IllegalThreadStateException-IllegalThreadStateException-constructor-java.lang.String~generic))

4
collects/profj/libs/java/lang/IndexOutOfBoundsException.ss
View File

@ -6,6 +6,4 @@
convert-assert-IndexOutOfBoundsException convert-assert-IndexOutOfBoundsException
wrap-convert-assert-IndexOutOfBoundsException wrap-convert-assert-IndexOutOfBoundsException
dynamic-IndexOutOfBoundsException/c dynamic-IndexOutOfBoundsException/c
static-IndexOutOfBoundsException/c static-IndexOutOfBoundsException/c))
IndexOutOfBoundsException-IndexOutOfBoundsException-constructor~generic
IndexOutOfBoundsException-IndexOutOfBoundsException-constructor-java.lang.String~generic))

4
collects/profj/libs/java/lang/InstantiationException.ss
View File

@ -6,6 +6,4 @@
convert-assert-InstantiationException convert-assert-InstantiationException
wrap-convert-assert-InstantiationException wrap-convert-assert-InstantiationException
dynamic-InstantiationException/c dynamic-InstantiationException/c
static-InstantiationException/c static-InstantiationException/c))
InstantiationException-InstantiationException-constructor~generic
InstantiationException-InstantiationException-constructor-java.lang.String~generic))

4
collects/profj/libs/java/lang/InterruptedException.ss
View File

@ -6,6 +6,4 @@
convert-assert-InterruptedException convert-assert-InterruptedException
wrap-convert-assert-InterruptedException wrap-convert-assert-InterruptedException
dynamic-InterruptedException/c dynamic-InterruptedException/c
static-InterruptedException/c static-InterruptedException/c))
InterruptedException-InterruptedException-constructor~generic
InterruptedException-InterruptedException-constructor-java.lang.String~generic))

4
collects/profj/libs/java/lang/NegativeArraySizeException.ss
View File

@ -6,6 +6,4 @@
convert-assert-NegativeArraySizeException convert-assert-NegativeArraySizeException
wrap-convert-assert-NegativeArraySizeException wrap-convert-assert-NegativeArraySizeException
dynamic-NegativeArraySizeException/c dynamic-NegativeArraySizeException/c
static-NegativeArraySizeException/c static-NegativeArraySizeException/c))
NegativeArraySizeException-NegativeArraySizeException-constructor~generic
NegativeArraySizeException-NegativeArraySizeException-constructor-java.lang.String~generic))

4
collects/profj/libs/java/lang/NoSuchFieldException.ss
View File

@ -6,6 +6,4 @@
convert-assert-NoSuchFieldException convert-assert-NoSuchFieldException
wrap-convert-assert-NoSuchFieldException wrap-convert-assert-NoSuchFieldException
dynamic-NoSuchFieldException/c dynamic-NoSuchFieldException/c
static-NoSuchFieldException/c static-NoSuchFieldException/c))
NoSuchFieldException-NoSuchFieldException-constructor~generic
NoSuchFieldException-NoSuchFieldException-constructor-java.lang.String~generic))

4
collects/profj/libs/java/lang/NoSuchMethodException.ss
View File

@ -6,6 +6,4 @@
convert-assert-NoSuchMethodException convert-assert-NoSuchMethodException
wrap-convert-assert-NoSuchMethodException wrap-convert-assert-NoSuchMethodException
dynamic-NoSuchMethodException/c dynamic-NoSuchMethodException/c
static-NoSuchMethodException/c static-NoSuchMethodException/c))
NoSuchMethodException-NoSuchMethodException-constructor~generic
NoSuchMethodException-NoSuchMethodException-constructor-java.lang.String~generic))

4
collects/profj/libs/java/lang/NullPointerException.ss
View File

@ -6,6 +6,4 @@
convert-assert-NullPointerException convert-assert-NullPointerException
wrap-convert-assert-NullPointerException wrap-convert-assert-NullPointerException
dynamic-NullPointerException/c dynamic-NullPointerException/c
static-NullPointerException/c static-NullPointerException/c))
NullPointerException-NullPointerException-constructor~generic
NullPointerException-NullPointerException-constructor-java.lang.String~generic))

4
collects/profj/libs/java/lang/NumberFormatException.ss
View File

@ -6,6 +6,4 @@
convert-assert-NumberFormatException convert-assert-NumberFormatException
wrap-convert-assert-NumberFormatException wrap-convert-assert-NumberFormatException
dynamic-NumberFormatException/c dynamic-NumberFormatException/c
static-NumberFormatException/c static-NumberFormatException/c))
NumberFormatException-NumberFormatException-constructor~generic
NumberFormatException-NumberFormatException-constructor-java.lang.String~generic))

2
collects/profj/libs/java/lang/Object.jinfo
View File

@ -17,5 +17,5 @@
() ()
(("Object" "java" "lang")) (("Object" "java" "lang"))
() ()
"version2") "version3")

6
collects/profj/libs/java/lang/RuntimeException.ss
View File

@ -6,8 +6,4 @@
convert-assert-RuntimeException convert-assert-RuntimeException
wrap-convert-assert-RuntimeException wrap-convert-assert-RuntimeException
dynamic-RuntimeException/c dynamic-RuntimeException/c
static-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))

4
collects/profj/libs/java/lang/SecurityException.ss
View File

@ -6,6 +6,4 @@
convert-assert-SecurityException convert-assert-SecurityException
wrap-convert-assert-SecurityException wrap-convert-assert-SecurityException
dynamic-SecurityException/c dynamic-SecurityException/c
static-SecurityException/c static-SecurityException/c))
SecurityException-SecurityException-constructor~generic
SecurityException-SecurityException-constructor-java.lang.String~generic))

2
collects/profj/libs/java/lang/String.jinfo
View File

@ -85,4 +85,4 @@
() ()
(("Object" "java" "lang")) (("Object" "java" "lang"))
(("Serializable" "java" "io") ("Comparable" "java" "lang") ("CharSequence" "java" "lang")) (("Serializable" "java" "io") ("Comparable" "java" "lang") ("CharSequence" "java" "lang"))
"version2") "version3")

5
collects/profj/libs/java/lang/StringIndexOutOfBoundsException.ss
View File

@ -6,7 +6,4 @@
convert-assert-StringIndexOutOfBoundsException convert-assert-StringIndexOutOfBoundsException
wrap-convert-assert-StringIndexOutOfBoundsException wrap-convert-assert-StringIndexOutOfBoundsException
dynamic-StringIndexOutOfBoundsException/c dynamic-StringIndexOutOfBoundsException/c
static-StringIndexOutOfBoundsException/c static-StringIndexOutOfBoundsException/c))
StringIndexOutOfBoundsException-StringIndexOutOfBoundsException-constructor~generic
StringIndexOutOfBoundsException-StringIndexOutOfBoundsException-constructor-java.lang.String~generic
StringIndexOutOfBoundsException-StringIndexOutOfBoundsException-constructor-int~generic))

2
collects/profj/libs/java/lang/Throwable.jinfo
View File

@ -35,4 +35,4 @@
() ()
(("Object" "java" "lang")) (("Object" "java" "lang"))
(("Serializable" "java" "io")) (("Serializable" "java" "io"))
"version2") "version3")

4
collects/profj/libs/java/lang/UnsupportedOperationException.ss
View File

@ -6,6 +6,4 @@
convert-assert-UnsupportedOperationException convert-assert-UnsupportedOperationException
wrap-convert-assert-UnsupportedOperationException wrap-convert-assert-UnsupportedOperationException
dynamic-UnsupportedOperationException/c dynamic-UnsupportedOperationException/c
static-UnsupportedOperationException/c static-UnsupportedOperationException/c))
UnsupportedOperationException-UnsupportedOperationException-constructor~generic
UnsupportedOperationException-UnsupportedOperationException-constructor-java.lang.String~generic))

99
collects/profj/parsers/beginner-parser.ss
View File

@ -1,4 +1,3 @@
#cs
(module beginner-parser mzscheme (module beginner-parser mzscheme
(require "general-parsing.ss" (require "general-parsing.ss"
@ -56,7 +55,6 @@
(- (position-offset (cadr $1)) (position-offset $1-start-pos)) (- (position-offset (cadr $1)) (position-offset $1-start-pos))
(file-path)) (file-path))
(car $1))]) (car $1))])
; [(NULL_LIT) (make-literal 'null (build-src 1) #f)])
;; 19.4 ;; 19.4
(Type (Type
@ -93,6 +91,9 @@
(ClassType (ClassType
[(ClassOrInterfaceType) $1]) [(ClassOrInterfaceType) $1])
(InterfaceType
[(ClassOrInterfaceType) $1])
;;19.5 ;;19.5
(Name (Name
[(IDENTIFIER) (make-name (make-id $1 (build-src 1)) null (build-src 1))] [(IDENTIFIER) (make-name (make-id $1 (build-src 1)) null (build-src 1))]
@ -113,18 +114,18 @@
(TypeDeclaration (TypeDeclaration
[(ClassDeclaration) $1] [(ClassDeclaration) $1]
[(InterfaceDeclaration) $1]
[(INTERACTIONS_BOX) $1] [(INTERACTIONS_BOX) $1]
[(EXAMPLE) $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] [(TEST_SUITE) $1]
[(SEMI_COLON) #f]) [(SEMI_COLON) #f])
;; 19.7 ;; 19.7
(Modifiers #;(Modifiers
[(Modifier) (list $1)]) [(Modifier) (list $1)])
; [(Modifiers Modifier) (cons $2 $1)])
(Modifier #;(Modifier
[(abstract) (make-modifier 'abstract (build-src 1))]) [(abstract) (make-modifier 'abstract (build-src 1))])
(ImportDeclarations (ImportDeclarations
@ -138,31 +139,20 @@
;; 19.8.1 ;; 19.8.1
(ClassDeclaration (ClassDeclaration
[(class IDENTIFIER Super ClassBody) [(class IDENTIFIER Interface ClassBody)
(make-class-def (make-header (make-id $2 (build-src 2 2)) (make-class-def (make-header (make-id $2 (build-src 2 2))
(list (make-modifier 'public #f)) (list (make-modifier 'public #f))
$3 null null (build-src 3)) null $3 null (build-src 3))
$4 $4
(build-src 1) (build-src 1)
(build-src 4) (build-src 4)
(file-path) (file-path)
'beginner '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)]) null 'top null)])
(Super (Interface
[() null] [() null]
[(extends ClassType) (list $2)]) [(implements InterfaceType) (list $2)])
(ClassBody (ClassBody
[(O_BRACE ClassBodyDeclarations C_BRACE) (reverse $2)]) [(O_BRACE ClassBodyDeclarations C_BRACE) (reverse $2)])
@ -213,22 +203,11 @@
#t #t
#f #f
(build-src 2))] (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 (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)]) [(Type MethodDeclarator) (construct-method-header (list (make-modifier 'public #f)) null $1 $2 null)])
(MethodDeclarator (MethodDeclarator
[(IDENTIFIER O_PAREN FormalParameterList C_PAREN) (list (make-id $1 (build-src 1)) (reverse $3) 0)] [(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)]) [(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)]) [(IDENTIFIER O_PAREN C_PAREN) (list (make-id $1 (build-src 1)) null)])
(ConstructorBody (ConstructorBody
[(O_BRACE ExplicitConstructorInvocation BlockStatements C_BRACE) #;[(O_BRACE ExplicitConstructorInvocation BlockStatements C_BRACE)
(make-block (cons $2 (reverse $3)) (build-src 4))] (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))] (make-block (list $2) (build-src 3))]
[(O_BRACE BlockStatements C_BRACE) [(O_BRACE BlockStatements C_BRACE)
(make-block (make-block
@ -264,7 +243,7 @@
(make-block (cons (make-call #f (build-src 2) #f (make-special-name #f #f "super") null #f) (make-block (cons (make-call #f (build-src 2) #f (make-special-name #f #f "super") null #f)
null) (build-src 2))]) null) (build-src 2))])
(ExplicitConstructorInvocation #;(ExplicitConstructorInvocation
[(super O_PAREN ArgumentList C_PAREN SEMI_COLON) [(super O_PAREN ArgumentList C_PAREN SEMI_COLON)
(make-call #f (build-src 5) (make-call #f (build-src 5)
#f (make-special-name #f (build-src 1) "super") (reverse $3) #f)] #f (make-special-name #f (build-src 1) "super") (reverse $3) #f)]
@ -272,6 +251,50 @@
(make-call #f (build-src 4) (make-call #f (build-src 4)
#f (make-special-name #f (build-src 1) "super") null #f)]) #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 ;; 19.11
(Block (Block
[(O_BRACE Statement C_BRACE) (make-block (list $2) (build-src 3))]) [(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)] (make-call #f (build-src 6) $1 (make-id $3 (build-src 3 3)) (reverse $5) #f)]
[(Primary PERIOD IDENTIFIER O_PAREN C_PAREN) [(Primary PERIOD IDENTIFIER O_PAREN C_PAREN)
(make-call #f (build-src 5) $1 (make-id $3 (build-src 3 3)) null #f)] (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-call #f (build-src 6)
(make-special-name #f (build-src 1) "super") (make-special-name #f (build-src 1) "super")
(make-id $3 (build-src 3 3)) (reverse $5) #f)] (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-call #f (build-src 5)
(make-special-name #f (build-src 1) "super") (make-special-name #f (build-src 1) "super")
(make-id $3 (build-src 3 3)) null #f)]) (make-id $3 (build-src 3 3)) null #f)])

7
collects/profj/parsers/general-parsing.ss
View File

@ -265,7 +265,12 @@
(member s (select-words (car args)))))) (member s (select-words (car args))))))
#f)) #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") (class "lass" "cass" "clss" "clas" "calss")
(abstract (abstract
"bstract" "astract" "abtract" "absract" "abstact" "abstrct" "abstrat" "abstract" "abstarct" "abstracts") "bstract" "astract" "abtract" "absract" "abstact" "abstrct" "abstrat" "abstract" "abstarct" "abstracts")

102
collects/profj/parsers/parse-error.ss
View File

@ -287,11 +287,13 @@
srt (get-end next))))) srt (get-end next)))))
((IDENTIFIER) ((IDENTIFIER)
(if (close-to-keyword? tok 'import) (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 (parse-error
(format "~a is close to 'import' but is either miscapitalized or mispelled" (token-value tok)) (format "~a is close to keyword 'import' but is mispelled" (token-value tok))
srt end) srt end))
(parse-definition pre cur-tok 'start getter))) (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 (else
(parse-definition pre cur-tok 'start getter)))) (parse-definition pre cur-tok 'start getter))))
((semi-colon) ((semi-colon)
@ -323,6 +325,8 @@
((EOF) #t) ((EOF) #t)
((class) (parse-definition cur-tok (getter) 'class-id getter)) ((class) (parse-definition cur-tok (getter) 'class-id getter))
((abstract) ((abstract)
(if (beginner?)
(parse-error "Expected class or interface definition, 'abstract' not allowed here" srt end)
(let* ((next (getter)) (let* ((next (getter))
(next-tok (get-tok next))) (next-tok (get-tok next)))
(cond (cond
@ -330,17 +334,18 @@
((eof? next-tok) (parse-error "abstract should be followed by class definition" srt end)) ((eof? next-tok) (parse-error "abstract should be followed by class definition" srt end))
(else (else
(if (close-to-keyword? next-tok 'class) (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)) (token-value next-tok))
srt srt
(get-end next)) (get-end next))
(parse-error (format "abstract must be immediately followed by 'class' not ~a" (format-out next-tok)) (parse-error (format "abstract must be immediately followed by 'class' not ~a" (format-out next-tok))
srt srt
(get-end next))))))) (get-end next))))))))
((interface) ((interface)
(if (or (intermediate?) (advanced?)) ;(if (or (intermediate?) (advanced?))
(parse-definition cur-tok (getter) 'interface-id getter) (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) ((public)
(if (advanced?) (if (advanced?)
(parse-definition cur-tok (getter) 'start getter) (parse-definition cur-tok (getter) 'start getter)
@ -359,10 +364,12 @@
(token-value tok)) (token-value tok))
srt end)) srt end))
((close-to-keyword? tok 'abstract) ((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" (parse-error (format "Expected 'abstract class' or 'class', found ~a which is incorrectly spelled or capitalized"
(token-value tok)) (token-value tok))
srt end)) srt end)))
((and (or (intermediate?) (advanced?)) (close-to-keyword? tok 'interface)) ((close-to-keyword? tok 'interface)
(parse-error (format "Expected 'interface' or 'class', found ~a which is incorrectly spelled or capitalized" (parse-error (format "Expected 'interface' or 'class', found ~a which is incorrectly spelled or capitalized"
(token-value tok)) srt end)) (token-value tok)) srt end))
((and (advanced?) (close-to-keyword? tok 'public)) ((and (advanced?) (close-to-keyword? tok 'public))
@ -393,14 +400,15 @@
(next-tok (get-tok next))) (next-tok (get-tok next)))
(cond (cond
((eof? next-tok) (parse-error (format "expected class body after ~a" (token-value tok)) srt end)) ((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 (extends? next-tok) (or (intermediate?) (advanced?)))
((and (or (intermediate?) (advanced?)) (implements? next-tok)) (parse-definition next (getter) 'extends getter))
((implements? next-tok)
(parse-definition next (getter) 'implements getter)) (parse-definition next (getter) 'implements getter))
((o-brace? next-tok) (parse-definition cur-tok next 'class-body 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)) (parse-error (format "found ~a, which is similar to 'extends'" (token-value next-tok))
(get-start next) (get-end next))) (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)) (parse-error (format "found ~a, which is similar to 'implements'" (token-value next-tok))
(get-start next) (get-end next))) (get-start next) (get-end next)))
((open-separator? next-tok) ((open-separator? next-tok)
@ -411,8 +419,8 @@
(get-start next) (get-end next))) (get-start next) (get-end next)))
(else (else
(parse-error (parse-error
(format "class name must be followed by 'extends' or ~a a { to start class body, found ~a" (format "class name must be followed by ~a 'implements' or a { to start class body, found ~a"
(if (not (beginner?)) "'implements' clause or " "") (if (not (beginner?)) "'extends' clause or " "")
(format-out next-tok)) srt (get-end next)))))) (format-out next-tok)) srt (get-end next))))))
(else (else
(if (java-keyword? tok) (if (java-keyword? tok)
@ -426,7 +434,7 @@
(next-tok (get-tok next))) (next-tok (get-tok next)))
(cond (cond
((eof? next-tok) (parse-error (format "Expected interface body after ~a" (token-value tok)) srt end)) ((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)) ((o-brace? next-tok) (parse-definition cur-tok next 'iface-body getter))
((close-to-keyword? next-tok 'extends) ((close-to-keyword? next-tok 'extends)
(parse-error (format "found ~a, which is similar to 'extends'" (token-value next-tok)) (parse-error (format "found ~a, which is similar to 'extends'" (token-value next-tok))
@ -450,8 +458,8 @@
(cond (cond
((eof? tok) (parse-error "Expected parent class after extends" ps pe)) ((eof? tok) (parse-error "Expected parent class after extends" ps pe))
((id-token? tok) ((id-token? tok)
(if (beginner?) ;(if (beginner?)
(parse-definition cur-tok (getter) 'class-body getter) ; (parse-definition cur-tok (getter) 'class-body getter)
(let* ((next (getter)) (let* ((next (getter))
(next-tok (get-tok next))) (next-tok (get-tok next)))
(cond (cond
@ -459,10 +467,10 @@
((close-to-keyword? next-tok 'implements) ((close-to-keyword? next-tok 'implements)
(parse-error (format "Expected 'implements', found ~a which is close to 'implements'" (token-value next-tok)) (parse-error (format "Expected 'implements', found ~a which is close to 'implements'" (token-value next-tok))
(get-start next) (get-end next))) (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)) ((o-brace? tok) (parse-error "Expected a parent name after extends and before the class body starts" srt end))
((java-keyword? tok) ((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)))) (else (parse-error (format "extends must be followed by parent name, found ~a" out) ps end))))
;Intermediate ;Intermediate
((implements) ((implements)
@ -473,7 +481,11 @@
(next-tok (get-tok next))) (next-tok (get-tok next)))
(cond (cond
((eof? next-tok) (parse-error "Expected more implemented interfaces or class body" srt end)) ((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)) ((o-brace? next-tok) (parse-definition cur-tok next 'class-body getter))
((id-token? next-tok) ((id-token? next-tok)
(parse-error "Implemented interfaces must be separated by a comma" srt (get-end next))) (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)))) (parse-definition cur-tok next 'start getter))))
(else (parse-error (format "Expected a } to close interface body, found ~a" out) ps end))))))) (else (parse-error (format "Expected a } to close interface body, found ~a" out) ps end)))))))
;parse-type: token token symbol (->token) -> void ;parse-type: token token symbol (->token) -> void
(define (parse-type pre cur state getter) (define (parse-type pre cur state getter)
(let* ((tok (get-tok cur)) (let* ((tok (get-tok cur))
@ -657,7 +668,8 @@
((eof? tok) cur) ((eof? tok) cur)
((and (c-brace? tok) (not just-method?)) cur) ((and (c-brace? tok) (not just-method?)) cur)
((and (c-brace? tok) just-method?) (parse-error "Encountered extra }" srt end)) ((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?)) ((prim-type? tok) (parse-members cur (getter) 'method-or-field getter #f just-method?))
;Intermediate & Advanced ;Intermediate & Advanced
((and (or (intermediate?) (advanced?)) (void-token? tok)) (parse-members cur (getter) 'method-id getter #f just-method?)) ((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)))) (format "Only fields, methods and a constructor may be within the class body, found ~a" out) srt end))))
((member) ((member)
(cond (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) ((dot? tok)
(if (beginner?) (if (beginner?)
(parse-error "The name of a type or class may not contain a '.'" ps end) (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 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)) (format "Fields must be separatley declared, method paramters must be in ()s, ~a not allowed" n-out))
srt ne))) srt ne)))
(else (parse-error (else
(format "Expected ';' to end field or abstract method parameter list, found ~a" n-out) srt ne))))) (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 (else
(if (and (advanced?) (o-bracket? tok)) (if (and (advanced?) (o-bracket? tok))
(let* ((next (getter)) (let* ((next (getter))
@ -1048,7 +1064,11 @@
(if abstract-method? (if abstract-method?
(parse-error (format "abstract methods should end with ';', found ~a" next-out) next-start next-end) (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))) (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 (else
(if abstract-method? (if abstract-method?
(parse-error (format "Expected a ';' to end abstract method, found ~a" next-out) next-start next-end) (parse-error (format "Expected a ';' to end abstract method, found ~a" next-out) next-start next-end)
@ -1209,9 +1229,11 @@
((start) ((start)
(cond (cond
((or (eof? tok) (c-brace? tok)) cur) ((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)) ((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)) ((id-token? tok) (parse-iface-body cur (getter) 'method-id getter))
(else (else
(parse-error (parse-error
@ -1219,7 +1241,9 @@
((method-type) ((method-type)
(cond (cond
((eof? tok) (parse-error "Expected method, and interface body still requires a }" ps pe)) ((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)) ((id-token? tok) (parse-iface-body cur (getter) 'method-id getter))
((java-keyword? tok) ((java-keyword? tok)
(parse-error (parse-error
@ -1349,7 +1373,10 @@
(case (get-token-name (get-tok cur-tok)) (case (get-token-name (get-tok cur-tok))
((EOF C_BRACE) cur-tok) ((EOF C_BRACE) cur-tok)
((super) ((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) ((this)
(cond (cond
((advanced?) (parse-ctor-call cur-tok (getter) 'start getter)) ((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-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))) (parse-error "Expected an expression. null may not be used here" start end)))
((TRUE_LIT FALSE_LIT STRING_LIT CHAR_LIT INTEGER_LIT ((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?)) (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) ((O_PAREN)
(if (or (advanced?) (intermediate?)) (if (or (advanced?) (intermediate?))
(parse-expression cur-tok (getter) 'cast-or-parened getter statement-ok? stmt-exp?) (parse-expression cur-tok (getter) 'cast-or-parened getter statement-ok? stmt-exp?)
@ -2214,8 +2245,13 @@
(next-tok (get-tok next))) (next-tok (get-tok next)))
(case (get-token-name next-tok) (case (get-token-name next-tok)
((~ ! - + TRUE_LIT FALSE_LIT STRING_LIT CHAR_LIT INTEGER_LIT ((~ ! - + 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?)) (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) ((NULL_LIT)
(if (or (advanced?) (intermediate?)) (if (or (advanced?) (intermediate?))
(parse-expression cur-tok next 'start getter #f stmt-exp?) (parse-expression cur-tok next 'start getter #f stmt-exp?)

5
collects/profj/profj-testing.ss
View File

@ -1,4 +1,3 @@
#cs
(module profj-testing mzscheme (module profj-testing mzscheme
(require (lib "compile.ss" "profj") (require (lib "compile.ss" "profj")
@ -6,6 +5,8 @@
(lib "tool.ss" "profj") (lib "tool.ss" "profj")
(lib "class.ss")) (lib "class.ss"))
(define report-expected-error-messages (make-parameter #t))
(define interaction-errors (make-parameter 0)) (define interaction-errors (make-parameter 0))
(define execution-errors (make-parameter 0)) (define execution-errors (make-parameter 0))
(define file-errors (make-parameter 0)) (define file-errors (make-parameter 0))
@ -61,7 +62,6 @@
(build-up (add1 c))))))) (build-up (add1 c)))))))
(build-up 0))) (build-up 0)))
;already-seen?: 'a 'a (list 'a) (list 'a)-> bool ;already-seen?: 'a 'a (list 'a) (list 'a)-> bool
(define (already-seen? v1 v2 visited-v1 visited-v2) (define (already-seen? v1 v2 visited-v1 visited-v2)
(cond (cond
@ -215,7 +215,6 @@
(file-errors 0) (file-errors 0)
(file-msgs null)) (file-msgs null))
(define report-expected-error-messages (make-parameter #f))
;report-test-results: -> void ;report-test-results: -> void
(define (report-test-results) (define (report-test-results)

154
collects/profj/to-scheme.ss
View File

@ -300,109 +300,6 @@
strongly-connecteds))) 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) ;order-defs: (list def) -> (list def)
(define (order-defs defs) (define (order-defs defs)
(reverse (reverse
@ -609,23 +506,23 @@
(restricted-methods (make-method-names ;(append (accesses-package methods) (restricted-methods (make-method-names ;(append (accesses-package methods)
(accesses-protected methods);) (accesses-protected methods);)
overridden-methods)) overridden-methods))
(make-gen-name #;(make-gen-name
(lambda (m) (lambda (m)
(build-generic-name (class-name) (build-generic-name (class-name)
((if (constructor? (id-string (method-name m))) build-constructor-name mangle-method-name) ((if (constructor? (id-string (method-name m))) build-constructor-name mangle-method-name)
(id-string (method-name m)) (id-string (method-name m))
(method-record-atypes (method-rec m)))))) (method-record-atypes (method-rec m))))))
(providable-generics #;(providable-generics
(map make-gen-name (map make-gen-name
(append (accesses-public methods) (append (accesses-public methods)
(accesses-package methods) (accesses-package methods)
(accesses-protected 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) (names-for-dynamic (generate-dynamic-names (append (accesses-public methods)
(accesses-package methods) (accesses-package methods)
(accesses-protected methods)) (accesses-protected methods))
overridden-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) (wrapper-classes (append (generate-wrappers (class-name)
(parent-name) (parent-name)
(filter (filter
@ -654,7 +551,7 @@
,@(map build-identifier static-method-names) ,@(map build-identifier static-method-names)
,@(map build-identifier static-field-names) ,@(map build-identifier static-field-names)
,@static-field-setters ,@static-field-setters
,@(map build-identifier providable-generics) #;,@(map build-identifier providable-generics)
,@field-getters/setters))) ,@field-getters/setters)))
(let ((class-syntax (let ((class-syntax
@ -664,8 +561,10 @@
(eq? 'anonymous kind) (eq? 'anonymous kind)
(eq? 'statement kind)) (eq? 'statement kind))
provides) provides)
,(create-local-names (append (make-method-names (accesses-private methods) null) ,@(if (null? restricted-methods)
restricted-methods)) null
(list (create-local-names (append (make-method-names (accesses-private methods) null)
restricted-methods))))
(define ,class (define ,class
(,class* ,(if extends-object? (,class* ,(if extends-object?
(translate-id parent parent-src) (translate-id parent parent-src)
@ -752,7 +651,10 @@
(define field-accessors ,(build-field-table create-get-name 'get fields)) (define field-accessors ,(build-field-table create-get-name 'get fields))
(define field-setters ,(build-field-table create-set-name 'set 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) ,@(map (lambda (i) (translate-initialize (initialize-static i)
(initialize-block i) (initialize-block i)
@ -764,7 +666,7 @@
,@wrapper-classes ,@wrapper-classes
,@(create-generic-methods (append (accesses-public methods) #;,@(create-generic-methods (append (accesses-public methods)
(accesses-package methods) (accesses-package methods)
(accesses-protected methods) (accesses-protected methods)
(accesses-private methods))) (accesses-private methods)))
@ -860,8 +762,13 @@
(dynamic-callables (refine-method-list wrapped-methods))) (dynamic-callables (refine-method-list wrapped-methods)))
(list (list
`(define (,(build-identifier (string-append "wrap-convert-assert-" class-name)) obj p n s c) `(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 (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)))) #;(c:contract ,(methods->contract (filter (lambda (m) (not (eq? 'ctor (method-record-rtype m))))
methods)) obj p n s) methods)) obj p n s)
(make-object ,(add-ca class-name) obj p n s c)) (make-object ,(add-ca class-name) obj p n s c))
@ -936,9 +843,7 @@
`(or (object-method-arity-includes? obj `(or (object-method-arity-includes? obj
(quote ,(build-identifier m-name)) (quote ,(build-identifier m-name))
,num-args) ,num-args)
(raise (make-exn:fail (raise-error ,name ,num-args))))
(format "~a broke the contract with ~a here, expected an object with a method ~a accepting ~a args"
n p ,name ,num-args) s)))))
;convert-value: sexp type boolean -> sexp ;convert-value: sexp type boolean -> sexp
(define (convert-value value type from-dynamic?) (define (convert-value value type from-dynamic?)
@ -1256,7 +1161,7 @@
(list `(begin ,provides (list `(begin ,provides
(define ,syntax-name (,interface ,(translate-parents (header-extends header)) (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)) ,@(create-static-fields static-field-names (members-field members))
,@(append (generate-wrappers (class-name) ,@(append (generate-wrappers (class-name)
"Object" "Object"
@ -1318,6 +1223,21 @@
(build-src (method-src method))))) (build-src (method-src method)))))
methods)) 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) ;make-method-names: (list methods) (list methods) -> (list symbol)
(define (make-method-names methods minus-methods) (define (make-method-names methods minus-methods)
(if (null? methods) (if (null? methods)

4
collects/profj/types.ss
View File

@ -231,7 +231,7 @@
;; (list method-records) (list inner-record) (list (list strings)) (list (list strings))) ;; (list method-records) (list inner-record) (list (list strings)) (list (list strings)))
;; After full processing fields and methods should contain all inherited fields ;; After full processing fields and methods should contain all inherited fields
;; and methods. Also parents and ifaces should contain all super-classes/ifaces ;; 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)) (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) (define type-length 10)
;; read-record: path -> (U class-record #f) ;; read-record: path -> (U class-record #f)