diff --git a/collects/stxclass/info.ss b/collects/stxclass/info.ss deleted file mode 100644 index 98d628e3ca..0000000000 --- a/collects/stxclass/info.ss +++ /dev/null @@ -1,6 +0,0 @@ -#lang setup/infotab - -#| -(define scribblings - '(("scribblings/stxclass.scrbl" (multi-page) (experimental)))) -|# diff --git a/collects/stxclass/main.ss b/collects/stxclass/main.ss deleted file mode 100644 index ba5bbc094c..0000000000 --- a/collects/stxclass/main.ss +++ /dev/null @@ -1,26 +0,0 @@ - -#lang scheme/base -(require "private/sc.ss" - "private/lib.ss") - -(provide define-syntax-class - pattern - - ~and - ~or - ...* - - syntax-parse - syntax-parser - with-patterns - attribute - - this-syntax - - current-expression - current-macro-name - - (all-from-out "private/lib.ss") - - (rename-out [parse-sc syntax-class-parse] - [attrs-of syntax-class-attributes])) diff --git a/collects/stxclass/private/codegen-data.ss b/collects/stxclass/private/codegen-data.ss deleted file mode 100644 index 77938937f4..0000000000 --- a/collects/stxclass/private/codegen-data.ss +++ /dev/null @@ -1,99 +0,0 @@ -#lang scheme/base -(require scheme/match - (for-template scheme/base "runtime.ss")) -(provide (all-defined-out)) - -;; A PK is (make-pk (listof Pattern) stx) -;; k is the rhs expression: -;; - open term with the attr names as free variables -;; - attr name must be bound to variable of (listof^depth value) -;; - 'fail' stxparameterized to (non-escaping!) failure procedure -(define-struct pk (ps k) #:transparent) - -;; A Group (G) is one of -;; - PK -;; - (make-idG stxclass (listof stx) (listof PK)) -;; where each PK starts with an id pattern of given stxclass/args -;; - (make-descrimG (listof DatumSG) (listof LiteralSG) (listof CompountSGs)) -;; where each DatumSG/LiteralSG/CompoundSG has a different datum/lit/kind -(define-struct idG (stxclass args idpks) #:transparent) -(define-struct descrimG (datumSGs literalSGs kindSGs) #:transparent) - -;; A DatumSG is (make-datumSG datum (listof PK)) -;; where each PK starts with a datum pattern equal to datum -(define-struct datumSG (datum pks)) - -;; A LiteralSG is (make-literalSG id (listof PK)) -;; where each PK starts with a literal pattern equal to literal -(define-struct literalSG (literal pks)) - -;; A CompoundSG is (make-compoundSG Kind (listof PK)) -;; where each PK starts with a compound pattern of given kind -(define-struct compoundSG (kind pks)) - - -;; A FrontierContextExpr (FCE) is one of -;; - (make-fce Id FrontierIndexExpr) -;; - (make-joined-frontier FCE id) -;; A FrontierIndexExpr is -;; - `(+ ,Number ,Syntax ...) -(define-struct fce (stx indexes)) -(define-struct joined-frontier (base ext) #:transparent) - -(define (empty-frontier x) - (make-fce x (list '(+ 0)))) - -(define (done-frontier x) - (make-fce x (list '(+ +inf.0)))) - -(define (frontier:add-car fc x) - (make-fce x (cons '(+ 0) (fce-indexes fc)))) - -(define (frontier:add-cdr fc) - (define (fi:add1 fi) - `(+ ,(add1 (cadr fi)) ,@(cddr fi))) - (make-fce (fce-stx fc) - (cons (fi:add1 (car (fce-indexes fc))) - (cdr (fce-indexes fc))))) - -(define (frontier:add-index fc expr) - (define (fi:add-index fi expr) - `(+ ,(cadr fi) ,expr ,@(cddr fi))) - (make-fce (fce-stx fc) - (cons (fi:add-index (car (fce-indexes fc)) expr) - (cdr (fce-indexes fc))))) - -(define (frontier:add-unvector fc) - (frontier:add-car fc (fce-stx fc))) -(define (frontier:add-unbox fc) - (frontier:add-car fc (fce-stx fc))) - -(define (join-frontiers base ext) - (make-joined-frontier base ext)) - -;; A DynamicFrontierContext (DFC) is a list of numbers. -;; More operations on DFCs in runtime.ss - -(define (frontier->dfc-expr fc) - (define (loop fc) - (match fc - [(struct fce (stx indexes)) - #`(list #,@indexes)] - [(struct joined-frontier (base ext)) - #`(let ([base #,(loop base)]) - (if (failed? #,ext) - (append (reverse (failed-frontier #,ext)) base) - base))])) - #`(reverse #,(loop fc))) - -(define (frontier->fstx-expr fc) - (define (loop fc) - (match fc - [(struct fce (stx indexes)) - stx] - [(struct joined-frontier (base ext)) - #`(let ([inner-failure #,ext]) - (or (and (failed? inner-failure) - (failed-frontier-stx inner-failure)) - #,(loop base)))])) - (loop fc)) diff --git a/collects/stxclass/private/codegen.ss b/collects/stxclass/private/codegen.ss deleted file mode 100644 index 0798fafc58..0000000000 --- a/collects/stxclass/private/codegen.ss +++ /dev/null @@ -1,650 +0,0 @@ -#lang scheme/base -(require (for-template scheme/base - syntax/stx - scheme/stxparam - "runtime.ss") - scheme/match - scheme/contract - scheme/private/sc - syntax/stx - syntax/boundmap - "rep-data.ss" - "rep.ss" - "codegen-data.ss" - "../util.ss") -(provide/contract - [parse:rhs (rhs? (listof sattr?) (listof identifier?) . -> . syntax?)] - [parse:clauses (syntax? identifier? identifier? . -> . syntax?)] - [announce-failures? parameter?]) - -(define announce-failures? (make-parameter #f)) - -;; parse:rhs : RHS (listof SAttr) (listof identifier) -> stx -;; Takes a list of the relevant attrs; order is significant! -;; Returns either fail or a list having length same as 'relsattrs' -(define (parse:rhs rhs relsattrs args) - (with-syntax ([(arg ...) args]) - #`(lambda (x arg ...) - (define (fail-rhs x expected frontier frontier-stx) - #,(if (rhs-transparent? rhs) - #`(make-failed x expected frontier frontier-stx) - #'#f)) - (syntax-parameterize ((this-syntax (make-rename-transformer #'x))) - #,(let ([pks (rhs->pks rhs relsattrs #'x)]) - (unless (pair? pks) - (wrong-syntax (rhs-ostx rhs) - "syntax class has no variants")) - (parse:pks (list #'x) - (list (empty-frontier #'x)) - #'fail-rhs - (list #f) - pks)))))) - -;; parse:clauses : stx identifier identifier -> stx -(define (parse:clauses stx var phi) - (define clauses-kw-table - (list (list '#:literals check-literals-list))) - (define-values (chunks clauses-stx) - (chunk-kw-seq/no-dups stx clauses-kw-table)) - (define literals - (cond [(assq '#:literals chunks) => caddr] - [else null])) - (define (clause->pk clause) - (syntax-case clause () - [(p . rest) - (let-values ([(rest decls _ sides) - (parse-pattern-directives #'rest - #:sc? #f - #:literals literals)]) - (let* ([pattern (parse-whole-pattern #'p decls)]) - (syntax-case rest () - [(b0 b ...) - (let ([body #'(let () b0 b ...)]) - (make-pk (list pattern) - (wrap-pvars (pattern-attrs pattern) - (convert-sides sides var body))))] - [_ - (wrong-syntax clause "expected body")])))])) - (unless (stx-list? clauses-stx) - (wrong-syntax clauses-stx "expected sequence of clauses")) - (let ([pks (map clause->pk (stx->list clauses-stx))]) - (unless (pair? pks) - (wrong-syntax stx "no variants")) - (parse:pks (list var) - (list (empty-frontier var)) - phi - (list #f) - pks))) - -;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK) -(define (rhs->pks rhs relsattrs main-var) - (match rhs - [(struct rhs:union (_ attrs transparent? description patterns)) - (for*/list ([rhs patterns] [pk (rhs-pattern->pks rhs relsattrs main-var)]) - pk)])) - -;; rhs-pattern->pks : RHS (listof SAttr) identifier -> (listof PK) -(define (rhs-pattern->pks rhs relsattrs main-var) - (match rhs - [(struct rhs:pattern (ostx attrs pattern decls remap sides)) - (parameterize ((current-syntax-context ostx)) - (define iattrs - (append-attrs - (cons (pattern-attrs pattern) - (for/list ([side sides] #:when (clause:with? side)) - (pattern-attrs (clause:with-pattern side)))))) - (define base-expr - (success-expr iattrs relsattrs remap main-var)) - (define expr - (wrap-pvars (pattern-attrs pattern) - (convert-sides sides main-var base-expr))) - (list (make-pk (list pattern) expr)))])) - -;; convert-sides : (listof SideClause) id stx -> stx -(define (convert-sides sides main-var body-expr) - (match sides - ['() body-expr] - [(cons (struct clause:when (e)) rest) - #`(if #,e - #,(convert-sides rest main-var body-expr) - #,(fail #'enclosing-fail main-var - #:pattern (expectation-of/message "side condition failed") - #:fce (done-frontier main-var)))] - [(cons (struct clause:with (p e)) rest) - (let ([inner - (wrap-pvars (pattern-attrs p) - (convert-sides rest main-var body-expr))]) - (with-syntax ([(x fail-k) (generate-temporaries #'(x fail-k))]) - #`(let ([x #,e] - [fail-k enclosing-fail]) - #,(parse:pks (list #'x) - (list (done-frontier #'x)) - #'fail-k - (list #f) - (list (make-pk (list p) inner))))))])) - -;; success-expr : (listof IAttr) (listof SAttr) RemapEnv stx -> stx -(define (success-expr iattrs relsattrs remap main-var) - (let* ([reliattrs (reorder-iattrs relsattrs iattrs remap)] - [flat-reliattrs (flatten-attrs* reliattrs)] - [relids (map attr-name flat-reliattrs)]) - (with-syntax ([main main-var] - [(relid ...) relids]) - #'(list main (attribute relid) ...)))) - -;; fail : id id #:pattern datum #:reason datum #:fce FCE #:fstx id -> stx -(define (fail k x #:pattern p #:fce fce) - (with-syntax ([k k] - [x x] - [p p] - [fc-expr (frontier->dfc-expr fce)] - [fstx-expr (frontier->fstx-expr fce)]) - #`(let ([failcontext fc-expr] - [failcontext-syntax fstx-expr]) - #,(when (announce-failures?) - #`(printf "failing on ~s\n reason: ~s\n" x p)) - (k x p failcontext failcontext-syntax)))) - -;; Parsing - -#| - -The parsing algorithm is based on the classic backtracking -algorithm (see Optimizing Pattern Matching for an overview). A PK -corresponds to a row in the pattern matrix. The failure argument -corresponds to the static catch continuation. - -The FCs (frontier contexts, one per column) are an addition for error -reporting. They track the matcher's progress into the term. The -matcher compares failures on backtracking, and reports the "furthest -along" failure, based on the frontiers. - -Conventions: - = - vars : listof identifiers, variables, one per column - fcs : listof FCEs, failure contexts, one per column - phi : id, failure continuation - ds : listof (string/#f), description string - -|# - - -;; parse:pks : (listof PK) -> stx -;; Each PK has a list of |vars| patterns. -;; The list of PKs must not be empty. -(define (parse:pks vars fcs phi ds pks) - (cond [(null? pks) - (error 'parse:pks "internal error: empty list of rows")] - [(null? vars) - ;; Success! - (let* ([failvar (generate-temporary 'fail-k)] - [exprs - (for/list ([pk pks]) - #`(with-enclosing-fail #,failvar #,(pk-k pk)))]) - (with-syntax ([failvar failvar] - [(expr ...) exprs]) - #`(try failvar [expr ...] #,phi)))] - [else - (let-values ([(vars groups) (split-pks vars pks)]) - (let* ([failvar (generate-temporary 'fail-k)] - [exprs - (for/list ([group groups]) - (parse:group vars fcs failvar ds group))]) - (with-syntax ([failvar failvar] - [(expr ...) exprs]) - #`(try failvar [expr ...] #,phi))))])) - - -;; parse:group : Group -> stx -;; Pre: vars is not empty -(define (parse:group vars fcs phi ds group) - (match group - [(struct idG (stxclass args pks)) - (if stxclass - (parse:group:id/stxclass vars fcs phi ds stxclass args pks) - (parse:group:id/any vars fcs phi ds args pks))] - [(struct descrimG (datumSGs literalSGs kindSGs)) - (parse:group:descrim vars fcs phi ds datumSGs literalSGs kindSGs)] - [(struct pk ((cons (? pat:and? and-pattern) rest-patterns) k)) - (parse:group:and vars fcs phi ds and-pattern rest-patterns k)] - [(struct pk ((cons (? pat:gseq? gseq-pattern) rest-patterns) k)) - (parse:group:gseq vars fcs phi ds gseq-pattern rest-patterns k)])) - -;; parse:group:id/stxclass : SC stx (listof pk) -;; -> stx -(define (parse:group:id/stxclass vars fcs phi ds stxclass args pks) - (with-syntax ([var0 (car vars)] - [(arg ...) args] - [(arg-var ...) (generate-temporaries args)] - [parser (sc-parser-name stxclass)] - [result (generate-temporary 'result)]) - #`(let ([arg-var arg] ...) - (let ([result (parser var0 arg-var ...)]) - (if (ok? result) - #,(parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:id pks #'result)) - #,(fail phi (car vars) - #:pattern (expectation-of-stxclass stxclass #'(arg-var ...) #'result) - #:fce (join-frontiers (car fcs) #'result))))))) - -;; parse:group:id/any : stx (listof pk) -> stx -(define (parse:group:id/any vars fcs phi ds args pks) - (with-syntax ([var0 (car vars)] - [(arg ...) args] - [(arg-var ...) (generate-temporaries args)] - [result (generate-temporary 'result)]) - #`(let ([arg-var arg] ...) - (let ([result (list var0)]) - #,(parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:id pks #'result)))))) - -;; parse:group:descrim : -;; (listof DatumSG) (listof LiteralSG) (listof CompoundSG) -;; -> stx -(define (parse:group:descrim vars fcs phi ds datumSGs literalSGs compoundSGs) - (define var (car vars)) - (define datum-var (generate-temporary 'datum)) - (define (datumSG-test datumSG) - (let ([datum (datumSG-datum datumSG)]) - #`(equal? #,datum-var (quote #,datum)))) - (define (datumSG-rhs datumSG) - (let ([pks (datumSG-pks datumSG)]) - (parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:datum pks)))) - (define (literalSG-test literalSG) - (let ([literal (literalSG-literal literalSG)]) - #`(and (identifier? #,var) - (free-identifier=? #,var (quote-syntax #,literal))))) - (define (literalSG-rhs literalSG) - (let ([pks (literalSG-pks literalSG)]) - (parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:literal pks)))) - (define (compoundSG-test compoundSG) - (let ([kind (compoundSG-kind compoundSG)]) - #`(#,(kind-predicate kind) #,datum-var))) - (define (compoundSG-rhs compoundSG) - (let* ([pks (compoundSG-pks compoundSG)] - [kind (compoundSG-kind compoundSG)] - [selectors (kind-selectors kind)] - [frontier-procs (kind-frontier-procs kind)] - [part-vars (for/list ([selector selectors]) (generate-temporary 'part))] - [part-frontiers - (for/list ([fproc frontier-procs] [part-var part-vars]) - (fproc (car fcs) part-var))] - [part-ds (for/list ([selector selectors]) (car ds))]) - (with-syntax ([(part-var ...) part-vars] - [(part-expr ...) - (for/list ([selector selectors]) (selector var datum-var))]) - #`(let ([part-var part-expr] ...) - #,(parse:pks (append part-vars (cdr vars)) - (append part-frontiers (cdr fcs)) - phi - (append part-ds (cdr ds)) - (shift-pks:compound pks)))))) - (define-pattern-variable var0 var) - (define-pattern-variable dvar0 datum-var) - (define-pattern-variable head-var (generate-temporary 'head)) - (define-pattern-variable tail-var (generate-temporary 'tail)) - (with-syntax ([(datum-clause ...) - (for/list ([datumSG datumSGs]) - #`[#,(datumSG-test datumSG) #,(datumSG-rhs datumSG)])] - [(lit-clause ...) - (for/list ([literalSG literalSGs]) - #`[#,(literalSG-test literalSG) #,(literalSG-rhs literalSG)])] - [(compound-clause ...) - (for/list ([compoundSG compoundSGs]) - #`[#,(compoundSG-test compoundSG) #,(compoundSG-rhs compoundSG)])]) - #`(let ([dvar0 (if (syntax? var0) (syntax-e var0) var0)]) - (cond compound-clause ... - lit-clause ... - datum-clause ... - [else - #,(fail phi (car vars) - #:pattern (expectation-of-constants - (pair? compoundSGs) - (for/list ([d datumSGs]) - (datumSG-datum d)) - (for/list ([l literalSGs]) - (literalSG-literal l)) - (car ds)) - #:fce (car fcs))])))) - -;; parse:gseq:and : pat:and (listof Pattern) stx -;; -> stx -(define (parse:group:and vars fcs phi ds and-pattern rest-patterns k) - (match-define (struct pat:and (_ _ _ description patterns)) - and-pattern) - ;; FIXME: handle description - (let ([var0-copies (for/list ([p patterns]) (car vars))] - [fc0-copies (for/list ([p patterns]) (car fcs))] - [ds-copies (for/list ([p patterns]) (or description (car ds)))]) - (parse:pks (append var0-copies (cdr vars)) - (append fc0-copies (cdr fcs)) - phi - (append ds-copies (cdr ds)) - (list (make pk (append patterns rest-patterns) k))))) - -;; parse:compound:gseq : pat:gseq (listof Pattern) stx -;; -> stx -(define (parse:group:gseq vars fcs phi ds gseq-pattern rest-patterns k) - (match-define (struct pat:gseq (ostx attrs depth heads tail)) gseq-pattern) - (define xvar (generate-temporary 'x)) - (define head-lengths (for/list ([head heads]) (length (head-ps head)))) - (define head-attrss (for/list ([head heads]) (flatten-attrs* (head-attrs head)))) - (define hid-initss - (for/list ([head heads] [head-attrs head-attrss]) - (for/list ([head-attr head-attrs]) - (cond [(head-as-list? head) #'null] - [else #'#f])))) - (define combinerss - (for/list ([head heads] [head-attrs head-attrss]) - (for/list ([head-attr head-attrs]) - (if (head-as-list? head) #'cons #'or)))) - (define finalizess - (for/list ([head heads] [head-attrs head-attrss]) - (for/list ([head-attr head-attrs]) - (if (head-as-list? head) #'reverse #'values)))) - (define head-idss - (for/list ([head-attrs head-attrss]) - (map attr-name head-attrs))) - (define completed-heads - (for/list ([head heads]) - (complete-heads-pattern head xvar (add1 depth) ostx))) - (define hid-argss (map generate-temporaries head-idss)) - (define hid-args (apply append hid-argss)) - (define mins (map head-min heads)) - (define maxs (map head-max heads)) - (define as-list?s (map head-as-list? heads)) - (define reps (generate-temporaries (for/list ([head heads]) 'rep))) - - (with-syntax ([x xvar] - [var0 (car vars)] - [((hid ...) ...) head-idss] - [((hid-arg ...) ...) hid-argss] - [((hid-init ...) ...) hid-initss] - [((combine ...) ...) combinerss] - [((finalize ...) ...) finalizess] - [(head-length ...) head-lengths] - [(rep ...) reps] - [(maxrepconstraint ...) - ;; FIXME: move to side condition to appropriate pattern - (for/list ([repvar reps] [maxrep maxs]) - (if maxrep - #`(< #,repvar #,maxrep) - #`#t))] - [(parse-loop failkv fail-tail) - (generate-temporaries #'(parse-loop failkv fail-tail))]) - - (define (gen-head-rhs my-hids my-hid-args combiners repvar maxrep) - (with-syntax ([(my-hid ...) my-hids] - [(my-hid-arg ...) my-hid-args] - [(combine ...) combiners] - [rep repvar] - [maxrep-constraint - (if maxrep - #`(< #,repvar #,maxrep) - #`'#t)]) - #`(let ([my-hid-arg (combine my-hid my-hid-arg)] ...) - (if maxrep-constraint - (let ([rep (add1 rep)]) - (parse-loop x #,@hid-args #,@reps enclosing-fail)) - #,(fail #'enclosing-fail #'var0 - #:pattern (expectation-of/message "maximum rep constraint failed") - #:fce (frontier:add-index (car fcs) - #`(calculate-index #,@reps))))))) - - (define tail-rhs-expr - (with-syntax ([(minrep-clause ...) - (for/list ([repvar reps] [minrep mins] #:when minrep) - #`[(< #,repvar #,minrep) - #,(fail #'enclosing-fail (car vars) - #:pattern (expectation-of/message "mininum rep constraint failed") - #:fce (frontier:add-index (car fcs) - #`(calculate-index #,@reps)))])]) - #`(cond minrep-clause ... - [else - (let ([hid (finalize hid-arg)] ... ... - [fail-tail enclosing-fail]) - #,(parse:pks (cdr vars) - (cdr fcs) - #'fail-tail - (cdr ds) - (list (make-pk rest-patterns k))))]))) - - (with-syntax ([tail-rhs tail-rhs-expr] - [(rhs ...) - (for/list ([hids head-idss] - [hid-args hid-argss] - [combiners combinerss] - [repvar reps] - [maxrep maxs]) - (gen-head-rhs hids hid-args combiners repvar maxrep))]) - #`(let () - (define (calculate-index rep ...) - (+ (* rep head-length) ...)) - (define (parse-loop x hid-arg ... ... rep ... failkv) - #,(parse:pks (list #'x) - (list (frontier:add-index (car fcs) - #'(calculate-index rep ...))) - #'failkv - (list (car ds)) - (append - (map make-pk - (map list completed-heads) - (syntax->list #'(rhs ...))) - (list (make-pk (list tail) #`tail-rhs))))) - (let ([hid hid-init] ... ... - [rep 0] ...) - (parse-loop var0 hid ... ... rep ... #,phi)))))) - -;; complete-heads-patterns : Head identifier number -> Pattern -(define (complete-heads-pattern head rest-var depth seq-ostx) - (define (loop ps pat) - (if (pair? ps) - (make pat:compound - (cons (pattern-ostx (car ps)) (pattern-ostx pat)) - (append (pattern-attrs (car ps)) (pattern-attrs pat)) - depth - pairK - (list (car ps) (loop (cdr ps) pat))) - pat)) - (define base - (make pat:id - seq-ostx - (list (make-attr rest-var depth null)) - depth rest-var #f null)) - (loop (head-ps head) base)) - -;; split-pks : (listof identifier) (listof PK) -;; -> (values (listof identifier) (listof ExtPK) -(define (split-pks vars pks) - (values vars - (if (pair? vars) - (split-pks/first-column pks) - pks))) - -;; split-pks/first-column : (listof PK) -> (listof ExtPK) -;; Pre: the PKs have at least one column -(define (split-pks/first-column pks) - (define (get-pat x) (car (pk-ps x))) - (define (constructor-pat? p) - (or (pat:compound? p) (pat:datum? p) (pat:literal? p))) - (define (constructor-pk? pk) - (constructor-pat? (get-pat pk))) - (define (id-pk? pk) - (pat:id? (get-pat pk))) - - (define pk-cache (make-hasheq)) - (define pattern-cache (make-hasheq)) - (define (commutes? pk1 pk2) - (let ([pk1-ht (hash-ref pk-cache pk1 - (lambda () - (let ([pk1-ht (make-hasheq)]) - (hash-set! pk-cache pk1 pk1-ht) - pk1-ht)))]) - (hash-ref pk1-ht pk2 - (lambda () - (let ([result (ormap pattern-commutes? - (pk-ps pk1) - (pk-ps pk2))]) - (hash-set! pk1-ht pk2 result) - result))))) - - (define (pattern-commutes? p1 p2) - (let ([result (not (pattern-intersects? p1 p2))]) - (when #f ;; result - (printf "commutes!\n ~s\n & ~s\n" - (syntax->datum (pattern-ostx p1)) - (syntax->datum (pattern-ostx p2)))) - result)) - - (define (pattern-intersects? p1 p2) - (let ([p1-ht (hash-ref pattern-cache p1 - (lambda () - (let ([p1-ht (make-hasheq)]) - (hash-set! pattern-cache p1 p1-ht) - p1-ht)))]) - (hash-ref p1-ht p2 - (lambda () - (let ([result (do-pattern-intersects? p1 p2)]) - (hash-set! p1-ht p2 result) - result))))) - - (define (do-pattern-intersects? p1 p2) - (or (pat:id? p1) - (pat:id? p2) - (and (pat:datum? p1) (pat:datum? p2) - (equal? (pat:datum-datum p1) (pat:datum-datum p2))) - (and (pat:compound? p1) (pat:compound? p2) - (eq? (pat:compound-kind p1) (pat:compound-kind p2)) - (andmap pattern-intersects? - (pat:compound-patterns p1) - (pat:compound-patterns p2))) - ;; FIXME: conservative - (and (pat:literal? p1) (pat:literal? p2)) - (pat:gseq? p1) - (pat:gseq? p2) - (pat:and? p1) - (pat:and? p2))) - - (define (major-loop pks epks) - (match pks - ['() (reverse epks)] - [(cons (? constructor-pk? head) tail) - (let-values ([(r-constructor-pks tail) - (gather constructor-pat? tail (list head) null)]) - (let ([c-epk (group-constructor-pks r-constructor-pks)]) - (major-loop tail (cons c-epk epks))))] - [(cons (? id-pk? head) tail) - (let* ([this-pat (get-pat head)] - [this-stxclass (pat:id-stxclass this-pat)] - [this-args (pat:id-args this-pat)]) - (let-values ([(r-id-pks tail) - (gather (lambda (p) - (and (pat:id? p) - (equal? (pat:id-stxclass p) this-stxclass) - (equal? (pat:id-args p) this-args))) - tail - (list head) - null)]) - (let ([id-epk (make idG this-stxclass this-args (reverse r-id-pks))]) - (major-loop tail (cons id-epk epks)))))] - ;; Leave gseq- and and-patterns by themselves (at least for now) - [(cons head tail) - (major-loop tail (cons head epks))])) - - ;; gather : (PK -> boolean) (listof PK) (listof PK) (listof PK) - ;; -> (listof PK) (listof PK) - (define (gather pred pks taken prefix) - (match pks - ['() - (values taken (reverse prefix))] - [(cons pk tail) - ;; We can have it if it can move past everything in the prefix. - (if (and (pred (get-pat pk)) - (for/and ([prefixpk prefix]) - (commutes? pk prefixpk))) - (gather pred tail (cons pk taken) prefix) - (gather pred tail taken (cons pk prefix)))])) - - ;; group-constructor-pks : (listof PK) -> ExtPK - (define (group-constructor-pks reversed-pks) - (define compound-ht (make-hasheq)) - (define datum-ht (make-hash)) - (define lit-ht (make-bound-identifier-mapping)) - (for ([pk reversed-pks]) - (let ([p (get-pat pk)]) - (cond [(pat:compound? p) - (let ([kind (pat:compound-kind p)]) - (hash-set! compound-ht - kind (cons pk (hash-ref compound-ht kind null))))] - [(pat:datum? p) - (let ([d (pat:datum-datum p)]) - (hash-set! datum-ht d (cons pk (hash-ref datum-ht d null))))] - [(pat:literal? p) - (let ([lit (pat:literal-literal p)]) - (bound-identifier-mapping-put! - lit-ht - lit - (cons pk - (bound-identifier-mapping-get lit-ht lit - (lambda () null)))))]))) - (let ([datumSGs (hash-map datum-ht make-datumSG)] - [literalSGs (bound-identifier-mapping-map lit-ht make-literalSG)] - [compoundSGs (hash-map compound-ht make-compoundSG)]) - (make descrimG datumSGs literalSGs compoundSGs))) - - (major-loop pks null)) - -;; shift-pks:id : (listof PK) identifier -> (listof PK) -(define (shift-pks:id pks matches-var) - (map (lambda (pk) (shift-pk:id pk matches-var)) - pks)) - -;; shift-pk:id : PK identifier identifier -> PK -;; FIXME: Assumes that all attrs are relevant!!! -(define (shift-pk:id pk0 matches-var0) - (match pk0 - [(struct pk ((cons (struct pat:id (_ attrs depth name _ _)) rest-ps) k)) - (let* ([flat-attrs (flatten-attrs* attrs depth #f #f)] - ;; FIXME: depth already included, right??? - [ids (map attr-name flat-attrs)] - [depths (map attr-depth flat-attrs)]) - (with-syntax ([(id ...) ids] - [(depth ...) depths]) - (make-pk rest-ps - (if (pair? ids) - #`(let-values ([(id ...) - #,(if name - #`(apply values #,matches-var0) - #`(apply values (cdr #,matches-var0)))]) - #,k) - k))))])) - -;; shift-pks:datum : (listof PK) -> (listof PK) -(define (shift-pks:datum pks) - (define (shift-pk pk) - (make-pk (cdr (pk-ps pk)) (pk-k pk))) - (map shift-pk pks)) - -;; shift-pks:literal : (listof PK) -> (listof PK) -(define (shift-pks:literal pks) - (define (shift-pk pk) - (make-pk (cdr (pk-ps pk)) (pk-k pk))) - (map shift-pk pks)) - -;; shift-pks:compound : (listof PK) -> (listof PK) -(define (shift-pks:compound pks) - (define (shift-pk pk0) - (match pk0 - [(struct pk ((cons (struct pat:compound (_ _ _ _ patterns)) rest-ps) - k)) - (make-pk (append patterns rest-ps) k)])) - (map shift-pk pks)) - -;; wrap-pvars : (listof IAttr) stx -> stx -(define (wrap-pvars iattrs expr) - (let* ([flat-iattrs (flatten-attrs* iattrs 0 #f #f)] - [ids (map attr-name flat-iattrs)] - [depths (map attr-depth flat-iattrs)]) - (with-syntax ([(id ...) ids] - [(depth ...) depths] - [expr expr]) - #'(let-attributes ([id depth id] ...) - expr)))) diff --git a/collects/stxclass/private/debug.ss b/collects/stxclass/private/debug.ss deleted file mode 100644 index 670ba1eb8f..0000000000 --- a/collects/stxclass/private/debug.ss +++ /dev/null @@ -1,15 +0,0 @@ - -#lang scheme/base -(require (for-syntax scheme/base) - (for-syntax "codegen.ss")) - -(provide announce-parse-failures) - -(define-syntax (announce-parse-failures stx) - (syntax-case stx () - [(_ b) - (begin (announce-failures? (and (syntax-e #'b) #t)) - #'(void))] - [(_) - #'(announce-failures #t)])) - diff --git a/collects/stxclass/private/lib.ss b/collects/stxclass/private/lib.ss deleted file mode 100644 index 5f2906f1f7..0000000000 --- a/collects/stxclass/private/lib.ss +++ /dev/null @@ -1,137 +0,0 @@ -#lang scheme/base - -(require "sc.ss" - "../util.ss" - syntax/stx - syntax/kerncase - scheme/struct-info - scheme/private/contract-helpers - (for-syntax scheme/base - "rep.ss") - (for-template scheme/base - scheme/contract)) -(provide (all-defined-out)) - -(define-syntax-rule (define-pred-stxclass name pred) - (define-syntax-class name #:attributes ([datum 0]) - (pattern x - #:with datum (if (syntax? #'x) (syntax-e #'x) #'x) - #:when (pred (attribute datum))))) - -(define-pred-stxclass identifier symbol?) -(define-pred-stxclass boolean boolean?) -(define-pred-stxclass str string?) -(define-pred-stxclass character char?) -(define-pred-stxclass keyword keyword?) - -(define-pred-stxclass number number?) -(define-pred-stxclass integer integer?) -(define-pred-stxclass exact-integer exact-integer?) -(define-pred-stxclass exact-nonnegative-integer exact-nonnegative-integer?) -(define-pred-stxclass exact-positive-integer exact-positive-integer?) - -(define-syntax-class (static-of name pred) - #:attributes (value) - (pattern x:id - #:with value-list (syntax-local-value* #'x) - #:when (pair? (attribute value-list)) - #:with value (car (attribute value-list)) - #:when (pred (attribute value)))) - -(define (syntax-local-value* id) - (let/ec escape - (list (syntax-local-value id (lambda () (escape null)))))) - -(define-syntax-class static #:attributes (value) - (pattern x - #:declare x (static-of "static" (lambda _ #t)) - #:with value #'x.value)) - -(define-syntax-class struct-name - #:description "struct name" - #:attributes (descriptor - constructor - predicate - [accessor 1] - super - complete?) - (pattern s - #:declare s (static-of "struct name" struct-info?) - #:with info (extract-struct-info (attribute s.value)) - #:with descriptor (list-ref (attribute info) 0) - #:with constructor (list-ref (attribute info) 1) - #:with predicate (list-ref (attribute info) 2) - #:with r-accessors (reverse (list-ref (attribute info) 3)) - #:with (accessor ...) - (datum->syntax #f (let ([r-accessors (attribute r-accessors)]) - (if (and (pair? r-accessors) (eq? #f (car r-accessors))) - (cdr r-accessors) - r-accessors))) - #:with super (list-ref (attribute info) 5) - #:with complete? (or (null? (attribute r-accessors)) - (and (pair? (attribute r-accessors)) - (not (eq? #f (car (attribute r-accessors)))))))) - -(define-syntax-class expr/local-expand - #:attributes (expanded) - (pattern x - #:with expanded (local-expand #'x 'expression null))) - -(define-syntax-class expr/head-local-expand - #:attributes (expanded) - (pattern x - #:with expanded (local-expand #'x 'expression (kernel-form-identifier-list)))) - -(define-syntax-class block/head-local-expand - #:attributes (expanded-block - [expanded 1] - [def 1] - [vdef 1] - [sdef 1] - [expr 1]) - (pattern x - #:with (expanded-block (expanded ...) (def ...) (vdef ...) (sdef ...) (expr ...)) - (datum->syntax #f - (let-values ([(ex1 ex2 defs vdefs sdefs exprs) - (head-local-expand-and-categorize-syntaxes - #'x #f #| #t |#)]) - (list ex1 ex2 defs vdefs sdefs exprs))))) - -(define-syntax-class internal-definitions - #:attributes (expanded-block - [expanded 1] - [def 1] - [vdef 1] - [sdef 1] - [expr 1]) - (pattern x - #:with (expanded-block (expanded ...) (def ...) (vdef ...) (sdef ...) (expr ...)) - (datum->syntax #f - (let-values ([(ex1 ex2 defs vdefs sdefs exprs) - (head-local-expand-and-categorize-syntaxes - #'x #t #| #f |#)]) - (list ex1 ex2 defs vdefs sdefs exprs))))) - -(define-syntax-class expr - #:attributes () - (pattern x - #:when (and (syntax? #'x) (not (keyword? (syntax-e #'x)))))) - - -;; FIXME: hack -(define expr/c-use-contracts? (make-parameter #t)) - -(define-syntax-class (expr/c ctc) - #:attributes (c) - (pattern x:expr - #:with c #`(contract #,ctc - x - (quote #,(string->symbol (or (build-src-loc-string #'x) ""))) - (quote #,(or (current-macro-name) ')) - (quote-syntax #,(syntax/loc #'x ()))))) - -;; Aliases - -(define-syntax id (make-rename-transformer #'identifier)) -(define-syntax nat (make-rename-transformer #'exact-nonnegative-integer)) -(define-syntax char (make-rename-transformer #'character)) diff --git a/collects/stxclass/private/rep-data.ss b/collects/stxclass/private/rep-data.ss deleted file mode 100644 index 7e06a6e34a..0000000000 --- a/collects/stxclass/private/rep-data.ss +++ /dev/null @@ -1,477 +0,0 @@ -#lang scheme/base -(require scheme/contract - scheme/match - syntax/stx - syntax/boundmap - "../util.ss") -(provide (struct-out sc) - (struct-out attr) - (struct-out rhs) - (struct-out rhs:union) - (struct-out rhs:pattern) - (struct-out pattern) - (struct-out pat:id) - (struct-out pat:datum) - (struct-out pat:literal) - (struct-out pat:compound) - (struct-out pat:gseq) - (struct-out pat:and) - (struct-out pat:orseq) - (struct-out kind) - (struct-out head) - (struct-out clause:when) - (struct-out clause:with)) - -;; An SC is one of (make-sc symbol (listof symbol) (list-of SAttr) identifier) -(define-struct sc (name inputs attrs parser-name description) - #:property prop:procedure (lambda (self stx) (sc-parser-name self)) - #:transparent) - -;; An IAttr is (make-attr identifier number (listof SAttr)) -;; An SAttr is (make-attr symbol number (listof SAttr)) -(define-struct attr (name depth inner) - #:transparent) - -;; RHSBase is stx (listof SAttr) boolean stx/#f -(define-struct rhs (ostx attrs transparent? description) - #:transparent) - -;; A RHS is one of -;; (make-rhs:union (listof RHS)) -(define-struct (rhs:union rhs) (patterns) - #:transparent) - -;; An RHSPattern is -;; (make-rhs:pattern stx (listof SAttr) Pattern Env Env (listof SideClause)) -(define-struct rhs:pattern (stx attrs pattern decls remap sides) - #:transparent) - -#| - -NOT YET ... - -;; A Pattern is -;; (make-pattern (listof IAttr) PCtx (listof id) string/#f Descriminator) -(define-struct pattern (attrs ctx names description descrim) #:transparent) - -;; A PatternContext (PCtx) is -;; (make-pctx stx nat (listof IAttr) (listof IAttr)) -(define-struct pctx (ostx depth env outer-env) #:transparent) - -;; A Descriminator is one of -;; (make-d:any) -;; (make-d:stxclass SC (listof stx)) -;; (make-d:datum datum) -;; (make-d:literal id) -;; (make-d:gseq (listof Head) Pattern) -;; (make-d:and (listof Pattern)) -;; (make-d:orseq (listof Head)) -;; (make-d:compound Kind (listof Pattern)) -(define-struct d:any () #:transparent) -(define-struct d:stxclass (stxclass args) #:transparent) -(define-struct d:datum (datum) #:transparent) -(define-struct d:literal (literal) #:transparent) -(define-struct d:gseq (heads tail) #:transparent) -(define-struct d:and (subpatterns) #:transparent) -(define-struct d:orseq (heads) #:transparent) -(define-struct d:compound (kind patterns) #:transparent) -|# - -;; A Pattern is one of -;; (make-pat:id identifier SC/#f (listof stx)) -;; (make-pat:datum datum) -;; (make-pat:pair Pattern Pattern) -;; (make-pat:seq Pattern Pattern) -;; (make-pat:gseq (listof Head) Pattern) -;; (make-pat:and string/#f (listof Pattern)) -;; (make-pat:compound Kind (listof Pattern)) -;; when = stx (listof IAttr) number -(define-struct pattern (ostx attrs depth) #:transparent) -(define-struct (pat:id pattern) (name stxclass args) #:transparent) -(define-struct (pat:datum pattern) (datum) #:transparent) -(define-struct (pat:literal pattern) (literal) #:transparent) -(define-struct (pat:gseq pattern) (heads tail) #:transparent) -(define-struct (pat:and pattern) (description subpatterns) #:transparent) -(define-struct (pat:orseq pattern) (heads) #:transparent) -(define-struct (pat:compound pattern) (kind patterns) #:transparent) - -;; A Kind is (make-kind id (listof (id id -> stx)) (listof (FCE id -> FCE))) -(define-struct kind (predicate selectors frontier-procs) #:transparent) - -;; A Head is -;; (make-head stx (listof IAttr) nat (listof Pattern) -;; nat/f nat/f boolean id/#f stx/#f) -(define-struct head (ostx attrs depth ps min max as-list?) #:transparent) - -;; A SideClause is one of -;; (make-clause:with pattern stx) -;; (make-clause:when stx) -(define-struct clause:with (pattern expr) #:transparent) -(define-struct clause:when (expr) #:transparent) - -;; make-empty-sc : identifier -> SC -;; Dummy stxclass for calculating attributes of recursive stxclasses. -(define (make-empty-sc name) - (make sc (syntax-e name) null null #f #f)) - -(define (iattr? a) - (and (attr? a) (identifier? (attr-name a)))) - -(define (sattr? a) - (and (attr? a) (symbol? (attr-name a)))) - - -;; Environments - -;; DeclEnv maps [id => DeclEntry] -;; DeclEntry = -;; (list 'literal id id) -;; (list 'stxclass id id (listof stx)) -;; #f - -(define-struct declenv (bm)) - -(define (new-declenv literals) - (let ([decls (make-declenv (make-bound-identifier-mapping))]) - (for ([literal literals]) - (declenv-put-literal decls (car literal) (cadr literal))) - decls)) - -(define (declenv-lookup env id) - (bound-identifier-mapping-get (declenv-bm env) id (lambda () #f))) - -(define (declenv-check-unbound env id [stxclass-name #f] - #:blame-declare? [blame-declare? #f]) - ;; Order goes: literals, pattern, declares - ;; So blame-declare? only applies to stxclass declares - (let ([val (declenv-lookup env id)]) - (when val - (cond [(eq? 'literal (car val)) - (wrong-syntax id "identifier previously declared as literal")] - [(and blame-declare? stxclass-name) - (wrong-syntax (cadr val) - "identifier previously declared with syntax class ~a" - stxclass-name)] - [else - (wrong-syntax (if blame-declare? (cadr val) id) - "identifier previously declared")])))) - -(define (declenv-put-literal env internal-id lit-id) - (declenv-check-unbound env internal-id) - (bound-identifier-mapping-put! (declenv-bm env) internal-id - (list 'literal internal-id lit-id))) - -(define (declenv-put-stxclass env id stxclass-name args) - (declenv-check-unbound env id) - (bound-identifier-mapping-put! (declenv-bm env) id - (list 'stxclass id stxclass-name args))) - -;; returns ids in domain of env but not in given list -(define (declenv-domain-difference env ids) - (define idbm (make-bound-identifier-mapping)) - (define excess null) - (for ([id ids]) (bound-identifier-mapping-put! idbm id #t)) - (bound-identifier-mapping-for-each - (declenv-bm env) - (lambda (k v) - (when (and (pair? v) (eq? (car v) 'stxclass)) - (unless (bound-identifier-mapping-get idbm k (lambda () #f)) - (set! excess (cons k excess)))))) - excess) - -;; A RemapEnv is a bound-identifier-mapping - -(define (new-remapenv) - (make-bound-identifier-mapping)) - -(define (remapenv-lookup env id) - (bound-identifier-mapping-get env id (lambda () (syntax-e id)))) - -(define (remapenv-put env id sym) - (bound-identifier-mapping-put! env id sym)) - -(define (remapenv-domain env) - (bound-identifier-mapping-map env (lambda (k v) k))) - -(define trivial-remap - (new-remapenv)) - -;; Contracts - -(define DeclEnv/c - (flat-named-contract "DeclEnv/c" declenv?)) - -(define RemapEnv/c - (flat-named-contract "RemapEnv/c" bound-identifier-mapping?)) - -(define SideClause/c - (or/c clause:with? clause:when?)) - -(provide/contract - [DeclEnv/c contract?] - [RemapEnv/c contract?] - [SideClause/c contract?] - - [make-empty-sc (-> identifier? sc?)] - [allow-unbound-stxclasses (parameter/c boolean?)] - [iattr? (any/c . -> . boolean?)] - [sattr? (any/c . -> . boolean?)] - - [new-declenv - (-> (listof (list/c identifier? identifier?)) DeclEnv/c)] - [declenv-lookup - (-> declenv? identifier? any)] - [declenv-put-literal - (-> declenv? identifier? identifier? any)] - [declenv-put-stxclass - (-> declenv? identifier? identifier? (listof syntax?) - any)] - [declenv-domain-difference - (-> declenv? (listof identifier?) - (listof identifier?))] - - [new-remapenv - (-> RemapEnv/c)] - [remapenv-lookup - (-> RemapEnv/c identifier? symbol?)] - [remapenv-put - (-> RemapEnv/c identifier? symbol? any)] - [remapenv-domain - (-> RemapEnv/c list?)] - [trivial-remap - RemapEnv/c] - - [iattr->sattr (iattr? . -> . sattr?)] - [rename-attr - (attr? symbol? . -> . sattr?)] - [iattrs->sattrs - (-> (listof iattr?) RemapEnv/c - (listof sattr?))] - [sattr->iattr/id (sattr? identifier? . -> . iattr?)] - - [get-stxclass - (-> identifier? any)] - [get-stxclass/check-arg-count - (-> identifier? exact-nonnegative-integer? any)] - [split-id/get-stxclass - (-> identifier? DeclEnv/c any)] - - [intersect-attrss ((listof (listof sattr?)) syntax? . -> . (listof sattr?))] - [join-attrs (sattr? sattr? syntax? . -> . sattr?)] - [reorder-iattrs - (-> (listof sattr?) (listof iattr?) RemapEnv/c - (listof iattr?))] - [restrict-iattrs - (-> (listof sattr?) (listof iattr?) RemapEnv/c - (listof iattr?))] - [flatten-sattrs - (->* [(listof sattr?)] - [exact-integer? (or/c symbol? false/c)] - (listof sattr?))] - [intersect-sattrs ((listof sattr?) (listof sattr?) . -> . (listof sattr?))] - [flatten-attrs* - (->* [(listof iattr?)] - [exact-nonnegative-integer? any/c any/c] - (listof iattr?))] - [append-attrs ((listof (listof iattr?)) . -> . (listof iattr?))] - [lookup-sattr (symbol? (listof sattr?) . -> . (or/c sattr? false/c))] - [lookup-iattr (identifier? (listof iattr?) . -> . (or/c iattr? false/c))] - ) - - -(define allow-unbound-stxclasses (make-parameter #f)) - -(define (iattr->sattr a) - (match a - [(struct attr (name depth inner)) - (make attr (syntax-e name) depth inner)])) - -(define (rename-attr a name) - (make attr name (attr-depth a) (attr-inner a))) - -(define (iattrs->sattrs as remap) - (if (pair? as) - (let ([name* (remapenv-lookup remap (attr-name (car as)))]) - (if name* - (cons (rename-attr (car as) name*) - (iattrs->sattrs (cdr as) remap)) - (iattrs->sattrs (cdr as) remap))) - null)) - -(define (sattr->iattr/id a id) - (match a - [(struct attr (name depth inner)) - (make attr (datum->syntax id name id) depth inner)])) - - -(define (get-stxclass id) - (define (no-good) - (if (allow-unbound-stxclasses) - (make-empty-sc id) - (wrong-syntax id "not defined as syntax class"))) - (let ([sc (syntax-local-value/catch id sc?)]) - (if (sc? sc) - sc - (no-good)))) - -(define (get-stxclass/check-arg-count id arg-count) - (let* ([sc (get-stxclass id)] - [expected-arg-count (length (sc-inputs sc))]) - (unless (or (= expected-arg-count arg-count) - (allow-unbound-stxclasses)) - ;; (above: don't check error if stxclass may not be defined yet) - (wrong-syntax id - "too few arguments for syntax-class ~a (expected ~s)" - (syntax-e id) - expected-arg-count)) - sc)) - -(define (split-id/get-stxclass id0 decls) - (cond [(regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id0))) - => (lambda (m) - (define id - (datum->syntax id0 (string->symbol (cadr m)) id0 id0)) - (define scname - (datum->syntax id0 (string->symbol (caddr m)) id0 id0)) - (declenv-check-unbound decls id (syntax-e scname) - #:blame-declare? #t) - (let ([sc (get-stxclass/check-arg-count scname 0)]) - (values id sc null)))] - [else (values id0 #f null)])) - -;; intersect-attrss : (listof (listof SAttr)) stx -> (listof SAttr) -(define (intersect-attrss attrss blamestx) - (cond [(null? attrss) null] - [else - (let* ([namess (map (lambda (attrs) (map attr-name attrs)) attrss)] - [names (filter (lambda (s) - (andmap (lambda (names) (memq s names)) - (cdr namess))) - (car namess))] - [ht (make-hasheq)] - [put (lambda (attr) (hash-set! ht (attr-name attr) attr))] - [fetch-like (lambda (attr) (hash-ref ht (attr-name attr) #f))]) - (for* ([attrs attrss] - [attr attrs] - #:when (memq (attr-name attr) names)) - (put (join-attrs attr (fetch-like attr) blamestx))) - (sort (hash-map ht (lambda (k v) v)) - (lambda (a b) - (stringstring (attr-name a)) - (symbol->string (attr-name b))))))])) - -;; join-attrs : SAttr SAttr stx -> SAttr -(define (join-attrs a b blamestx) - (define (complain str . args) - (apply wrong-syntax blamestx str args)) - (if (not b) - a - (begin - (unless (equal? (attr-depth a) (attr-depth b)) - (complain "attribute '~a'occurs with different nesting depth" - (attr-name a))) - (make attr (attr-name a) - (attr-depth a) - (intersect-attrss (list (attr-inner a) (attr-inner b)) - blamestx))))) - -;; reorder-iattrs : (listof SAttr) (listof IAttr) RemapEnv/c -> (listof IAttr) -;; Reorders iattrs (and restricts) based on relsattrs -;; If a relsattr is not found, or if depth or contents mismatches, raises error. -(define (reorder-iattrs relsattrs iattrs remap) - (let ([ht (make-hasheq)]) - (for ([iattr iattrs]) - (let ([remap-name (remapenv-lookup remap (attr-name iattr))]) - (hash-set! ht remap-name iattr))) - (let loop ([relsattrs relsattrs]) - (match relsattrs - ['() null] - [(cons (struct attr (name depth inner)) rest) - (let ([iattr (hash-ref ht name #f)]) - (unless iattr - (wrong-syntax #f "required attribute is not defined: ~s" name)) - (unless (= (attr-depth iattr) depth) - (wrong-syntax (attr-name iattr) - "attribute has wrong depth (expected ~s, found ~s)" - depth (attr-depth iattr))) - (cons (make attr (attr-name iattr) - (attr-depth iattr) - (intersect-sattrs inner (attr-inner iattr))) - (loop rest)))])))) - -;; restrict-iattrs : (listof SAttr) (listof IAttr) RemapEnv/c -> (listof IAttr) -;; Preserves order of iattrs -(define (restrict-iattrs relsattrs iattrs remap) - (match iattrs - ['() null] - [(cons (struct attr (name depth inner)) rest) - (let ([sattr (lookup-sattr (remapenv-lookup remap name) relsattrs)]) - (if (and sattr (= depth (attr-depth sattr))) - (cons (make attr name depth - (intersect-sattrs inner (attr-inner sattr))) - (restrict-iattrs relsattrs (cdr iattrs) remap)) - (restrict-iattrs relsattrs (cdr iattrs) remap)))])) - -;; flatten-sattrs : (listof SAttr) num symbol -> (listof SAttr) -(define (flatten-sattrs sattrs [depth-delta 0] [prefix #f]) - (match sattrs - ['() - null] - [(cons (struct attr (name depth nested)) rest) - (let ([prefixed-name - (if prefix - (format-symbol "~a.~a" prefix name) - name)]) - (append (list (make attr prefixed-name - (+ depth-delta depth) - null)) - (flatten-sattrs nested (+ depth depth-delta) prefixed-name) - (flatten-sattrs rest depth-delta prefix)))])) - -;; intersect-sattrs : (listof SAttr) (listof SAttr) -> (listof SAttr) -;; Preserves order of first list of attrs. -(define (intersect-sattrs as bs) - (match as - ['() null] - [(cons (struct attr (name depth inner)) rest) - (let ([b (lookup-sattr name bs)]) - (if (and b (= depth (attr-depth b))) - (cons (make attr name depth (intersect-sattrs inner (attr-inner b))) - (intersect-sattrs (cdr as) bs)) - (intersect-sattrs (cdr as) bs)))])) - -;; flatten-attrs* : (listof attr) num symbol stx -> (listof attr) -(define (flatten-attrs* attrs [depth-delta 0] [prefix #f] [ctx #f]) - (match attrs - ['() - null] - [(cons (struct attr (name depth nested)) rest) - (let ([prefixed-name - (if prefix - (format-symbol "~a.~a" prefix name) - (syntax-e name))] - [ctx (or ctx name)]) - (append (list (make attr (if ctx (datum->syntax ctx prefixed-name) name) - (+ depth-delta depth) - null)) - (flatten-attrs* nested (+ depth depth-delta) prefixed-name ctx) - (flatten-attrs* rest depth-delta prefix ctx)))])) - -;; append-attrs : (listof (listof IAttr)) -> (listof IAttr) -(define (append-attrs attrss) - (let* ([all (apply append attrss)] - [names (map attr-name all)] - [dup (check-duplicate-identifier names)]) - (when dup - (wrong-syntax dup "duplicate pattern variable")) - all)) - -(define (lookup-sattr name sattrs) - (cond [(null? sattrs) #f] - [(eq? name (attr-name (car sattrs))) (car sattrs)] - [else (lookup-sattr name (cdr sattrs))])) - -(define (lookup-iattr name iattrs) - (cond [(null? iattrs) #f] - [(bound-identifier=? name (attr-name (car iattrs))) (car iattrs)] - [else (lookup-iattr name (cdr iattrs))])) diff --git a/collects/stxclass/private/rep.ss b/collects/stxclass/private/rep.ss deleted file mode 100644 index d604bae802..0000000000 --- a/collects/stxclass/private/rep.ss +++ /dev/null @@ -1,462 +0,0 @@ -#lang scheme/base -(require (for-template scheme/base) - (for-template "runtime.ss") - scheme/contract - scheme/match - syntax/boundmap - syntax/stx - "../util.ss" - "rep-data.ss" - "codegen-data.ss") - -(provide/contract - [parse-whole-pattern - (-> syntax? DeclEnv/c - pattern?)] - [parse-pattern-directives - (->* [stx-list?] - [#:sc? boolean? #:literals (listof (list/c identifier? identifier?))] - (values stx-list? DeclEnv/c RemapEnv/c (listof SideClause/c)))] - [parse-rhs - (-> syntax? boolean? syntax? - rhs?)] - [check-literals-list - (-> syntax? - (listof (list/c identifier? identifier?)))] - [pairK kind?] - [vectorK kind?] - [boxK kind?]) - -(define (atomic-datum? stx) - (let ([datum (syntax-e stx)]) - (or (null? datum) - (boolean? datum) - (string? datum) - (number? datum) - (keyword? datum)))) - -(define (wildcard? stx) - (and (identifier? stx) - (or (free-identifier=? stx (quote-syntax _))))) - -(define (epsilon? stx) - (and (identifier? stx) - (free-identifier=? stx (quote-syntax ||)))) - -(define (dots? stx) - (and (identifier? stx) - (free-identifier=? stx (quote-syntax ...)))) - -(define (gdots? stx) - (and (identifier? stx) - (free-identifier=? stx (quote-syntax ...*)))) - -(define (and-kw? stx) - (and (identifier? stx) - (free-identifier=? stx (quote-syntax ~and)))) - -(define (orseq-kw? stx) - (and (identifier? stx) - (free-identifier=? stx (quote-syntax ~or)))) - -(define (reserved? stx) - (or (dots? stx) - (gdots? stx) - (and-kw? stx) - (orseq-kw? stx))) - -;; ---- Kinds ---- - -(define pairK - (make-kind #'pair? - (list (lambda (s d) #`(car #,d)) - (lambda (s d) #`(datum->syntax #,s (cdr #,d) #,s))) - (list (lambda (fc x) (frontier:add-car fc x)) - (lambda (fc x) (frontier:add-cdr fc))))) - -(define vectorK - (make-kind #'vector? - (list (lambda (s d) - #`(datum->syntax #,s (vector->list #,d) #,s))) - (list (lambda (fc x) (frontier:add-unvector fc))))) - -(define boxK - (make-kind #'box? - (list (lambda (s d) #`(unbox #,d))) - (list (lambda (fc x) (frontier:add-unbox fc))))) - -;; --- - -;; parse-rhs : stx(SyntaxClassRHS) boolean stx -> RHS -;; If allow-unbound? is true, then unbound stxclass acts as if it has no attrs. -;; Used for pass1 (attr collection); parser requires stxclasses to be bound. -(define (parse-rhs stx allow-unbound? ctx) - (define-values (chunks rest) - (chunk-kw-seq stx rhs-directive-table #:context ctx)) - (define lits0 (assq '#:literals chunks)) - (define desc0 (assq '#:description chunks)) - (define trans0 (assq '#:transparent chunks)) - (define attrs0 (assq '#:attributes chunks)) - (define literals (if lits0 (caddr lits0) null)) - (define description (and desc0 (caddr desc0))) - (define transparent? (and trans0 #t)) - (define attributes (and attrs0 (caddr attrs0))) - - (define (parse-rhs*-patterns rest) - (define (gather-patterns stx) - (syntax-case stx (pattern) - [((pattern . _) . rest) - (cons (parse-rhs-pattern (stx-car stx) allow-unbound? literals) - (gather-patterns #'rest))] - [() - null])) - (define patterns (gather-patterns rest)) - (when (null? patterns) - (wrong-syntax ctx "expected at least one variant")) - (let ([sattrs - (or attributes - (intersect-attrss (map rhs:pattern-attrs patterns) ctx))]) - (make rhs:union stx sattrs - transparent? - description - patterns))) - - (parse-rhs*-patterns rest)) - -;; parse-rhs-pattern : stx boolean boolean (listof id+id) -> RHS -(define (parse-rhs-pattern stx allow-unbound? literals) - (syntax-case stx (pattern) - [(pattern p . rest) - (parameterize ((allow-unbound-stxclasses allow-unbound?)) - (let-values ([(rest decls remap clauses) - (parse-pattern-directives #'rest - #:literals literals - #:sc? #t)]) - (unless (stx-null? rest) - (wrong-syntax (if (pair? rest) (car rest) rest) - "unexpected terms after pattern directives")) - (let* ([pattern (parse-whole-pattern #'p decls)] - [with-patterns - (for/list ([c clauses] #:when (clause:with? c)) - (clause:with-pattern c))] - [attrs (append-attrs - (cons (pattern-attrs pattern) - (map pattern-attrs with-patterns)))] - [sattrs (iattrs->sattrs attrs remap)]) - (make rhs:pattern stx sattrs pattern decls remap clauses))))])) - -;; parse-whole-pattern : stx DeclEnv -> Pattern -(define (parse-whole-pattern stx decls) - (define pattern (parse-pattern stx decls 0)) - (define pvars (map attr-name (pattern-attrs pattern))) - (define excess-domain (declenv-domain-difference decls pvars)) - (when (pair? excess-domain) - (wrong-syntax #f "declared pattern variables do not appear in pattern" - #:extra excess-domain)) - pattern) - -;; parse-pattern : stx(Pattern) DeclEnv number -> Pattern -(define (parse-pattern stx decls depth - #:allow-orseq-pattern? [allow-orseq-pattern? #f]) - (syntax-case stx (~and ~or) - [gdots - (gdots? #'gdots) - (wrong-syntax stx "obsolete (...*) sequence syntax")] - [reserved - (reserved? #'reserved) - (wrong-syntax #'reserved "not allowed here")] - [id - (identifier? #'id) - (match (declenv-lookup decls #'id) - [(list 'literal internal-id literal-id) - (make pat:literal stx null depth literal-id)] - [(list 'stxclass declared-id scname args) - (let* ([sc (get-stxclass/check-arg-count scname (length args))] - [attrs (id-pattern-attrs #'id sc depth)]) - (make pat:id stx attrs depth #'id sc args))] - [#f - (let-values ([(name sc args) (split-id/get-stxclass #'id decls)]) - (let ([attrs (id-pattern-attrs name sc depth)] - [name (if (epsilon? name) #f name)]) - (make pat:id stx attrs depth name sc args)))])] - [datum - (atomic-datum? #'datum) - (make pat:datum stx null depth (syntax->datum #'datum))] - [(~and . rest) - (begin (unless (stx-list? #'rest) - (wrong-syntax stx "expected list of patterns")) - (parse-and-pattern stx decls depth))] - [(~or . heads) - (begin (unless (stx-list? #'heads) - (wrong-syntax stx "expected list of pattern sequences")) - (unless allow-orseq-pattern? - (wrong-syntax stx "or/sequence pattern not allowed here")) - (let* ([heads (parse-heads #'heads decls depth)] - [attrs - (append-attrs - (for/list ([head heads]) (head-attrs head)))]) - (make pat:orseq stx attrs depth heads)))] - [(head dots . tail) - (dots? #'dots) - (let* ([headp (parse-pattern #'head decls (add1 depth) - #:allow-orseq-pattern? #t)] - [heads - (if (pat:orseq? headp) - (pat:orseq-heads headp) - (list (pattern->head headp)))] - [tail (parse-pattern #'tail decls depth)] - [hattrs (pattern-attrs headp)] - [tattrs (pattern-attrs tail)]) - (make pat:gseq stx (append-attrs (list hattrs tattrs)) - depth heads tail))] - [(a . b) - (let ([pa (parse-pattern #'a decls depth)] - [pb (parse-pattern #'b decls depth)]) - (define attrs - (append-attrs (list (pattern-attrs pa) (pattern-attrs pb)))) - (make pat:compound stx attrs depth pairK (list pa pb)) - #| (make pat:pair stx attrs depth pa pb) |#)] - [#(a ...) - (let ([lp (parse-pattern (syntax/loc stx (a ...)) decls depth)]) - (make pat:compound stx (pattern-attrs lp) depth vectorK (list lp)))] - [#&x - (let ([bp (parse-pattern #'x decls depth)]) - (make pat:compound stx (pattern-attrs bp) depth boxK (list bp)))])) - -(define (id-pattern-attrs name sc depth) - (cond [(wildcard? name) null] - [(and (epsilon? name) sc) - (for/list ([a (sc-attrs sc)]) - (make attr (datum->syntax name (attr-name a)) - (+ depth (attr-depth a)) - (attr-inner a)))] - [sc - (list (make attr name depth (sc-attrs sc)))] - [else - (list (make attr name depth null))])) - -;; parse-and-patttern : stxlist DeclEnv nat -> Pattern -(define (parse-and-pattern stx decls depth) - (define-values (chunks rest) - (chunk-kw-seq/no-dups (stx-cdr stx) and-pattern-directive-table)) - (define description - (cond [(assq '#:description chunks) => caddr] - [else #f])) - (define patterns - (for/list ([x (stx->list rest)]) - (parse-pattern x decls depth))) - (define attrs (append-attrs (map pattern-attrs patterns))) - (make pat:and stx attrs depth description patterns)) - -(define (pattern->head p) - (match p - [(struct pattern (ostx iattrs depth)) - (make head ostx iattrs depth (list p) #f #f #t)])) - -(define (parse-heads stx decls enclosing-depth) - (syntax-case stx () - [({} . more) - (wrong-syntax (stx-car stx) - "empty head sequence not allowed")] - [({p ...} . more) - (let() - (define-values (chunks rest) - (chunk-kw-seq/no-dups #'more head-directive-table)) - (define-values (chunks2 rest2) - (chunk-kw-seq rest head-directive-table2)) - ;; FIXME FIXME: handle chunks2 !!!! - (cons (parse-head/chunks (stx-car stx) decls enclosing-depth chunks) - (parse-heads rest2 decls enclosing-depth)))] - [() - null] - [_ - (wrong-syntax (cond [(pair? stx) (car stx)] - [(syntax? stx) stx] - [else #f]) - "expected sequence of patterns or sequence directive")])) - -(define (parse-head/chunks pstx decls depth chunks) - (let* ([min-row (assq '#:min chunks)] - [max-row (assq '#:max chunks)] - [opt-row (assq '#:opt chunks)] - [mand-row (assq '#:mand chunks)] - [min-stx (and min-row (caddr min-row))] - [max-stx (and max-row (caddr max-row))] - [min (if min-stx (syntax-e min-stx) #f)] - [max (if max-stx (syntax-e max-stx) #f)]) - (unless (<= (or min 0) (or max +inf.0)) - (wrong-syntax (or min-stx max-stx) - "min-constraint must be less than max-constraint")) - (when (and opt-row mand-row) - (wrong-syntax (cadr opt-row) - "opt and mand directives are incompatible")) - (when (and (or min-row max-row) (or opt-row mand-row)) - (wrong-syntax (or min-stx max-stx) - "min/max-constraints are incompatible with opt/mand directives")) - (parse-head/options pstx - decls - depth - (cond [opt-row 0] [mand-row 1] [else min]) - (cond [opt-row 1] [mand-row 1] [else max]) - (not (or opt-row mand-row))))) - -(define (parse-head/options pstx decls depth min max as-list?) - (let* ([effective-depth (if as-list? depth (sub1 depth))] - [heads - (for/list ([p (stx->list pstx)]) - (parse-pattern p decls effective-depth))] - [heads-attrs - (append-attrs (map pattern-attrs heads))]) - (make head pstx - heads-attrs - depth - heads - min max as-list?))) - -;; parse-pattern-directives : stxs(PatternDirective) #:literals (listof id+id) -;; -> stx DeclEnv RemapEnv (listof SideClause) -(define (parse-pattern-directives stx - #:sc? [sc? #f] - #:literals [literals null]) - (define remap (new-remapenv)) - (define-values (chunks rest) - (chunk-kw-seq stx pattern-directive-table)) - (define (process-renames chunks) - (match chunks - [(cons (list '#:rename rename-stx internal-id sym-id) rest) - (unless sc? - (wrong-syntax rename-stx - "only allowed within syntax-class definition")) - (remapenv-put remap internal-id (syntax-e sym-id)) - (process-renames rest)] - [(cons decl rest) - (cons decl (process-renames rest))] - ['() - '()])) - (define chunks2 (process-renames chunks)) - (define-values (decls chunks3) - (grab-decls chunks2 literals)) - (values rest decls remap - (parse-pattern-sides chunks3 literals))) - -;; grab-decls : (listof chunk) (listof id+id) -;; -> (values DeclEnv/c (listof chunk)) -(define (grab-decls chunks literals) - (define decls (new-declenv literals)) - (define (loop chunks) - (match chunks - [(cons (cons '#:declare decl-stx) rest) - (add-decl decl-stx) - (loop rest)] - [else chunks])) - (define (add-decl stx) - (syntax-case stx () - [(#:declare name sc) - (identifier? #'sc) - (add-decl #'(#:declare name (sc)))] - [(#:declare name (sc expr ...)) - (declenv-put-stxclass decls #'name #'sc (syntax->list #'(expr ...)))] - [(#:declare name bad-sc) - (wrong-syntax #'bad-sc - "expected syntax class name (possibly with parameters)")])) - (let ([rest (loop chunks)]) - (values decls rest))) - -;; parse-pattern-sides : (listof chunk) (listof id+id) -;; -> (listof SideClause/c) -(define (parse-pattern-sides chunks literals) - (match chunks - [(cons (list '#:declare declare-stx _ _) rest) - (wrong-syntax declare-stx - "#:declare can only follow pattern or #:with clause")] - [(cons (list '#:when when-stx expr) rest) - (cons (make clause:when expr) - (parse-pattern-sides rest literals))] - [(cons (list '#:with with-stx pattern expr) rest) - (let-values ([(decls rest) (grab-decls rest literals)]) - (cons (make clause:with (parse-whole-pattern pattern decls) expr) - (parse-pattern-sides rest literals)))] - ['() - '()])) - - -;; check-lit-string : stx -> string -(define (check-lit-string stx) - (let ([x (syntax-e stx)]) - (unless (string? x) - (wrong-syntax stx "expected string literal")) - x)) - -;; check-attr-arity-list : stx -> (listof SAttr) -(define (check-attr-arity-list stx) - (unless (stx-list? stx) - (wrong-syntax stx "expected list of attribute declarations")) - (let ([iattrs (map check-attr-arity (stx->list stx))]) - (iattrs->sattrs (append-attrs (map list iattrs)) trivial-remap))) - -;; check-attr-arity : stx -> IAttr -(define (check-attr-arity stx) - (syntax-case stx () - [attr - (identifier? #'attr) - (make-attr #'attr 0 null)] - [(attr depth) - (check-attr-arity #'(attr depth ()))] - [(attr depth inners) - (begin (unless (identifier? #'attr) - (wrong-syntax #'attr "expected attribute name")) - (unless (exact-nonnegative-integer? (syntax-e #'depth)) - (wrong-syntax #'depth "expected depth (nonnegative integer)")) - (make-attr #'attr (syntax-e #'depth) (check-attr-arity-list #'inners)))] - [_ - (wrong-syntax stx "expected attribute arity declaration")])) - - -;; check-literals-list : syntax -> (listof id) -(define (check-literals-list stx) - (unless (stx-list? stx) - (wrong-syntax stx "expected literals list")) - (let ([lits (map check-literal-entry (stx->list stx))]) - (let ([dup (check-duplicate-identifier (map car lits))]) - (when dup (wrong-syntax dup "duplicate literal identifier"))) - lits)) - -(define (check-literal-entry stx) - (syntax-case stx () - [(internal external) - (and (identifier? #'internal) (identifier? #'external)) - (list #'internal #'external)] - [id - (identifier? #'id) - (list #'id #'id)] - [_ - (wrong-syntax stx - "expected literal (identifier or pair of identifiers)")])) - -;; rhs-directive-table -(define rhs-directive-table - (list (list '#:literals check-literals-list) - (list '#:description values) - (list '#:transparent) - (list '#:attributes check-attr-arity-list))) - -;; pattern-directive-table -(define pattern-directive-table - (list (list '#:declare check-id values) - (list '#:rename check-id check-id) - (list '#:with values values) - (list '#:when values))) - -;; and-pattern-directive-table -(define and-pattern-directive-table - (list (list '#:description check-lit-string))) - -(define head-directive-table - (list (list '#:min check-nat/f) - (list '#:max check-nat/f) - (list '#:opt) - (list '#:mand))) - -(define head-directive-table2 - (list (list '#:with values values) - (list '#:declare check-id values))) diff --git a/collects/stxclass/private/runtime.ss b/collects/stxclass/private/runtime.ss deleted file mode 100644 index be748fd4f2..0000000000 --- a/collects/stxclass/private/runtime.ss +++ /dev/null @@ -1,310 +0,0 @@ -#lang scheme/base -(require scheme/contract - scheme/match - scheme/stxparam - (for-syntax scheme/base) - (for-syntax syntax/stx) - (for-syntax scheme/private/sc) - (for-syntax "rep-data.ss") - (for-syntax "../util/error.ss")) -(provide pattern - ~and - ~or - ...* - - with-enclosing-fail - enclosing-fail - - ok? - (struct-out failed) - - current-expression - current-macro-name - - this-syntax - - (for-syntax expectation-of-stxclass - expectation-of-constants - expectation-of/message) - - try - expectation/c - expectation-of-null? - expectation->string - - let-attributes - attribute) - -;; Keywords - -(define-syntax-rule (define-keyword name) - (define-syntax name - (lambda (stx) - (raise-syntax-error #f "keyword used out of context" stx)))) - -(define-keyword pattern) -(define-keyword ~and) -(define-keyword ~or) -(define-keyword ...*) - -;; Parameters & Syntax Parameters - -(define-syntax-parameter enclosing-fail - (lambda (stx) - (wrong-syntax stx "used out of context: not parsing pattern"))) - -(define-syntax-rule (with-enclosing-fail failvar expr) - (syntax-parameterize ((enclosing-fail - (make-rename-transformer (quote-syntax failvar)))) - expr)) - -(define-syntax-parameter pattern-source - (lambda (stx) - (wrong-syntax stx "used out of context: not parsing pattern"))) - -;; this-syntax -;; Bound to syntax being matched inside of syntax class -(define-syntax-parameter this-syntax - (lambda (stx) - (wrong-syntax stx "used out of context: not within a syntax class"))) - -(define current-expression (make-parameter #f)) - -(define (current-macro-name) - (let ([expr (current-expression)]) - (and expr - (syntax-case expr (set!) - [(set! kw . _) - #'kw] - [(kw . _) - (identifier? #'kw) - #'kw] - [kw - (identifier? #'kw) - #'kw] - [_ #f])))) - -;; Runtime: syntax-class parser results - -;; A PatternParseResult is one of -;; - (listof value) -;; - (make-failed stx expectation/c frontier/#f stx) - -(define (ok? x) (or (pair? x) (null? x))) -(define-struct failed (stx expectation frontier frontier-stx) - #:transparent) - -;; Runtime: Dynamic Frontier Contexts (DFCs) - -;; A DFC is a list of numbers. - -;; compare-dfcs : DFC DFC -> (one-of '< '= '>) -;; Note A>B means A is "further along" than B. -(define (compare-dfcs a b) - (cond [(and (null? a) (null? b)) - '=] - [(and (pair? a) (null? b)) - '>] - [(and (null? a) (pair? b)) - '<] - [(and (pair? a) (pair? b)) - (cond [(> (car a) (car b)) '>] - [(< (car a) (car b)) '<] - [else (compare-dfcs (cdr a) (cdr b))])])) - -;; Runtime: parsing failures/expectations - -;; An Expectation is -;; (make-expc (listof scdyn) (listof string/#t) (listof atom) (listof id)) -(define-struct expc (stxclasses compound data literals) - #:transparent) - -(define-struct scdyn (name desc failure) - #:transparent) - -(define expectation/c (or/c expc?)) - -(define (make-stxclass-expc scdyn) - (make-expc (list scdyn) null null null)) - -(begin-for-syntax - (define certify (syntax-local-certifier)) - (define (expectation-of-stxclass stxclass args result-var) - (unless (sc? stxclass) - (raise-type-error 'expectation-of-stxclass "stxclass" stxclass)) - (with-syntax ([name (sc-name stxclass)] - [desc-var (sc-description stxclass)] - [(arg ...) args]) - (certify #`(begin - (make-stxclass-expc - (make-scdyn 'name (desc-var arg ...) - (if (failed? #,result-var) #,result-var #f))))))) - - (define (expectation-of-constants pairs? data literals description) - (with-syntax ([(datum ...) data] - [(literal ...) literals] - [pairs? pairs?] - [description - (if pairs? - (list (or description #t)) - null)]) - (certify - #'(make-expc null 'description (list 'datum ...) - (list (quote-syntax literal) ...))))) - - (define (expectation-of/message msg) - (with-syntax ([msg msg]) - (certify - #'(make-expc '() '() '((msg)) '()))))) - -(define-syntax (try stx) - (syntax-case stx () - [(try failvar (expr ...) previous-fail) - (when (stx-null? #'(expr ...)) - (raise-syntax-error #f "must have at least one attempt" stx)) - #'(try* (list (lambda (failvar) expr) ...) previous-fail)])) - -;; try* : (nonempty-listof (-> FailFunction Result)) FailFunction -> Result -;; FailFunction = (stx expectation/c ?? DynamicFrontier) -> Result -(define (try* attempts fail) - (let ([first-attempt (car attempts)] - [rest-attempts (cdr attempts)]) - (if (null? rest-attempts) - (first-attempt fail) - (let ([next-fail - (lambda (x1 p1 f1 fs1) - (let ([combining-fail - (lambda (x2 p2 f2 fs2) - (choose-error fail x1 x2 p1 p2 f1 f2 fs1 fs2))]) - (try* rest-attempts combining-fail)))]) - (first-attempt next-fail))))) - -(define (choose-error k x1 x2 p1 p2 frontier1 frontier2 fs1 fs2) - (case (compare-dfcs frontier1 frontier2) - [(>) (k x1 p1 frontier1 fs1)] - [(<) (k x2 p2 frontier2 fs2)] - [(=) (k x1 (merge-expectations p1 p2) frontier1 fs1)])) - -(define (merge-expectations e1 e2) - (make-expc (union (expc-stxclasses e1) (expc-stxclasses e2)) - (union (expc-compound e1) (expc-compound e2)) - (union (expc-data e1) (expc-data e2)) - (union (expc-literals e1) (expc-literals e2)))) - -(define (union a b) - (append a (for/list ([x b] #:when (not (member x a))) x))) - -(define (expectation-of-null? e) - (match e - [(struct expc (scs compound data literals)) - (and (null? scs) - (null? compound) - (null? literals) - (and (pair? data) (null? (cdr data))) - (equal? (car data) '()))] - [#f #f])) - -(define (expectation->string e) - (match e - [(struct expc (stxclasses compound data literals)) - (cond [(null? compound) - (let ([s1 (and (pair? stxclasses) (string-of-stxclasses stxclasses))] - [s2 (and (pair? data) (string-of-data data))] - [s3 (and (pair? literals) (string-of-literals literals))]) - (join-sep (filter string? (list s1 s2 s3)) - ";" - "or"))] - [(andmap string? compound) - (join-sep compound ";" "or")] - [else - #f])])) - -(define (string-of-stxclasses scdyns) - (comma-list (map string-of-stxclass scdyns))) - -(define (string-of-stxclass scdyn) - (define expected (or (scdyn-desc scdyn) (scdyn-name scdyn))) - (if (scdyn-failure scdyn) - (let ([inner (expectation->string (failed-expectation (scdyn-failure scdyn)))]) - (or inner (format "~a" expected))) - (format "~a" expected))) - -(define (string-of-literals literals0) - (define literals - (sort (map syntax-e literals0) - stringstring - #:cache-keys? #t)) - (case (length literals) - [(1) (format "the literal identifier ~s" (car literals))] - [else (format "one of the following literal identifiers: ~a" - (comma-list (map ->string literals)))])) - -(define (string-of-data data) - (case (length data) - [(1) (format "the literal ~s" (car data))] - [else (format "one of the following literals: ~a" - (comma-list (map ->string data)))])) - -(define (->string x) (format "~s" x)) - -(define string-of-pairs? - "structured syntax") - -(define (comma-list items) - (join-sep items "," "or")) - -(define (join-sep items sep0 ult0) - (define sep (string-append sep0 " ")) - (define ult (string-append ult0 " ")) - (define (loop items) - (cond [(null? items) - null] - [(null? (cdr items)) - (list sep ult (car items))] - [else - (list* sep (car items) (loop (cdr items)))])) - (case (length items) - [(2) (format "~a ~a~a" (car items) ult (cadr items))] - [else (let ([strings (list* (car items) (loop (cdr items)))]) - (apply string-append strings))])) - - -;; Attributes - -(begin-for-syntax - (define-struct attribute-mapping (var) - #:omit-define-syntaxes - #:property prop:procedure - (lambda (self stx) - #`(#%expression #,(attribute-mapping-var self))))) - -(define-syntax (let-attributes stx) - (syntax-case stx () - [(let-attributes ([attr depth value] ...) . body) - (with-syntax ([(vtmp ...) (generate-temporaries #'(attr ...))] - [(stmp ...) (generate-temporaries #'(attr ...))]) - #'(letrec-syntaxes+values - ([(stmp) (make-attribute-mapping (quote-syntax vtmp))] - ...) - ([(vtmp) value] ...) - (letrec-syntaxes+values - ([(attr) (make-syntax-mapping 'depth (quote-syntax stmp))] ...) - () - . body)))])) - -(define-syntax (attribute stx) - (parameterize ((current-syntax-context stx)) - (syntax-case stx () - [(attribute name) - (identifier? #'name) - (let ([mapping (syntax-local-value #'name (lambda () #f))]) - (unless (syntax-pattern-variable? mapping) - (wrong-syntax #'name "not bound as a pattern variable")) - (let ([var (syntax-mapping-valvar mapping)]) - (let ([attr (syntax-local-value var (lambda () #f))]) - (unless (attribute-mapping? attr) - (wrong-syntax #'name "not bound as an attribute")) - (syntax-property (attribute-mapping-var attr) - 'disappeared-use - #'name))))]))) diff --git a/collects/stxclass/private/sc.ss b/collects/stxclass/private/sc.ss deleted file mode 100644 index 453d8e63fb..0000000000 --- a/collects/stxclass/private/sc.ss +++ /dev/null @@ -1,242 +0,0 @@ -#lang scheme/base -(require (for-syntax scheme/base - scheme/match - scheme/private/sc - "rep-data.ss" - "rep.ss" - "codegen.ss" - "../util.ss") - scheme/list - scheme/match - syntax/stx - "runtime.ss") - -(provide define-syntax-class - parse-sc - attrs-of - - syntax-parse - syntax-parser - with-patterns - - pattern - ~and - ~or - ...* - - attribute - - (struct-out failed) - - this-syntax - - current-expression - current-macro-name) - -;; (define-syntax-class name SyntaxClassDirective* SyntaxClassRHS*) -;; (define-syntax-class (name id ...) SyntaxClassDirective* SyntaxClassRHS*) - -;; A SCDirective is one of -;; #:description String -;; #:transparent - -;; A SyntaxClassRHS is -;; (pattern Pattern PatternDirective ...) - -;; A Pattern is one of -;; name:syntaxclass -;; (Pattern . Pattern) -;; (Pattern ... . Pattern) -;; (((Pattern*) HeadDirective* *) ...* . Pattern) -;; datum, including () - -;; A PatternDirective is one of -;; #:declare name SyntaxClassName -;; #:declare name (SyntaxClassName expr ...) -;; #:rename internal-id external-id -;; #:with pattern expr -;; #:with clauses are let*-scoped -;; #:when expr - -;; A HeadDirective is one of -;; #:min nat/#f -;; #:max nat/#f -;; #:opt -;; #:mand -;; -- For optional heads only: -;; #:occurs id -;; 'id' is bound to #t is the pattern occurs, #f otherwise -;; #:default form -;; Preceding head must have a single pvar -;; If the head is not present, the pvar is bound to 'form' instead - -(define-syntax (define-syntax-class stx) - (syntax-case stx () - [(define-syntax-class (name arg ...) . rhss) - #`(begin (define-syntax name - (let ([the-rhs - (parameterize ((current-syntax-context - (quote-syntax #,stx))) - (parse-rhs (quote-syntax rhss) #t (quote-syntax #,stx)))]) - (make sc 'name - '(arg ...) - (rhs-attrs the-rhs) - ((syntax-local-certifier) #'parser) - #'description))) - (define-values (parser description) - (rhs->parser+description name rhss (arg ...) #,stx)))] - [(define-syntax-class name . rhss) - (syntax/loc stx - (define-syntax-class (name) . rhss))])) - -(define-syntax (rhs->parser+description stx) - (syntax-case stx () - [(rhs->parser+description name rhss (arg ...) ctx) - (with-disappeared-uses - (parameterize ((current-syntax-context #'ctx)) - (let ([rhs (parse-rhs #'rhss #f #'ctx)] - [sc (syntax-local-value #'name)]) - #`(values #,(parse:rhs rhs - (sc-attrs sc) - (syntax->list #'(arg ...))) - (lambda (arg ...) - #,(or (rhs-description rhs) - #'(symbol->string 'name)))))))])) - -(define-syntax (parse-sc stx) - (syntax-case stx () - [(parse s x arg ...) - (parameterize ((current-syntax-context stx)) - (let* ([arg-count (length (syntax->list #'(arg ...)))] - [stxclass (get-stxclass/check-arg-count #'s arg-count)] - [attrs (flatten-sattrs (sc-attrs stxclass))]) - (with-syntax ([parser (sc-parser-name stxclass)] - [(name ...) (map attr-name attrs)] - [(depth ...) (map attr-depth attrs)]) - #'(let ([raw (parser x arg ...)]) - (if (ok? raw) - (map vector '(name ...) '(depth ...) (cdr raw)) - raw)))))])) - -(define-syntax (attrs-of stx) - (syntax-case stx () - [(attrs-of s) - (parameterize ((current-syntax-context stx)) - (let ([attrs (flatten-sattrs (sc-attrs (get-stxclass #'s)))]) - (with-syntax ([(a ...) (map attr-name attrs)] - [(depth ...) (map attr-depth attrs)]) - #'(quote ((a depth) ...)))))])) - -(define-syntax (debug-rhs stx) - (syntax-case stx () - [(debug-rhs rhs) - (let ([rhs (parse-rhs #'rhs #f stx)]) - #`(quote #,rhs))])) - -(define-syntax-rule (syntax-parse stx-expr . clauses) - (let ([x stx-expr]) - (syntax-parse* syntax-parse x . clauses))) - -(define-syntax-rule (syntax-parser . clauses) - (lambda (x) (syntax-parse* syntax-parser x . clauses))) - -(define-syntax (syntax-parse* stx) - (syntax-case stx () - [(syntax-parse report-as expr . clauses) - (with-disappeared-uses - (parameterize ((current-syntax-context - (syntax-property stx - 'report-errors-as - (syntax-e #'report-as)))) - #`(let ([x expr]) - (let ([fail (syntax-patterns-fail x)]) - (parameterize ((current-expression (or (current-expression) x))) - #,(parse:clauses #'clauses #'x #'fail))))))])) - -(define-syntax with-patterns - (syntax-rules () - [(with-patterns () . b) - (let () . b)] - [(with-patterns ([p x] . more) . b) - (syntax-parse x [p (with-patterns more . b)])])) - -(define ((syntax-patterns-fail stx0) x expected frontier frontier-stx) - (define (err msg stx) - (raise (make-exn:fail:syntax - (if msg - (string->immutable-string (string-append "bad syntax: " msg)) - (string->immutable-string "bad syntax")) - (current-continuation-marks) - (list stx)))) - (define n (last frontier)) - (cond [(expectation-of-null? expected) - ;; FIXME: "extra term(s) after " - (syntax-case x () - [(one) - (err "unexpected term" #'one)] - [(first . more) - (err "unexpected terms starting here" #'first)] - [_ - (err "unexpected term" x)])] - [(and expected (expectation->string expected)) - => - (lambda (msg) - (err (format "expected ~a~a" - msg - (cond [(zero? n) ""] - [(= n +inf.0) " after matching main pattern"] - [else (format " after ~s ~a" - n - (if (= 1 n) "form" "forms"))])) - frontier-stx))] - [else - (err #f stx0)])) - - - -#| -(begin-for-syntax - (define (check-attrlist stx) - (syntax-case stx () - [(form ...) - (let ([names (for/list ([s (syntax->list #'(form ...))]) - (check-attr s) - (stx-car s))]) - (check-duplicate-identifier names) - stx)] - [_ - (raise-syntax-error 'define-syntax-class - "expected attribute table" stx)])) - (define stxclass-table - `((#:description check-string) - (#:attributes check-attrlist))) - (define (split-rhss rhss stx) - (define-values (chunks rest) - (chunk-kw-seq/no-dups rhss stxclass-table #:context stx)) - (define (assq* x alist default) - (cond [(assq x alist) => cdr] - [else default])) - (values (cond [(assq '#:attributes chunks) => caddr] - [else null]) - (cond [(assq '#:description chunks) => caddr] - [else #f]) - rest))) - -(define-syntax (define-syntax-class stx) - (syntax-case stx () - [(define-syntax-class (name arg ...) . rhss) - (let-values ([(attrs description rhss) (split-rhss #'rhss stx)]) - #`(begin (define-syntax name - (make sc - 'name - '(arg ...) - '#,attrs - ((syntax-local-value) #'parser) - '#,description)) - (define parser - (rhs->parser name #,rhss (arg ...) #,stx))))] - [(define-syntax-class name . rhss) - (syntax/loc stx - (define-syntax-class (name) . rhss))])) -|# - diff --git a/collects/stxclass/scribblings/library.scrbl b/collects/stxclass/scribblings/library.scrbl deleted file mode 100644 index e3add81914..0000000000 --- a/collects/stxclass/scribblings/library.scrbl +++ /dev/null @@ -1,103 +0,0 @@ -#lang scribble/doc -@(require scribble/manual - scribble/struct - scribble/decode - (for-label scheme/base - scheme/contract - stxclass - stxclass/util)) - -@(define ellipses @scheme[...]) -@(define (TODO . pre-flow) - (make-splice - (cons (bold "TODO: ") - (decode-content pre-flow)))) - -@title{Library syntax classes} -@declare-exporting[stxclass] - -@(define-syntax-rule (defstxclass name . pre-flows) - (defidform name . pre-flows)) - -@(define-syntax-rule (defstxclass* (name arg ...) . pre-flows) - (defform (name arg ...) . pre-flows)) - -@defstxclass[expr]{ - -Matches anything except a keyword literal (to distinguish expressions -from the start of a keyword argument sequence). Does not expand or -otherwise inspect the term. - -} - -@deftogether[( -@defstxclass[identifier] -@defstxclass[boolean] -@defstxclass[str] -@defstxclass[char] -@defstxclass[keyword] -@defstxclass[number] -@defstxclass[integer] -@defstxclass[exact-integer] -@defstxclass[exact-nonnegative-integer] -@defstxclass[exact-positive-integer])]{ - -Match syntax satisfying the corresponding predicates. - -} - -@defstxclass[id]{ Alias for @scheme[identifier]. } -@defstxclass[nat]{ Alias for @scheme[exact-nonnegative-integer]. } - -The following syntax classes mirror parts of the macro API. They may -only be used during transformation (when @scheme[syntax-transforming?] -returns true). Otherwise they may raise an error. - -@defstxclass[static]{ - -Matches identifiers that are bound in the syntactic environment to -static information (see @scheme[syntax-local-value]). Attribute -@scheme[_value] contains the value the name is bound to. - -} - -@defform[(static-of description predicate)]{ - -Refines @scheme[static]: matches identifiers that are bound in the -syntactic environment to static information satisfying the given -@scheme[predicate]. Attribute @scheme[_value] contains the value the -name is bound to. The @scheme[description] argument is used for error -reporting. - -} - -@;{ -@defstxclass[struct-name]{ - -Matches identifiers bound to static struct information. Attributes are -@scheme[_descriptor], @scheme[_constructor], @scheme[_predicate], -@scheme[(_accessor ...)], @scheme[_super], and @scheme[_complete?]. - -} -} -@;{ -@defstxclass[expr/local-expand]{ - -Matches any term and @scheme[local-expand]s it as an expression with -an empty stop list. Attribute @scheme[_expanded] is the expanded form. - -} - -@defstxclass[expr/head-local-expand] -@defstxclass[block/head-local-expand] -@defstxclass[internal-definitions] -} - -@;{ -@defform[(expr/c contract-expr-stx)]{ - -Accepts any term and returns as the match that term wrapped in a -@scheme[contract] expression enforcing @scheme[contract-expr-stx]. - -} -} diff --git a/collects/stxclass/scribblings/parsing-syntax.scrbl b/collects/stxclass/scribblings/parsing-syntax.scrbl deleted file mode 100644 index 93d253320a..0000000000 --- a/collects/stxclass/scribblings/parsing-syntax.scrbl +++ /dev/null @@ -1,258 +0,0 @@ -#lang scribble/doc -@(require scribble/manual - scribble/struct - scribble/decode - (for-label scheme/base - scheme/contract - stxclass - stxclass/util)) - -@(define ellipses @scheme[...]) -@(define (TODO . pre-flow) - (make-splice - (cons (bold "TODO: ") - (decode-content pre-flow)))) - -@title{Parsing Syntax} -@declare-exporting[stxclass] - -This section describes @schememodname[stxclass]'s facilities for -parsing syntax. - -@defform/subs[(syntax-parse stx-expr maybe-literals clause ...) - ([maybe-literals code:blank - (code:line #:literals (literal ...))] - [literal id - (internal-id external-id)] - [clause (syntax-pattern pattern-directive ... expr)])]{ - -Evaluates @scheme[stx-expr], which should produce a syntax object, and -matches it against the patterns in order. If some pattern matches, its -pattern variables are bound to the corresponding subterms of the -syntax object and that clause's side conditions and @scheme[expr] is -evaluated. The result is the result of @scheme[expr]. - -If the syntax object fails to match any of the patterns (or all -matches fail the corresponding clauses' side conditions), a syntax -error is raised. The syntax error indicates the first specific subterm -for which no pattern matches. - -A literal in the literals list has two components: the identifier used -within the pattern to signify the positions to be matched, and the -identifier expected to occur in those positions. If the -single-identifier form is used, the same identifier is used for both -purposes. - -} - -@defform[(syntax-parser maybe-literals clause ...)]{ - -Like @scheme[syntax-parse], but produces a matching procedure. The -procedure accepts a single argument, which should be a syntax object. - -} - -The grammar of patterns accepted by @scheme[syntax-parse] and -@scheme[syntax-parser] follows: - -@schemegrammar*[#:literals (_ ~or ~and) - [syntax-pattern - pvar-id - pvar-id:syntax-class-id - literal-id - atomic-datum - (syntax-pattern . syntax-pattern) - (ellipsis-head-pattern #,ellipses . syntax-pattern) - (~and maybe-description syntax-pattern ...)] - [ellipsis-head-pattern - (~or head ...+) - syntax-pattern] - [maybe-description - (code:line) - (code:line #:description string)] - [pvar-id - _ - id]] - -Here are the variants of @scheme[syntax-pattern]: - -@specsubform[pvar-id]{ - -Matches anything. The pattern variable is bound to the matched -subterm, unless the pattern variable is the wildcard (@scheme[_]), in -which case no binding occurs. - -} -@specsubform[pvar-id:syntax-class-id]{ - -Matches only subterms specified by the @scheme[_syntax-class-id]. The -syntax class's attributes are computed for the subterm and bound to -the pattern variables formed by prefixing @scheme[_pvar-id.] to the -name of the attribute. @scheme[_pvar-id] is typically bound to the -matched subterm, but the syntax class can substitute a transformed -subterm instead. - -@;{(for example, @scheme[expr/c] wraps the matched -subterm in a @scheme[contract] expression).} - -If @scheme[_pvar-id] is @scheme[_], no pattern variables are bound. - -} -@specsubform[literal-id]{ - -An identifier that appears in the literals list is not a pattern -variable; instead, it is a literal that matches any identifier -@scheme[free-identifier=?] to it. - -Specifically, if @scheme[literal-id] is the ``internal'' name of an -entry in the literals list, then it represents a pattern that matches -only identifiers @scheme[free-identifier=?] to the ``external'' -name. These identifiers are often the same. - -} -@specsubform[atomic-datum]{ - -The empty list, numbers, strings, booleans, and keywords match as -literals. - -} -@specsubform[(syntax-pattern . syntax-pattern)]{ - -Matches a syntax pair whose head matches the first pattern and whose -tail matches the second. - -} - -@specsubform[(ellipsis-head-pattern #,ellipses . syntax-pattern)]{ - -Matches a sequence of the first pattern ending in a tail matching the -second pattern. - -That is, the sequence pattern matches either the second pattern (which -need not be a list) or a pair whose head matches the first pattern and -whose tail recursively matches the whole sequence pattern. - -The head pattern can be either an ordinary pattern or an -or/sequence-pattern: - -@specsubform/subs[#:literals (~or) - (~or head ...+) - ([head - (code:line (syntax-pattern ...+) head-directive ...)] - [head-directive - (code:line #:min min-reps) - (code:line #:max max-reps) - (code:line #:mand)])]{ - -If the head is an or/sequence-pattern (introduced by @scheme[~or]), -then the whole sequence pattern matches any combination of the head -sequences followed by a tail matching the final pattern. - -@specsubform[(code:line #:min min-reps)]{ - -Requires at least @scheme[min-reps] occurrences of the preceding head -to match. @scheme[min-reps] must be a literal exact nonnegative -integer. - -} -@specsubform[(code:line #:max max-reps)]{ - -Requires that no more than @scheme[max-reps] occurrences of the -preceeding head to match. @scheme[max-reps] must be a literal exact -nonnegative integer, and it must be greater than or equal to -@scheme[min-reps]. - -} -@specsubform[#:mand]{ - -Requires that the preceding head occur exactly once. Pattern variables -in the preceding head are not bound at a higher ellipsis nesting -depth. - -} -} -} -@specsubform/subs[#:literals (~and) - (~and maybe-description syntax-pattern ...) - ([maybe-description - (code:line) - (code:line #:description string)])]{ - -Matches any syntax that matches all of the included patterns. - -} - -Both @scheme[syntax-parse] and @scheme[syntax-parser] support -directives for annotating the pattern and specifying side -conditions. The grammar for pattern directives follows: - -@schemegrammar[pattern-directive - (code:line #:declare pattern-id syntax-class-id) - (code:line #:declare pattern-id (syntax-class-id expr ...)) - (code:line #:with syntax-pattern expr) - (code:line #:when expr)] - -@specsubform[(code:line #:declare pvar-id syntax-class-id)] -@specsubform[(code:line #:declare pvar-id (syntax-class-id expr ...))]{ - -The first form is equivalent to using the -@scheme[_pvar-id:syntax-class-id] form in the pattern (but it is -illegal to use both for a single pattern variable). The -@scheme[#:declare] form may be preferred when writing macro-defining -macros or to avoid dealing with structured identifiers. - -The second form allows the use of parameterized syntax classes, which -cannot be expressed using the ``colon'' notation. The @scheme[expr]s -are evaluated outside the scope of the pattern variable bindings. - -} -@specsubform[(code:line #:with syntax-pattern expr)]{ - -Evaluates the @scheme[expr] in the context of all previous pattern -variable bindings and matches it against the pattern. If the match -succeeds, the new pattern variables are added to the environment for -the evaluation of subsequent side conditions. If the @scheme[#:with] -match fails, the matching process backtracks. Since a syntax object -may match a pattern in several ways, backtracking may cause the same -clause to be tried multiple times before the next clause is reached. - -} -@specsubform[(code:line #:when expr)]{ - -Evaluates the @scheme[expr] in the context of all previous pattern -variable bindings. If it produces a false value, the matching process -backtracks as described above; otherwise, it continues. - -} - - -@defidform[~and]{ - -Keyword recognized by @scheme[syntax-parse] etc as notation for -and-patterns. - -} - -@defidform[~or]{ - -Keyword recognized by @scheme[syntax-parse] etc as notation for -or/sequence-patterns (within sequences). It may not be used as an -expression. - -} - -@defform[(attribute attr-id)]{ - -Returns the value associated with the attribute named -@scheme[attr-id]. If @scheme[attr-id] is not bound as an attribute, an -error is raised. If @scheme[attr-id] is an attribute with a nonzero -ellipsis depth, then the result has the corresponding level of list -nesting. - -The values returned by @scheme[attribute] never undergo additional -wrapping as syntax objects, unlike values produced by some uses of -@scheme[syntax], @scheme[quasisyntax], etc. Consequently, the -@scheme[attribute] form is preferred when the attribute value is used -as data, not placed in a syntax object. - -} diff --git a/collects/stxclass/scribblings/stxclass.scrbl b/collects/stxclass/scribblings/stxclass.scrbl deleted file mode 100644 index a8902fb591..0000000000 --- a/collects/stxclass/scribblings/stxclass.scrbl +++ /dev/null @@ -1,88 +0,0 @@ -#lang scribble/doc -@(require scribble/manual - scribble/struct - scribble/decode - (for-label scheme/base - scheme/contract - stxclass - stxclass/util)) - -@(define ellipses @scheme[...]) -@(define (TODO . pre-flow) - (make-splice - (cons (bold "TODO: ") - (decode-content pre-flow)))) - -@title{Parsing Syntax and Syntax Classes} - -@bold{Warning: This library is still very volatile! Its interface and -behavior are subject to frequent change. I highly recommend that you -avoid creating PLaneT packages that depend on this library.} - -The @schememodname[stxclass] library provides a framework for -describing and parsing syntax. Using @schememodname[stxclass], macro -writers can define new syntactic categories, specify their legal -syntax, and use them to write clear, concise, and robust macros. - -To load the library: -@defmodule[stxclass] - -@;{The first section is an overview with examples that illustrate -@schememodname[stxclass] features.} - -The following sections are a reference for @schememodname[stxclass] -features. - -@include-section["parsing-syntax.scrbl"] -@include-section["syntax-classes.scrbl"] -@include-section["library.scrbl"] -@include-section["util.scrbl"] - -@local-table-of-contents[] - -@;{ - - -1 How to abstract over similar patterns: - -(syntax-parse stx #:literals (blah bleh blaz kwA kwX) - [(blah (bleh (kwX y z)) blaz) - ___] - [(blah (bleh (kwA (b c))) blaz) - ___]) - -=> - -(define-syntax-class common - #:attributes (inner) - #:literals (blah bleh blaz) - (pattern (blah (bleh inner) blaz))) -(syntax-parse stx #:literals (kwA kwX) - [c:common - #:with (kwX y z) #'c.inner - ___] - [c:common - #:with (kwA (b c)) #'c.inner - ___]) - - -OR => - -(define-syntax-class (common expected-kw) - #:attributes (inner) - #:literals (blah bleh blaz) - (pattern (blah (bleh (kw . inner)) blaz) - #:when (free-identifier=? #'kw expected-kw))) -(syntax-parse stx - [c - #:declare c (common #'kwX) - #:with (y z) #'c.inner - ___] - [c - #:declare c (common #'kwA) - #:with ((b c)) #'c.inner - ___]) - - -} - diff --git a/collects/stxclass/scribblings/syntax-classes.scrbl b/collects/stxclass/scribblings/syntax-classes.scrbl deleted file mode 100644 index de9339887b..0000000000 --- a/collects/stxclass/scribblings/syntax-classes.scrbl +++ /dev/null @@ -1,225 +0,0 @@ -#lang scribble/doc -@(require scribble/manual - scribble/struct - scribble/decode - (for-label scheme/base - scheme/contract - stxclass - stxclass/util)) - -@(define ellipses @scheme[...]) -@(define (TODO . pre-flow) - (make-splice - (cons (bold "TODO: ") - (decode-content pre-flow)))) - -@title{Syntax Classes} -@declare-exporting[stxclass] - -Syntax classes provide an abstraction mechanism for the specification -of syntax. Basic syntax classes include @scheme[identifier] and -@scheme[keyword]. More generally, a programmer can define a ``basic'' -syntax from an arbitrary predicate, although syntax classes thus -defined lose some of the benefits of declarative specification of -syntactic structure. - -Programmers can also compose basic syntax classes to build -specifications of more complex syntax, such as lists of distinct -identifiers and formal arguments with keywords. Macros that manipulate -the same syntactic structures can share syntax class definitions. The -structure of syntax classes and patterns also allows -@scheme[syntax-parse] to automatically generate error messages for -syntax errors. - -When a syntax class accepts (matches, includes) a syntax object, it -computes and provides attributes based on the contents of the matched -syntax. While the values of the attributes depend on the matched -syntax, the set of attributes and each attribute's ellipsis nesting -depth is fixed for each syntax class. - -@defform*/subs[#:literals (pattern basic-syntax-class) - [(define-syntax-class name-id stxclass-option ... - stxclass-body) - (define-syntax-class (name-id arg-id ...) stxclass-option ... - stxclass-body)] - ([stxclass-options - (code:line #:attributes (attr-arity-decl ...)) - (code:line #:description description) - (code:line #:transparent) - (code:line #:literals (literal-entry ...))] - [attr-arity-decl - attr-name-id - (attr-name-id depth)] - [stxclass-body - (code:line (pattern syntax-pattern stxclass-pattern-directive ...) ...+) - (code:line (basic-syntax-class parser-expr))])]{ - -Defines @scheme[name-id] as a syntax class. When the @scheme[arg-id]s -are present, they are bound as variables (not pattern variables) in -the body. The body of the syntax-class definition contains either one -@scheme[basic-syntax-class] clause or a non-empty sequence of -@scheme[pattern] clauses. - -@specsubform[(code:line #:attributes (attr-arity-decl ...))]{ - -Declares the attributes of the syntax class. An attribute arity -declaration consists of the attribute name and optionally its ellipsis -depth (zero if not explicitly specified). - -If the attributes are not explicitly listed, they are computed using -@techlink{attribute inference}. - -} - -@specsubform[(code:line #:description description)]{ - -The @scheme[description] argument is an expression (with the -syntax-class's parameters in scope) that should evaluate to a -string. It is used in error messages involving the syntax class. For -example, if a term is rejected by the syntax class, an error of the -form @scheme["expected "] may be generated. - -If absent, the name of the syntax class is used instead. - -} - -@specsubform[#:transparent]{ - -Indicates that errors may be reported with respect to the internal -structure of the syntax class. -} - -@specsubform[(code:line #:literals (literal-entry))]{ - -Declares the literal identifiers for the syntax class's main patterns -(immediately within @scheme[pattern] variants) and @scheme[#:with] -clauses. The literals list does not affect patterns that occur within -subexpressions inside the syntax class (for example, the condition of -a @scheme[#:when] clause or the right-hand side of a @scheme[#:with] -binding). - -A literal can have separate internal and external names, as described -for @scheme[syntax-parse]. - -} - -@specsubform/subs[#:literals (pattern) - (pattern syntax-pattern stxclass-pattern-directive ...) - ([stxclass-pattern-directive - pattern-directive - (code:line #:rename internal-id external-id)])]{ - -Accepts syntax matching the given pattern with the accompanying -pattern directives as in @scheme[syntax-parse]. - -The attributes of the pattern are the pattern variables within the -@scheme[pattern] form together with all pattern variables bound by -@scheme[#:with] clauses, including nested attributes produced by -syntax classes associated with the pattern variables. - -The name of an attribute is the symbolic name of the pattern variable, -except when the name is explicitly given via a @scheme[#:rename] -clause. - -@specsubform[(code:line #:rename internal-id external-id)]{ - -Exports the pattern variable binding named by @scheme[internal-id] as -the attribute named @scheme[external-id]. - -} -} - -@specsubform[#:literals (basic-syntax-class) - (basic-syntax-class parser-expr)]{ - -The @scheme[parser-expr] must evaluate to a procedure. This procedure -is used to parse or reject syntax objects. The arguments to the parser -procedure consist of the syntax object to parse followed by the -syntax-class parameterization arguments (the parameter names given at -the @scheme[define-syntax-class] level are not bound within the -@scheme[parser-expr]). To indicate success, the parser should return a -list of attribute values, one for each attribute listed. (For example, -a parser for a syntax class that defines no attributes returns the -empty list when it succeeds.) To indicate failure, the parser -procedure should return @scheme[#f]. - -The parser procedure should avoid side-effects, as they interfere with -the parsing process's backtracking and error reporting. - -@TODO{Add support for better error reporting within basic syntax -class.} - -} - -} - -@defidform[pattern]{ - -Keyword recognized by @scheme[define-syntax-class]. It may not be -used as an expression. -} -@defidform[basic-syntax-class]{ - -Keyword recognized by @scheme[define-syntax-class]. It may not be used -as an expression. - -} - -@section{Attributes} - -A syntax class has a set of @deftech{attribute}s. Each attribute has a -name, an ellipsis depth, and a set of nested attributes. When an -instance of the syntax class is parsed and bound to a pattern -variable, additional pattern variables are bound for each of the -syntax class's attributes. The name of these additional pattern -variables is the dotted concatenation of the primary pattern -variable with the name of the attribute. - -For example, if pattern variable @scheme[p] is bound to an instance of -a syntax class with attribute @scheme[a], then the pattern variable -@scheme[p.a] is bound to the value of that attribute. The ellipsis -depth of @scheme[p.a] is the sum of the depths of @scheme[p] and -attribute @scheme[a]. - -If the attributes are not declared explicitly, they are computed via -@deftech{attribute inference}. For ``basic'' syntax classes, the -inferred attribute list is always empty. For compound syntax classes, -each @scheme[pattern] form is analyzed to determine its candiate -attributes. The attributes of the syntax class are the attributes -common to all of the variants (that is, the intersection of the -candidate attributes). An attribute must have the same ellipsis-depth -in each of the variants; otherwise, an error is raised. - -The candidate attributes of a @scheme[pattern] variant are the pattern -variables bound by the variant's pattern (including nested attributes -contributed by their associated syntax classes) together with the -pattern variables (and nested attributes) from @scheme[#:with] -clauses. - -For the purpose of attribute inference, recursive references to the -same syntax class and forward references to syntax classes not yet -defined do not contribute any nested attributes. This avoids various -problems in computing attributes, including infinitely nested -attributes. - -@section{Inspection tools} - -The following special forms are for debugging syntax classes. - -@defform[(syntax-class-attributes syntax-class-id)]{ - -Returns a list of the syntax class's attributes in flattened -form. Each attribute is listed by its name and ellipsis depth. - -} - -@defform[(syntax-class-parse syntax-class-id stx-expr arg-expr ...)]{ - -Runs the parser for the syntax class (parameterized by the -@scheme[arg-expr]s) on the syntax object produced by -@scheme[stx-expr]. On success, the result is a list of vectors -representing the attribute bindings of the syntax class. Each vector -contains the attribute name, depth, and associated value. On failure, -the result is some internal representation of the failure. - -} diff --git a/collects/stxclass/scribblings/util.scrbl b/collects/stxclass/scribblings/util.scrbl deleted file mode 100644 index ec6df7b123..0000000000 --- a/collects/stxclass/scribblings/util.scrbl +++ /dev/null @@ -1,232 +0,0 @@ -#lang scribble/doc -@(require scribble/manual - scribble/struct - scribble/decode - (for-label scheme/base - scheme/contract - stxclass - stxclass/util)) - -@(define ellipses @scheme[...]) -@(define (TODO . pre-flow) - (make-splice - (cons (bold "TODO: ") - (decode-content pre-flow)))) - -@title{Utilities} - -The @schememodname[stxclass] collection includes several utility -modules. They are documented individually below. - -As a shortcut, the @schememodname[stxclass/util] module provides all -of the contents of the separate utility modules: - -@defmodule[stxclass/util] - -The contents of the utility modules are not provided by the main -@schememodname[stxclass] module. - -@section{Error reporting} - -@defmodule[stxclass/util/error] - -The @schememodname[scheme/base] and @schememodname[scheme] languages -provide the @scheme[raise-syntax-error] procedure for reporting syntax -errors. Using @scheme[raise-syntax-error] effectively requires passing -around either a symbol indicating the special form that signals the -error or else a ``contextual'' syntax object from which the special -form's name can be extracted. This library helps manage the contextual -syntax for reporting errors. - -@defparam[current-syntax-context stx (or/c syntax? false/c)]{ - -The current contextual syntax object, defaulting to @scheme[#f]. It -determines the special form name that prefixes syntax errors created -by @scheme[wrong-syntax], as follows: - -If it is a syntax object with a @scheme['report-error-as] syntax -property whose value is a symbol, then that symbol is used as the -special form name. Otherwise, the same rules apply as in -@scheme[raise-syntax-error]. - -} - -@defproc[(wrong-syntax [stx syntax?] [format-string string?] [v any/c] ...) - any]{ - -Raises a syntax error using the result of -@scheme[(current-syntax-context)] as the ``major'' syntax object and -the provided @scheme[stx] as the specific syntax object. (The latter, -@scheme[stx], is usually the one highlighted by DrScheme.) The error -message is constructed using the format string and arguments, and it -is prefixed with the special form name as described under -@scheme[current-syntax-context]. - -} - -A macro using this system might set the syntax context at the very -beginning of its transformation as follows: -@SCHEMEBLOCK[ -(define-syntax (my-macro stx) - (parameterize ((current-syntax-context stx)) - (syntax-case stx () - ___))) -] -Then any calls to @scheme[wrong-syntax] during the macro's -transformation will refer to @scheme[my-macro] (more precisely, the name that -referred to @scheme[my-macro] where the macro was used, which may be -different due to renaming, prefixing, etc). - -A macro that expands into a helper macro can insert its own name into -syntax errors raised by the helper macro by installing a -@scheme['report-error-as] syntax property on the helper macro -expression. For example: -@SCHEMEBLOCK[ -(define-syntax (public-macro stx) - (syntax-case stx () - [(public-macro stuff) - (syntax-property - (syntax/loc stx (my-macro stuff other-internal-stuff)) - 'report-error-as - (syntax-e #'public-macro))])) -] - -@;{ -@section[Expand] - -@defmodule[stxclass/util/expand] - -TODO -} - -@section{Miscellaneous utilities} - -@defmodule[stxclass/util/misc] - -@defform[(define-pattern-variable id expr)]{ - -Evaluates @scheme[expr] and binds it to @scheme[id] as a pattern -variable, so @scheme[id] can be used in subsequent @scheme[syntax] -patterns. - -} - -@defform[(with-temporaries (temp-id ...) . body)]{ - -Evaluates @scheme[body] with each @scheme[temp-id] bound as a pattern -variable to a freshly generated identifier. - -For example, the following are equivalent: -@SCHEMEBLOCK[ -(with-temporaries (x) #'(lambda (x) x)) -(with-syntax ([(x) (generate-temporaries '(x))]) - #'(lambda (x) x)) -] - -} - -@defproc[(generate-temporary) identifier?]{ - -Generates one fresh identifier. Singular form of -@scheme[generate-temporaries]. - -} - -@defproc[(generate-n-temporaries [n exact-nonnegative-integer?]) - (listof identifier?)]{ - -Generates a list of @scheme[n] fresh identifiers. - -} - -@defform[(with-catching-disappeared-uses body-expr)]{ - -Evaluates the @scheme[body-expr], catching identifiers looked up using -@scheme[syntax-local-value/catch]. Returns two values: the result of -@scheme[body-expr] and the list of caught identifiers. - -} - -@defform[(with-disappeared-uses stx-expr)]{ - -Evaluates the @scheme[stx-expr], catching identifiers looked up using -@scheme[syntax-local-value/catch]. Adds the caught identifiers to the -@scheme['disappeared-uses] syntax property of the resulting syntax -object. - -} - -@defproc[(syntax-local-value/catch [id identifier?] [predicate (-> any/c boolean?)]) - any/c]{ - -Looks up @scheme[id] in the syntactic environment (as -@scheme[syntax-local-value]). If the lookup succeeds and returns a -value satisfying the predicate, the value is returned and @scheme[id] -is recorded (``caught'') as a disappeared use. If the lookup fails or -if the value does not satisfy the predicate, @scheme[#f] is returned -and the identifier is not recorded as a disappeared use. - -} - - -@defproc[(chunk-kw-seq [stx syntax?] - [table - (listof (cons/c keyword? - (listof (-> syntax? any))))] - [context (or/c syntax? false/c) #f]) - (values (listof (cons/c keyword? (cons/c (syntax/c keyword?) list?))) - syntax?)]{ - -Parses a syntax list into keyword-argument ``chunks'' and a syntax -list tail (the remainder of the syntax list). The syntax of the -keyword arguments is specified by @scheme[table], an association list -mapping keywords to lists of checker procedures. The length of the -checker list is the number of ``arguments'' expected to follow the -keyword, and each checker procedure is applied to the corresponding -argument. The result of the checker procedure is entered into the -chunk for that keyword sequence. The same keyword can appear multiple -times in the result list. - -The @scheme[context] is used to report errors. - -} - -@defproc[(chunk-kw-seq/no-dups - [stx syntax?] - [table - (listof (cons/c keyword? - (listof (-> syntax? any))))] - [context (or/c syntax? false/c) #f]) - (values (listof (cons/c keyword? (cons/c (syntax/c keyword?) list?))) - syntax?)]{ - -Like @scheme[chunk-kw-seq] filtered by @scheme[reject-duplicate-chunks]. - -The @scheme[context] is used to report errors. - -} - -@defproc[(reject-duplicate-chunks - [chunks (listof (cons/c keyword? (cons/c (syntax/c keyword?) list?)))]) - void?]{ - -Raises a syntax error if it encounters the same keyword more than once -in the @scheme[chunks] list. - -The @scheme[context] is used to report errors. - -} - - -@section{Structs} - -@defmodule[stxclass/util/struct] - -@defform[(make struct-id v ...)]{ - -Constructs an instance of @scheme[struct-id], which must be defined -as a struct name. If @scheme[struct-id] has a different number of -fields than the number of @scheme[v] values provided, @scheme[make] -raises a compile-time error. - -} diff --git a/collects/stxclass/util.ss b/collects/stxclass/util.ss deleted file mode 100644 index 6dd0a3e5ba..0000000000 --- a/collects/stxclass/util.ss +++ /dev/null @@ -1,9 +0,0 @@ -#lang scheme/base -(require "util/error.ss" - "util/expand.ss" - "util/misc.ss" - "util/struct.ss") -(provide (all-from-out "util/error.ss") - (all-from-out "util/expand.ss") - (all-from-out "util/misc.ss") - (all-from-out "util/struct.ss")) diff --git a/collects/stxclass/util/error.ss b/collects/stxclass/util/error.ss deleted file mode 100644 index 06e9f058ca..0000000000 --- a/collects/stxclass/util/error.ss +++ /dev/null @@ -1,16 +0,0 @@ -#lang scheme/base -(provide wrong-syntax - current-syntax-context) - -(define current-syntax-context (make-parameter #f)) - -(define (wrong-syntax stx #:extra [extras null] format-string . args) - (unless (or (eq? stx #f) (syntax? stx)) - (raise-type-error 'wrong-syntax "syntax or #f" 0 (list* stx format-string args))) - (let* ([ctx (current-syntax-context)] - [blame (syntax-property ctx 'report-errors-as)]) - (raise-syntax-error (if (symbol? blame) blame #f) - (apply format format-string args) - ctx - (or stx ctx) - extras))) diff --git a/collects/stxclass/util/expand.ss b/collects/stxclass/util/expand.ss deleted file mode 100644 index 5e8a6b99ca..0000000000 --- a/collects/stxclass/util/expand.ss +++ /dev/null @@ -1,88 +0,0 @@ -#lang scheme/base -(require syntax/kerncase - syntax/stx) -(provide head-local-expand-and-categorize-syntaxes - categorize-expanded-syntaxes - head-local-expand-syntaxes) - -;; head-local-expand-syntaxes : syntax boolean boolean -> stxs ^ 6 -;; Setting allow-def-after-expr? allows def/expr interleaving. -(define (head-local-expand-and-categorize-syntaxes x allow-def-after-expr?) - (define estxs (head-local-expand-syntaxes x allow-def-after-expr?)) - (define-values (defs vdefs sdefs exprs) - (categorize-expanded-syntaxes estxs)) - (values estxs estxs defs vdefs sdefs exprs)) - -;; categorize-expanded-syntaxes : (listof stx) -> stxs ^ 4 -;; Split head-expanded stxs into -;; definitions, values-definitions, syntaxes-definitions, exprs -;; (definitions include both values-definitions and syntaxes-definitions.) -(define (categorize-expanded-syntaxes estxs0) - (let loop ([estxs estxs0] [defs null] [vdefs null] [sdefs null] [exprs null]) - (cond [(pair? estxs) - (let ([ee (car estxs)]) - (syntax-case ee (begin define-values define-syntaxes) - [(define-values . _) - (loop (cdr estxs) - (cons ee defs) - (cons ee vdefs) - sdefs - exprs)] - [(define-syntaxes (var ...) rhs) - (loop (cdr estxs) - (cons ee defs) - vdefs - (cons ee sdefs) - exprs)] - [_ - (loop (cdr estxs) - defs - vdefs - sdefs - (cons ee exprs))]))] - [(null? estxs) - (values (reverse defs) - (reverse vdefs) - (reverse sdefs) - (reverse exprs))]))) - -;; head-local-expand-syntaxes : syntax boolean -> (listof syntax) -(define (head-local-expand-syntaxes x allow-def-after-expr?) - (let ([intdef (syntax-local-make-definition-context)] - [ctx '(block)]) - (let loop ([x x] [ex null] [expr? #f]) - (cond [(stx-pair? x) - (let ([ee (local-expand (stx-car x) - ctx - (kernel-form-identifier-list) - intdef)]) - (syntax-case ee (begin define-values define-syntaxes) - [(begin e ...) - (loop (append (syntax->list #'(e ...)) (stx-cdr x)) ex expr?)] - [(begin . _) - (raise-syntax-error #f "bad begin form" ee)] - [(define-values (var ...) rhs) - (andmap identifier? (syntax->list #'(var ...))) - (begin - (when (and expr? (not allow-def-after-expr?)) - (raise-syntax-error #f "definition after expression" ee)) - (syntax-local-bind-syntaxes (syntax->list #'(var ...)) #f intdef) - (loop (stx-cdr x) (cons ee ex) expr?))] - [(define-values . _) - (raise-syntax-error #f "bad define-values form" ee)] - [(define-syntaxes (var ...) rhs) - (andmap identifier? (syntax->list #'(var ...))) - (begin - (when (and expr? (not allow-def-after-expr?)) - (raise-syntax-error #f "definition after expression" ee)) - (syntax-local-bind-syntaxes (syntax->list #'(var ...)) - #'rhs - intdef) - (loop (stx-cdr x) (cons ee ex) expr?))] - [(define-syntaxes . _) - (raise-syntax-error #f "bad define-syntaxes form" ee)] - [_ - (loop (stx-cdr x) (cons ee ex) #t)]))] - [(stx-null? x) - (internal-definition-context-seal intdef) - (reverse ex)])))) diff --git a/collects/stxclass/util/misc.ss b/collects/stxclass/util/misc.ss deleted file mode 100644 index 17fb4f9f08..0000000000 --- a/collects/stxclass/util/misc.ss +++ /dev/null @@ -1,167 +0,0 @@ -#lang scheme/base -(require syntax/kerncase - syntax/stx - (for-syntax scheme/base - scheme/private/sc)) - -(provide define-pattern-variable - - with-temporaries - generate-temporary - generate-n-temporaries - - current-caught-disappeared-uses - with-catching-disappeared-uses - with-disappeared-uses - syntax-local-value/catch - record-disappeared-uses - - format-symbol - - chunk-kw-seq/no-dups - chunk-kw-seq - reject-duplicate-chunks - check-id - check-nat/f - check-string - check-idlist) - -;; Defining pattern variables - -(define-syntax-rule (define-pattern-variable name expr) - (begin (define var expr) - (define-syntax name (make-syntax-mapping '0 (quote-syntax var))))) - -;; Statics and disappeared uses - -(define current-caught-disappeared-uses (make-parameter #f)) - -(define-syntax-rule (with-catching-disappeared-uses . body) - (parameterize ((current-caught-disappeared-uses null)) - (let ([result (let () . body)]) - (values result (current-caught-disappeared-uses))))) - -(define-syntax-rule (with-disappeared-uses stx-expr) - (let-values ([(stx disappeared-uses) - (with-catching-disappeared-uses stx-expr)]) - (syntax-property stx - 'disappeared-use - (append (or (syntax-property stx 'disappeared-use) null) - disappeared-uses)))) - -(define (syntax-local-value/catch 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) - (let ([uses (current-caught-disappeared-uses)]) - (when uses - (current-caught-disappeared-uses (append ids uses))))) - -;; Generating temporaries - -;; with-temporaries -(define-syntax-rule (with-temporaries (temp-name ...) . body) - (with-syntax ([(temp-name ...) (generate-temporaries (quote-syntax (temp-name ...)))]) - . body)) - -;; generate-temporary : any -> identifier -(define (generate-temporary [stx 'g]) - (car (generate-temporaries (list stx)))) - -;; generate-n-temporaries : exact-nonnegative-integer -> (listof identifier) -(define (generate-n-temporaries n) - (generate-temporaries - (for/list ([i (in-range n)]) - (string->symbol (format "g~sx" i))))) - -;; Symbol Formatting - -(define (format-symbol fmt . args) - (let ([args (for/list ([arg args]) (if (syntax? arg) (syntax->datum arg) arg))]) - (string->symbol (apply format fmt args)))) - -;; Parsing keyword arguments - -;; chunk-kw-seq/no-dups : syntax -;; alist[keyword => (listof (stx -> any))] -;; -> (values (listof (cons kw (cons stx(kw) (listof any)))) stx) -(define (chunk-kw-seq/no-dups stx kws #:context [ctx #f]) - (let-values ([(chunks rest) (chunk-kw-seq stx kws #:context ctx)]) - (reject-duplicate-chunks chunks) - (values chunks rest))) - -;; chunk-kw-seq : stx -;; alist[keyword => (listof (stx -> any)) -;; -> (values (listof (cons kw (cons stx(kw) (listof any)))) stx) -(define (chunk-kw-seq stx kws #:context [ctx #f]) - (define (loop stx rchunks) - (syntax-case stx () - [(kw . more) - (and (keyword? (syntax-e #'kw)) (assq (syntax-e #'kw) kws)) - (let* ([kw-value (syntax-e #'kw)] - [arity (cdr (assq kw-value kws))] - [args+rest (stx-split #'more arity)]) - (if args+rest - (loop (cdr args+rest) - (cons (list* kw-value #'kw (car args+rest)) rchunks)) - (raise-syntax-error #f "too few arguments for keyword" #'kw ctx)))] - [(kw . more) - (keyword? (syntax-e #'kw)) - (raise-syntax-error #f "unexpected keyword" ctx #'kw)] - [_ - (values (reverse rchunks) stx)])) - (loop stx null)) - -;; reject-duplicate-chunks : (listof (cons kw (cons stx(kw) (listof any)))) -> void -(define (reject-duplicate-chunks chunks #:context [ctx #f]) - (define kws (make-hasheq)) - (define (loop chunks) - (when (pair? chunks) - (let ([kw (caar chunks)]) - (when (hash-ref kws kw #f) - (raise-syntax-error #f "duplicate keyword argument" (cadar chunks) ctx)) - (hash-set! kws kw #t)) - (loop (cdr chunks)))) - (loop chunks)) - -;; stx-split : stx nat -> (cons (listof stx) stx) -(define (stx-split stx procs) - (define (loop stx procs acc) - (cond [(null? procs) - (cons (reverse acc) stx)] - [(stx-pair? stx) - (loop (stx-cdr stx) (cdr procs) (cons ((car procs) (stx-car stx)) acc))] - [else #f])) - (loop stx procs null)) - -;; check-id : stx -> identifier -(define (check-id stx) - (unless (identifier? stx) - (raise-syntax-error 'pattern "expected identifier" stx)) - stx) - -;; check-string : stx -> stx -(define (check-string stx) - (unless (string? (syntax-e stx)) - (raise-syntax-error #f "expected string" stx)) - stx) - -;; nat/f : any -> boolean -(define (nat/f x) - (or (not x) (exact-nonnegative-integer? x))) - -;; check-nat/f : stx -> stx -(define (check-nat/f stx) - (let ([d (syntax-e stx)]) - (unless (nat/f d) - (raise-syntax-error #f "expected exact nonnegative integer or #f" stx)) - stx)) - -;; check-idlist : stx -> (listof identifier) -(define (check-idlist stx) - (unless (and (stx-list? stx) (andmap identifier? (stx->list stx))) - (raise-syntax-error #f "expected list of identifiers" stx)) - (stx->list stx)) diff --git a/collects/stxclass/util/struct.ss b/collects/stxclass/util/struct.ss deleted file mode 100644 index e28d31b7ae..0000000000 --- a/collects/stxclass/util/struct.ss +++ /dev/null @@ -1,39 +0,0 @@ -#lang scheme/base -(require (for-syntax scheme/base - scheme/struct-info)) - -(provide make) - -;; (make struct-name field-expr ...) -;; Checks that correct number of fields given. -(define-syntax (make stx) - (define (bad-struct-name x) - (raise-syntax-error #f "expected struct name" stx x)) - (define (get-struct-info id) - (unless (identifier? id) - (bad-struct-name id)) - (let ([value (syntax-local-value id (lambda () #f))]) - (unless (struct-info? value) - (bad-struct-name id)) - (extract-struct-info value))) - (syntax-case stx () - [(make S expr ...) - (let () - (define info (get-struct-info #'S)) - (define constructor (list-ref info 1)) - (define accessors (list-ref info 3)) - (unless (identifier? #'constructor) - (raise-syntax-error #f "constructor not available for struct" stx #'S)) - (unless (andmap identifier? accessors) - (raise-syntax-error #f "incomplete info for struct type" stx #'S)) - (let ([num-slots (length accessors)] - [num-provided (length (syntax->list #'(expr ...)))]) - (unless (= num-provided num-slots) - (raise-syntax-error - #f - (format "wrong number of arguments for struct ~s (expected ~s)" - (syntax-e #'S) - num-slots) - stx))) - (with-syntax ([constructor constructor]) - #'(constructor expr ...)))])) diff --git a/collects/syntax/private/util/struct.ss b/collects/syntax/private/util/struct.ss index e28d31b7ae..5073815048 100644 --- a/collects/syntax/private/util/struct.ss +++ b/collects/syntax/private/util/struct.ss @@ -36,4 +36,6 @@ num-slots) stx))) (with-syntax ([constructor constructor]) - #'(constructor expr ...)))])) + (syntax-property #'(constructor expr ...) + 'disappeared-use + #'S)))])) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index f74187297a..91f503faf4 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -5,7 +5,7 @@ (rename-in (types convenience union utils) [make-arr* make-arr]) (utils tc-utils stxclass-util) syntax/stx (prefix-in c: scheme/contract) - syntax/parse stxclass/util + syntax/parse (env type-environments type-name-env type-alias-env lexical-env) (prefix-in t: (combine-in "base-types-extra.ss" "base-types.ss")) (only-in "colon.ss" :) scheme/match diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index 7af74c0f23..ce6d0c34b5 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -27,7 +27,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (require (except-in "../utils/utils.ss" extend)) (require (for-syntax syntax/parse - stxclass/util + syntax/private/util scheme/base (rep type-rep) mzlib/match diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index c56bf5b0a5..dae537c7ba 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -10,7 +10,7 @@ scheme/contract (for-syntax scheme/list - stxclass/util + (only-in syntax/private/util/misc generate-temporary) scheme/match (except-in syntax/parse id identifier keyword) scheme/base diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index 1365b5cd18..d0685d2c95 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -5,7 +5,6 @@ "rep-utils.ss" "object-rep.ss" "filter-rep.ss" "free-variance.ss" mzlib/trace scheme/match scheme/contract - stxclass/util (for-syntax scheme/base)) (define name-table (make-weak-hasheq)) diff --git a/collects/typed-scheme/typecheck/tc-envops.ss b/collects/typed-scheme/typecheck/tc-envops.ss index 380010a754..010f5f85b1 100644 --- a/collects/typed-scheme/typecheck/tc-envops.ss +++ b/collects/typed-scheme/typecheck/tc-envops.ss @@ -11,7 +11,7 @@ (types resolve) (only-in (env type-environments lexical-env) env? update-type/lexical env-map) scheme/contract scheme/match - stxclass/util mzlib/trace + mzlib/trace (for-syntax scheme/base)) (provide env+) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index c3f8d228f3..cba789f5dc 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -5,7 +5,7 @@ "tc-metafunctions.ss" mzlib/trace scheme/list - stxclass/util syntax/stx + syntax/private/util syntax/stx (rename-in scheme/contract [-> -->] [->* -->*] [one-of/c -one-of/c]) (except-in (rep type-rep) make-arr) (rename-in (types convenience utils union) diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index 5e2b7919ac..a7b46e5024 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -7,7 +7,6 @@ [one-of/c -one-of/c]) (rep type-rep) scheme/contract scheme/match - stxclass/util (for-syntax scheme/base)) (provide combine-filter apply-filter abstract-filter abstract-filters diff --git a/collects/typed-scheme/utils/stxclass-util.ss b/collects/typed-scheme/utils/stxclass-util.ss index 430efe362e..94a75f5f57 100644 --- a/collects/typed-scheme/utils/stxclass-util.ss +++ b/collects/typed-scheme/utils/stxclass-util.ss @@ -1,6 +1,9 @@ #lang scheme/base -(require (except-in syntax/parse id keyword) (for-syntax syntax/parse scheme/base stxclass/util)) +(require (except-in syntax/parse id keyword) + (for-syntax syntax/parse + scheme/base + (only-in syntax/private/util/misc generate-temporary))) (provide (except-out (all-defined-out) id keyword) (rename-out [id id*] [keyword keyword*]))