1625 lines
83 KiB
Scheme
1625 lines
83 KiB
Scheme
(module build-info mzscheme
|
|
|
|
(require (lib "class.ss") (lib "file.ss") (lib "list.ss")
|
|
"ast.ss" "types.ss" "error-messaging.ss" "parameters.ss"
|
|
"restrictions.ss" "parser.ss" "profj-pref.ss")
|
|
|
|
(provide build-info build-interactions-info build-inner-info find-implicit-import load-lang)
|
|
|
|
;-------------------------------------------------------------------------------
|
|
;General helper functions for building information
|
|
|
|
;; name->list: name -> (list string)
|
|
(define (name->list n)
|
|
(cons (id-string (name-id n)) (map id-string (name-path n))))
|
|
|
|
;same-base-dir?: path path -> bool
|
|
(define (same-base-dir? full sub)
|
|
(with-handlers ((exn? (lambda (e) #f)))
|
|
(letrec ((full-ex (explode-path full))
|
|
(sub-ex (explode-path sub))
|
|
(first-of?
|
|
(lambda (full sub)
|
|
(or (null? sub)
|
|
(and (equal? (car full) (car sub))
|
|
(first-of? (cdr full) (cdr sub)))))))
|
|
(and (< (length sub-ex) (length full-ex))
|
|
(first-of? full-ex sub-ex)))))
|
|
|
|
;build-require-syntax: string (list string) dir bool bool-> (list syntax)
|
|
(define (build-require-syntax name path dir local? scheme?)
|
|
(let* ((syn (lambda (acc) (datum->syntax-object #f acc #f)))
|
|
(profj-lib? (ormap (lambda (p) (same-base-dir? dir p))
|
|
(map (lambda (p) (build-path p "profj" "libs"))
|
|
(current-library-collection-paths))))
|
|
(htdch-lib? (ormap (lambda (p) (same-base-dir? dir p))
|
|
(map (lambda (p) (build-path p "htdch"))
|
|
(current-library-collection-paths))))
|
|
(scheme-lib? (ormap (lambda (p) (same-base-dir? dir p))
|
|
(current-library-collection-paths)))
|
|
(access (lambda (name)
|
|
(cond
|
|
(profj-lib? `(lib ,name "profj" "libs" ,@path))
|
|
(htdch-lib?
|
|
`(lib ,name "htdch" ,@(if scheme? (cdddr path) path)))
|
|
(scheme-lib? `(lib ,name ,@(cddr path)))
|
|
((and local? (not (to-file))) name)
|
|
(else `(file ,(path->string (build-path dir name)))))))
|
|
(make-name (lambda ()
|
|
(let ((n (if scheme? (java-name->scheme name) name)))
|
|
(if (or (not local?) profj-lib? htdch-lib? scheme-lib? (to-file))
|
|
(string-append n ".ss")
|
|
(string->symbol n))))))
|
|
#;(when (or htdch-lib? (equal? name "Image"))
|
|
(printf "build-require : class ~a path ~a ~a~n" name path (access (make-name))))
|
|
#;(printf "build-req of ~a profj-lib? ~a htdch-lib? ~a scheme-lib? ~a ~n"
|
|
(make-name) profj-lib? htdch-lib? scheme-lib?)
|
|
(if scheme?
|
|
(list (syn `(prefix ,(string->symbol
|
|
(apply string-append
|
|
(append (map (lambda (s) (string-append s ".")) path)
|
|
(list name "-"))))
|
|
,(syn (access (make-name)))))
|
|
(syn `(prefix ,(string->symbol (string-append name "-")) ,(syn (access (make-name))))))
|
|
(list (syn `(prefix ,(string->symbol (apply string-append
|
|
(map (lambda (s) (string-append s ".")) path)))
|
|
,(syn (access (make-name)))))
|
|
(syn (access (make-name)))))))
|
|
|
|
;-------------------------------------------------------------------------------
|
|
;Main functions
|
|
|
|
;; build-info: package symbol type-records (opt symbol)-> void
|
|
(define (build-info prog level type-recs . args)
|
|
(let* ((pname (if (package-name prog)
|
|
(append (map id-string (name-path (package-name prog)))
|
|
(list (id-string (name-id (package-name prog)))))
|
|
null))
|
|
(lang-pack `("java" "lang"))
|
|
(lang (filter (lambda (class)
|
|
(not (forbidden-lang-class? class level)))
|
|
(send type-recs get-package-contents lang-pack
|
|
(lambda () (error 'type-recs "Internal error: Type record not set with lang")))))
|
|
(defs (let loop ((cur-defs (package-defs prog)))
|
|
(cond
|
|
((null? cur-defs) null)
|
|
((def? (car cur-defs)) (cons (car cur-defs) (loop (cdr cur-defs))))
|
|
(else
|
|
(when (execution?)
|
|
(send type-recs add-interactions-box (car cur-defs)))
|
|
(loop (cdr cur-defs))))))
|
|
(current-loc (cond
|
|
((not (null? defs)) (def-file (car defs)))
|
|
((not (null? (package-imports prog)))
|
|
(import-file (car (package-imports prog)))))))
|
|
(set-package-defs! prog defs)
|
|
|
|
;Add lang to local environment
|
|
(for-each (lambda (class) (send type-recs add-to-env class lang-pack current-loc)) lang)
|
|
(for-each (lambda (class) (send type-recs add-class-req (cons class lang-pack) #f current-loc)) lang)
|
|
(send type-recs add-class-req (list 'array) #f current-loc)
|
|
|
|
;Set location for type error messages
|
|
(build-info-location current-loc)
|
|
|
|
(let loop ((cur-defs defs))
|
|
(unless (null? cur-defs)
|
|
(when (member (id-string (def-name (car cur-defs)))
|
|
(map (lambda (d) (id-string (def-name d))) (cdr cur-defs)))
|
|
(repeated-def-name-error (def-name (car cur-defs))
|
|
(class-def? (car cur-defs))
|
|
level
|
|
(id-src (def-name (car cur-defs)))))
|
|
(loop (cdr cur-defs))))
|
|
|
|
;Add all defs in this file to environment
|
|
(for-each (lambda (def) (add-def-info def pname type-recs current-loc (null? args) level)) defs)
|
|
|
|
;Set the package of the interactions window to that of the definitions window
|
|
(when (execution?)
|
|
(send type-recs set-interactions-package pname)
|
|
(send type-recs set-execution-loc! current-loc))
|
|
|
|
;All further definitions do not come from the execution window
|
|
(execution? #f)
|
|
|
|
;Add package information to environment
|
|
(when (memq level '(advanced full))
|
|
(add-my-package type-recs pname (package-defs prog) current-loc level))
|
|
|
|
;Add import information
|
|
(for-each (lambda (imp) (process-import type-recs imp level)) (package-imports prog))
|
|
|
|
;Build jinfo information for each def in this file
|
|
(for-each (lambda (def) (process-class/iface def pname type-recs (null? args) #t level)) defs)
|
|
|
|
;Add these to the list for type checking
|
|
(add-to-queue defs)))
|
|
|
|
;build-interactions-info: ast location type-records -> void
|
|
(define (build-interactions-info prog level loc type-recs)
|
|
(build-info-location loc)
|
|
(send type-recs give-interaction-execution-names)
|
|
(if (list? prog)
|
|
(for-each (lambda (f) (build-interactions-info f level loc type-recs)) prog)
|
|
(when (field? prog)
|
|
(send type-recs add-interactions-field
|
|
(process-field prog '("scheme-interactions") type-recs level)))))
|
|
|
|
;add-def-info: def (list string) type-records loc bool symbol . (list syntax)-> void
|
|
(define (add-def-info def pname type-recs current-loc look-in-table level . inner-req)
|
|
(let* ((name (id-string (def-name def)))
|
|
(defname (cons name pname))
|
|
(native-name (cons (string-append name "-native-methods") pname))
|
|
(dir (dir-path-path (find-directory pname (lambda ()
|
|
(make-dir-path (build-path 'same) #f))))))
|
|
(unless (memq 'private (map modifier-kind (header-modifiers (def-header def))))
|
|
(send type-recs add-to-env name pname current-loc)
|
|
(when (execution?) (send type-recs add-to-env name pname 'interactions)))
|
|
(let ((req-syn (if (null? inner-req) (build-require-syntax name pname dir #t #f) (car inner-req))))
|
|
(send type-recs add-class-req defname #f current-loc)
|
|
(send type-recs add-require-syntax defname req-syn)
|
|
(send type-recs add-class-req native-name #f current-loc)
|
|
(send type-recs add-require-syntax native-name
|
|
(build-require-syntax (car native-name) pname dir #f #f))
|
|
(send type-recs add-to-records defname
|
|
(lambda () (process-class/iface def pname type-recs look-in-table #t level)))
|
|
;;get info for Inner member classes
|
|
(let ([prefix (format "~a." name)])
|
|
(for-each (lambda (member)
|
|
(when (class-def? member)
|
|
;; Adjust id to attach the prefix:
|
|
(let ([id (def-name member)])
|
|
(set-id-string! id (string-append prefix (id-string id))))
|
|
(add-def-info member pname type-recs current-loc #f (def-level def) req-syn)))
|
|
(def-members def))))))
|
|
|
|
;build-inner-info: def (U void string) (list string) symbol type-records loc bool -> class-record
|
|
(define (build-inner-info def unique-name pname level type-recs current-loc look-in-table?)
|
|
;(add-def-info def pname type-recs current-loc look-in-table? level)
|
|
(let ((record (process-class/iface def pname type-recs #f #f level)))
|
|
(when (string? unique-name) (set-class-record-name! record (list unique-name)))
|
|
(send type-recs add-to-records
|
|
(if (eq? (def-kind def) 'statement) (list unique-name) (id-string (def-name def)))
|
|
record)
|
|
record))
|
|
|
|
;add-to-queue: (list definition) -> void
|
|
(define (add-to-queue defs)
|
|
(check-list (append defs (check-list))))
|
|
|
|
;-----------------------------------------------------------------------------------
|
|
;Import processing/General loading
|
|
|
|
;;process-import: type-records import symbol -> void
|
|
(define (process-import type-recs imp level)
|
|
(let* ((star? (import-star imp))
|
|
(file (import-file imp))
|
|
(name (id-string (name-id (import-name imp))))
|
|
(name-path (map id-string (name-path (import-name imp))))
|
|
(path (if star? (append name-path (list name)) name-path))
|
|
(err (lambda () (import-error (import-name imp) (import-src imp)))))
|
|
(if star?
|
|
(let ((classes (send type-recs get-package-contents path (lambda () #f))))
|
|
(if classes
|
|
(for-each (lambda (class) (send type-recs add-to-env class path file)) classes)
|
|
(let* ((dir (find-directory path err))
|
|
(classes (get-class-list dir)))
|
|
(for-each (lambda (class)
|
|
(import-class class path dir file type-recs level (import-src imp) #t))
|
|
classes)
|
|
(send type-recs add-package-contents path classes))))
|
|
(import-class name path (find-directory path err) file type-recs level (import-src imp) #t))))
|
|
|
|
;import-class: string (list string) dir-path location type-records symbol src bool-> void
|
|
(define (import-class class path in-dir loc type-recs level caller-src add-to-env)
|
|
(let* ((dir (dir-path-path in-dir))
|
|
(class-name (cons class path))
|
|
(type-path (build-path dir "compiled" (string-append class ".jinfo")))
|
|
(new-level (box level))
|
|
(class-exists? (check-file-exists? class dir new-level))
|
|
(suffix (case (unbox new-level)
|
|
((beginner) ".bjava")
|
|
((intermediate) ".ijava")
|
|
((advanced) ".ajava")
|
|
((full) ".java")
|
|
((dynamic-full) ".djava")))
|
|
(file-path (build-path dir (string-append class suffix))))
|
|
(cond
|
|
((is-import-restricted? class path level) (used-restricted-import class path caller-src))
|
|
((send type-recs get-class-record class-name #f (lambda () #f)) void)
|
|
((and (file-exists? type-path)
|
|
(or (core? class-name) (older-than? file-path type-path)) (read-record type-path))
|
|
=>
|
|
(lambda (record)
|
|
(send type-recs add-class-record record)
|
|
(send type-recs add-require-syntax class-name (build-require-syntax class path dir #f #f))
|
|
(map (lambda (ancestor)
|
|
(import-class (car ancestor) (cdr ancestor)
|
|
(find-directory
|
|
(cdr ancestor)
|
|
(lambda () (error 'internal-error "Compiled parent's directory is not found")))
|
|
loc type-recs level caller-src add-to-env))
|
|
(append (class-record-parents record) (class-record-ifaces record)))
|
|
))
|
|
((and (dynamic?) (dir-path-scheme? in-dir) (check-scheme-file-exists? class dir))
|
|
(send type-recs add-to-records class-name (make-scheme-record class (cdr path) dir null))
|
|
(send type-recs add-require-syntax class-name (build-require-syntax class path dir #f #t)))
|
|
(class-exists?
|
|
(send type-recs add-to-records
|
|
class-name
|
|
(lambda ()
|
|
(let ((location (string-append class suffix))
|
|
(old-dynamic? (dynamic?)))
|
|
(when (eq? 'dynamic-full (unbox new-level))
|
|
(dynamic? #t) (set-box! new-level 'full))
|
|
(let ((ast (call-with-input-file file-path
|
|
(lambda (p) (parse p location (unbox new-level))))))
|
|
(send type-recs set-compilation-location location (build-path dir "compiled"))
|
|
(build-info ast (unbox new-level) type-recs 'not_look_up)
|
|
(begin0 (send type-recs get-class-record class-name #f
|
|
(lambda () 'internal-error "Failed to add record"))
|
|
(dynamic? old-dynamic?))
|
|
))))
|
|
(send type-recs add-require-syntax class-name (build-require-syntax class path dir #t #f)))
|
|
(else (file-error 'file (cons class path) caller-src level)))
|
|
(when add-to-env (send type-recs add-to-env class path loc))
|
|
(send type-recs add-class-req class-name (not add-to-env) loc)))
|
|
|
|
;determines if file a is older than file b
|
|
;older-than?: path path -> bool
|
|
(define (older-than? file-a file-b)
|
|
(and (file-exists? file-a)
|
|
(file-exists? file-b)
|
|
(<= (file-or-directory-modify-seconds file-a)
|
|
(file-or-directory-modify-seconds file-b))))
|
|
|
|
;core: (list string) -> bool
|
|
;Determines if the given class is a core class not written in Java
|
|
(define (core? class)
|
|
(member class `(("Object" "java" "lang")
|
|
("String" "java" "lang")
|
|
("Throwable" "java" "lang")
|
|
("Comparable" "java" "lang")
|
|
("Serializable" "java" "io"))))
|
|
|
|
;check-file-exists?: string path box -> bool
|
|
;side-effect: modifies contents of box
|
|
(define (check-file-exists? class path level)
|
|
(let ((exists?
|
|
(lambda (suffix lang)
|
|
(and (file-exists? (build-path path (string-append class suffix)))
|
|
(set-box! level lang)))))
|
|
(or (exists? ".java" 'full)
|
|
(exists? ".djava" 'dynamic-full)
|
|
(exists? ".bjava" 'beginner)
|
|
(exists? ".ijava" 'intermediate)
|
|
(exists? ".ajava" 'advanced))))
|
|
|
|
;check-scheme-file-exists? string path -> bool
|
|
(define (check-scheme-file-exists? name path)
|
|
(or (file-exists? (build-path path (string-append (java-name->scheme name) ".ss")))
|
|
(file-exists? (build-path path (string-append (java-name->scheme name) ".scm")))))
|
|
|
|
(define (create-scheme-type-rec mod-name req-path) 'scheme-types)
|
|
|
|
;add-my-package: type-records (list string) (list defs) loc symbol-> void
|
|
(define (add-my-package type-recs package defs loc level)
|
|
(let* ((dir (find-directory package
|
|
(lambda ()
|
|
(let-values (((base cur dir?) (split-path (current-directory))))
|
|
(and (equal? (apply build-path package) cur)
|
|
(make-dir-path (build-path 'same) #f))))))
|
|
(classes (if dir (get-class-list dir) null)))
|
|
;(printf "~n~nadd-my-package package ~a~n" package)
|
|
;(printf "add-my-package: dir ~a class ~a~n" dir classes)
|
|
(for-each (lambda (c)
|
|
(import-class c package
|
|
(make-dir-path (build-path 'same) #f) loc type-recs level #f #t)
|
|
(send type-recs add-to-env c package loc))
|
|
(filter (lambda (c) (not (contained-in? defs c))) classes))
|
|
(send type-recs add-package-contents package classes)))
|
|
|
|
;contained-in? (list definition) definition -> bool
|
|
(define (contained-in? defs class)
|
|
(and (not (null? defs))
|
|
(or (equal? class (id-string (def-name (car defs))))
|
|
(contained-in? (cdr defs) class))))
|
|
|
|
;find-implicit-import: (list string) type-records symbol src-> ( -> record )
|
|
(define (find-implicit-import name type-recs level call-src)
|
|
(lambda ()
|
|
(let ((original-loc (send type-recs get-location))
|
|
(dir (find-directory (cdr name) (lambda () (file-error 'dir (cdr name) call-src level)))))
|
|
(when (memq level '(beginner intermediate))
|
|
(file-error 'file name call-src level))
|
|
(import-class (car name) (cdr name) dir original-loc type-recs level call-src #f)
|
|
(begin0 (get-record (send type-recs get-class-record name) type-recs)
|
|
(send type-recs set-location! original-loc)))))
|
|
|
|
;(make-directory path bool)
|
|
(define-struct dir-path (path scheme?))
|
|
|
|
;find-directory: (list string) ( -> void) -> dir-path
|
|
(define (find-directory path fail)
|
|
(cond
|
|
((null? path) (make-dir-path (build-path 'same) #f))
|
|
((and (dynamic?) (equal? (car path) "scheme"))
|
|
(cond
|
|
((null? (cdr path)) (make-dir-path (build-path 'same) #t))
|
|
((not (equal? (cadr path) "lib"))
|
|
(let ((dir (find-directory (cdr path) fail)))
|
|
(make-dir-path dir #t)))
|
|
((and (equal? (cadr path) "lib") (not (null? (cddr path))))
|
|
(make-dir-path (apply collection-path (cddr path)) #t))
|
|
(else (make-dir-path (list "mzlib") #t))))
|
|
(else
|
|
(when (null? (classpath)) (classpath (get-classpath)))
|
|
(let-values (((search)
|
|
(lambda ()
|
|
(let loop ((paths (classpath)))
|
|
(cond
|
|
((null? paths) (fail))
|
|
((and (directory-exists? (build-path (car paths)
|
|
(apply build-path path))))
|
|
(make-dir-path (build-path (car paths) (apply build-path path)) #f))
|
|
(else (loop (cdr paths)))))))
|
|
((cur-path-base cur-path dir?)
|
|
(split-path (simplify-path (path->complete-path (build-path 'same))))))
|
|
(cond
|
|
((equal? (car path) (path->string cur-path))
|
|
(if (null? (cdr path))
|
|
(make-dir-path (build-path 'same) #f)
|
|
(if (directory-exists? (build-path (build-path 'same) (apply build-path (cdr path))))
|
|
(make-dir-path (build-path (build-path 'same) (apply build-path (cdr path))) #f)
|
|
(search))))
|
|
(else (search)))))))
|
|
|
|
;get-class-list: dir-path -> (list string)
|
|
(define (get-class-list dir)
|
|
(if (and (dynamic?) (dir-path-scheme? dir))
|
|
(filter (lambda (f) (or (equal? (filename-extension f) #".ss")
|
|
(equal? (filename-extension f) #".scm")))
|
|
(directory-list (dir-path-path dir)))
|
|
(filter (lambda (c-name) (not (equal? c-name "")))
|
|
(map (lambda (fn)
|
|
(let ((str (path->string fn)))
|
|
(substring str 0 (- (string-length str)
|
|
(add1 (bytes-length (filename-extension fn)))))))
|
|
(filter (lambda (f)
|
|
(let ((ext (filename-extension f)))
|
|
(or (equal? ext #"java")
|
|
(equal? ext #"djava")
|
|
(equal? ext #"ajava"))))
|
|
(directory-list (dir-path-path dir)))))))
|
|
|
|
;load-lang: type-records -> void (adds lang to type-recs)
|
|
(define (load-lang type-recs)
|
|
(let* ((lang `("java" "lang"))
|
|
(dir (find-directory lang (lambda () (error 'load-lang "Internal-error: Lang not accessible"))))
|
|
(class-list (map (lambda (fn) (substring fn 0 (- (string-length fn) 6)))
|
|
(map path->string
|
|
(filter (lambda (f) (equal? (filename-extension f) #"jinfo"))
|
|
(directory-list (build-path (dir-path-path dir) "compiled"))))))
|
|
(array (datum->syntax-object #f `(lib "array.ss" "profj" "libs" "java" "lang") #f)))
|
|
(send type-recs add-package-contents lang class-list)
|
|
(for-each (lambda (c) (import-class c lang dir #f type-recs 'full #f #f)) class-list)
|
|
(send type-recs add-require-syntax (list 'array) (list array array))
|
|
|
|
;Add lang to interactions environment
|
|
(for-each (lambda (class) (send type-recs add-to-env class lang 'interactions)) class-list)
|
|
(send type-recs set-location! 'interactions)
|
|
(for-each (lambda (class) (send type-recs add-class-req (cons class lang) #f 'interactions)) class-list)
|
|
(send type-recs add-class-req (list 'array) #f 'interactions)
|
|
))
|
|
|
|
;------------------------------------------------------------------------------------
|
|
;Functions for processing classes and interfaces
|
|
|
|
;; process-class/iface: (U class-def interface-def) (list string) type-records bool bool symbol -> class-record
|
|
(define (process-class/iface ci package-name type-recs look-in-table put-in-table level)
|
|
(cond
|
|
((interface-def? ci)
|
|
(process-interface ci package-name type-recs look-in-table put-in-table level))
|
|
((class-def? ci)
|
|
(process-class ci package-name type-recs look-in-table put-in-table level))))
|
|
|
|
;;get-parent-record: (list string) name (list string) type-records (list string) -> record
|
|
(define (get-parent-record name n child-name level type-recs)
|
|
(when (equal? name child-name)
|
|
(dependence-error 'immediate (name-id n) (name-src n)))
|
|
(let ((record (send type-recs get-class-record name)))
|
|
(cond
|
|
((class-record? record) record)
|
|
((procedure? record)
|
|
(let ((cur-src-loc (build-info-location)))
|
|
(begin0 (get-record record type-recs)
|
|
(build-info-location cur-src-loc))))
|
|
((eq? record 'in-progress)
|
|
(dependence-error 'cycle (name-id n) (name-src n)))
|
|
(else
|
|
(let ((cur-src-loc (build-info-location)))
|
|
(begin0
|
|
(get-record (find-implicit-import name type-recs level (name-src n)) type-recs)
|
|
(build-info-location cur-src-loc)))))))
|
|
|
|
(define (class-specific-field? field)
|
|
(not (memq 'private
|
|
(field-record-modifiers field))))
|
|
|
|
(define (class-specific-method? method new-methods)
|
|
(not (or (memq 'static (method-record-modifiers method))
|
|
(memq 'private (method-record-modifiers method))
|
|
(eq? 'ctor (method-record-rtype method))
|
|
(over-riden? method new-methods))))
|
|
|
|
(define (over-riden? m listm)
|
|
(and (not (null? listm))
|
|
(let ((m2 (car listm)))
|
|
(or (and (equal? (method-record-name m)
|
|
(method-record-name m2))
|
|
(type=? (method-record-rtype m)
|
|
(method-record-rtype m2))
|
|
(and (= (length (method-record-atypes m))
|
|
(length (method-record-atypes m2)))
|
|
(andmap type=? (method-record-atypes m)
|
|
(method-record-atypes m2)))
|
|
(and (= (length (method-record-modifiers m))
|
|
(length (method-record-modifiers m2)))
|
|
(andmap eq? (method-record-modifiers m)
|
|
(method-record-modifiers m2))))
|
|
(over-riden? m (cdr listm))))))
|
|
|
|
;; process-class: class-def (list string) type-records bool bool symbol -> class-record
|
|
(define (process-class class package-name type-recs look-in-table? put-in-table? level)
|
|
(let* ((info (def-header class))
|
|
(cname (cons (id-string (header-id info)) package-name)))
|
|
(send type-recs set-location! (def-file class))
|
|
(let ((build-record
|
|
(lambda ()
|
|
(when put-in-table? (send type-recs add-to-records cname 'in-progress))
|
|
(let* ((super (if (null? (header-extends info)) null (car (header-extends info))))
|
|
(super-name (if (null? super)
|
|
'("Object" "java" "lang")
|
|
(if (null? (name-path super))
|
|
(cons (id-string (name-id super))
|
|
(send type-recs lookup-path (id-string (name-id super)) (lambda () null)))
|
|
(name->list super))))
|
|
(super-record (get-parent-record super-name super cname level type-recs))
|
|
(iface-records (map (lambda (i)
|
|
(get-parent-record (name->list i) i #f level type-recs))
|
|
(header-implements info)))
|
|
(members (def-members class))
|
|
(modifiers (header-modifiers info))
|
|
(test-mods (map modifier-kind modifiers))
|
|
(reqs (map (lambda (name-list)
|
|
(if (= (length name-list) 1)
|
|
(make-req (car name-list)
|
|
(send type-recs lookup-path (car name-list) (lambda () null)))
|
|
(make-req (car name-list) (cdr name-list))))
|
|
(cons super-name (map name->list (header-implements info))))))
|
|
|
|
(set! reqs
|
|
(remove-dup-reqs
|
|
(append (get-method-reqs (class-record-methods super-record))
|
|
reqs)))
|
|
(send type-recs set-location! (def-file class))
|
|
(set-def-uses! class reqs)
|
|
|
|
(when (eq? level 'full)
|
|
(when (memq 'final (class-record-modifiers super-record))
|
|
(extension-error 'final (header-id info) super (id-src super))))
|
|
|
|
(unless (class-record-class? super-record)
|
|
(extension-error 'class-iface (header-id info) super (name-src super)))
|
|
|
|
(when (ormap class-record-class? iface-records)
|
|
(letrec ((find-class
|
|
(lambda (recs names)
|
|
(if (class-record-class? (car recs))
|
|
(car names)
|
|
(find-class (cdr recs) (cdr names)))))
|
|
(name (find-class iface-records (header-implements info))))
|
|
(extension-error 'implement-class (header-id info) name (name-src name))))
|
|
|
|
(valid-iface-implement? iface-records (header-implements info))
|
|
|
|
(let*-values (((old-methods) (class-record-methods super-record))
|
|
((f m i)
|
|
(if (memq 'strictfp test-mods)
|
|
(process-members members old-methods cname type-recs level
|
|
(find-strictfp modifiers))
|
|
(process-members members old-methods cname type-recs level)))
|
|
((ctor?) (has-ctor? m)))
|
|
|
|
(unless ctor?
|
|
(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))
|
|
(beginner-ctor-error 'abstract (header-id info) (id-src (header-id info))))
|
|
|
|
(valid-field-names? (if (memq level '(beginner intermediate advanced))
|
|
(append f (class-record-fields super-record)) f)
|
|
members m level type-recs)
|
|
(valid-method-sigs? m members level type-recs)
|
|
|
|
(when (not (memq 'abstract test-mods))
|
|
(and (class-fully-implemented? super-record super
|
|
iface-records (header-implements info)
|
|
m level)
|
|
(no-abstract-methods m members level type-recs)))
|
|
|
|
(valid-inherited-methods? (cons super-record iface-records)
|
|
(cons (if (null? super)
|
|
(make-name (make-id "Object" #f) null #f)
|
|
super)
|
|
(header-implements info))
|
|
level
|
|
type-recs)
|
|
(check-current-methods (cons super-record iface-records)
|
|
m
|
|
members
|
|
level
|
|
type-recs)
|
|
|
|
(let ((record
|
|
(make-class-record
|
|
cname
|
|
(check-class-modifiers level (def-kind class) modifiers)
|
|
#t
|
|
#t
|
|
(append f (filter class-specific-field? (class-record-fields super-record)))
|
|
(append m (filter (lambda (meth)
|
|
(class-specific-method? meth m))
|
|
(class-record-methods super-record)))
|
|
(append i (filter (lambda (i-r)
|
|
(not (memq 'private (inner-record-modifiers i-r))))
|
|
(class-record-inners super-record)))
|
|
(cons super-name (class-record-parents super-record))
|
|
(map (lambda (iface)
|
|
(if (null? (cdr iface))
|
|
(cons (car iface)
|
|
(send type-recs lookup-path (car iface) (lambda () null)))
|
|
iface))
|
|
(filter (lambda (iface) (not (null? iface)))
|
|
(append (map name->list (header-implements info))
|
|
(map class-record-parents iface-records)
|
|
(class-record-ifaces super-record)))))))
|
|
(when put-in-table? (send type-recs add-class-record record))
|
|
|
|
(for-each (lambda (member)
|
|
(when (def? member)
|
|
(process-class/iface member package-name type-recs #f put-in-table? level)))
|
|
members)
|
|
|
|
record))))))
|
|
(cond
|
|
((class-record? (send type-recs get-class-record cname)) =>
|
|
(lambda (rec) rec))
|
|
(look-in-table?
|
|
(get-record (send type-recs get-class-record cname #f build-record) type-recs))
|
|
(else (build-record))))))
|
|
|
|
;find-strictfp (list modifier) -> modifier
|
|
(define (find-strictfp mods)
|
|
(if (null? mods)
|
|
null
|
|
(if (eq? 'strictfp (modifier-kind (car mods)))
|
|
(car mods)
|
|
(find-strictfp (cdr mods)))))
|
|
|
|
;has-ctor?: (list method-record)-> bool
|
|
(define (has-ctor? methods)
|
|
(and (not (null? methods))
|
|
(or (eq? (method-record-rtype (car methods)) 'ctor)
|
|
(has-ctor? (cdr methods)))))
|
|
|
|
;add-ctor: class-def (method-record -> void) (list method-record) id symbol-> void
|
|
(define (add-ctor class add-rec super-methods name level)
|
|
(let ((super-ctor (find-default-ctor super-methods)))
|
|
(cond
|
|
((not super-ctor)
|
|
(default-ctor-error 'non-accessible name (car (method-record-class (car super-methods))) (id-src name) level))
|
|
((memq 'private (method-record-modifiers super-ctor))
|
|
(default-ctor-error 'private name (method-record-class super-ctor) (id-src name) level))
|
|
((and (memq level '(advanced full))
|
|
(not (null? (method-record-throws super-ctor))))
|
|
(default-ctor-error 'throws name (method-record-class super-ctor) (id-src name) level))
|
|
(else
|
|
(let* ((rec (make-method-record (id-string name) `(public) 'ctor null null #f (list (id-string name))))
|
|
(method (make-method (list (make-modifier 'public #f))
|
|
(make-type-spec 'ctor 0 #f)
|
|
null
|
|
(make-id (id-string name) #f)
|
|
null
|
|
null
|
|
(make-block
|
|
(list (make-call #f #f #f (make-special-name #f #f "super") null #f)) #f)
|
|
#t
|
|
rec
|
|
#f)))
|
|
(set-def-members! class (cons method (def-members class)))
|
|
(add-rec rec))))))
|
|
|
|
;find-default-ctor: (list method-record) -> (U boolean method-record)
|
|
(define (find-default-ctor methods)
|
|
(and (not (null? methods))
|
|
(or (and (eq? (method-record-rtype (car methods)) 'ctor)
|
|
(null? (method-record-atypes (car methods)))
|
|
(car methods))
|
|
(find-default-ctor (cdr methods)))))
|
|
|
|
;remove-dup-reqs (list req) -> (list req)
|
|
(define (remove-dup-reqs reqs)
|
|
(cond
|
|
((null? reqs) null)
|
|
((member (car reqs) (cdr reqs))
|
|
(remove-dup-reqs (cdr reqs)))
|
|
(else
|
|
(cons (car reqs) (remove-dup-reqs (cdr reqs))))))
|
|
|
|
;get-method-reqs: (list method-record) -> (list req)
|
|
(define (get-method-reqs methods)
|
|
(cond
|
|
((null? methods) methods)
|
|
((or (memq (method-record-rtype (car methods)) '(void ctor short byte int long float double
|
|
boolean dynamic char))
|
|
(array-type? (method-record-rtype (car methods))))
|
|
(append (get-reqs-parms (method-record-atypes (car methods)))
|
|
(get-method-reqs (cdr methods))))
|
|
((null? (method-record-atypes (car methods)))
|
|
(cons (type->req (method-record-rtype (car methods)))
|
|
(get-method-reqs (cdr methods))))
|
|
(else
|
|
(cons (type->req (method-record-rtype (car methods)))
|
|
(append (get-reqs-parms (method-record-atypes (car methods)))
|
|
(get-method-reqs (cdr methods)))))))
|
|
|
|
(define (get-reqs-parms parms)
|
|
(cond
|
|
((null? parms) null)
|
|
((memq (car parms) '(short byte int char long float double boolean dynamic))
|
|
(get-reqs-parms (cdr parms)))
|
|
((array-type? (car parms)) (get-reqs-parms (cdr parms)))
|
|
(else (cons (type->req (car parms)) (get-reqs-parms (cdr parms))))))
|
|
(define (type->req t)
|
|
(cond
|
|
((or (eq? 'string t) (equal? string-type t))
|
|
(make-req "String" '("java" "lang")))
|
|
((ref-type? t)
|
|
(make-req (ref-type-class/iface t) (ref-type-path t)))
|
|
#;(else (make-req 'array '()))))
|
|
|
|
;; process-interface: interface-def (list string) type-records bool bool symbol -> class-record
|
|
(define (process-interface iface package-name type-recs look-in-table? put-in-table? level)
|
|
(let* ((info (def-header iface))
|
|
(iname (cons (id-string (header-id info)) package-name)))
|
|
(send type-recs set-location! (def-file iface))
|
|
(let ((build-record
|
|
(lambda ()
|
|
(send type-recs add-to-records iname 'in-progress)
|
|
(let* ((super-names (map name->list (header-extends info)))
|
|
(super-records (map (lambda (n sc) (get-parent-record n sc iname level type-recs))
|
|
super-names
|
|
(header-extends info)))
|
|
(members (def-members iface))
|
|
(reqs (map (lambda (name-list) (make-req (car name-list) (cdr name-list)))
|
|
super-names)))
|
|
(send type-recs set-location! (def-file iface))
|
|
(set-def-uses! iface reqs)
|
|
|
|
(when (ormap class-record-class? super-records)
|
|
(letrec ((find-class
|
|
(lambda (recs names)
|
|
(if (class-record-class? (car recs))
|
|
(car names)
|
|
(find-class (cdr recs) (cdr names)))))
|
|
(name (find-class super-records (header-extends info))))
|
|
(extension-error 'iface-class (header-id info) name (name-src name))))
|
|
|
|
(valid-iface-extend? super-records (header-extends info))
|
|
|
|
(let-values (((f m i) (process-members members null iname type-recs level)))
|
|
|
|
(valid-field-names? f members m level type-recs)
|
|
(valid-method-sigs? m members level type-recs)
|
|
(valid-inherited-methods? super-records (header-extends info) level type-recs)
|
|
(check-current-methods super-records m members level type-recs)
|
|
|
|
(let ((record
|
|
(make-class-record
|
|
iname
|
|
(check-interface-modifiers level (header-modifiers info))
|
|
#f
|
|
#t
|
|
(apply append (cons f (map class-record-fields super-records)))
|
|
(apply append (cons m (map class-record-methods super-records)))
|
|
(apply append (cons i (map class-record-inners super-records)))
|
|
(apply append (cons super-names
|
|
(map class-record-parents super-records)))
|
|
null)))
|
|
(send type-recs add-class-record record)
|
|
record))))))
|
|
(if look-in-table?
|
|
(get-record (send type-recs get-class-record iname #f build-record) type-recs)
|
|
(build-record)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;Code to check for conflicts in method/field/class naming (including types)
|
|
|
|
(define (valid-iface-extend? records extends)
|
|
(or (null? records)
|
|
(and (memq (car records) (cdr records))
|
|
(extension-error 'ifaces #f (car extends) (name-src (car extends))))
|
|
(valid-iface-extend? (cdr records) (cdr extends))))
|
|
|
|
(define (valid-iface-implement? records implements)
|
|
(or (null? records)
|
|
(and (memq (car records) (cdr records))
|
|
(extension-error 'implement #f (car implements) (name-src (car implements))))
|
|
(valid-iface-implement? (cdr records) (cdr implements))))
|
|
|
|
;valid-field-names? (list field-record) (list member) (list method-record) symbol type-records -> bool
|
|
(define (valid-field-names? fields members methods level type-recs)
|
|
(or (null? fields)
|
|
(and (field-member? (car fields) (cdr fields))
|
|
(let ((f (find-member (car fields) members level type-recs)))
|
|
(if (method? f)
|
|
(field-name-error 'inherited-conflict-method
|
|
(method-name f)
|
|
level
|
|
(method-src f))
|
|
(field-name-error 'field (field-name f) level (field-src f)))))
|
|
(and (memq level '(beginner intermediate))
|
|
(or (and (shared-name? (car fields) methods)
|
|
(let ((f (find-member (car fields) members level type-recs)))
|
|
(if (method? f)
|
|
(field-name-error 'inherited-conflict-method
|
|
(method-name f)
|
|
level
|
|
(method-src f))
|
|
(field-name-error 'method (field-name f) level (field-src f)))))
|
|
(and (shared-class-name? (car fields) (send type-recs get-class-env))
|
|
(let ((f (find-member (car fields) members level type-recs)))
|
|
(if (method? f)
|
|
(field-name-error 'inherited-conflict-method
|
|
(method-name f)
|
|
level
|
|
(method-src f))
|
|
(field-name-error 'class (field-name f) level (field-src f)))))))
|
|
(valid-field-names? (cdr fields) members methods level type-recs)))
|
|
|
|
;field-member: field-record (list field-record) -> bool
|
|
(define (field-member? field fields)
|
|
(and (not (null? fields))
|
|
(or (equal? (field-record-name field)
|
|
(field-record-name (car fields)))
|
|
(field-member? field (cdr fields)))))
|
|
|
|
;shared-name field-record (list method-record) -> bool
|
|
(define (shared-name? field methods)
|
|
(and (not (null? methods))
|
|
(or (equal? (field-record-name field)
|
|
(method-record-name (car methods)))
|
|
(shared-name? field (cdr methods)))))
|
|
|
|
;shared-class-name?: (U field-record method-record) (list string) -> bool
|
|
(define (shared-class-name? member classes)
|
|
(and (not (null? classes))
|
|
(or (equal? ((if (field-record? member) field-record-name method-record-name) member)
|
|
(car classes))
|
|
(shared-class-name? member (cdr classes)))))
|
|
|
|
;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)
|
|
(printf "~a~n" member-record)
|
|
(error 'internal-error "Find-member given a member that is not contained in the member list"))
|
|
(cond
|
|
((and (field-record? member-record)
|
|
(field? (car members)))
|
|
(if (equal? (id-string (field-name (car members)))
|
|
(field-record-name member-record))
|
|
(car members)
|
|
(find-member member-record (cdr members) level type-recs)))
|
|
((and (method-record? member-record)
|
|
(method? (car members)))
|
|
(if (and (equal? (id-string (method-name (car members)))
|
|
(method-record-name member-record))
|
|
(= (length (method-record-atypes member-record))
|
|
(length (method-parms (car members))))
|
|
(andmap type=?
|
|
(method-record-atypes member-record)
|
|
(map (lambda (t)
|
|
(type-spec-to-type t (method-record-class member-record) level type-recs))
|
|
(map field-type-spec (method-parms (car members)))))
|
|
(type=? (method-record-rtype member-record)
|
|
(type-spec-to-type (method-type (car members)) (method-record-class member-record) level type-recs)))
|
|
(car members)
|
|
(find-member member-record (cdr members) level type-recs)))
|
|
((memq level '(beginner intermediate advanced))
|
|
(let ((given-name ((if (field-record? member-record) field-record-name method-record-name) member-record))
|
|
(looking-at (id-string ((if (field? (car members)) field-name method-name) (car members)))))
|
|
(if (equal? given-name looking-at)
|
|
(car members)
|
|
(find-member member-record (cdr members) level type-recs))))
|
|
(else
|
|
(find-member member-record (cdr members) level type-recs))))
|
|
|
|
;valid-method-sigs? (list method-record) (list member) symbol type-records -> bool
|
|
(define (valid-method-sigs? methods members level type-recs)
|
|
(or (null? methods)
|
|
(and (method-member? (car methods) (cdr methods) level)
|
|
(let ((m (find-member (car methods) members level type-recs))
|
|
(class (method-record-class (car methods))))
|
|
(if (field? m)
|
|
(method-error 'inherited-conflict-field
|
|
(field-name m)
|
|
null
|
|
(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))
|
|
(car class)
|
|
(method-src m)
|
|
(eq? (method-record-rtype (car methods)) 'ctor)))))
|
|
(and (equal? (method-record-name (car methods))
|
|
(method-record-class (car methods)))
|
|
(not (eq? (method-record-rtype (car methods)) 'ctor))
|
|
(let ((m (find-member (car methods) members level type-recs))
|
|
(class (method-record-class (car methods))))
|
|
(if (field? m)
|
|
(method-error 'inherited-conflict-field
|
|
(field-name m)
|
|
null
|
|
(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))
|
|
(car class)
|
|
(method-src m)
|
|
#f))))
|
|
(and (memq level `(beginner intermediate))
|
|
(not (eq? (method-record-rtype (car methods)) 'ctor))
|
|
(shared-class-name? (car methods) (send type-recs get-class-env))
|
|
(let ((m (find-member (car methods) members level type-recs))
|
|
(class (method-record-class (car methods))))
|
|
(if (field? m)
|
|
(method-error 'inherited-conflict-field
|
|
(field-name m)
|
|
null
|
|
(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))
|
|
(car class)
|
|
(method-src m)
|
|
(eq? (method-record-rtype (car methods)) 'ctor)))))
|
|
(valid-method-sigs? (cdr methods) members level type-recs)))
|
|
|
|
(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))
|
|
(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))))
|
|
|
|
;valid-inherited-methods?: (list class-record) (list name) symbol type-records -> bool
|
|
(define (valid-inherited-methods? records extends level type-recs)
|
|
(or (null? records)
|
|
(and (check-inherited-method (class-record-methods (car records))
|
|
(cdr records)
|
|
(car extends)
|
|
level
|
|
type-recs)
|
|
(valid-inherited-methods? (cdr records) (cdr extends) level type-recs))))
|
|
|
|
;check-inherited-method: (list method-record) (list class-record) name symbol type-records -> bool
|
|
(define (check-inherited-method methods records from level type-recs)
|
|
(or (null? methods)
|
|
(and (method-conflicts? (car methods)
|
|
(apply append (map class-record-methods records))
|
|
level)
|
|
(method-error 'inherit-conflict
|
|
(method-record-name (car methods))
|
|
(method-record-atypes (car methods))
|
|
(id-string (name-id from))
|
|
(name-src from)
|
|
#f))
|
|
(check-inherited-method (cdr methods) records from level type-recs)))
|
|
|
|
;method-conflicts?: method-record (list method-record) symbol -> bool
|
|
(define (method-conflicts? method methods level)
|
|
(and (not (null? methods))
|
|
(or (and (equal? (method-record-name method)
|
|
(method-record-name (car methods)))
|
|
(or (or (eq? level 'beginner) (eq? level '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))))
|
|
|
|
(define (check-current-methods records methods members level type-recs)
|
|
(or (null? records)
|
|
(and (check-for-conflicts methods (car records) members level type-recs)
|
|
(check-current-methods (cdr records) methods members level type-recs))))
|
|
|
|
(define (check-for-conflicts methods record members level type-recs)
|
|
(or (null? methods)
|
|
(and (method-conflicts? (car methods)
|
|
(class-record-methods record)
|
|
level)
|
|
(let ((method (find-member (car methods) members level type-recs))
|
|
(class (class-record-name record)))
|
|
(if (field? method)
|
|
(method-error 'inherited-conflict-field
|
|
(field-name method)
|
|
null
|
|
(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))
|
|
(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)
|
|
(when (memq 'abstract (class-record-modifiers super))
|
|
(implements-all? (get-methods-need-implementing (class-record-methods super))
|
|
methods super-name level))
|
|
(andmap (lambda (iface iface-name)
|
|
(implements-all? (class-record-methods iface) methods iface-name level))
|
|
ifaces
|
|
ifaces-name))
|
|
|
|
;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))
|
|
(non-abstract-methods (filter (lambda (m) (not (memq 'abstract (method-record-modifiers m)))) methods)))
|
|
(filter (lambda (m)
|
|
(not (member m (map method-record-override non-abstract-methods))))
|
|
abstract-methods)))
|
|
|
|
;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))
|
|
(method-error 'not-implement
|
|
(make-id (method-record-name (car inherit-methods)) #f)
|
|
(method-record-atypes (car inherit-methods))
|
|
(id-string (name-id name))
|
|
(id-src (name-id name))
|
|
#f))
|
|
(implements-all? (cdr inherit-methods) methods name level)))
|
|
|
|
(define (no-abstract-methods methods members level type-recs)
|
|
(or (null? methods)
|
|
(and (memq 'abstract (method-record-modifiers (car methods)))
|
|
(let ((method (find-member (car methods) members level type-recs))
|
|
(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))
|
|
(car class)
|
|
(method-src method)
|
|
#f)))
|
|
(no-abstract-methods (cdr methods) members level type-recs)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;Methods to process fields and methods
|
|
|
|
;; process-members: (list members) (list method-record) (list string) type-records symbol ->
|
|
;; (values (list field-record) (list method-record) (list inner-record))
|
|
(define (process-members members inherited-methods cname type-recs level . args)
|
|
(let loop ((members members)
|
|
(fields null)
|
|
(methods null)
|
|
(inners null))
|
|
(cond
|
|
((null? members) (values fields methods inners))
|
|
((field? (car members))
|
|
(loop (cdr members)
|
|
(cons (process-field (car members) cname type-recs level) fields)
|
|
methods
|
|
inners))
|
|
((method? (car members))
|
|
(loop (cdr members)
|
|
fields
|
|
(cons (if (null? args)
|
|
(process-method (car members) inherited-methods cname type-recs level)
|
|
(process-method (car members) inherited-methods cname type-recs level (car args)))
|
|
methods)
|
|
inners))
|
|
((def? (car members))
|
|
(loop (cdr members)
|
|
fields
|
|
methods
|
|
(cons (process-inner (car members) cname type-recs level) inners)))
|
|
(else
|
|
(loop (cdr members)
|
|
fields
|
|
methods
|
|
inners)))))
|
|
|
|
;; process-field: field (string list) type-records symbol -> field-record
|
|
(define (process-field field cname type-recs level)
|
|
(set-field-type! field (type-spec-to-type (field-type-spec field) cname level type-recs))
|
|
(make-field-record (id-string (field-name field))
|
|
(check-field-modifiers level (field-modifiers field))
|
|
(var-init? field)
|
|
cname
|
|
(field-type field)))
|
|
|
|
;; process-method: method (list method-record) (list string) type-records symbol -> method-record
|
|
(define (process-method method inherited-methods cname type-recs level . args)
|
|
(let* ((name (id-string (method-name method)))
|
|
(parms (map (lambda (p)
|
|
(set-field-type! p (type-spec-to-type (field-type-spec p) cname level type-recs))
|
|
(field-type p))
|
|
(method-parms method)))
|
|
(mods (if (null? args) (method-modifiers method) (cons (car args) (method-modifiers method))))
|
|
(ret (type-spec-to-type (method-type method) cname level type-recs))
|
|
(throws (filter (lambda (n)
|
|
(not (or (is-eq-subclass? n runtime-exn-type type-recs))))
|
|
;(is-eq-subclass? n error-type type-recs))))
|
|
(map (lambda (t)
|
|
(let ((n (make-ref-type (id-string (name-id t))
|
|
(map id-string (name-path t)))))
|
|
(if (is-eq-subclass? n throw-type type-recs)
|
|
n
|
|
(throws-error (name-id t) (name-src t)))))
|
|
(method-throws method))))
|
|
(over? (overrides? name parms inherited-methods)))
|
|
|
|
(when (and (memq level '(beginner intermediate))
|
|
(member name (map method-record-name inherited-methods))
|
|
(not over?))
|
|
(inherited-overload-error name parms (method-record-atypes
|
|
(car (filter (lambda (m) (equal? (method-record-name m) name))
|
|
inherited-methods)))
|
|
(id-src (method-name method))))
|
|
|
|
(when (eq? ret 'ctor)
|
|
(if (regexp-match "\\." (car cname))
|
|
(begin
|
|
(unless (equal? name (filename-extension (car cname)))
|
|
(not-ctor-error name (car cname) (id-src (method-name method))))
|
|
(set! name (car cname))
|
|
(set-id-string! (method-name method) (car cname)))
|
|
(unless (equal? name (car cname))
|
|
(not-ctor-error name (car cname) (id-src (method-name method))))))
|
|
|
|
(check-parm-names (method-parms method) name cname)
|
|
|
|
(when over?
|
|
(when (memq level `(advanced full))
|
|
(check-gtequal-access mods name parms cname over? (method-src method)))
|
|
|
|
(unless (type=? ret (method-record-rtype over?))
|
|
(override-return-error name parms cname ret
|
|
(method-record-rtype over?)
|
|
(type-spec-src (method-type method))))
|
|
|
|
(when (memq 'final (method-record-modifiers over?))
|
|
(override-access-error 'final level
|
|
name parms cname (method-record-class over?)
|
|
(id-src (method-name method))))
|
|
|
|
(when (and (memq level '(advanced full))
|
|
(memq 'static (method-record-modifiers over?)))
|
|
(override-access-error 'static level
|
|
name parms cname (method-record-class over?)
|
|
(id-src (method-name method))))
|
|
(when (eq? level 'full)
|
|
(check-throws-match throws method cname over? type-recs)))
|
|
|
|
(let ((record (make-method-record name
|
|
(check-method-modifiers level mods (eq? 'ctor ret))
|
|
ret
|
|
parms
|
|
throws
|
|
over?
|
|
cname)))
|
|
(set-method-rec! method record)
|
|
record)))
|
|
|
|
;process-inner def (list name) type-records symbol -> inner-record
|
|
(define (process-inner def cname type-recs level)
|
|
(make-inner-record (filename-extension (id-string (def-name def)))
|
|
(map modifier-kind (header-modifiers (def-header def)))
|
|
(class-def? def)))
|
|
|
|
;overrides?: string (list type) (list method-record) -> (U bool method-record)
|
|
(define (overrides? mname parms methods)
|
|
(and (not (null? methods))
|
|
(if (and (equal? mname
|
|
(method-record-name (car methods)))
|
|
(= (length parms)
|
|
(length (method-record-atypes (car methods))))
|
|
(andmap type=? parms (method-record-atypes (car methods))))
|
|
(car methods)
|
|
(overrides? mname parms (cdr methods)))))
|
|
|
|
;check-parm-names: (list field) string (list string) -> void
|
|
(define (check-parm-names parms meth class)
|
|
(or (null? parms)
|
|
(and (parm-member? (car parms) (cdr parms))
|
|
(repeated-parm-error (car parms) meth class))
|
|
(check-parm-names (cdr parms) meth class)))
|
|
|
|
;parm-member? field (list field) -> bool
|
|
(define (parm-member? p parms)
|
|
(and (not (null? parms))
|
|
(or (equal? (id-string (field-name p))
|
|
(id-string (field-name (car parms))))
|
|
(parm-member? p (cdr parms)))))
|
|
|
|
;check-gtequal-access: (list modifier) string (list type) (list string) method-record src -> void
|
|
(define (check-gtequal-access mods name parms class over src)
|
|
(let ((old-mods (method-record-modifiers over))
|
|
(old-class (method-record-class over)))
|
|
(cond
|
|
((memq 'public old-mods)
|
|
(unless (memq 'public (map modifier-kind mods))
|
|
(override-access-error 'public 'full name parms class (method-record-class over) src)))
|
|
((memq 'protected old-mods)
|
|
(unless (or (memq 'public (map modifier-kind mods))
|
|
(memq 'protected (map modifier-kind mods)))
|
|
(override-access-error 'protected 'full name parms class (method-record-class over) src)))
|
|
(else
|
|
(unless (or (memq 'public (map modifier-kind mods))
|
|
(not (memq 'private (map modifier-kind mods)))
|
|
(not (memq 'protected (map modifier-kind mods))))
|
|
(override-access-error 'package 'full name parms class (method-record-class over) src))))))
|
|
|
|
;check-throws-same: (list type) method (list string) method-record type-records -> void
|
|
(define (check-throws-match throws method cname over type-recs)
|
|
(if (= 0 (length (method-record-throws over)))
|
|
(for-each (lambda (t)
|
|
(unless (is-subclass-of1? t (method-record-throws over) type-recs)
|
|
(inherited-throw-error 'subclass
|
|
(method-name method)
|
|
(method-parms method)
|
|
cname
|
|
(method-record-class over)
|
|
t
|
|
(id-src (find-type t (method-throws method))))))
|
|
throws)
|
|
(inherited-throw-error 'num (method-name method) (method-parms method) cname
|
|
(method-record-class over) #t (method-src method))))
|
|
|
|
;is-subclass-of1?: type (list type) type-records-> bool
|
|
(define (is-subclass-of1? throw thrown type-recs)
|
|
(and (not (null? thrown))
|
|
(or (is-eq-subclass? throw (car thrown) type-recs)
|
|
(is-subclass-of1? throw (cdr thrown) type-recs))))
|
|
|
|
;find-type type (list name) -> src
|
|
(define (find-type throw throws)
|
|
(or (and (equal? (ref-type-class/iface throw)
|
|
(id-string (name-id (car throws))))
|
|
(name-id (car throws)))
|
|
(find-type throw (cdr throws))))
|
|
|
|
;-----------------------------------------------------------------------------------
|
|
;Code to check modifiers
|
|
|
|
;check-class-modifiers: symbol symbol (list modifier) -> (list symbol)
|
|
(define (check-class-modifiers level kind mods)
|
|
(when (and ((valid-class-mods? kind) level mods)
|
|
(not (final-and-abstract? mods))
|
|
(not (duplicate-mods? mods)))
|
|
(map modifier-kind mods)))
|
|
|
|
;check-interface-modifiers: (list modifier) symbol -> (list symbol)
|
|
(define (check-interface-modifiers level mods)
|
|
(when (and (valid-interface-mods? level mods)
|
|
(not (duplicate-mods? mods)))
|
|
(map modifier-kind mods)))
|
|
|
|
;check-method-modifiers: symbol (list modifier) -> (list symbol)
|
|
(define (check-method-modifiers level mods ctor?)
|
|
(when (and (not (duplicate-mods? mods))
|
|
(one-of-access? mods)
|
|
(if ctor?
|
|
(valid-method-mods? 'ctor mods)
|
|
(valid-method-mods? level mods))
|
|
(not (native-and-fp? mods))
|
|
(or (not (memq 'abstract (map modifier-kind mods)))
|
|
(valid-method-mods? 'abstract mods)))
|
|
(map modifier-kind mods)))
|
|
|
|
;check-field-modifiers: symbol (list modifier) -> (list symbol)
|
|
(define (check-field-modifiers level mods)
|
|
(when (and (not (duplicate-mods? mods))
|
|
(one-of-access? mods)
|
|
(valid-field-mods? level mods)
|
|
(not (volatile-and-final? mods)))
|
|
(map modifier-kind mods)))
|
|
|
|
;make-valid-mods: (symbol -> (list symbol)) (symbol -> symbol) -> (symbol (list modifier) -> bool)
|
|
(define (make-valid-mods valids-choice error-type)
|
|
(letrec ((tester
|
|
(lambda (level mods)
|
|
(or (null? mods)
|
|
(and (not (memq (modifier-kind (car mods)) (valids-choice level)))
|
|
(modifier-error (error-type level) (car mods)))
|
|
(tester level (cdr mods))))))
|
|
tester))
|
|
|
|
;valid-*-mods?: symbol -> (symbol (list modifier) -> bool)
|
|
(define (valid-class-mods? kind)
|
|
(make-valid-mods
|
|
(lambda (level)
|
|
(case kind
|
|
((top) '(public abstract final strictfp))
|
|
((member) '(public private protected abstract final static))
|
|
((anon) '())
|
|
((statement) '(public private protected abstract final))))
|
|
(lambda (x) 'invalid-class)))
|
|
(define valid-interface-mods?
|
|
(make-valid-mods (lambda (x) '(public abstract strictfp))
|
|
(lambda (x) 'invalid-iface)))
|
|
(define valid-field-mods?
|
|
(make-valid-mods
|
|
(lambda (level)
|
|
(case level
|
|
((beginner) '(public final))
|
|
((intermediate) '(public))
|
|
((advanced) '(public protected private static))
|
|
((full) `(public protected private static final transient volatile))))
|
|
(lambda (x) 'invalid-field)))
|
|
(define valid-method-mods?
|
|
(make-valid-mods
|
|
(lambda (level)
|
|
(case level
|
|
((beginner intermediate) '(public abstract))
|
|
((advanced) `(public protected private abstract static final))
|
|
((full) '(public protected private abstract static final synchronized native strictfp))
|
|
((abstract) '(public protected abstract))
|
|
((ctor) '(public protected private))))
|
|
(lambda (level)
|
|
(case level
|
|
((abstract) 'invalid-abstract)
|
|
((ctor) 'invalid-ctor)
|
|
(else 'invalid-method)))))
|
|
|
|
;one-access: symbol symbol symbol (list modifiers) -> bool
|
|
(define (one-access is check1 check2 mods)
|
|
(and (eq? is (modifier-kind (car mods)))
|
|
(or (memq check1 (map modifier-kind (cdr mods)))
|
|
(memq check2 (map modifier-kind (cdr mods))))
|
|
(modifier-error 'access (car mods))))
|
|
|
|
;one-of-access?: (list modifier) -> bool
|
|
(define (one-of-access? mods)
|
|
(or (null? mods)
|
|
(one-access 'public 'private 'protected mods)
|
|
(one-access 'private 'public 'protected mods)
|
|
(one-access 'protected 'private 'public mods)
|
|
(one-of-access? (cdr mods))))
|
|
|
|
;make-not-two: symbol symbol symbol -> ((list modifier) -> bool)
|
|
(define (make-not-two first second error)
|
|
(letrec ((tester
|
|
(lambda (mods)
|
|
(and (not (null? mods))
|
|
(or (and (eq? first (modifier-kind (car mods)))
|
|
(memq second (map modifier-kind (cdr mods)))
|
|
(modifier-error error (car mods)))
|
|
(and (eq? second (modifier-kind (car mods)))
|
|
(memq first (map modifier-kind (cdr mods)))
|
|
(modifier-error error (car mods)))
|
|
(tester (cdr mods)))))))
|
|
tester))
|
|
|
|
(define final-and-abstract? (make-not-two 'final 'abstract 'final-abstract))
|
|
(define volatile-and-final? (make-not-two 'volatile 'final 'final-volatile))
|
|
(define native-and-fp? (make-not-two 'native 'strictfp 'native-strictfp))
|
|
|
|
;duplicate-mods?: (list modifier) -> bool
|
|
(define (duplicate-mods? mods)
|
|
(and (not (null? mods))
|
|
(or (and (memq (modifier-kind (car mods))
|
|
(map modifier-kind (cdr mods)))
|
|
(modifier-error 'dups (car mods)))
|
|
(duplicate-mods? (cdr mods)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;Error raising code: code that takes information about the error message and throws the error
|
|
|
|
;repeated-def-name-error: id bool symbol src -> void
|
|
(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 "))
|
|
n src)))
|
|
|
|
;modifier-error: symbol modifier -> void
|
|
(define (modifier-error kind mod)
|
|
(let ((m (modifier-kind mod))
|
|
(src (modifier-src mod)))
|
|
(raise-error m
|
|
(case kind
|
|
((dups)
|
|
(format "Modifier ~a may only appear once in a declaration, it occurs multiple times here." m))
|
|
((access)
|
|
"Declaration may only be one of public, private, or protected, more than one occurs here")
|
|
((invalid-iface)
|
|
(format "Modifier ~a is not valid for interfaces" m))
|
|
((invalid-class)
|
|
(format "Modifier ~a is not valid for classes" m))
|
|
((invalid-field)
|
|
(format "Modifier ~a is not valid for fields" m))
|
|
((invalid-method)
|
|
(format "Modifier ~a is not valid for methods" m))
|
|
((invalid-ctor)
|
|
(format "Modifier ~a is not valid for constructors" m))
|
|
((invalid-abstract)
|
|
(format "Modifier ~a is not valid for an abstract method" m))
|
|
((final-abstract) "Class declared final and abstract which is not allowed")
|
|
((final-volatile) "Field declared final and volatile which is not allowed")
|
|
((native-strictfp) "Method declared native and strictfp which is not allowed"))
|
|
m src)))
|
|
|
|
;dependence-error: symbol id src -> void
|
|
(define (dependence-error kind name src)
|
|
(let ((n (id->ext-name name)))
|
|
(raise-error n
|
|
(case kind
|
|
((immediate) (format "~a may not extend itself, which it does here" n))
|
|
((cycle)
|
|
(format "~a is illegally dependent on itself, potentially through other definitions" n)))
|
|
n src)))
|
|
|
|
;extension-error: symbol id name src -> void
|
|
(define (extension-error kind name super src)
|
|
(let ((n (if name (id->ext-name name) name))
|
|
(s (id->ext-name (name-id super))))
|
|
(raise-error
|
|
s
|
|
(case kind
|
|
((final)
|
|
(format "Final classes may never be extended, therefore final class ~a may not be extended by ~a" s n))
|
|
((implement)
|
|
(format
|
|
"A class may only declare an implemented interface once, this class declares it is implementing ~a more than once"
|
|
s))
|
|
((ifaces)
|
|
(format "An interface may only declare each extended interface once, ~a declares this interface more than once" s))
|
|
((iface-class)
|
|
(format "Interfaces may never extend classes, interface ~a has attemped to extend ~a, which is a class" n s))
|
|
((class-iface)
|
|
(format "Classes may never extend interfaces, class ~a has attempted to extend ~a, which is an interface" n s))
|
|
((implement-class)
|
|
(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?)
|
|
(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)))
|
|
(raise-error
|
|
m-name
|
|
(case kind
|
|
((illegal-abstract)
|
|
(format
|
|
"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"
|
|
(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))
|
|
((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)))
|
|
m-name src))))
|
|
|
|
;inherited-overload-error: string (list type) (list type) src -> void
|
|
(define (inherited-overload-error name new-type inherit-type src)
|
|
(let ((n (string->symbol name))
|
|
(nt (map type->ext-name new-type))
|
|
(gt (map type->ext-name inherit-type)))
|
|
(raise-error n
|
|
(string-append
|
|
(format "Attempted to override method ~a, but it should have ~a arguments with types ~a.~n"
|
|
n (length inherit-type) gt)
|
|
(format "Given ~a arguments with types ~a" (length new-type) nt))
|
|
n src)))
|
|
|
|
;not-ctor-error: string string src -> void
|
|
(define (not-ctor-error meth class src)
|
|
(let ((n (string->symbol meth)))
|
|
(raise-error
|
|
n
|
|
(format "~a~n~a"
|
|
(format "Method ~a has no return type and does not have the same name as the class, ~a"
|
|
n class)
|
|
"Only constructors may have no return type, but must have the name of the class")
|
|
n src)))
|
|
|
|
;beginner-ctor-error: symbol id src -> void
|
|
(define (beginner-ctor-error kind class src)
|
|
(let ((n (id->ext-name class)))
|
|
(raise-error n (case kind
|
|
((none) (format "Class ~a must have a constructor" n))
|
|
((abstract) (format "Abstract class ~a may not have a constructor" n))) n src)))
|
|
|
|
;default-ctor-error symbol id string src symbol -> void
|
|
(define (default-ctor-error kind name parent src level)
|
|
(let ((n (id->ext-name name)))
|
|
(raise-error n
|
|
(case kind
|
|
((private)
|
|
(if (memq level '(beginner intermediate))
|
|
(format "Class ~a cannot extend ~a" n parent)
|
|
(format "Class ~a cannot access the default constructor of ~a, which is private" n parent)))
|
|
((non-accessible)
|
|
(if (memq level '(beginner intermediate))
|
|
(format "Class ~a must have a constructor due to its extension of class ~a" n parent)
|
|
(format "Class ~a cannot access a default constructor for ~a" n parent)))
|
|
((throws)
|
|
(format "Class ~a cannot use the default constructor for ~a, as ~a's default contains a throws clause"
|
|
n parent parent)))
|
|
n src)))
|
|
|
|
;inherited-throw-error:symbol string (list type) (list string) string type src -> void
|
|
(define (inherited-throw-error kind m-name parms class parent throw src)
|
|
(raise-error
|
|
'throws
|
|
(case kind
|
|
((num)
|
|
(format
|
|
"Method ~a in ~a overrides a method from ~a: Method in ~a should throw no types if original doesn't"
|
|
(method-name->ext-name m-name parms) (car class) parent (car class)))
|
|
((subclass)
|
|
(let ((line1 (format "Method ~a in ~a overrides from a method from ~a"
|
|
(method-name->ext-name m-name parms) (car class) parent))
|
|
(line2
|
|
(format
|
|
"All types thrown by overriding method in ~a must be subtypes of original throws: ~a is not"
|
|
(car class) (type->ext-name throw))))
|
|
(format "~a~n~a" line1 line2))))
|
|
'throws src))
|
|
|
|
;return-error string (list type) (list string) type type src -> void
|
|
(define (override-return-error name parms class ret old-ret src)
|
|
(let ((name (string->symbol name))
|
|
(m-name (method-name->ext-name name parms)))
|
|
(raise-error
|
|
name
|
|
(format
|
|
"~a~n~a"
|
|
(format "Method ~a of class ~a overrides an inherited method, in overriding the return type must remain the same"
|
|
m-name (car class))
|
|
(format "~a's return has changed from ~a to ~a" m-name (type->ext-name old-ret) (type->ext-name ret)))
|
|
name src)))
|
|
|
|
;override-access-error symbol symbol string (list type) (list string) string src -> void
|
|
(define (override-access-error kind level name parms class parent src)
|
|
(let ((name (string->symbol name))
|
|
(m-name (method-name->ext-name name parms)))
|
|
(raise-error name
|
|
(case kind
|
|
((final)
|
|
(if (eq? level 'full)
|
|
(format
|
|
"Method ~a in ~a attempts to override final method from ~a, final methods may not be overridden"
|
|
m-name (car class) parent)
|
|
(format "Method ~a from ~a cannot be overridden in ~a" m-name parent (car class))))
|
|
((static)
|
|
(format "Method ~a in ~a attempts to override static method from ~a, which is not allowed"
|
|
m-name (car class) parent))
|
|
((public)
|
|
(format "Method ~a in ~a must be public to override public method from ~a, ~a is not public"
|
|
m-name (car class) parent m-name))
|
|
((protected)
|
|
(format
|
|
"Method ~a in ~a must be public or protected to override protected method from ~a, it is neither"
|
|
m-name (car class) parent))
|
|
((package)
|
|
(format "Method ~a in ~a must be public, or have no access modifier, to override method from ~a"
|
|
m-name (car class) parent)))
|
|
name src)))
|
|
|
|
;repeated-parm-error: field string (list string) -> void
|
|
(define (repeated-parm-error parm meth class)
|
|
(let ((name (id->ext-name (field-name parm))))
|
|
(raise-error name
|
|
(format
|
|
"Method parameters may not share names, ~a in ~a cannot have multiple parameters with the name ~a"
|
|
meth (car class) name)
|
|
name (id-src (field-name parm)))))
|
|
|
|
;field-name-error: symbol id symbol src -> void
|
|
(define (field-name-error kind name level src)
|
|
(let ((n (id->ext-name name)))
|
|
(raise-error n
|
|
(case kind
|
|
((field)
|
|
(format
|
|
"Each field in a class must have a unique name. Multiple fields have been declared with the name ~a"
|
|
n))
|
|
((method)
|
|
(format "~a has been declared as a field and a method, which is not allowed" n))
|
|
((class)
|
|
(format "~a has been declared as a field and a ~a, which is not allowed" n
|
|
(if (eq? level 'intermediate) "class or interface" "class")))
|
|
((inherited-conflict-method)
|
|
(format "Method ~a conflicts with an inherited field of the same name" n)))
|
|
n src)))
|
|
|
|
;import-error: name src -> void
|
|
(define (import-error imp src)
|
|
(raise-error 'import
|
|
(format "Import ~a not found" (path->ext (name->path imp)))
|
|
'import src))
|
|
|
|
;file-error: symbol (list string) src symbol -> void
|
|
(define (file-error kind path src level)
|
|
(if (eq? level 'full)
|
|
(let ((k (if (eq? kind 'file) 'file-not-found 'directory-not-found)))
|
|
(raise-error k
|
|
(case kind
|
|
((file) (format "Required file ~a not found" (path->ext path)))
|
|
((dir) (format "Required directory ~a not found" (path->ext path))))
|
|
k src))
|
|
(raise-error (string->symbol (car path))
|
|
(case kind
|
|
((file) (format "Class ~a is not known" (path->ext path)))
|
|
((dir) (format "Directory to search, ~a, is not known" (path->ext path))))
|
|
(string->symbol (car path))
|
|
src)))
|
|
|
|
;used-restricted-import: string (list string) src -> void
|
|
(define (used-restricted-import class path src)
|
|
(raise-error 'import
|
|
(format "Imported class, ~a, cannot be imported or used" (path->ext (cons class path)))
|
|
'import src))
|
|
|
|
|
|
;throws-error id src -> void
|
|
(define (throws-error t src)
|
|
(raise-error 'throws
|
|
(format "Thrown class must be a subtype of Throwable: Given ~a" (id->ext-name t))
|
|
'throws src))
|
|
|
|
(define build-info-location (make-parameter #f))
|
|
(define raise-error (make-error-pass build-info-location))
|
|
|
|
)
|
|
|