116 lines
3.8 KiB
Scheme
116 lines
3.8 KiB
Scheme
(module error-messaging mzscheme
|
|
|
|
(require "ast.ss")
|
|
(require "types.ss")
|
|
|
|
(provide make-error-pass get-expected type->ext-name id->ext-name
|
|
get-call-type method-name->ext-name path->ext name->path
|
|
statement->ext-name)
|
|
|
|
;make-error: 'a string 'a src -> void
|
|
(define (make-error-pass parm)
|
|
(lambda (_ message syn-obj src)
|
|
(raise (make-exn:fail:syntax
|
|
message (current-continuation-marks)
|
|
(list (make-so syn-obj src parm))))))
|
|
|
|
;make-so: symbol src (-> location) -> syntax-object
|
|
(define (make-so id src parm)
|
|
(datum->syntax-object #f id (build-src-list src parm)))
|
|
|
|
;build-src-list: src (-> location) -> (U bool (list loc int int int int))
|
|
(define (build-src-list src parm)
|
|
(if (not src)
|
|
src
|
|
(if (and (= (src-line src) 0)
|
|
(= (src-col src) 0)
|
|
(= (src-pos src) 0)
|
|
(= (src-span src) 0))
|
|
#f
|
|
(list (or (src-file src) (parm)) (src-line src) (src-col src) (src-pos src) (src-span src)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;Message helpers
|
|
|
|
;get-expected: symbol-> string
|
|
(define (get-expected e)
|
|
(case e
|
|
((bool) 'boolean)
|
|
((int) "int, short, byte or char")
|
|
((num) "double, float, long, int, short, byte or char")
|
|
(else "dummy")))
|
|
|
|
;type->ext-name: type -> symbol
|
|
(define (type->ext-name t)
|
|
(string->symbol
|
|
(cond
|
|
((ref-type? t) (ref-type-class/iface t))
|
|
((array-type? t)
|
|
(format "~a~a" (type->ext-name (array-type-type t))
|
|
(let ((dims ""))
|
|
(let loop ((d (array-type-dim t)))
|
|
(if (= d 0)
|
|
dims
|
|
(begin (set! dims (string-append dims "[]"))
|
|
(loop (sub1 d))))))))
|
|
(else (format "~a" t)))))
|
|
|
|
;id->ext-name: id -> symbol
|
|
(define (id->ext-name id)
|
|
(string->symbol (if (special-name? id)
|
|
(special-name-name id)
|
|
(id-string id))))
|
|
|
|
;get-call-type: type -> string
|
|
(define (get-call-type t)
|
|
(cond
|
|
((eq? t 'super) "the current super class")
|
|
((not t) "this class")
|
|
(else (type->ext-name t))))
|
|
|
|
;make-parm-string: (list type) -> string
|
|
(define (make-parm-string parms)
|
|
(if (null? parms)
|
|
""
|
|
(let ((parm-str (apply string-append
|
|
(map
|
|
(lambda (p) (format "~a " (type->ext-name p))) parms))))
|
|
(substring parm-str 0 (sub1 (string-length parm-str))))))
|
|
|
|
;method-name->ext-name: string (list type) -> symbol
|
|
;(define (method-name->ext-name name parms)
|
|
; (string->symbol (format "~a(~a)" name (make-parm-string parms))))
|
|
|
|
(define (method-name->ext-name name parms)
|
|
(string->symbol
|
|
(cond
|
|
((null? parms) name)
|
|
((= 1 (length parms)) (format "~a, expecting one argument with type ~a, "
|
|
name (type->ext-name (car parms))))
|
|
(else
|
|
(format "~a, expecting arguments with types ~a," name (make-parm-string parms))))))
|
|
|
|
;path->ext: (list string) -> string
|
|
(define (path->ext path)
|
|
(apply string-append
|
|
(append (map (lambda (a) (string-append a "."))
|
|
(cdr path))
|
|
(list (car path)))))
|
|
|
|
;name->path: name -> (list string)
|
|
(define (name->path n)
|
|
(cons (id-string (name-id n)) (map id-string (name-path n))))
|
|
|
|
;statement->ext-name: statement -> symbol
|
|
(define (statement->ext-name s)
|
|
(cond
|
|
((ifS? s) 'if)
|
|
((return? s) 'return)
|
|
((call? s)
|
|
(let ((method (call-method-name s)))
|
|
(string->symbol (if (special-name? method)
|
|
(special-name-name method)
|
|
(id-string method)))))))
|
|
|
|
)
|