62 lines
2.4 KiB
Scheme
62 lines
2.4 KiB
Scheme
|
|
(module sba-errors (lib "mrflow.ss" "mrflow")
|
|
(require
|
|
(prefix cst: "constants.ss")
|
|
(prefix lab: "labels.ss")
|
|
;"assoc-set-list.ss"
|
|
"assoc-set-hash.ss"
|
|
)
|
|
|
|
; (listof label) symbol string
|
|
; need this before the contracts because of sba-error?
|
|
(define-struct sba-error (labels gravity message) (make-inspector))
|
|
|
|
; (assoc-setof label (listof sba-error))
|
|
; we use a list instead of a set for the sba-errors, because that's what error-table-get
|
|
; has to return anyway
|
|
(define-struct error-table (assoc-set))
|
|
|
|
(provide/contract
|
|
(sba-error-gravity (sba-error? . -> . (symbols 'red 'orange 'green)))
|
|
(sba-error-message (sba-error? . -> . string?))
|
|
(error-table-make (-> error-table?))
|
|
(error-table? (any/c . -> . boolean?))
|
|
(error-table-set (error-table? (listof lab:label?) (symbols 'red 'orange 'green) string? . -> . void?))
|
|
(error-table-get (error-table? lab:label? . -> . (listof sba-error?)))
|
|
)
|
|
|
|
; -> error-table
|
|
(define (error-table-make)
|
|
(make-error-table (assoc-set-make)))
|
|
|
|
; top -> boolean
|
|
; error-table? comes from the structure definition
|
|
|
|
; error-table (listof label) (union 'red 'orange 'green) string -> void
|
|
; adds error to the error list for each label
|
|
; we use terms instead of labels as the key, because a primitive will have several labels
|
|
; associated with it (one created from the program text, and at least one created from the
|
|
; type for that primitive), so we need to use as key something unique about the primitive.
|
|
(define (error-table-set error-table labels gravity message)
|
|
(let ([assoc-set (error-table-assoc-set error-table)]
|
|
[error (make-sba-error labels gravity message)])
|
|
(for-each (lambda (label)
|
|
(let ([term (lab:label-term label)])
|
|
(if (syntax-position term)
|
|
(assoc-set-set
|
|
assoc-set
|
|
term
|
|
(cons error (assoc-set-get assoc-set term cst:thunk-empty))
|
|
#f)
|
|
(printf "~a error detected for term ~a: ~a~n"
|
|
gravity
|
|
(syntax-object->datum term)
|
|
message))))
|
|
labels)))
|
|
|
|
; error-table label -> (listof sba-error)
|
|
(define (error-table-get error-table label)
|
|
(assoc-set-get (error-table-assoc-set error-table) (lab:label-term label) cst:thunk-empty))
|
|
|
|
)
|