112 lines
3.2 KiB
Scheme
112 lines
3.2 KiB
Scheme
#lang scheme/base
|
|
(require (for-syntax scheme/base)
|
|
scheme/match
|
|
scheme/contract
|
|
"deriv.ss"
|
|
"deriv-util.ss"
|
|
"reductions-config.ss"
|
|
"stx-util.ss")
|
|
|
|
(provide current-unvisited-lifts
|
|
current-unhidden-lifts
|
|
|
|
current-hiding-warning-handler
|
|
|
|
handle-hiding-failure
|
|
warn
|
|
|
|
DEBUG-LIFTS
|
|
|
|
add-unhidden-lift
|
|
extract/remove-unvisited-lift)
|
|
|
|
;; Parameters
|
|
|
|
;; current-hiding-warning-handler : (parameter-of (symbol any -> void))
|
|
(define current-hiding-warning-handler
|
|
(make-parameter
|
|
(lambda (tag args) (printf "hiding warning: ~a\n" tag))))
|
|
|
|
;; current-unvisited-lifts : (paramter-of Derivation)
|
|
;; The derivs for the lifts yet to be seen in the processing
|
|
;; of the first part of the current lift-deriv.
|
|
(define current-unvisited-lifts (make-parameter null))
|
|
|
|
;; current-unhidden-lifts : (parameter-of Derivation)
|
|
;; The derivs for those lifts that occur within unhidden macros.
|
|
;; Derivs are moved from the current-unvisited-lifts to this list.
|
|
(define current-unhidden-lifts (make-parameter null))
|
|
|
|
;; Helper
|
|
|
|
(define-syntax DEBUG-LIFTS
|
|
(syntax-rules ()
|
|
[(DEBUG-LIFTS . b)
|
|
(void)]
|
|
#;
|
|
[(DEBUG-LIFTS . b)
|
|
(begin . b)]))
|
|
|
|
;; Operations
|
|
|
|
;; add-unhidden-lift : Derivation -> void
|
|
(define (add-unhidden-lift d)
|
|
(when d
|
|
(current-unhidden-lifts
|
|
(cons d (current-unhidden-lifts)))))
|
|
|
|
;; extract/remove-unvisted-lift : identifier -> Derivation
|
|
(define (extract/remove-unvisited-lift id)
|
|
(define (get-defined-id d)
|
|
(match d
|
|
[(Wrap deriv (e1 e2))
|
|
(with-syntax ([(?define-values (?id) ?expr) e1])
|
|
#'?id)]))
|
|
;; The Wrong Way
|
|
(let ([unvisited (current-unvisited-lifts)])
|
|
(if (null? unvisited)
|
|
(begin (DEBUG-LIFTS
|
|
(printf "hide:extract/remove-unvisited-lift: out of lifts!"))
|
|
#f)
|
|
(let ([lift (car unvisited)])
|
|
(DEBUG-LIFTS
|
|
(printf "extracting lift: ~s left\n" (length (cdr unvisited))))
|
|
(current-unvisited-lifts (cdr unvisited))
|
|
lift)))
|
|
;; The Right Way
|
|
;; FIXME: Doesn't work inside of modules. Why not?
|
|
#;
|
|
(let loop ([lifts (current-unvisited-lifts)]
|
|
[prefix null])
|
|
(cond [(null? lifts)
|
|
(DEBUG-LIFTS
|
|
(fprintf (current-error-port)
|
|
"hide:extract/remove-unvisited-lift: can't find lift for ~s~n"
|
|
id))
|
|
(raise (make localactions))]
|
|
[(bound-identifier=? id (get-defined-id (car lifts)))
|
|
(let ([lift (car lifts)])
|
|
(current-unvisited-lifts
|
|
(let loop ([prefix prefix] [lifts (cdr lifts)])
|
|
(if (null? prefix)
|
|
lifts
|
|
(loop (cdr prefix) (cons (car prefix) lifts)))))
|
|
lift)]
|
|
[else
|
|
(loop (cdr lifts) (cons (car lifts) prefix))])))
|
|
|
|
;; Warnings
|
|
|
|
(define (warn tag . args)
|
|
((current-hiding-warning-handler) tag args))
|
|
|
|
(define (handle-hiding-failure d failure)
|
|
(match failure
|
|
[(struct nonlinearity (term paths))
|
|
(warn 'nonlinearity term paths d)]
|
|
[(struct localactions ())
|
|
(warn 'localactions d)]
|
|
[(struct hidden-lift-site ())
|
|
(warn 'hidden-lift-site d)]))
|
|
|