48 lines
1.6 KiB
Scheme
48 lines
1.6 KiB
Scheme
(module contract-opt-guts mzscheme
|
|
(require "contract.ss"
|
|
"contract-guts.ss"
|
|
"contract-arrow.ss")
|
|
|
|
(provide make-known known? known-flag known-sexp
|
|
get-opter reg-opter! opter
|
|
make-lifted interleave-lifted)
|
|
|
|
(define-struct known (flag sexp))
|
|
|
|
;; State information for opters
|
|
(define opters-table
|
|
(make-hash-table 'equal))
|
|
|
|
;; get-opter : syntax -> opter
|
|
(define (get-opter ctc)
|
|
(hash-table-get opters-table ctc #f))
|
|
|
|
;; opter : syntax or symbol -> opter
|
|
(define (opter ctc)
|
|
(if (or (identifier? ctc) (symbol? ctc))
|
|
(let ((key (if (syntax? ctc) (syntax-e ctc) ctc)))
|
|
(get-opter key))
|
|
(error 'opter "the argument must either be an identifier or a syntax object of an identifier, got ~e" ctc)))
|
|
|
|
;; reg-opter! : symbol opter ->
|
|
(define (reg-opter! ctc opter)
|
|
(hash-table-put! opters-table ctc opter))
|
|
|
|
;; make-lifted : list -> syntax
|
|
;; converts a list of lifted-var lifted-expr pairs into a syntax object
|
|
;; suitable for use in a let.
|
|
(define (make-lifted lst)
|
|
(map (λ (x) (with-syntax ((var (car x))
|
|
(e (cdr x)))
|
|
(syntax (var e)))) lst))
|
|
|
|
;; interleave-lifted : list list -> list
|
|
;; interleaves a list of variables names and a list of sexps into a list of
|
|
;; (var sexp) pairs
|
|
(define (interleave-lifted vars sexps)
|
|
(if (= (length vars) (length sexps))
|
|
(if (null? vars) null
|
|
(cons (cons (car vars) (car sexps))
|
|
(interleave-lifted (cdr vars) (cdr sexps))))
|
|
(error 'interleave-lifted "expected lists of equal length, got ~e and ~e" vars sexps))))
|