106 lines
5.2 KiB
Scheme
106 lines
5.2 KiB
Scheme
#lang scheme/base
|
|
|
|
(require "matcher.ss")
|
|
|
|
;; don't provide reduction-relation directly, so that we can use that for the macro's name.
|
|
(provide reduction-relation-lang
|
|
reduction-relation-make-procs
|
|
reduction-relation-rule-names
|
|
reduction-relation-lws
|
|
reduction-relation-procs
|
|
build-reduction-relation
|
|
reduction-relation?
|
|
empty-reduction-relation
|
|
make-rewrite-proc rewrite-proc? rewrite-proc-name
|
|
rewrite-proc-lhs rewrite-proc-lhs-src rewrite-proc-id
|
|
(struct-out rule-pict))
|
|
|
|
(define-struct rule-pict (arrow lhs rhs label side-conditions/pattern-binds fresh-vars))
|
|
|
|
;; type proc = (exp exp (any -> any) (listof any) -> (listof any)))
|
|
;; a proc is a `cached' version of a make-proc, specialized to a particular langugage
|
|
;; since that first application does all the work of compiling a pattern (wrt to a language),
|
|
;; we want to avoid doing it multiple times, so it is cached in a reduction-relation struct
|
|
|
|
|
|
(define-values (make-rewrite-proc
|
|
rewrite-proc?
|
|
rewrite-proc-name rewrite-proc-lhs rewrite-proc-lhs-src rewrite-proc-id)
|
|
(let ()
|
|
(define-values (type constructor predicate accessor mutator)
|
|
(make-struct-type 'rewrite-proc #f 5 0 #f '() #f 0))
|
|
(values constructor
|
|
predicate
|
|
(make-struct-field-accessor accessor 1 'name)
|
|
(make-struct-field-accessor accessor 2 'lhs)
|
|
(make-struct-field-accessor accessor 3 'lhs-src)
|
|
(make-struct-field-accessor accessor 4 'id))))
|
|
|
|
;; lang : compiled-language
|
|
;; make-procs = (listof (compiled-lang -> proc))
|
|
;; rule-names : (listof sym)
|
|
;; procs : (listof proc)
|
|
(define-struct reduction-relation (lang make-procs rule-names lws procs))
|
|
|
|
(define empty-reduction-relation (make-reduction-relation 'empty-reduction-relations-language
|
|
'()
|
|
'()
|
|
'()
|
|
'()))
|
|
|
|
;; the domain pattern isn't actually used here.
|
|
;; I started to add it, but didn't finish. -robby
|
|
(define (build-reduction-relation orig-reduction-relation lang make-procs rule-names lws domain-pattern)
|
|
(let* ([make-procs/check-domain
|
|
(let loop ([make-procs make-procs]
|
|
[i 0])
|
|
(cond
|
|
[(null? make-procs) null]
|
|
[else
|
|
(let ([make-proc (car make-procs)])
|
|
(cons (make-rewrite-proc
|
|
(λ (lang)
|
|
(let ([compiled-domain-pat (compile-pattern lang domain-pattern #f)]
|
|
[proc (make-proc lang)])
|
|
(λ (tl-exp exp f acc)
|
|
(unless (match-pattern compiled-domain-pat tl-exp)
|
|
(error 'reduction-relation "relation not defined for ~s" tl-exp))
|
|
(let ([ress (proc tl-exp exp f acc)])
|
|
(for-each
|
|
(λ (res)
|
|
(let ([term (cadr res)])
|
|
(unless (match-pattern compiled-domain-pat term)
|
|
(error 'reduction-relation "relation reduced to ~s via ~a, which is outside its domain"
|
|
term
|
|
(let ([name (rewrite-proc-name make-proc)])
|
|
(if name
|
|
(format "the rule named ~a" name)
|
|
(format "rule #~a (counting from 0)" i)))))))
|
|
ress)
|
|
ress))))
|
|
(rewrite-proc-name make-proc)
|
|
(rewrite-proc-lhs make-proc)
|
|
(rewrite-proc-lhs-src make-proc)
|
|
(rewrite-proc-id make-proc))
|
|
(loop (cdr make-procs)
|
|
(+ i 1))))]))])
|
|
(cond
|
|
[orig-reduction-relation
|
|
(let* ([new-names (map rewrite-proc-name make-procs)]
|
|
[all-make-procs
|
|
(append
|
|
(filter (λ (x) (or (not (rewrite-proc-name x))
|
|
(not (member (rewrite-proc-name x) new-names))))
|
|
(reduction-relation-make-procs orig-reduction-relation))
|
|
make-procs/check-domain)])
|
|
(make-reduction-relation lang
|
|
all-make-procs
|
|
(append rule-names
|
|
(reduction-relation-rule-names orig-reduction-relation))
|
|
lws ;; only keep new lws for typesetting
|
|
(map (λ (make-proc) (make-proc lang)) all-make-procs)))]
|
|
[else
|
|
(make-reduction-relation lang make-procs/check-domain rule-names lws
|
|
(map (λ (make-proc) (make-proc lang))
|
|
make-procs/check-domain))])))
|