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

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

@ -31,7 +31,7 @@
(define-struct metafunc-extra-where (lhs rhs)) (define-struct metafunc-extra-where (lhs rhs))
(define-struct metafunc-extra-fresh (vars)) (define-struct metafunc-extra-fresh (vars))
(define-for-syntax (judgment-form-id? stx) (define-for-syntax (judgment-form-id? stx)
(and (identifier? stx) (and (identifier? stx)
(judgment-form? (syntax-local-value stx (λ () #f))))) (judgment-form? (syntax-local-value stx (λ () #f)))))
@ -196,7 +196,7 @@
(let ([input (quasisyntax/loc premise (term/nts #,input-template #,lang-nts))]) (let ([input (quasisyntax/loc premise (term/nts #,input-template #,lang-nts))])
(define (make-traced input) (define (make-traced input)
(quasisyntax/loc premise (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? (if under-ellipsis?
#`(repeated-premise-outputs #,input (λ (x) #,(make-traced #'x))) #`(repeated-premise-outputs #,input (λ (x) #,(make-traced #'x)))
(make-traced input)))]) (make-traced input)))])
@ -213,10 +213,10 @@
#,call #,call
#,under-ellipsis? #,under-ellipsis?
#,jf-results-id #,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)] ...) (let ([temp (lookup-binding bindings 'output-name)] ...)
(and binding-constraint ... (and binding-constraint ...
(term-let ([output-name/ellipsis temp] ...) (term-let ([output-name/ellipsis temp] ...)
#,rest-body))))))))])))) #,rest-body))))))))]))))
(define (judgment-form-bind-withs/proc lang output-pattern output under-ellipsis? old-maps do-something) (define (judgment-form-bind-withs/proc lang output-pattern output under-ellipsis? old-maps do-something)
@ -231,12 +231,11 @@
(define mtchs (match-pattern compiled-pattern term)) (define mtchs (match-pattern compiled-pattern term))
(if mtchs (if mtchs
(for/fold ([outputs outputs]) ([mtch (in-list mtchs)]) (for/fold ([outputs outputs]) ([mtch (in-list mtchs)])
(define mtch-outputs (if old-maps (define mtch-outputs (do-something (mtch-bindings mtch)
(do-something (mtch-bindings mtch) (and old-maps
(if under-ellipsis? (if under-ellipsis?
(append (reverse sub-tree) old-maps) (append (reverse sub-tree) old-maps)
(cons sub-tree old-maps))) (cons sub-tree old-maps)))))
(do-something (mtch-bindings mtch))))
(if mtch-outputs (if mtch-outputs
(append mtch-outputs outputs) (append mtch-outputs outputs)
outputs)) outputs))
@ -262,7 +261,7 @@
(for*/list ([o output] [os (repeated-premise-outputs (cdr inputs) premise)]) (for*/list ([o output] [os (repeated-premise-outputs (cdr inputs) premise)])
(cons o os)))))) (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 traced (current-traced-metafunctions))
(define vecs (define vecs
(if (or (eq? 'all traced) (memq form-name traced)) (if (or (eq? 'all traced) (memq form-name traced))
@ -271,15 +270,16 @@
(for/fold ([s '()]) ([m mode]) (for/fold ([s '()]) ([m mode])
(case m [(I) s] [(O) (cons '_ s)]))) (case m [(I) s] [(O) (cons '_ s)])))
(define (wrapped . _) (define (wrapped . _)
(set! outputs (form-proc form-proc input)) (set! outputs (form-proc form-proc input derivation-init))
(for/list ([output outputs]) (for/list ([output outputs])
(cons form-name (assemble mode input (vector-ref output 1))))) (cons form-name (assemble mode input (vector-ref output 1)))))
(apply trace-call form-name wrapped (assemble mode input spacers)) (apply trace-call form-name wrapped (assemble mode input spacers))
outputs) outputs)
(form-proc form-proc input))) (form-proc form-proc input derivation-init)))
(for/list ([v (in-list vecs)]) (for/list ([v (in-list vecs)])
(vector (derivation (cons form-name (assemble mode input (vector-ref v 1))) (define subs (vector-ref v 0))
(reverse (vector-ref v 0))) (vector (and subs (derivation (cons form-name (assemble mode input (vector-ref v 1)))
(reverse subs)))
(vector-ref v 1)))) (vector-ref v 1))))
(struct derivation (term subs) (struct derivation (term subs)
#:transparent #:transparent
@ -588,87 +588,88 @@
#'(#%expression (judgment-holds/derivation build-derivations #t jf-expr any))])) #'(#%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) (define-for-syntax (do-compile-judgment-form-proc name mode-stx clauses contracts nts orig stx syn-error-name)
(define mode (cdr (syntax->datum mode-stx))) (with-syntax ([(init-jf-derivation-id) (generate-temporaries '(init-jf-derivation-id))])
(define-values (input-contracts output-contracts) (define mode (cdr (syntax->datum mode-stx)))
(if contracts (define-values (input-contracts output-contracts)
(let-values ([(ins outs) (split-by-mode contracts mode)]) (if contracts
(values ins outs)) (let-values ([(ins outs) (split-by-mode contracts mode)])
(values #f #f))) (values ins outs))
(define (compile-clause clause) (values #f #f)))
(syntax-case clause () (define (compile-clause clause)
[((_ . conc-pats) . prems) (syntax-case clause ()
(let-values ([(input-pats output-pats) (split-by-mode (syntax->list #'conc-pats) mode)]) [((_ . conc-pats) . prems)
(with-syntax ([(lhs (names ...) (names/ellipses ...)) (rewrite-side-conditions/check-errs nts syn-error-name #t input-pats)] (let-values ([(input-pats output-pats) (split-by-mode (syntax->list #'conc-pats) mode)])
[(jf-derivation-id) (generate-temporaries '(jf-derivation-id))]) (with-syntax ([(lhs (names ...) (names/ellipses ...)) (rewrite-side-conditions/check-errs nts syn-error-name #t input-pats)]
(define (contracts-compilation ctcs) [(jf-derivation-id) (generate-temporaries '(jf-derivation-id))])
(and ctcs (define (contracts-compilation ctcs)
(with-syntax ([(ctc ...) ctcs]) (and ctcs
#`(list (compile-pattern lang `ctc #f) ...)))) (with-syntax ([(ctc ...) ctcs])
(define body #`(list (compile-pattern lang `ctc #f) ...))))
(parameterize ([judgment-form-pending-expansion (define body
(cons name (parameterize ([judgment-form-pending-expansion
(struct-copy judgment-form (lookup-judgment-form-id name) (cons name
[proc #'recur]))]) (struct-copy judgment-form (lookup-judgment-form-id name)
(bind-withs syn-error-name '() #'lang nts (syntax->list #'prems) [proc #'recur]))])
'flatten #`(list (vector jf-derivation-id (term/nts (#,@output-pats) #,nts))) (bind-withs syn-error-name '() #'lang nts (syntax->list #'prems)
(syntax->list #'(names ...)) 'flatten #`(list (vector jf-derivation-id (term/nts (#,@output-pats) #,nts)))
(syntax->list #'(names/ellipses ...)) (syntax->list #'(names ...))
#f (syntax->list #'(names/ellipses ...))
#'jf-derivation-id))) #f
(with-syntax ([(compiled-lhs compiled-input-ctcs compiled-output-ctcs) #'jf-derivation-id)))
(generate-temporaries '(compiled-lhs compiled-input-ctcs compiled-output-ctcs))]) (with-syntax ([(compiled-lhs compiled-input-ctcs compiled-output-ctcs)
(generate-temporaries '(compiled-lhs compiled-input-ctcs compiled-output-ctcs))])
#`(
;; pieces of a 'let' expression to be combined: first some bindings #`(
([jf-derivation-id '()] ;; pieces of a 'let' expression to be combined: first some bindings
[compiled-lhs (compile-pattern lang `lhs #t)] ([compiled-lhs (compile-pattern lang `lhs #t)]
#,@(if (contracts-compilation input-contracts) #,@(if (contracts-compilation input-contracts)
(list #`[compiled-input-ctcs #,(contracts-compilation input-contracts)]) (list #`[compiled-input-ctcs #,(contracts-compilation input-contracts)])
(list)) (list))
#,@(if (contracts-compilation output-contracts) #,@(if (contracts-compilation output-contracts)
(list #`[compiled-output-ctcs #,(contracts-compilation output-contracts)]) (list #`[compiled-output-ctcs #,(contracts-compilation output-contracts)])
(list))) (list)))
;; and then the body of the let, but expected to be behind a (λ (input) ...). ;; and then the body of the let, but expected to be behind a (λ (input) ...).
(begin (let ([jf-derivation-id init-jf-derivation-id])
#,@(if (contracts-compilation input-contracts) (begin
(list #`(check-judgment-form-contract '#,name input compiled-input-ctcs 'I '#,mode)) #,@(if (contracts-compilation input-contracts)
(list)) (list #`(check-judgment-form-contract '#,name input compiled-input-ctcs 'I '#,mode))
(combine-judgment-rhses (list))
compiled-lhs (combine-judgment-rhses
input compiled-lhs
(λ (bnds) input
(term-let ([names/ellipses (lookup-binding bnds 'names)] ...) (λ (bnds)
#,body)) (term-let ([names/ellipses (lookup-binding bnds 'names)] ...)
#,(if (contracts-compilation output-contracts) #,body))
#`(λ (output) #,(if (contracts-compilation output-contracts)
(check-judgment-form-contract '#,name output compiled-output-ctcs 'O '#,mode)) #`(λ (output)
#`void)))))))])) (check-judgment-form-contract '#,name output compiled-output-ctcs 'O '#,mode))
#`void))))))))]))
(when (identifier? orig) (when (identifier? orig)
(define orig-mode (judgment-form-mode (lookup-judgment-form-id orig))) (define orig-mode (judgment-form-mode (lookup-judgment-form-id orig)))
(unless (equal? mode orig-mode) (unless (equal? mode orig-mode)
(raise-syntax-error syn-error-name (raise-syntax-error syn-error-name
(format (format
"mode for extended judgment form does not match original mode; got ~s for the original and ~s for the extension" "mode for extended judgment form does not match original mode; got ~s for the original and ~s for the extension"
`(,(syntax-e orig) ,@orig-mode) `(,(syntax-e orig) ,@orig-mode)
`(,(syntax-e name) ,@mode)) `(,(syntax-e name) ,@mode))
stx stx
mode-stx))) mode-stx)))
(with-syntax ([(((clause-proc-binding ...) clause-proc-body) ...) (map compile-clause clauses)]) (with-syntax ([(((clause-proc-binding ...) clause-proc-body) ...) (map compile-clause clauses)])
(with-syntax ([(clause-proc-body-backwards ...) (reverse (syntax->list #'(clause-proc-body ...)))]) (with-syntax ([(clause-proc-body-backwards ...) (reverse (syntax->list #'(clause-proc-body ...)))])
(if (identifier? orig) (if (identifier? orig)
(with-syntax ([orig-mk (judgment-form-mk-proc (lookup-judgment-form-id orig))]) (with-syntax ([orig-mk (judgment-form-mk-proc (lookup-judgment-form-id orig))])
#`(λ (lang)
(let (clause-proc-binding ... ...)
(let ([prev (orig-mk lang)])
(λ (recur input init-jf-derivation-id)
(append (prev recur input init-jf-derivation-id)
clause-proc-body-backwards ...))))))
#`(λ (lang) #`(λ (lang)
(let (clause-proc-binding ... ...) (let (clause-proc-binding ... ...)
(let ([prev (orig-mk lang)]) (λ (recur input init-jf-derivation-id)
(λ (recur input) (append clause-proc-body-backwards ...)))))))))
(append (prev recur input)
clause-proc-body-backwards ...))))))
#`(λ (lang)
(let (clause-proc-binding ... ...)
(λ (recur input)
(append clause-proc-body-backwards ...))))))))
(define (combine-judgment-rhses compiled-lhs input rhs check-output) (define (combine-judgment-rhses compiled-lhs input rhs check-output)
(define mtchs (match-pattern compiled-lhs input)) (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)) (unless (and (not (exn? got))
(matches? got expected)) (matches? got expected))
(set! failures (+ 1 failures)) (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 filename
line line
got got
expected)))) expected)
(when (exn:fail? got)
((error-display-handler) (exn-message got) got))
(eprintf "\n"))))
(define (matches? got expected) (define (matches? got expected)
(cond (cond