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

improved handling of source locations

Browse Source 
svn: r15132
This commit is contained in:
Robby Findler 2009-06-10 19:30:36 +00:00
parent 3b401288f7
commit 1450b89b75
7 changed files with 423 additions and 350 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/redex/private/bitmap-test.ss
View File

@ -92,6 +92,7 @@
(render-metafunction Name)) (render-metafunction Name))
"metafunction-Name-vertical.png") "metafunction-Name-vertical.png")
;; makes sure that there is no overlap inside or across metafunction calls ;; makes sure that there is no overlap inside or across metafunction calls
;; or when there are unquotes involved ;; or when there are unquotes involved
(define-metafunction lang (define-metafunction lang

7
collects/redex/private/core-layout.ss
View File

@ -457,7 +457,12 @@
(set! current-line line) (set! current-line line)
(set! current-column col))] (set! current-column col))]
[else [else
(error 'eject "lines going backwards")]) (error 'eject
"lines going backwards (current-line ~s line ~s atom ~s tokens ~s)"
current-line
line
atom
tokens)])
(when (< current-column col) (when (< current-column col)
(let ([space-span (- col current-column)]) (let ([space-span (- col current-column)])
(set! tokens (cons (make-blank-space-token unquoted? (set! tokens (cons (make-blank-space-token unquoted?

96
collects/redex/private/loc-wrapper-ct.ss Normal file
View File

@ -0,0 +1,96 @@
#lang scheme/base
(require (for-template scheme/base)
(for-template "loc-wrapper-rt.ss")
"term-fn.ss")
(provide to-lw/proc to-lw/uq/proc)
(define (process-arg stx quote-depth)
(define quoted? (quote-depth . > . 0))
(define-values (op cl)
(if (syntax? stx)
(case (syntax-property stx 'paren-shape)
[(#\{) (values "{" "}")]
[(#\[) (values "[" "]")]
[else (values "(" ")")])
(values #f #f)))
(define (reader-shorthand arg qd-delta mrk)
#`(init-loc-wrapper
(list (init-loc-wrapper #,mrk
#,(syntax-line stx)
#,(syntax-column stx)
#,quoted?)
'spring
#,(process-arg arg (+ quote-depth qd-delta)))
#,(syntax-line stx)
#,(syntax-column stx)
#,quoted?))
(define (handle-sequence qd-delta)
#`(init-loc-wrapper
(list (init-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
#,@(map (λ (x) (process-arg x (+ qd-delta quote-depth))) (syntax->list stx))
(init-loc-wrapper #,cl #f #f #,quoted?))
#,(syntax-line stx)
#,(syntax-column stx)
#,quoted?))
(syntax-case* stx (name unquote quote unquote-splicing term) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
['a (reader-shorthand #'a +1 (if (= quote-depth 0) "" "'"))]
[,a (reader-shorthand #'a -1 (if (= quote-depth 1) "" ","))]
[,@a (reader-shorthand #'a -1 (if (= quote-depth 1) "" ",@"))]
[(term a)
(if (= quote-depth 0)
#`(init-loc-wrapper
(list (init-loc-wrapper "" #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
'spring
#,(process-arg (cadr (syntax->list stx)) (+ quote-depth 1)))
#,(syntax-line stx)
#,(syntax-column stx)
#,quoted?)
(handle-sequence +1))]
[(a ...)
(handle-sequence 0)]
[(a b ... . c)
#`(init-loc-wrapper
(list (init-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
#,@(map (λ (x) (process-arg x quote-depth)) (syntax->list (syntax (a b ...))))
(init-loc-wrapper #," . " #f #f #,quoted?)
#,(process-arg #'c quote-depth)
(init-loc-wrapper #,cl #f #f #,quoted?))
#,(syntax-line stx)
#,(syntax-column stx)
#,quoted?)]
[x
(and (identifier? #'x)
(term-fn? (syntax-local-value #'x (λ () #f))))
#`(make-lw
'#,(syntax-e #'x)
#,(syntax-line stx)
#f
#,(syntax-column stx)
#f
#f
#t)]
[x
(identifier? #'x)
#`(init-loc-wrapper
'#,(syntax-e #'x)
#,(syntax-line stx)
#,(syntax-column stx)
#,quoted?)]
[x
#`(init-loc-wrapper
#,(let ([base (syntax-e #'x)])
(if (string? base)
#`(rewrite-quotes #,(format "~s" base))
(format "~s" (syntax-e #'x))))
#,(syntax-line stx)
#,(syntax-column stx)
#,quoted?)]))
(define (to-lw/proc stx)
(syntax-case stx ()
[(_ stx)
#`(add-spans #,(process-arg #'stx 1))]))
(define (to-lw/uq/proc stx)
(syntax-case stx ()
[(_ stx)
#`(add-spans #,(process-arg #'stx 0))]))

96
collects/redex/private/loc-wrapper-rt.ss Normal file
View File

@ -0,0 +1,96 @@
#lang scheme/base
;; this is the runtime code for loc-wrapper-ct.ss.
;; it isn't really its own module, but separated
;; out in order to get the phases right.
(provide (all-defined-out))
(require (lib "etc.ss")
"term.ss")
(define (init-loc-wrapper e line column quoted?)
(make-lw e line #f column #f (not quoted?) #f))
;; lw = (union 'spring loc-wrapper)
;; e : (union string symbol #f (listof lw))
;; line, line-span, column, column-span : number
(define-struct lw (e line line-span column column-span unq? metafunction?)
#:mutable
#:inspector (make-inspector))
;; build-lw is designed for external consumption
(define (build-lw e line line-span column column-span)
(make-lw e line line-span column column-span #f #f))
(define curly-quotes-for-strings (make-parameter #t))
(define (rewrite-quotes s)
(if (curly-quotes-for-strings)
(string-append "“"
(substring s 1 (- (string-length s) 1))
"”")
s))
(define (add-spans lw)
(define line-seen-so-far 0)
(define (add-spans/lw lw line col)
(cond
[(eq? lw 'spring) (values line col col)]
[else
(let ([start-line (or (lw-line lw) line line-seen-so-far)]
[start-column (or (lw-column lw) col 0)])
(set! line-seen-so-far (max line-seen-so-far start-line))
(unless (lw-line lw) (set-lw-line! lw line-seen-so-far))
(unless (lw-column lw) (set-lw-column! lw start-column))
(let-values ([(last-line first-column last-column)
(add-spans/obj (lw-e lw) start-line start-column)])
(set-lw-line-span! lw (- last-line start-line))
(let ([new-col (min/f (lw-column lw)
first-column)])
(set-lw-column! lw new-col)
(set-lw-column-span! lw (- last-column new-col)))
(values last-line first-column last-column)))]))
(define (add-spans/obj e line col)
(cond
[(string? e)
(values line col (+ col (string-length e)))]
[(symbol? e)
(values line col (+ col (string-length (symbol->string e))))]
[(not e) (values line col col)]
[else
(let loop ([lws e]
[line line]
[first-column col]
[last-column col]
[current-col col])
(cond
[(null? lws) (values line first-column last-column)]
[else
(let-values ([(last-line inner-first-column inner-last-column)
(add-spans/lw (car lws) line current-col)])
(if (= last-line line)
(loop (cdr lws)
last-line
(min inner-first-column first-column)
(max inner-last-column last-column)
inner-last-column)
(loop (cdr lws)
last-line
(min inner-first-column first-column)
inner-last-column
inner-last-column)))]))]))
(add-spans/lw lw #f #f)
lw)
(define (min/f a b)
(cond
[(and a b) (min a b)]
[a a]
[b b]
[else 0]))

181
collects/redex/private/loc-wrapper.ss
View File

@ -1,181 +1,12 @@
#lang scheme/base #lang scheme/base
(require (lib "etc.ss") (require scheme/contract
"term.ss" (for-syntax scheme/base)
scheme/contract) (for-syntax "loc-wrapper-ct.ss")
(require (for-syntax "term-fn.ss" scheme/base)) "loc-wrapper-rt.ss")
(define (init-loc-wrapper e line column quoted?) (define-syntax (to-lw stx) (to-lw/proc stx))
(make-lw e line #f column #f (not quoted?) #f)) (define-syntax (to-lw/uq stx) (to-lw/uq/proc stx))
;; lw = (union 'spring loc-wrapper)
;; e : (union string symbol #f (listof lw))
;; line, line-span, column, column-span : number
(define-struct lw (e line line-span column column-span unq? metafunction?)
#:mutable
#:inspector (make-inspector))
;; build-lw is designed for external consumption
(define (build-lw e line line-span column column-span)
(make-lw e line line-span column column-span #f #f))
(define curly-quotes-for-strings (make-parameter #t))
(define (rewrite-quotes s)
(if (curly-quotes-for-strings)
(string-append "“"
(substring s 1 (- (string-length s) 1))
"”")
s))
(define-syntax-set (to-lw to-lw/uq)
(define (process-arg stx quote-depth)
(define quoted? (quote-depth . > . 0))
(define-values (op cl)
(if (syntax? stx)
(case (syntax-property stx 'paren-shape)
[(#\{) (values "{" "}")]
[(#\[) (values "[" "]")]
[else (values "(" ")")])
(values #f #f)))
(define (reader-shorthand arg qd-delta mrk)
#`(init-loc-wrapper
(list (init-loc-wrapper #,mrk
#,(syntax-line stx)
#,(syntax-column stx)
#,quoted?)
'spring
#,(process-arg arg (+ quote-depth qd-delta)))
#,(syntax-line stx)
#,(syntax-column stx)
#,quoted?))
(define (handle-sequence qd-delta)
#`(init-loc-wrapper
(list (init-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
#,@(map (λ (x) (process-arg x (+ qd-delta quote-depth))) (syntax->list stx))
(init-loc-wrapper #,cl #f #f #,quoted?))
#,(syntax-line stx)
#,(syntax-column stx)
#,quoted?))
(syntax-case* stx (name unquote quote unquote-splicing term) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
['a (reader-shorthand #'a +1 (if (= quote-depth 0) "" "'"))]
[,a (reader-shorthand #'a -1 (if (= quote-depth 1) "" ","))]
[,@a (reader-shorthand #'a -1 (if (= quote-depth 1) "" ",@"))]
[(term a)
(if (= quote-depth 0)
#`(init-loc-wrapper
(list (init-loc-wrapper "" #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
'spring
#,(process-arg (cadr (syntax->list stx)) (+ quote-depth 1)))
#,(syntax-line stx)
#,(syntax-column stx)
#,quoted?)
(handle-sequence +1))]
[(a ...)
(handle-sequence 0)]
[(a b ... . c)
#`(init-loc-wrapper
(list (init-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx) #,quoted?)
#,@(map (λ (x) (process-arg x quote-depth)) (syntax->list (syntax (a b ...))))
(init-loc-wrapper #," . " #f #f #,quoted?)
#,(process-arg #'c quote-depth)
(init-loc-wrapper #,cl #f #f #,quoted?))
#,(syntax-line stx)
#,(syntax-column stx)
#,quoted?)]
[x
(and (identifier? #'x)
(term-fn? (syntax-local-value #'x (λ () #f))))
#`(make-lw
'#,(syntax-e #'x)
#,(syntax-line stx)
#f
#,(syntax-column stx)
#f
#f
#t)]
[x
(identifier? #'x)
#`(init-loc-wrapper
'#,(syntax-e #'x)
#,(syntax-line stx)
#,(syntax-column stx)
#,quoted?)]
[x
#`(init-loc-wrapper
#,(let ([base (syntax-e #'x)])
(if (string? base)
#`(rewrite-quotes #,(format "~s" base))
(format "~s" (syntax-e #'x))))
#,(syntax-line stx)
#,(syntax-column stx)
#,quoted?)]))
(define (to-lw/proc stx)
(syntax-case stx ()
[(_ stx)
#`(add-spans #,(process-arg #'stx 1))]))
(define (to-lw/uq/proc stx)
(syntax-case stx ()
[(_ stx)
#`(add-spans #,(process-arg #'stx 0))])))
(define (add-spans lw)
(define (add-spans/lw lw line col)
(cond
[(eq? lw 'spring) (values line col col)]
[else
(let ([start-line (or (lw-line lw) line)]
[start-column (or (lw-column lw) col)])
(when (and start-line ;; if we don't have src loc info, just give up.
start-column)
(let-values ([(last-line first-column last-column)
(add-spans/obj (lw-e lw) start-line start-column)])
(unless (lw-line lw)
(set-lw-line! lw line))
(set-lw-line-span! lw (- last-line start-line))
(unless (lw-column lw)
(set-lw-column! lw col))
(let ([new-col (min (lw-column lw)
first-column)])
(set-lw-column! lw new-col)
(set-lw-column-span! lw (- last-column new-col)))
(values last-line first-column last-column))))]))
(define (add-spans/obj e line col)
(cond
[(string? e)
(values line col (+ col (string-length e)))]
[(symbol? e)
(values line col (+ col (string-length (symbol->string e))))]
[(not e) (values line col col)]
[else
(let loop ([lws e]
[line line]
[first-column col]
[last-column col]
[current-col col])
(cond
[(null? lws) (values line first-column last-column)]
[else
(let-values ([(last-line inner-first-column inner-last-column)
(add-spans/lw (car lws) line current-col)])
(if (= last-line line)
(loop (cdr lws)
last-line
(min inner-first-column first-column)
(max inner-last-column last-column)
inner-last-column)
(loop (cdr lws)
last-line
(min inner-first-column first-column)
inner-last-column
inner-last-column)))]))]))
(add-spans/lw lw #f #f)
lw)
(define pnum (and/c number? (or/c zero? positive?))) (define pnum (and/c number? (or/c zero? positive?)))

7
collects/redex/private/pict.ss
View File

@ -580,9 +580,10 @@
[column (+ (lw-column fst) [column (+ (lw-column fst)
(lw-column-span fst))] (lw-column-span fst))]
[column-span [column-span
(- (lw-column snd) (max (- (lw-column snd)
(+ (lw-column fst) (+ (lw-column fst)
(lw-column-span fst)))]) (lw-column-span fst)))
0)])
(build-lw (make-bar) line line-span column column-span))] (build-lw (make-bar) line line-span column column-span))]
[else [else
(build-lw (build-lw

383
collects/redex/private/reduction-semantics.ss
View File

@ -20,6 +20,46 @@
(define (language-nts lang) (define (language-nts lang)
(hash-map (compiled-lang-ht lang) (λ (x y) x))) (hash-map (compiled-lang-ht lang) (λ (x y) x)))
#;
(define-for-syntax (prune-syntax stx)
(datum->syntax
(identifier-prune-lexical-context #'whatever '())
(let loop ([stx stx])
(syntax-case stx (quote)
[(quote x) (list (quote-syntax/prune quote)
(syntax->datum #'x))]
[x
(cond
[(identifier? stx) (identifier-prune-lexical-context stx)]
[(syntax? stx)
(datum->syntax (identifier-prune-lexical-context
#'whatever
'(#%app))
(syntax-e stx)
stx)]
[(pair? stx)
(cons (loop (car stx))
(loop (cdr stx)))]
[else stx])]))))
(define-for-syntax (prune-syntax stx)
stx
#;
(datum->syntax
(identifier-prune-lexical-context #'whatever '(#%app #%datum))
(let loop ([stx stx])
(syntax-case stx (quote)
[(quote x) (list (quote-syntax/prune quote)
(syntax->datum #'x))]
[(a . b) (cons (loop #'a) (loop #'b))]
[x
(identifier? #'x)
(datum->syntax (identifier-prune-lexical-context #'x)
(syntax-e #'x))]
[() '()]
[_ (syntax->datum stx)]))))
(define-syntax (term-match/single stx) (define-syntax (term-match/single stx)
(syntax-case stx () (syntax-case stx ()
[(_ lang [pattern rhs] ...) [(_ lang [pattern rhs] ...)
@ -243,22 +283,23 @@
(syntax-case stx () (syntax-case stx ()
[(_ id orig-reduction-relation allow-zero-rules? lang . w/domain-args) [(_ id orig-reduction-relation allow-zero-rules? lang . w/domain-args)
(identifier? #'lang) (identifier? #'lang)
(let-values ([(domain-pattern main-arrow args) (prune-syntax
(parse-keywords stx #'id #'w/domain-args)]) (let-values ([(domain-pattern main-arrow args)
(with-syntax ([(rules ...) (before-with args)] (parse-keywords stx #'id #'w/domain-args)])
[(shortcuts ...) (after-with args)]) (with-syntax ([(rules ...) (before-with args)]
(with-syntax ([(lws ...) (map rule->lws (syntax->list #'(rules ...)))]) [(shortcuts ...) (after-with args)])
(reduction-relation/helper (with-syntax ([(lws ...) (map rule->lws (syntax->list #'(rules ...)))])
stx (reduction-relation/helper
(syntax-e #'id) stx
#'orig-reduction-relation (syntax-e #'id)
(syntax lang) #'orig-reduction-relation
(syntax->list (syntax (rules ...))) (syntax lang)
(syntax->list (syntax (shortcuts ...))) (syntax->list (syntax (rules ...)))
#'(list lws ...) (syntax->list (syntax (shortcuts ...)))
(syntax-e #'allow-zero-rules?) #'(list lws ...)
domain-pattern (syntax-e #'allow-zero-rules?)
main-arrow))))] domain-pattern
main-arrow)))))]
[(_ id orig-reduction-relation allow-zero-rules? lang args ...) [(_ id orig-reduction-relation allow-zero-rules? lang args ...)
(raise-syntax-error (syntax-e #'id) (raise-syntax-error (syntax-e #'id)
"expected an identifier for the language name" "expected an identifier for the language name"
@ -983,146 +1024,147 @@
(raise-syntax-error syn-error-name "expected an identifier in the language position" orig-stx #'lang)) (raise-syntax-error syn-error-name "expected an identifier in the language position" orig-stx #'lang))
(when (null? (syntax-e #'rest)) (when (null? (syntax-e #'rest))
(raise-syntax-error syn-error-name "no clauses" orig-stx)) (raise-syntax-error syn-error-name "no clauses" orig-stx))
(let-values ([(contract-name dom-ctcs codom-contract pats) (prune-syntax
(split-out-contract orig-stx syn-error-name #'rest)]) (let-values ([(contract-name dom-ctcs codom-contract pats)
(with-syntax ([(((original-names lhs-clauses ...) rhs stuff ...) ...) pats] (split-out-contract orig-stx syn-error-name #'rest)])
[(lhs-for-lw ...) (with-syntax ([(((original-names lhs-clauses ...) rhs stuff ...) ...) pats]
(with-syntax ([((lhs-for-lw _ _ ...) ...) pats]) [(lhs-for-lw ...)
(map (λ (x) (datum->syntax #f (cdr (syntax-e x)) x)) (with-syntax ([((lhs-for-lw _ _ ...) ...) pats])
(syntax->list #'(lhs-for-lw ...))))]) (map (λ (x) (datum->syntax #f (cdr (syntax-e x)) x))
(with-syntax ([(lhs ...) #'((lhs-clauses ...) ...)] (syntax->list #'(lhs-for-lw ...))))])
[name (let loop ([name (if contract-name (with-syntax ([(lhs ...) #'((lhs-clauses ...) ...)]
contract-name [name (let loop ([name (if contract-name
(car (syntax->list #'(original-names ...))))] contract-name
[names (if contract-name (car (syntax->list #'(original-names ...))))]
(syntax->list #'(original-names ...)) [names (if contract-name
(cdr (syntax->list #'(original-names ...))))]) (syntax->list #'(original-names ...))
(cond (cdr (syntax->list #'(original-names ...))))])
[(null? names) name] (cond
[else [(null? names) name]
(unless (eq? (syntax-e name) (syntax-e (car names))) [else
(raise (unless (eq? (syntax-e name) (syntax-e (car names)))
(make-exn:fail:syntax (raise
(if contract-name (make-exn:fail:syntax
"define-metafunction: expected each clause and the contract to use the same name" (if contract-name
"define-metafunction: expected each clause to use the same name") "define-metafunction: expected each clause and the contract to use the same name"
(current-continuation-marks) "define-metafunction: expected each clause to use the same name")
(list name (current-continuation-marks)
(car names))))) (list name
(loop name (cdr names))]))]) (car names)))))
(loop name (cdr names))]))])
(with-syntax ([(((tl-side-conds ...) ...) (with-syntax ([(((tl-side-conds ...) ...)
(tl-bindings ...) (tl-bindings ...)
(tl-side-cond/binds ...)) (tl-side-cond/binds ...))
(parse-extras #'((stuff ...) ...))]) (parse-extras #'((stuff ...) ...))])
(let ([lang-nts (language-id-nts #'lang 'define-metafunction)]) (let ([lang-nts (language-id-nts #'lang 'define-metafunction)])
(with-syntax ([(tl-withs ...) (map (λ (sc/b) (bind-withs syn-error-name '() sc/b #t)) (with-syntax ([(tl-withs ...) (map (λ (sc/b) (bind-withs syn-error-name '() sc/b #t))
(syntax->list #'(tl-side-cond/binds ...)))]) (syntax->list #'(tl-side-cond/binds ...)))])
(with-syntax ([(side-conditions-rewritten ...) (with-syntax ([(side-conditions-rewritten ...)
(map (λ (x) (rewrite-side-conditions/check-errs (map (λ (x) (rewrite-side-conditions/check-errs
lang-nts lang-nts
'define-metafunction 'define-metafunction
#t #t
x)) x))
(syntax->list (syntax ((side-condition lhs tl-withs) ...))))] (syntax->list (syntax ((side-condition lhs tl-withs) ...))))]
[dom-side-conditions-rewritten [dom-side-conditions-rewritten
(and dom-ctcs (and dom-ctcs
(rewrite-side-conditions/check-errs (rewrite-side-conditions/check-errs
lang-nts lang-nts
'define-metafunction 'define-metafunction
#f #f
dom-ctcs))] dom-ctcs))]
[codom-side-conditions-rewritten [codom-side-conditions-rewritten
(rewrite-side-conditions/check-errs (rewrite-side-conditions/check-errs
lang-nts lang-nts
'define-metafunction 'define-metafunction
#f #f
codom-contract)] codom-contract)]
[(rhs-fns ...) [(rhs-fns ...)
(map (λ (lhs rhs bindings) (map (λ (lhs rhs bindings)
(let-values ([(names names/ellipses) (extract-names lang-nts 'define-metafunction #t lhs)]) (let-values ([(names names/ellipses) (extract-names lang-nts 'define-metafunction #t lhs)])
(with-syntax ([(names ...) names] (with-syntax ([(names ...) names]
[(names/ellipses ...) names/ellipses] [(names/ellipses ...) names/ellipses]
[rhs rhs] [rhs rhs]
[((tl-var tl-exp) ...) bindings]) [((tl-var tl-exp) ...) bindings])
(syntax (syntax
(λ (name bindings) (λ (name bindings)
(term-let-fn ((name name)) (term-let-fn ((name name))
(term-let ([names/ellipses (lookup-binding bindings 'names)] ...) (term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
(term-let ([tl-var (term tl-exp)] ...) (term-let ([tl-var (term tl-exp)] ...)
(term rhs))))))))) (term rhs)))))))))
(syntax->list (syntax (lhs ...))) (syntax->list (syntax (lhs ...)))
(syntax->list (syntax (rhs ...))) (syntax->list (syntax (rhs ...)))
(syntax->list (syntax (tl-bindings ...))))] (syntax->list (syntax (tl-bindings ...))))]
[(name2 name-predicate) (generate-temporaries (syntax (name name)))] [(name2 name-predicate) (generate-temporaries (syntax (name name)))]
[((side-cond ...) ...) [((side-cond ...) ...)
;; For generating a pict, separate out side conditions wrapping the LHS and at the top-level ;; For generating a pict, separate out side conditions wrapping the LHS and at the top-level
(map (lambda (lhs scs) (map (lambda (lhs scs)
(append (append
(let loop ([lhs lhs]) (let loop ([lhs lhs])
(syntax-case lhs (side-condition term) (syntax-case lhs (side-condition term)
[(side-condition pat (term sc)) [(side-condition pat (term sc))
(cons #'sc (loop #'pat))] (cons #'sc (loop #'pat))]
[_else null])) [_else null]))
scs)) scs))
(syntax->list #'(lhs ...)) (syntax->list #'(lhs ...))
(syntax->list #'((tl-side-conds ...) ...)))] (syntax->list #'((tl-side-conds ...) ...)))]
[(((bind-id . bind-pat) ...) ...) [(((bind-id . bind-pat) ...) ...)
;; Also for pict, extract pattern bindings ;; Also for pict, extract pattern bindings
(map extract-pattern-binds (syntax->list #'(lhs ...)))] (map extract-pattern-binds (syntax->list #'(lhs ...)))]
[(((rhs-bind-id . rhs-bind-pat) ...) ...) [(((rhs-bind-id . rhs-bind-pat) ...) ...)
;; Also for pict, extract pattern bindings ;; Also for pict, extract pattern bindings
(map extract-term-let-binds (syntax->list #'(rhs ...)))] (map extract-term-let-binds (syntax->list #'(rhs ...)))]
[(((where-id where-pat) ...) ...) [(((where-id where-pat) ...) ...)
;; Also for pict, extract where bindings ;; Also for pict, extract where bindings
#'(tl-bindings ...)]) #'(tl-bindings ...)])
(syntax-property (syntax-property
#`(begin #`(begin
(define-values (name2 name-predicate) (define-values (name2 name-predicate)
(let ([sc `(side-conditions-rewritten ...)] (let ([sc `(side-conditions-rewritten ...)]
[dsc `dom-side-conditions-rewritten]) [dsc `dom-side-conditions-rewritten])
(build-metafunction (build-metafunction
lang
sc
(list rhs-fns ...)
#,(if prev-metafunction
(let ([term-fn (syntax-local-value prev-metafunction)])
#`(metafunc-proc-cps #,(term-fn-get-id term-fn)))
#''())
#,(if prev-metafunction
(let ([term-fn (syntax-local-value prev-metafunction)])
#`(metafunc-proc-rhss #,(term-fn-get-id term-fn)))
#''())
(λ (f/dom cps rhss)
(make-metafunc-proc
(let ([name (lambda (x) (f/dom x))]) name)
(list (list (to-lw lhs-for-lw)
(list (to-lw/uq side-cond) ...)
(list (cons (to-lw bind-id)
(to-lw bind-pat))
...
(cons (to-lw rhs-bind-id)
(to-lw/uq rhs-bind-pat))
...
(cons (to-lw where-id)
(to-lw where-pat))
...)
(to-lw rhs))
...)
lang lang
sc #t ;; multi-args?
(list rhs-fns ...) 'name
#,(if prev-metafunction cps
(let ([term-fn (syntax-local-value prev-metafunction)]) rhss
#`(metafunc-proc-cps #,(term-fn-get-id term-fn))) (let ([name (lambda (x) (name-predicate x))]) name)
#''())
#,(if prev-metafunction
(let ([term-fn (syntax-local-value prev-metafunction)])
#`(metafunc-proc-rhss #,(term-fn-get-id term-fn)))
#''())
(λ (f/dom cps rhss)
(make-metafunc-proc
(let ([name (lambda (x) (f/dom x))]) name)
(list (list (to-lw lhs-for-lw)
(list (to-lw/uq side-cond) ...)
(list (cons (to-lw bind-id)
(to-lw bind-pat))
...
(cons (to-lw rhs-bind-id)
(to-lw/uq rhs-bind-pat))
...
(cons (to-lw where-id)
(to-lw where-pat))
...)
(to-lw rhs))
...)
lang
#t ;; multi-args?
'name
cps
rhss
(let ([name (lambda (x) (name-predicate x))]) name)
dsc
sc))
dsc dsc
`codom-side-conditions-rewritten sc))
'name))) dsc
(term-define-fn name name2)) `codom-side-conditions-rewritten
'disappeared-use 'name)))
(map syntax-local-introduce (syntax->list #'(original-names ...))))))))))))] (term-define-fn name name2))
'disappeared-use
(map syntax-local-introduce (syntax->list #'(original-names ...)))))))))))))]
[(_ prev-metafunction name lang clauses ...) [(_ prev-metafunction name lang clauses ...)
(begin (begin
(unless (identifier? #'name) (unless (identifier? #'name)
@ -1361,23 +1403,24 @@
(identifier? (syntax name)) (identifier? (syntax name))
(begin (begin
(check-rhss-not-empty stx (cddr (syntax->list stx))) (check-rhss-not-empty stx (cddr (syntax->list stx)))
(with-syntax ([((nt-names orig) ...) (pull-out-names 'define-language stx #'(names ...))]) (prune-syntax
(with-syntax ([(subst-names ...) (generate-temporaries (syntax->list #'(nt-names ...)))]) (with-syntax ([((nt-names orig) ...) (pull-out-names 'define-language stx #'(names ...))])
(syntax/loc stx (with-syntax ([(subst-names ...) (generate-temporaries (syntax->list #'(nt-names ...)))])
(begin (syntax/loc stx
(define-syntax name (begin
(make-set!-transformer (define-syntax name
(make-language-id (make-set!-transformer
(case-lambda (make-language-id
[(stx) (case-lambda
(syntax-case stx (set!) [(stx)
[(set! x e) (raise-syntax-error 'define-language "cannot set! identifier" stx #'e)] (syntax-case stx (set!)
[(x e (... ...)) #'(define-language-name e (... ...))] [(set! x e) (raise-syntax-error 'define-language "cannot set! identifier" stx #'e)]
[x [(x e (... ...)) #'(define-language-name e (... ...))]
(identifier? #'x) [x
#'define-language-name])]) (identifier? #'x)
'(nt-names ...)))) #'define-language-name])])
(define define-language-name (language name (names rhs ...) ...)))))))])) '(nt-names ...))))
(define define-language-name (language name (names rhs ...) ...))))))))]))
(define-struct binds (source binds)) (define-struct binds (source binds))