From ea44edde13f41943bbf11de4fb7bc31f7cc791de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Mon, 23 Jan 2017 19:19:43 +0100 Subject: [PATCH] Imported more files from https://github.com/racket/racket/commit/28f1df4cffcc21c0892454406645ab05d93b9e79 --- case/stxcase-scheme.rkt | 74 +++++ case/stxcase.rkt | 604 ++++++++++++++++++++++++++++++++++++++++ case/stxloc.rkt | 80 ++++++ case/syntax.rkt | 208 ++++++++++++++ case/with-stx.rkt | 99 +++++++ 5 files changed, 1065 insertions(+) create mode 100644 case/stxcase-scheme.rkt create mode 100644 case/stxcase.rkt create mode 100644 case/stxloc.rkt create mode 100644 case/syntax.rkt create mode 100644 case/with-stx.rkt diff --git a/case/stxcase-scheme.rkt b/case/stxcase-scheme.rkt new file mode 100644 index 0000000..9f1a21a --- /dev/null +++ b/case/stxcase-scheme.rkt @@ -0,0 +1,74 @@ + +;;---------------------------------------------------------------------- +;; #%stxcase-scheme: adds let-syntax, syntax-rules, and +;; check-duplicate-identifier, and assembles everything we have so far + +(module stxcase-scheme '#%kernel + (#%require "small-scheme.rkt" "stx.rkt" "stxcase.rkt" "with-stx.rkt" "stxloc.rkt" + (for-syntax '#%kernel "small-scheme.rkt" "stx.rkt" "stxcase.rkt" + "stxloc.rkt")) + + (-define (check-duplicate-identifier names) + (unless (and (list? names) (andmap identifier? names)) + (raise-argument-error 'check-duplicate-identifier "(listof identifier?)" names)) + (let/ec escape + (let ([ht (make-hasheq)]) + (for-each + (lambda (defined-name) + (unless (identifier? defined-name) + (raise-argument-error 'check-duplicate-identifier + "(listof identifier?)" names)) + (let ([l (hash-ref ht (syntax-e defined-name) null)]) + (when (ormap (lambda (i) (bound-identifier=? i defined-name)) l) + (escape defined-name)) + (hash-set! ht (syntax-e defined-name) (cons defined-name l)))) + names) + #f))) + + (begin-for-syntax + (define-values (check-sr-rules) + (lambda (stx kws) + (for-each (lambda (id) + (unless (identifier? id) + (raise-syntax-error + #f + "pattern must start with an identifier, found something else" + stx + id))) + (syntax->list kws))))) + + ;; From Dybvig, mostly: + (-define-syntax syntax-rules + (lambda (stx) + (syntax-case** syntax-rules #t stx () free-identifier=? #f + ((sr (k ...) ((keyword . pattern) template) ...) + (andmap identifier? (syntax->list (syntax (k ...)))) + (begin + (check-sr-rules stx (syntax (keyword ...))) + (syntax/loc stx + (lambda (x) + (syntax-case** sr #t x (k ...) free-identifier=? #f + ((_ . pattern) (syntax-protect (syntax/loc x template))) + ...)))))))) + + (-define-syntax syntax-id-rules + (lambda (x) + (syntax-case** syntax-id-rules #t x () free-identifier=? #f + ((sidr (k ...) (pattern template) ...) + (andmap identifier? (syntax->list (syntax (k ...)))) + (syntax/loc x + (make-set!-transformer + (lambda (x) + (syntax-case** sidr #t x (k ...) free-identifier=? #f + (pattern (syntax-protect (syntax/loc x template))) + ...)))))))) + + (-define (syntax-protect stx) + (if (syntax? stx) + (syntax-arm stx #f #t) + (raise-argument-error 'syntax-protect "syntax?" stx))) + + (#%provide syntax datum (all-from "with-stx.rkt") (all-from "stxloc.rkt") + check-duplicate-identifier syntax-protect + syntax-rules syntax-id-rules + (for-syntax syntax-pattern-variable?))) diff --git a/case/stxcase.rkt b/case/stxcase.rkt new file mode 100644 index 0000000..cc3b2ec --- /dev/null +++ b/case/stxcase.rkt @@ -0,0 +1,604 @@ +;;---------------------------------------------------------------------- +;; syntax-case and syntax + +(module stxcase '#%kernel + (#%require "stx.rkt" "small-scheme.rkt" '#%paramz '#%unsafe + "ellipses.rkt" + (for-syntax "stx.rkt" "small-scheme.rkt" + "member.rkt" "sc.rkt" '#%kernel)) + + (-define (datum->syntax/shape orig datum) + (if (syntax? datum) + datum + ;; Keeps 'paren-shape and any other properties: + (datum->syntax orig datum orig orig))) + + (-define (catch-ellipsis-error thunk sexp sloc) + ((let/ec esc + (with-continuation-mark + exception-handler-key + (lambda (exn) + (esc + (lambda () + (if (exn:break? exn) + (raise exn) + (raise-syntax-error + 'syntax + "incompatible ellipsis match counts for template" + sexp + sloc))))) + (let ([v (thunk)]) + (lambda () v)))))) + + (-define substitute-stop 'dummy) + + ;; pattern-substitute optimizes a pattern substitution by + ;; merging variables that look up the same simple mapping + (-define-syntax pattern-substitute + (lambda (stx) + (let ([pat (stx-car (stx-cdr stx))] + [subs (stx->list (stx-cdr (stx-cdr stx)))]) + (let ([ht-common (make-hash)] + [ht-map (make-hasheq)]) + ;; Determine merges: + (let loop ([subs subs]) + (unless (null? subs) + (let ([id (syntax-e (car subs))] + [expr (cadr subs)]) + (when (or (identifier? expr) + (and (stx-pair? expr) + (memq (syntax-e (stx-car expr)) + '(car cadr caddr cadddr + cdr cddr cdddr cddddr + list-ref list-tail)) + (stx-pair? (stx-cdr expr)) + (identifier? (stx-car (stx-cdr expr))))) + (let ([s-expr (syntax->datum expr)]) + (let ([new-id (hash-ref ht-common s-expr #f)]) + (if new-id + (hash-set! ht-map id new-id) + (hash-set! ht-common s-expr id)))))) + (loop (cddr subs)))) + ;; Merge: + (let ([new-pattern (if (zero? (hash-count ht-map)) + pat + (let loop ([stx pat]) + (cond + [(pair? stx) + (let ([a (loop (car stx))] + [b (loop (cdr stx))]) + (if (and (eq? a (car stx)) + (eq? b (cdr stx))) + stx + (cons a b)))] + [(symbol? stx) + (let ([new-id (hash-ref ht-map stx #f)]) + (or new-id stx))] + [(syntax? stx) + (let ([new-e (loop (syntax-e stx))]) + (if (eq? (syntax-e stx) new-e) + stx + (datum->syntax stx new-e stx stx)))] + [(vector? stx) + (list->vector (map loop (vector->list stx)))] + [(box? stx) (box (loop (unbox stx)))] + [else stx])))]) + (datum->syntax (quote-syntax here) + `(apply-pattern-substitute + ,new-pattern + (quote ,(let loop ([subs subs]) + (cond + [(null? subs) null] + [(hash-ref ht-map (syntax-e (car subs)) #f) + ;; Drop mapped id + (loop (cddr subs))] + [else + (cons (car subs) (loop (cddr subs)))]))) + . ,(let loop ([subs subs]) + (cond + [(null? subs) null] + [(hash-ref ht-map (syntax-e (car subs)) #f) + ;; Drop mapped id + (loop (cddr subs))] + [else + (cons (cadr subs) (loop (cddr subs)))]))) + stx)))))) + + (-define apply-pattern-substitute + (lambda (stx sub-ids . sub-vals) + (let loop ([stx stx]) + (cond + [(pair? stx) (let ([a (loop (car stx))] + [b (loop (cdr stx))]) + (if (and (eq? a (car stx)) + (eq? b (cdr stx))) + stx + (cons a b)))] + [(symbol? stx) + (let sloop ([sub-ids sub-ids][sub-vals sub-vals]) + (cond + [(null? sub-ids) stx] + [(eq? stx (car sub-ids)) (car sub-vals)] + [else (sloop (cdr sub-ids) (cdr sub-vals))]))] + [(syntax? stx) + (let ([new-e (loop (syntax-e stx))]) + (if (eq? (syntax-e stx) new-e) + stx + (datum->syntax/shape stx new-e)))] + [(vector? stx) + (list->vector (map loop (vector->list stx)))] + [(box? stx) (box (loop (unbox stx)))] + [else stx])))) + + (-define interp-match + (lambda (pat e literals immediate=?) + (interp-gen-match pat e literals immediate=? #f))) + + (-define interp-s-match + (lambda (pat e literals immediate=?) + (interp-gen-match pat e literals immediate=? #t))) + + (-define interp-gen-match + (lambda (pat e literals immediate=? s-exp?) + (let loop ([pat pat][e e][cap e]) + (cond + [(null? pat) + (if s-exp? + (null? e) + (stx-null? e))] + [(number? pat) + (and (if s-exp? (symbol? e) (identifier? e)) + (immediate=? e (vector-ref (if s-exp? literals (syntax-e literals)) pat)))] + [(not pat) + #t] + [else + (let ([i (vector-ref pat 0)]) + (cond + [(eq? i 'bind) + (let ([e (if s-exp? + e + (if (vector-ref pat 2) + (datum->syntax cap e cap) + e))]) + (if (vector-ref pat 1) + e + (list e)))] + [(eq? i 'pair) + (let ([match-head (vector-ref pat 1)] + [match-tail (vector-ref pat 2)] + [mh-did-var? (vector-ref pat 3)] + [mt-did-var? (vector-ref pat 4)]) + (let ([cap (if (syntax? e) e cap)]) + (and (stx-pair? e) + (let ([h (loop match-head (stx-car e) cap)]) + (and h + (let ([t (loop match-tail (stx-cdr e) cap)]) + (and t + (if mh-did-var? + (if mt-did-var? + (append h t) + h) + t))))))))] + [(eq? i 'quote) + (if s-exp? + (and (equal? (vector-ref pat 1) e) + null) + (and (syntax? e) + (equal? (vector-ref pat 1) (syntax-e e)) + null))] + [(eq? i 'ellipses) + (let ([match-head (vector-ref pat 1)] + [nest-cnt (vector-ref pat 2)] + [last? (vector-ref pat 3)]) + (and (if s-exp? + (list? e) + (stx-list? e)) + (if (zero? nest-cnt) + (andmap (lambda (e) (loop match-head e cap)) + (if s-exp? e (stx->list e))) + (let/ec esc + (let ([l (map (lambda (e) + (let ([m (loop match-head e cap)]) + (if m + m + (esc #f)))) + (if s-exp? e (stx->list e)))]) + (if (null? l) + (let loop ([cnt nest-cnt]) + (cond + [(= 1 cnt) (if last? '() '(()))] + [else (cons '() (loop (sub1 cnt)))])) + ((if last? stx-rotate* stx-rotate) l)))))))] + [(eq? i 'mid-ellipses) + (let ([match-head (vector-ref pat 1)] + [match-tail (vector-ref pat 2)] + [tail-cnt (vector-ref pat 3)] + [prop? (vector-ref pat 4)] + [mh-did-var? (vector-ref pat 5)] + [mt-did-var? (vector-ref pat 6)]) + (let-values ([(pre-items post-items ok?) + (split-stx-list e tail-cnt prop?)] + [(cap) (if (syntax? e) e cap)]) + (and ok? + (let ([h (loop match-head pre-items cap)]) + (and h + (let ([t (loop match-tail post-items cap)]) + (and t + (if mt-did-var? + (if mh-did-var? + (append h t) + t) + h))))))))] + [(eq? i 'veclist) + (and (if s-exp? + (vector? e) + (stx-vector? e #f)) + (loop (vector-ref pat 1) (vector->list (if s-exp? e (syntax-e e))) cap))] + [(eq? i 'vector) + (and (if s-exp? + (and (vector? e) (= (vector-length e) (vector-ref pat 1))) + (stx-vector? e (vector-ref pat 1))) + (let vloop ([p (vector-ref pat 2)][pos 0]) + (cond + [(null? p) null] + [else + (let ([clause (car p)]) + (let ([match-elem (car clause)] + [elem-did-var? (cdr clause)]) + (let ([m (loop match-elem (if s-exp? (vector-ref e pos) (stx-vector-ref e pos)) cap)]) + (and m + (let ([body (vloop (cdr p) (add1 pos))]) + (and body + (if elem-did-var? + (if (null? body) + m + (append m body)) + body)))))))])))] + [(eq? i 'box) + (let ([match-content (vector-ref pat 1)]) + (and (if s-exp? + (box? e) + (stx-box? e)) + (loop match-content (unbox (if s-exp? e (syntax-e e))) cap)))] + [(eq? i 'prefab) + (and (if s-exp? + (equal? (vector-ref pat 1) (prefab-struct-key e)) + (stx-prefab? (vector-ref pat 1) e)) + (loop (vector-ref pat 2) (cdr (vector->list (struct->vector (if s-exp? e (syntax-e e))))) cap))] + [else (error "yikes!" pat)]))])))) + + (-define-syntax syntax-case** + (lambda (x) + (-define l (and (stx-list? x) (cdr (stx->list x)))) + (unless (and (stx-list? x) + (> (length l) 3)) + (raise-syntax-error + #f + "bad form" + x)) + (let ([who (car l)] + [arg-is-stx? (cadr l)] + [expr (caddr l)] + [kws (cadddr l)] + [lit-comp (cadddr (cdr l))] + [s-exp? (syntax-e (cadddr (cddr l)))] + [clauses (cddddr (cddr l))]) + (unless (stx-list? kws) + (raise-syntax-error + (syntax-e who) + "expected a parenthesized sequence of literal identifiers" + kws)) + (for-each + (lambda (lit) + (unless (identifier? lit) + (raise-syntax-error + (syntax-e who) + "literal is not an identifier" + lit))) + (stx->list kws)) + (for-each + (lambda (clause) + (unless (and (stx-list? clause) + (<= 2 (length (stx->list clause)) 3)) + (raise-syntax-error + (syntax-e who) + "expected a clause containing a pattern, an optional guard expression, and an expression" + clause))) + clauses) + (let ([patterns (map stx-car clauses)] + [fenders (map (lambda (clause) + (and (stx-pair? (stx-cdr (stx-cdr clause))) + (stx-car (stx-cdr clause)))) + clauses)] + [answers (map (lambda (clause) + (let ([r (stx-cdr (stx-cdr clause))]) + (if (stx-pair? r) + (stx-car r) + (stx-car (stx-cdr clause))))) + clauses)]) + (let* ([arg (quote-syntax arg)] + [rslt (quote-syntax rslt)] + [pattern-varss (map + (lambda (pattern) + (get-match-vars who pattern pattern (stx->list kws))) + (stx->list patterns))] + [lit-comp-is-mod? (and (identifier? lit-comp) + (free-identifier=? + lit-comp + (quote-syntax free-identifier=?)))]) + (syntax-arm + (datum->syntax + (quote-syntax here) + (list (quote-syntax let) (list (list arg (if (or s-exp? (syntax-e arg-is-stx?)) + expr + (list (quote-syntax datum->syntax) + (list + (quote-syntax quote-syntax) + (datum->syntax + expr + 'here)) + expr)))) + (let loop ([patterns patterns] + [fenders fenders] + [unflat-pattern-varss pattern-varss] + [answers answers]) + (cond + [(null? patterns) + (list + (quote-syntax raise-syntax-error) + #f + "bad syntax" + arg)] + [else + (let ([rest (loop (cdr patterns) (cdr fenders) + (cdr unflat-pattern-varss) (cdr answers))]) + (let ([pattern (car patterns)] + [fender (car fenders)] + [unflat-pattern-vars (car unflat-pattern-varss)] + [answer (car answers)]) + (-define pattern-vars + (map (lambda (var) + (let loop ([var var]) + (if (syntax? var) + var + (loop (car var))))) + unflat-pattern-vars)) + (-define temp-vars + (map + (lambda (p) (gen-temp-id 'sc)) + pattern-vars)) + (-define tail-pattern-var (sub1 (length pattern-vars))) + ;; Here's the result expression for one match: + (let* ([do-try-next (if (car fenders) + (list (quote-syntax try-next)) + rest)] + [mtch (make-match&env + who + pattern + pattern + (stx->list kws) + (not lit-comp-is-mod?) + s-exp?)] + [cant-fail? (if lit-comp-is-mod? + (equal? mtch '(lambda (e) e)) + (equal? mtch '(lambda (e free-identifier=?) e)))] + ;; Avoid generating gigantic matching expressions. + ;; If it's too big, interpret at run time, instead + [interp? (and (not cant-fail?) + (zero? + (let sz ([mtch mtch][fuel 100]) + (cond + [(zero? fuel) 0] + [(pair? mtch) (sz (cdr mtch) + (sz (car mtch) + fuel))] + [(syntax? mtch) (sz (syntax-e mtch) (sub1 fuel))] + [else (sub1 fuel)]))))] + [mtch (if interp? + (let ([interp-box (box null)]) + (let ([pat (make-interp-match pattern (syntax->list kws) interp-box s-exp?)]) + (list 'lambda + '(e) + (list (if s-exp? 'interp-s-match 'interp-match) + (list 'quote pat) + 'e + (if (null? (unbox interp-box)) + #f + (list (if s-exp? 'quote 'quote-syntax) + (list->vector (reverse (unbox interp-box))))) + lit-comp)))) + mtch)] + [m + ;; Do match, bind result to rslt: + (list (quote-syntax let) + (list + (list rslt + (if cant-fail? + arg + (list* (datum->syntax + (quote-syntax here) + mtch + pattern) + arg + (if (or interp? lit-comp-is-mod?) + null + (list lit-comp)))))) + ;; If match succeeded... + (list + (quote-syntax if) + (if cant-fail? + #t + rslt) + ;; Extract each name binding into a temp variable: + (list + (quote-syntax let) + (map (lambda (pattern-var temp-var) + (list + temp-var + (let ([pos (stx-memq-pos pattern-var pattern-vars)]) + (let ([accessor (cond + [(= tail-pattern-var pos) + (cond + [(eq? pos 0) 'tail] + [(eq? pos 1) (quote-syntax unsafe-cdr)] + [else 'tail])] + [(eq? pos 0) (quote-syntax unsafe-car)] + [else #f])]) + (cond + [(eq? accessor 'tail) + (if (zero? pos) + rslt + (list + (quote-syntax unsafe-list-tail) + rslt + pos))] + [accessor (list + accessor + rslt)] + [else (list + (quote-syntax unsafe-list-ref) + rslt + pos)]))))) + pattern-vars temp-vars) + ;; Tell nested `syntax' forms about the + ;; pattern-bound variables: + (list + (quote-syntax letrec-syntaxes+values) + (map (lambda (pattern-var unflat-pattern-var temp-var) + (list (list pattern-var) + (list + (if s-exp? + (quote-syntax make-s-exp-mapping) + (quote-syntax make-syntax-mapping)) + ;; Tell it the shape of the variable: + (let loop ([var unflat-pattern-var][d 0]) + (if (syntax? var) + d + (loop (car var) (add1 d)))) + ;; Tell it the variable name: + (list + (quote-syntax quote-syntax) + temp-var)))) + pattern-vars unflat-pattern-vars + temp-vars) + null + (if fender + (list (quote-syntax if) fender + answer + do-try-next) + answer))) + do-try-next))]) + (if fender + (list + (quote-syntax let) + ;; Bind try-next to try next case + (list (list (quote try-next) + (list (quote-syntax lambda) + (list) + rest))) + ;; Try one match + m) + ;; Match try already embed the rest case + m))))]))) + x))))))) + + (begin-for-syntax + (define-values (gen-template) + (lambda (x s-exp?) + (-define here-stx (quote-syntax here)) + (unless (and (stx-pair? x) + (let ([rest (stx-cdr x)]) + (and (stx-pair? rest) + (stx-null? (stx-cdr rest))))) + (raise-syntax-error + #f + "bad form" + x)) + (syntax-arm + (datum->syntax + here-stx + (let ([pattern (stx-car (stx-cdr x))]) + (let-values ([(unique-vars all-varss) (make-pexpand pattern #f null #f s-exp?)]) + (let ([var-bindings + (map + (lambda (var) + (and (let ([v (syntax-local-value var (lambda () #f))]) + (and (if s-exp? + (s-exp-pattern-variable? v) + (syntax-pattern-variable? v)) + v)))) + unique-vars)]) + (if (and (or (null? var-bindings) + (not (ormap (lambda (x) x) var-bindings))) + (no-ellipses? pattern)) + ;; Constant template: + (list (if s-exp? + (quote-syntax quote) + (quote-syntax quote-syntax)) + pattern) + ;; Non-constant: + (let ([proto-r (let loop ([vars unique-vars][bindings var-bindings]) + (if (null? bindings) + null + (let ([rest (loop (cdr vars) + (cdr bindings))]) + (if (car bindings) + (cons (let loop ([v (car vars)] + [d (if s-exp? + (s-exp-mapping-depth (car bindings)) + (syntax-mapping-depth (car bindings)))]) + (if (zero? d) + v + (loop (list v) (sub1 d)))) + rest) + rest))))] + [non-pattern-vars (let loop ([vars unique-vars][bindings var-bindings]) + (if (null? bindings) + null + (let ([rest (loop (cdr vars) + (cdr bindings))]) + (if (car bindings) + rest + (cons (car vars) rest)))))]) + (let ([build-from-template + ;; Even if we don't use the builder, we need to check + ;; for a well-formed pattern: + (make-pexpand pattern proto-r non-pattern-vars pattern s-exp?)] + [r (let loop ([vars unique-vars][bindings var-bindings][all-varss all-varss]) + (cond + [(null? bindings) null] + [(car bindings) + (cons + (syntax-property + (let ([id (if s-exp? + (s-exp-mapping-valvar (car bindings)) + (syntax-mapping-valvar (car bindings)))]) + (datum->syntax + id + (syntax-e id) + x)) + 'disappeared-use + (map syntax-local-introduce (car all-varss))) + (loop (cdr vars) (cdr bindings) (cdr all-varss)))] + [else (loop (cdr vars) (cdr bindings) (cdr all-varss))]))]) + (if (identifier? pattern) + ;; Simple syntax-id lookup: + (car r) + ;; General case: + (list (datum->syntax + here-stx + build-from-template + pattern) + (let ([len (length r)]) + (cond + [(zero? len) (quote-syntax ())] + [(= len 1) (car r)] + [else + (cons (quote-syntax list*) r)])))))))))) + x))))) + + (-define-syntax syntax (lambda (stx) (gen-template stx #f))) + (-define-syntax datum (lambda (stx) (gen-template stx #t))) + + (#%provide (all-from "ellipses.rkt") syntax-case** syntax datum + (for-syntax syntax-pattern-variable?))) diff --git a/case/stxloc.rkt b/case/stxloc.rkt new file mode 100644 index 0000000..0e0082a --- /dev/null +++ b/case/stxloc.rkt @@ -0,0 +1,80 @@ + +;;---------------------------------------------------------------------- +;; syntax/loc + +(module stxloc '#%kernel + (#%require "qq-and-or.rkt" "stxcase.rkt" "define-et-al.rkt" + (for-syntax '#%kernel "stxcase.rkt" "sc.rkt")) + + (begin-for-syntax + (define-values (transform-to-syntax-case**) + (lambda (stx sc arg-is-stx? expr kws lit-comp s-exp? clauses) + ((λ (ans) (datum->syntax #'here ans stx)) + (list* 'syntax-case** sc arg-is-stx? expr kws lit-comp s-exp? + clauses))))) + + ;; Like regular syntax-case, but with free-identifier=? replacement + (-define-syntax syntax-case* + (lambda (stx) + (syntax-case** #f #t stx () free-identifier=? #f + [(sc stxe kl id=? . clause) + (transform-to-syntax-case** stx #'sc #f #'stxe #'kl #'id=? #f #'clause)]))) + + ;; Regular syntax-case + (-define-syntax syntax-case + (lambda (stx) + (syntax-case** #f #t stx () free-identifier=? #f + [(sc stxe kl . clause) + (transform-to-syntax-case** stx #'sc #f #'stxe #'kl #'free-identifier=? #f + #'clause)]))) + + ;; Like `syntax-case, but on plain datums + (-define-syntax datum-case + (lambda (stx) + (syntax-case** #f #t stx () free-identifier=? #f + [(sc stxe kl . clause) + (transform-to-syntax-case** stx #'sc #f #'stxe #'kl #'eq? #t #'clause)]))) + + (-define (relocate loc stx) + (if (or (syntax-source loc) + (syntax-position loc)) + (datum->syntax stx + (syntax-e stx) + loc + stx) + stx)) + + ;; Like syntax, but also takes a syntax object + ;; that supplies a source location for the + ;; resulting syntax object. + (-define-syntax syntax/loc + (lambda (stx) + (syntax-case** #f #t stx () free-identifier=? #f + [(_ loc pattern) + (if (if (symbol? (syntax-e #'pattern)) + (syntax-pattern-variable? (syntax-local-value #'pattern (lambda () #f))) + #f) + (syntax (syntax pattern)) + (syntax (relocate loc (syntax pattern))))]))) + + (-define-syntax quote-syntax/prune + (lambda (stx) + (syntax-case** #f #t stx () free-identifier=? #f + [(_ id) + (if (symbol? (syntax-e #'id)) + (datum->syntax #'here + (list (quote-syntax quote-syntax) + (identifier-prune-lexical-context (syntax id) + (list + (syntax-e (syntax id)) + '#%top))) + stx + #f + stx) + (raise-syntax-error + #f + "expected an identifier" + stx + #'id))]))) + + (#%provide syntax/loc quote-syntax/prune syntax-case* syntax-case datum-case ... _)) diff --git a/case/syntax.rkt b/case/syntax.rkt new file mode 100644 index 0000000..af8c5c6 --- /dev/null +++ b/case/syntax.rkt @@ -0,0 +1,208 @@ +#lang racket/base +(require (for-syntax racket/base + racket/private/sc)) +(provide define/with-syntax + + current-recorded-disappeared-uses + with-disappeared-uses + syntax-local-value/record + record-disappeared-uses + + format-symbol + format-id + + current-syntax-context + wrong-syntax + + generate-temporary + internal-definition-context-apply + syntax-local-eval + with-syntax*) + +;; == Defining pattern variables == + +(define-syntax (define/with-syntax stx) + (syntax-case stx () + [(define/with-syntax pattern rhs) + (let* ([pvar-env (get-match-vars #'define/with-syntax + stx + #'pattern + '())] + [depthmap (for/list ([x pvar-env]) + (let loop ([x x] [d 0]) + (if (pair? x) + (loop (car x) (add1 d)) + (cons x d))))] + [pvars (map car depthmap)] + [depths (map cdr depthmap)] + [mark (make-syntax-introducer)]) + (with-syntax ([(pvar ...) pvars] + [(depth ...) depths] + [(valvar ...) (generate-temporaries pvars)]) + #'(begin (define-values (valvar ...) + (with-syntax ([pattern rhs]) + (values (pvar-value pvar) ...))) + (define-syntax pvar + (make-syntax-mapping 'depth (quote-syntax valvar))) + ...)))])) +;; Ryan: alternative name: define/syntax-pattern ?? + +;; auxiliary macro +(define-syntax (pvar-value stx) + (syntax-case stx () + [(_ pvar) + (identifier? #'pvar) + (let ([mapping (syntax-local-value #'pvar)]) + (unless (syntax-pattern-variable? mapping) + (raise-syntax-error #f "not a pattern variable" #'pvar)) + (syntax-mapping-valvar mapping))])) + + +;; == Disappeared uses == + +(define current-recorded-disappeared-uses (make-parameter #f)) + +(define-syntax-rule (with-disappeared-uses body-expr ... stx-expr) + (let-values ([(stx disappeared-uses) + (parameterize ((current-recorded-disappeared-uses null)) + (let ([result (let () body-expr ... stx-expr)]) + (values result (current-recorded-disappeared-uses))))]) + (syntax-property stx + 'disappeared-use + (append (or (syntax-property stx 'disappeared-use) null) + disappeared-uses)))) + +(define (syntax-local-value/record id pred) + (unless (identifier? id) + (raise-argument-error 'syntax-local-value/record + "identifier?" + 0 id pred)) + (unless (and (procedure? pred) + (procedure-arity-includes? pred 1)) + (raise-argument-error 'syntax-local-value/record + "(-> any/c boolean?)" + 1 id pred)) + (let ([value (syntax-local-value id (lambda () #f))]) + (and (pred value) + (begin (record-disappeared-uses (list id)) + value)))) + +(define (record-disappeared-uses ids) + (cond + [(identifier? ids) (record-disappeared-uses (list ids))] + [(and (list? ids) (andmap identifier? ids)) + (let ([uses (current-recorded-disappeared-uses)]) + (when uses + (current-recorded-disappeared-uses + (append + (if (syntax-transforming?) + (map syntax-local-introduce ids) + ids) + uses))))] + [else (raise-argument-error 'record-disappeared-uses + "(or/c identifier? (listof identifier?))" + ids)])) + + +;; == Identifier formatting == + +(define (format-id lctx + #:source [src #f] + #:props [props #f] + #:cert [cert #f] + fmt . args) + (define (convert x) (->atom x 'format-id)) + (check-restricted-format-string 'format-id fmt) + (let* ([args (map convert args)] + [str (apply format fmt args)] + [sym (string->symbol str)]) + (datum->syntax lctx sym src props cert))) +;; Eli: This looks very *useful*, but I'd like to see it more convenient to +;; "preserve everything". Maybe add a keyword argument that when #t makes +;; all the others use values lctx, and when syntax makes the others use that +;; syntax? +;; Finally, if you get to add this, then another useful utility in the same +;; spirit is one that concatenates symbols and/or strings and/or identifiers +;; into a new identifier. I considered something like that, which expects a +;; single syntax among its inputs, and will use it for the context etc, or +;; throw an error if there's more or less than 1. + +(define (format-symbol fmt . args) + (define (convert x) (->atom x 'format-symbol)) + (check-restricted-format-string 'format-symbol fmt) + (let ([args (map convert args)]) + (string->symbol (apply format fmt args)))) + +(define (restricted-format-string? fmt) + (regexp-match? #rx"^(?:[^~]|~[aAn~%])*$" fmt)) + +(define (check-restricted-format-string who fmt) + (unless (restricted-format-string? fmt) + (raise-arguments-error who + (format "format string should have ~a placeholders" + fmt) + "format string" fmt))) + +(define (->atom x err) + (cond [(string? x) x] + [(symbol? x) x] + [(identifier? x) (syntax-e x)] + [(keyword? x) (keyword->string x)] + [(number? x) x] + [(char? x) x] + [else (raise-argument-error err + "(or/c string? symbol? identifier? keyword? char? number?)" + x)])) + + +;; == Error reporting == + +(define current-syntax-context + (make-parameter #f + (lambda (new-value) + (unless (or (syntax? new-value) (eq? new-value #f)) + (raise-argument-error 'current-syntax-context + "(or/c syntax? #f)" + new-value)) + new-value))) + +(define (wrong-syntax stx #:extra [extras null] format-string . args) + (unless (or (eq? stx #f) (syntax? stx)) + (raise-argument-error 'wrong-syntax "(or/c syntax? #f)" 0 (list* stx format-string args))) + (let* ([ctx (current-syntax-context)] + [blame (and (syntax? ctx) (syntax-property ctx 'report-error-as))]) + (raise-syntax-error (if (symbol? blame) blame #f) + (apply format format-string args) + ctx + stx + extras))) +;; Eli: The `report-error-as' thing seems arbitrary to me. + + +;; == Other utilities == + +;; generate-temporary : any -> identifier +(define (generate-temporary [stx 'g]) + (car (generate-temporaries (list stx)))) + +;; Applies the renaming of intdefs to stx. +(define (internal-definition-context-apply intdefs stx) + (let ([qastx (local-expand #`(quote #,stx) 'expression (list #'quote) intdefs)]) + (with-syntax ([(q astx) qastx]) #'astx))) + +(define (syntax-local-eval stx [intdef0 #f]) + (let* ([name (generate-temporary)] + [intdefs (syntax-local-make-definition-context intdef0)]) + (syntax-local-bind-syntaxes (list name) + #`(call-with-values (lambda () #,stx) list) + intdefs) + (internal-definition-context-seal intdefs) + (apply values + (syntax-local-value (internal-definition-context-apply intdefs name) + #f intdefs)))) + +(define-syntax (with-syntax* stx) + (syntax-case stx () + [(_ (cl) body ...) #'(with-syntax (cl) body ...)] + [(_ (cl cls ...) body ...) + #'(with-syntax (cl) (with-syntax* (cls ...) body ...))])) diff --git a/case/with-stx.rkt b/case/with-stx.rkt new file mode 100644 index 0000000..64ea885 --- /dev/null +++ b/case/with-stx.rkt @@ -0,0 +1,99 @@ +;;---------------------------------------------------------------------- +;; with-syntax, generate-temporaries + +(module with-stx '#%kernel + (#%require "stx.rkt" "small-scheme.rkt" "stxcase.rkt" + (for-syntax '#%kernel "stx.rkt" "stxcase.rkt" "stxloc.rkt" + "sc.rkt" "qq-and-or.rkt" "cond.rkt")) + + (-define (with-syntax-fail stx) + (raise-syntax-error + 'with-syntax + "binding match failed" + stx)) + + (-define (with-datum-fail stx) + (raise-syntax-error + 'with-datum + "binding match failed" + stx)) + + ;; Partly from Dybvig + (begin-for-syntax + (define-values (gen-with-syntax) + (let ([here-stx (quote-syntax here)]) + (lambda (x s-exp?) + (syntax-case x () + ((_ () e1 e2 ...) + (syntax/loc x (begin e1 e2 ...))) + ((_ ((out in) ...) e1 e2 ...) + (let ([ins (syntax->list (syntax (in ...)))]) + ;; Check for duplicates or other syntax errors: + (get-match-vars (syntax _) x (syntax (out ...)) null) + ;; Generate temps and contexts: + (let ([tmps (map (lambda (x) (gen-temp-id 'ws)) ins)] + [heres (map (lambda (x) + (datum->syntax + x + 'here + x)) + ins)] + [outs (syntax->list (syntax (out ...)))]) + ;; Let-bind RHSs, then build up nested syntax-cases: + (datum->syntax + here-stx + `(let ,(map (lambda (tmp here in) + `[,tmp ,(if s-exp? + in + `(datum->syntax + (quote-syntax ,here) + ,in))]) + tmps heres ins) + ,(let loop ([tmps tmps][outs outs]) + (cond + [(null? tmps) + (syntax (begin e1 e2 ...))] + [else `(syntax-case** #f #t ,(car tmps) () ,(if s-exp? 'eq? 'free-identifier=?) ,s-exp? + [,(car outs) ,(loop (cdr tmps) + (cdr outs))] + [_ (,(if s-exp? 'with-datum-fail 'with-syntax-fail) + ;; Minimize the syntax structure we keep: + (quote-syntax ,(datum->syntax + #f + (syntax->datum (car outs)) + (car outs))))])]))) + x))))))))) + + (-define-syntax with-syntax (lambda (stx) (gen-with-syntax stx #f))) + (-define-syntax with-datum (lambda (stx) (gen-with-syntax stx #t))) + + (-define counter 0) + (-define (append-number s) + (set! counter (add1 counter)) + (string->symbol (format "~a~s" s counter))) + + (-define (generate-temporaries sl) + (unless (stx-list? sl) + (raise-argument-error + 'generate-temporaries + "(or/c list? syntax->list)" + sl)) + (let ([l (stx->list sl)]) + (map (lambda (x) + ((make-syntax-introducer) + (cond + [(symbol? x) + (datum->syntax #f (append-number x))] + [(string? x) + (datum->syntax #f (append-number x))] + [(keyword? x) + (datum->syntax #f (append-number (keyword->string x)))] + [(identifier? x) + (datum->syntax #f (append-number (syntax-e x)))] + [(and (syntax? x) (keyword? (syntax-e x))) + (datum->syntax #f (append-number (keyword->string (syntax-e x))))] + [else + (datum->syntax #f (append-number 'temp))]))) + l))) + + (#%provide with-syntax with-datum generate-temporaries))