suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

attempted to clean up the derivation support

Browse Source 
so that no derivation data structure creation
happens during just a normal judgment-holds,
but this was not entirely successful, so there
still is some....

Also, improved the test-util to show stacktraces
for errors (when they exist)
This commit is contained in:
Robby Findler 2012-10-22 15:16:15 -05:00
parent 1b589c1529
commit 661f702497
2 changed files with 99 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/redex/private/judgment-form.rkt
View File

@ -196,7 +196,7 @@
(let ([input (quasisyntax/loc premise (term/nts #,input-template #,lang-nts))])
(define (make-traced input)
(quasisyntax/loc premise
(call-judgment-form 'form-name #,judgment-proc '#,mode #,input)))
(call-judgment-form 'form-name #,judgment-proc '#,mode #,input #,(if jf-results-id #''() #f))))
(if under-ellipsis?
#`(repeated-premise-outputs #,input (λ (x) #,(make-traced #'x)))
(make-traced input)))])
@ -213,7 +213,7 @@
#,call
#,under-ellipsis?
#,jf-results-id
(λ (bindings #,@(if jf-results-id (list jf-results-id) '()))
(λ (bindings #,(if jf-results-id jf-results-id '_ignored))
(let ([temp (lookup-binding bindings 'output-name)] ...)
(and binding-constraint ...
(term-let ([output-name/ellipsis temp] ...)
@ -231,12 +231,11 @@
(define mtchs (match-pattern compiled-pattern term))
(if mtchs
(for/fold ([outputs outputs]) ([mtch (in-list mtchs)])
(define mtch-outputs (if old-maps
(do-something (mtch-bindings mtch)
(define mtch-outputs (do-something (mtch-bindings mtch)
(and old-maps
(if under-ellipsis?
(append (reverse sub-tree) old-maps)
(cons sub-tree old-maps)))
(do-something (mtch-bindings mtch))))
(cons sub-tree old-maps)))))
(if mtch-outputs
(append mtch-outputs outputs)
outputs))
@ -262,7 +261,7 @@
(for*/list ([o output] [os (repeated-premise-outputs (cdr inputs) premise)])
(cons o os))))))
(define (call-judgment-form form-name form-proc mode input)
(define (call-judgment-form form-name form-proc mode input derivation-init)
(define traced (current-traced-metafunctions))
(define vecs
(if (or (eq? 'all traced) (memq form-name traced))
@ -271,15 +270,16 @@
(for/fold ([s '()]) ([m mode])
(case m [(I) s] [(O) (cons '_ s)])))
(define (wrapped . _)
(set! outputs (form-proc form-proc input))
(set! outputs (form-proc form-proc input derivation-init))
(for/list ([output outputs])
(cons form-name (assemble mode input (vector-ref output 1)))))
(apply trace-call form-name wrapped (assemble mode input spacers))
outputs)
(form-proc form-proc input)))
(form-proc form-proc input derivation-init)))
(for/list ([v (in-list vecs)])
(vector (derivation (cons form-name (assemble mode input (vector-ref v 1)))
(reverse (vector-ref v 0)))
(define subs (vector-ref v 0))
(vector (and subs (derivation (cons form-name (assemble mode input (vector-ref v 1)))
(reverse subs)))
(vector-ref v 1))))
(struct derivation (term subs)
#:transparent
@ -588,6 +588,7 @@
#'(#%expression (judgment-holds/derivation build-derivations #t jf-expr any))]))
(define-for-syntax (do-compile-judgment-form-proc name mode-stx clauses contracts nts orig stx syn-error-name)
(with-syntax ([(init-jf-derivation-id) (generate-temporaries '(init-jf-derivation-id))])
(define mode (cdr (syntax->datum mode-stx)))
(define-values (input-contracts output-contracts)
(if contracts
@ -620,8 +621,7 @@
#`(
;; pieces of a 'let' expression to be combined: first some bindings
([jf-derivation-id '()]
[compiled-lhs (compile-pattern lang `lhs #t)]
([compiled-lhs (compile-pattern lang `lhs #t)]
#,@(if (contracts-compilation input-contracts)
(list #`[compiled-input-ctcs #,(contracts-compilation input-contracts)])
(list))
@ -629,6 +629,7 @@
(list #`[compiled-output-ctcs #,(contracts-compilation output-contracts)])
(list)))
;; and then the body of the let, but expected to be behind a (λ (input) ...).
(let ([jf-derivation-id init-jf-derivation-id])
(begin
#,@(if (contracts-compilation input-contracts)
(list #`(check-judgment-form-contract '#,name input compiled-input-ctcs 'I '#,mode))
@ -642,7 +643,7 @@
#,(if (contracts-compilation output-contracts)
#`(λ (output)
(check-judgment-form-contract '#,name output compiled-output-ctcs 'O '#,mode))
#`void)))))))]))
#`void))))))))]))
(when (identifier? orig)
(define orig-mode (judgment-form-mode (lookup-judgment-form-id orig)))
@ -662,13 +663,13 @@
#`(λ (lang)
(let (clause-proc-binding ... ...)
(let ([prev (orig-mk lang)])
(λ (recur input)
(append (prev recur input)
(λ (recur input init-jf-derivation-id)
(append (prev recur input init-jf-derivation-id)
clause-proc-body-backwards ...))))))
#`(λ (lang)
(let (clause-proc-binding ... ...)
(λ (recur input)
(append clause-proc-body-backwards ...))))))))
(λ (recur input init-jf-derivation-id)
(append clause-proc-body-backwards ...)))))))))
(define (combine-judgment-rhses compiled-lhs input rhs check-output)
(define mtchs (match-pattern compiled-lhs input))

7
collects/redex/tests/test-util.rkt
View File

@ -148,11 +148,14 @@
(unless (and (not (exn? got))
(matches? got expected))
(set! failures (+ 1 failures))
(eprintf "test: file ~a line ~a:\n got ~s\nexpected ~s\n\n"
(eprintf "test: file ~a line ~a:\n got ~s\nexpected ~s\n"
filename
line
got
expected))))
expected)
(when (exn:fail? got)
((error-display-handler) (exn-message got) got))
(eprintf "\n"))))
(define (matches? got expected)
(cond