From c439b4b7f4bf58317da0c58b92675d167b0ef946 Mon Sep 17 00:00:00 2001 From: Suzanne Soy Date: Sat, 27 Feb 2021 02:06:59 +0000 Subject: [PATCH] fixed includes & paths --- 6-11/racket/collects/syntax/parse/define.rkt | 20 + .../syntax/parse/experimental/dset.rkt | 54 +++ .../collects/syntax/parse/experimental/eh.rkt | 5 + .../syntax/parse/lib/function-header.rkt | 112 ++++++ .../collects/syntax/parse/private/3d-stx.rkt | 250 ++++++++++++ .../collects/syntax/parse/private/litconv.rkt | 284 ++++++++++++++ .../collects/syntax/parse/private/make.rkt | 43 +++ .../syntax/parse/private/runtime-progress.rkt | 257 +++++++++++++ .../collects/syntax/parse/private/txlift.rkt | 45 +++ .../stxparse-info.scrbl | 0 6-12/racket/collects/syntax/parse/define.rkt | 20 + .../syntax/parse/experimental/dset.rkt | 54 +++ .../collects/syntax/parse/experimental/eh.rkt | 5 + .../syntax/parse/lib/function-header.rkt | 112 ++++++ .../collects/syntax/parse/private/3d-stx.rkt | 250 ++++++++++++ .../collects/syntax/parse/private/litconv.rkt | 284 ++++++++++++++ .../collects/syntax/parse/private/make.rkt | 43 +++ .../syntax/parse/private/runtime-progress.rkt | 257 +++++++++++++ .../collects/syntax/parse/private/txlift.rkt | 45 +++ .../stxparse-info.scrbl | 0 .../racket/collects/syntax/parse/define.rkt | 20 + .../syntax/parse/experimental/dset.rkt | 54 +++ .../collects/syntax/parse/experimental/eh.rkt | 5 + .../syntax/parse/lib/function-header.rkt | 112 ++++++ .../collects/syntax/parse/private/3d-stx.rkt | 250 ++++++++++++ .../collects/syntax/parse/private/litconv.rkt | 284 ++++++++++++++ .../collects/syntax/parse/private/make.rkt | 43 +++ .../syntax/parse/private/runtime-progress.rkt | 257 +++++++++++++ .../collects/syntax/parse/private/txlift.rkt | 45 +++ .../stxparse-info.scrbl | 0 .../racket/collects/syntax/parse/define.rkt | 20 + .../syntax/parse/experimental/dset.rkt | 54 +++ .../collects/syntax/parse/experimental/eh.rkt | 5 + .../syntax/parse/lib/function-header.rkt | 112 ++++++ .../collects/syntax/parse/private/3d-stx.rkt | 250 ++++++++++++ .../collects/syntax/parse/private/litconv.rkt | 284 ++++++++++++++ .../collects/syntax/parse/private/make.rkt | 43 +++ .../syntax/parse/private/runtime-progress.rkt | 257 +++++++++++++ .../collects/syntax/parse/private/txlift.rkt | 45 +++ 7-0-0-20/stxparse-info.scrbl | 356 ++++++++++++++++++ .../racket/collects/syntax/parse/define.rkt | 20 + .../syntax/parse/experimental/dset.rkt | 54 +++ .../collects/syntax/parse/experimental/eh.rkt | 5 + .../syntax/parse/lib/function-header.rkt | 112 ++++++ .../collects/syntax/parse/private/3d-stx.rkt | 250 ++++++++++++ .../collects/syntax/parse/private/litconv.rkt | 284 ++++++++++++++ .../collects/syntax/parse/private/make.rkt | 43 +++ .../syntax/parse/private/runtime-progress.rkt | 257 +++++++++++++ .../collects/syntax/parse/private/txlift.rkt | 45 +++ .../stxparse-info.scrbl | 0 case/stxcase-scheme.rkt | 9 +- case/stxcase.rkt | 9 +- case/stxloc.rkt | 9 +- case/syntax.rkt | 9 +- case/template.rkt | 8 +- case/with-stx.rkt | 9 +- info.rkt | 2 + my-include.rkt | 42 ++- parse.rkt | 6 +- parse/debug.rkt | 12 +- parse/define.rkt | 24 +- parse/experimental/contract.rkt | 6 +- parse/experimental/dset.rkt | 58 +-- parse/experimental/eh.rkt | 9 +- parse/experimental/private/substitute.rkt | 6 +- parse/experimental/provide.rkt | 8 +- parse/experimental/reflect.rkt | 10 +- parse/experimental/specialize.rkt | 8 +- parse/experimental/splicing.rkt | 8 +- parse/experimental/template.rkt | 8 +- parse/lib/function-header.rkt | 116 +----- parse/pre.rkt | 10 +- parse/private/3d-stx.rkt | 253 +------------ parse/private/lib.rkt | 10 +- parse/private/litconv.rkt | 288 +------------- parse/private/make.rkt | 47 +-- parse/private/opt.rkt | 6 +- parse/private/parse-aux.rkt | 6 +- parse/private/parse.rkt | 12 +- parse/private/rep.rkt | 12 +- parse/private/residual.rkt | 10 +- parse/private/runtime-progress.rkt | 261 +------------ parse/private/runtime-reflect.rkt | 8 +- parse/private/runtime-report.rkt | 8 +- parse/private/runtime.rkt | 8 +- parse/private/sc.rkt | 10 +- parse/private/txlift.rkt | 49 +-- scribblings/stxparse-info.scrbl | 11 +- 88 files changed, 5813 insertions(+), 1278 deletions(-) create mode 100644 6-11/racket/collects/syntax/parse/define.rkt create mode 100644 6-11/racket/collects/syntax/parse/experimental/dset.rkt create mode 100644 6-11/racket/collects/syntax/parse/experimental/eh.rkt create mode 100644 6-11/racket/collects/syntax/parse/lib/function-header.rkt create mode 100644 6-11/racket/collects/syntax/parse/private/3d-stx.rkt create mode 100644 6-11/racket/collects/syntax/parse/private/litconv.rkt create mode 100644 6-11/racket/collects/syntax/parse/private/make.rkt create mode 100644 6-11/racket/collects/syntax/parse/private/runtime-progress.rkt create mode 100644 6-11/racket/collects/syntax/parse/private/txlift.rkt rename scribblings/stxparse-info.scrbl-6-11 => 6-11/stxparse-info.scrbl (100%) create mode 100644 6-12/racket/collects/syntax/parse/define.rkt create mode 100644 6-12/racket/collects/syntax/parse/experimental/dset.rkt create mode 100644 6-12/racket/collects/syntax/parse/experimental/eh.rkt create mode 100644 6-12/racket/collects/syntax/parse/lib/function-header.rkt create mode 100644 6-12/racket/collects/syntax/parse/private/3d-stx.rkt create mode 100644 6-12/racket/collects/syntax/parse/private/litconv.rkt create mode 100644 6-12/racket/collects/syntax/parse/private/make.rkt create mode 100644 6-12/racket/collects/syntax/parse/private/runtime-progress.rkt create mode 100644 6-12/racket/collects/syntax/parse/private/txlift.rkt rename scribblings/stxparse-info.scrbl-6-12 => 6-12/stxparse-info.scrbl (100%) create mode 100644 6-90-0-29/racket/collects/syntax/parse/define.rkt create mode 100644 6-90-0-29/racket/collects/syntax/parse/experimental/dset.rkt create mode 100644 6-90-0-29/racket/collects/syntax/parse/experimental/eh.rkt create mode 100644 6-90-0-29/racket/collects/syntax/parse/lib/function-header.rkt create mode 100644 6-90-0-29/racket/collects/syntax/parse/private/3d-stx.rkt create mode 100644 6-90-0-29/racket/collects/syntax/parse/private/litconv.rkt create mode 100644 6-90-0-29/racket/collects/syntax/parse/private/make.rkt create mode 100644 6-90-0-29/racket/collects/syntax/parse/private/runtime-progress.rkt create mode 100644 6-90-0-29/racket/collects/syntax/parse/private/txlift.rkt rename scribblings/stxparse-info.scrbl-6-90-0-29 => 6-90-0-29/stxparse-info.scrbl (100%) create mode 100644 7-0-0-20/racket/collects/syntax/parse/define.rkt create mode 100644 7-0-0-20/racket/collects/syntax/parse/experimental/dset.rkt create mode 100644 7-0-0-20/racket/collects/syntax/parse/experimental/eh.rkt create mode 100644 7-0-0-20/racket/collects/syntax/parse/lib/function-header.rkt create mode 100644 7-0-0-20/racket/collects/syntax/parse/private/3d-stx.rkt create mode 100644 7-0-0-20/racket/collects/syntax/parse/private/litconv.rkt create mode 100644 7-0-0-20/racket/collects/syntax/parse/private/make.rkt create mode 100644 7-0-0-20/racket/collects/syntax/parse/private/runtime-progress.rkt create mode 100644 7-0-0-20/racket/collects/syntax/parse/private/txlift.rkt create mode 100644 7-0-0-20/stxparse-info.scrbl create mode 100644 7-3-0-1/racket/collects/syntax/parse/define.rkt create mode 100644 7-3-0-1/racket/collects/syntax/parse/experimental/dset.rkt create mode 100644 7-3-0-1/racket/collects/syntax/parse/experimental/eh.rkt create mode 100644 7-3-0-1/racket/collects/syntax/parse/lib/function-header.rkt create mode 100644 7-3-0-1/racket/collects/syntax/parse/private/3d-stx.rkt create mode 100644 7-3-0-1/racket/collects/syntax/parse/private/litconv.rkt create mode 100644 7-3-0-1/racket/collects/syntax/parse/private/make.rkt create mode 100644 7-3-0-1/racket/collects/syntax/parse/private/runtime-progress.rkt create mode 100644 7-3-0-1/racket/collects/syntax/parse/private/txlift.rkt rename scribblings/stxparse-info.scrbl-7-3-0-1 => 7-3-0-1/stxparse-info.scrbl (100%) diff --git a/6-11/racket/collects/syntax/parse/define.rkt b/6-11/racket/collects/syntax/parse/define.rkt new file mode 100644 index 0000000..28e5148 --- /dev/null +++ b/6-11/racket/collects/syntax/parse/define.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require (for-syntax racket/base + stxparse-info/parse + "private/sc.rkt")) +(provide define-simple-macro + define-syntax-parser + (for-syntax (all-from-out stxparse-info/parse))) + +(define-syntax (define-simple-macro stx) + (syntax-parse stx + [(define-simple-macro (~and (macro:id . _) pattern) . body) + #`(define-syntax macro + (syntax-parser/template + #,((make-syntax-introducer) stx) + [pattern . body]))])) + +(define-simple-macro (define-syntax-parser macro:id option-or-clause ...) + (define-syntax macro + (syntax-parser option-or-clause ...))) + diff --git a/6-11/racket/collects/syntax/parse/experimental/dset.rkt b/6-11/racket/collects/syntax/parse/experimental/dset.rkt new file mode 100644 index 0000000..57c53e5 --- /dev/null +++ b/6-11/racket/collects/syntax/parse/experimental/dset.rkt @@ -0,0 +1,54 @@ +#lang racket/base + +;; A dset is an `equal?`-based set, but it preserves order based on +;; the history of additions, so that if items are added in a +;; deterministic order, they come back out in a deterministic order. + +(provide dset + dset-empty? + dset->list + dset-add + dset-union + dset-subtract + dset-filter) + +(define dset + (case-lambda + [() (hash)] + [(e) (hash e 0)])) + +(define (dset-empty? ds) + (zero? (hash-count ds))) + +(define (dset->list ds) + (map cdr + (sort (for/list ([(k v) (in-hash ds)]) + (cons v k)) + < + #:key car))) + +(define (dset-add ds e) + (if (hash-ref ds e #f) + ds + (hash-set ds e (hash-count ds)))) + +(define (dset-union ds1 ds2) + (cond + [((hash-count ds1) . > . (hash-count ds2)) + (dset-union ds2 ds1)] + [else + (for/fold ([ds2 ds2]) ([e (dset->list ds1)]) + (dset-add ds2 e))])) + +(define (dset-subtract ds1 ds2) + ;; ! takes O(size(ds2)) time ! + (for/fold ([r (dset)]) ([e (in-list (dset->list ds1))]) + (if (hash-ref ds2 e #f) + r + (dset-add r e)))) + +(define (dset-filter ds pred) + (for/fold ([r (dset)]) ([e (in-list (dset->list ds))]) + (if (pred e) + (dset-add r e) + r))) diff --git a/6-11/racket/collects/syntax/parse/experimental/eh.rkt b/6-11/racket/collects/syntax/parse/experimental/eh.rkt new file mode 100644 index 0000000..f8e1b09 --- /dev/null +++ b/6-11/racket/collects/syntax/parse/experimental/eh.rkt @@ -0,0 +1,5 @@ +#lang racket/base +(require "../private/sc.rkt" + syntax/parse/private/keywords) +(provide ~eh-var + define-eh-alternative-set) diff --git a/6-11/racket/collects/syntax/parse/lib/function-header.rkt b/6-11/racket/collects/syntax/parse/lib/function-header.rkt new file mode 100644 index 0000000..79e80f3 --- /dev/null +++ b/6-11/racket/collects/syntax/parse/lib/function-header.rkt @@ -0,0 +1,112 @@ +#lang racket/base + +(require "../../parse.rkt" + "../experimental/template.rkt" + racket/dict) + +(provide function-header formal formals) + +(define-syntax-class function-header + (pattern ((~or header:function-header name:id) . args:formals) + #:attr params + (template ((?@ . (?? header.params ())) + . args.params)))) + +(define-syntax-class formals + #:attributes (params) + (pattern (arg:formal ...) + #:attr params #'(arg.name ...) + #:fail-when (check-duplicate-identifier (syntax->list #'params)) + "duplicate argument name" + #:fail-when (check-duplicate (attribute arg.kw) + #:same? (λ (x y) + (and x y (equal? (syntax-e x) + (syntax-e y))))) + "duplicate keyword for argument" + #:fail-when (invalid-option-placement + (attribute arg.name) (attribute arg.default)) + "default-value expression missing") + (pattern (arg:formal ... . rest:id) + #:attr params #'(arg.name ... rest) + #:fail-when (check-duplicate-identifier (syntax->list #'params)) + "duplicate argument name" + #:fail-when (check-duplicate (attribute arg.kw) + #:same? (λ (x y) + (and x y (equal? (syntax-e x) + (syntax-e y))))) + "duplicate keyword for argument" + #:fail-when (invalid-option-placement + (attribute arg.name) (attribute arg.default)) + "default-value expression missing")) + +(define-splicing-syntax-class formal + #:attributes (name kw default) + (pattern name:id + #:attr kw #f + #:attr default #f) + (pattern [name:id default] + #:attr kw #f) + (pattern (~seq kw:keyword name:id) + #:attr default #f) + (pattern (~seq kw:keyword [name:id default]))) + +;; invalid-option-placement : (Listof Id) (Listof Syntax/#f) -> Id/#f +;; Checks for mandatory argument after optional argument; if found, returns +;; identifier of mandatory argument. +(define (invalid-option-placement names defaults) + ;; find-mandatory : (Listof Id) (Listof Syntax/#f) -> Id/#f + ;; Finds first name w/o corresponding default. + (define (find-mandatory names defaults) + (for/first ([name (in-list names)] + [default (in-list defaults)] + #:when (not default)) + name)) + ;; Skip through mandatory args until first optional found, then search + ;; for another mandatory. + (let loop ([names names] [defaults defaults]) + (cond [(or (null? names) (null? defaults)) + #f] + [(eq? (car defaults) #f) ;; mandatory + (loop (cdr names) (cdr defaults))] + [else ;; found optional + (find-mandatory (cdr names) (cdr defaults))]))) + +;; Copied from unstable/list +;; check-duplicate : (listof X) +;; #:key (X -> K) +;; #:same? (or/c (K K -> bool) dict?) +;; -> X or #f +(define (check-duplicate items + #:key [key values] + #:same? [same? equal?]) + (cond [(procedure? same?) + (cond [(eq? same? equal?) + (check-duplicate/t items key (make-hash) #t)] + [(eq? same? eq?) + (check-duplicate/t items key (make-hasheq) #t)] + [(eq? same? eqv?) + (check-duplicate/t items key (make-hasheqv) #t)] + [else + (check-duplicate/list items key same?)])] + [(dict? same?) + (let ([dict same?]) + (if (dict-mutable? dict) + (check-duplicate/t items key dict #t) + (check-duplicate/t items key dict #f)))])) +(define (check-duplicate/t items key table mutating?) + (let loop ([items items] [table table]) + (and (pair? items) + (let ([key-item (key (car items))]) + (if (dict-ref table key-item #f) + (car items) + (loop (cdr items) (if mutating? + (begin (dict-set! table key-item #t) table) + (dict-set table key-item #t)))))))) +(define (check-duplicate/list items key same?) + (let loop ([items items] [sofar null]) + (and (pair? items) + (let ([key-item (key (car items))]) + (if (for/or ([prev (in-list sofar)]) + (same? key-item prev)) + (car items) + (loop (cdr items) (cons key-item sofar))))))) diff --git a/6-11/racket/collects/syntax/parse/private/3d-stx.rkt b/6-11/racket/collects/syntax/parse/private/3d-stx.rkt new file mode 100644 index 0000000..b5083d5 --- /dev/null +++ b/6-11/racket/collects/syntax/parse/private/3d-stx.rkt @@ -0,0 +1,250 @@ +#lang racket/base +(require (only-in '#%flfxnum flvector? fxvector?) + (only-in '#%extfl extflonum? extflvector?)) +(provide 2d-stx? + check-datum) + +;; Checks for 3D syntax (syntax that contains unwritable values, etc) + +(define INIT-FUEL #e1e6) + +;; TO DO: +;; - extension via proc (any -> list/#f), +;; value considered good if result is list, all values in list are good + +;; -- + +#| +Some other predicates one might like to have: + - would (read (write x)) succeed and be equal/similar to x? + - would (datum->syntax #f x) succeed? + - would (syntax->datum (datum->syntax #f x)) succeed and be equal/similar to x? + - would (eval (read (write (compile `(quote ,x))))) succeed and be equal/similar to x? + +where equal/similar could mean one of the following: + - equal?, which equates eg (vector 1 2 3) and (vector-immutable 1 2 3) + - equal? relaxed to equate eg mutable and immutable hashes (but not prefabs) + - equal? but also requiring same mutability at every point + +Some aux definitions: + +(define (rt x) + (define-values (in out) (make-pipe)) + (write x out) + (close-output-port out) + (read in)) + +(define (wrsd x) + (define-values (in out) (make-pipe)) + (write x out) + (close-output-port out) + (syntax->datum (read-syntax #f in))) + +(define (dsd x) + (syntax->datum (datum->syntax #f x))) + +(define (evalc x) ;; mimics compiled zo-file constraints + (eval (rt (compile `(quote ,x))))) + +How mutability behaves: + - for vectors, boxes: + - read always mutable + - read-syntax always immutable + - (dsd x) always immutable + - (evalc x) always immutable + - for hashes: + - read always immutable + - (dsd x) same as x + - (evalc x) always immutable (!!!) + - for prefab structs: + - read same as x + - read-syntax same as x + - (dsd x) same as x + - (evalc x) same as x + +Symbols + - (dsd x) same as x + - (evalc x) preserves interned, unreadable, makes new uninterned (loses eq-ness) + +Chaperones allow the lazy generation of infinite trees of data +undetectable by eq?-based cycle detection. Might be helpful to have +chaperone-eq? (not recursive, just chaperones of same object) and +chaperone-eq?-hash-code, to use with make-custom-hash.) + +Impersonators allow the lazy generation of infinite trees of data, +period. + +|# + +;; ---- + +;; 2d-stx? : any ... -> boolean +;; Would (write (compile `(quote-syntax ,x))) succeed? +;; If traverse-syntax? is #t, recurs into existing syntax +;; If traverse-syntax? is #f, assumes existing stxobjs are 2d, and only +;; checks if *new* 3d syntax would be created. +(define (2d-stx? x + #:traverse-syntax? [traverse-syntax? #t] + #:irritant [irritant-box #f]) + (check-datum x + #:syntax-mode (if traverse-syntax? 'compound 'atomic) + #:allow-impersonators? #f + #:allow-mutable? 'no-hash/prefab + #:allow-unreadable-symbols? #t + #:allow-cycles? #t + #:irritant irritant-box)) + +;; ---- + +;; check-datum : any ... -> boolean +;; where StxMode = (U 'atomic 'compound #f) +;; Returns nat if x is "good", #f if "bad" +;; If irritant-b is a box, the first bad subvalue found is put in the box. +;; If visited-t is a hash, it is used to detect cycles. +(define (check-datum x + #:syntax-mode [stx-mode #f] + #:allow-impersonators? [allow-impersonators? #f] + #:allow-mutable? [allow-mutable? #f] + #:allow-unreadable-symbols? [allow-unreadable? #f] + #:allow-cycles? [allow-cycles? #f] + #:irritant [irritant-b #f]) + ;; Try once with some fuel. If runs out of fuel, try again with cycle checking. + (define (run fuel visited-t) + (check* x fuel visited-t + stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles? + irritant-b)) + (let ([result (run INIT-FUEL #f)]) + (cond [(not (equal? result 0)) ;; nat>0 or #f + (and result #t)] + [else + ;; (eprintf "out of fuel, restarting\n") + (and (run +inf.0 (make-hasheq)) #t)]))) + +;; check* : any nat/+inf.0 StxMode boolean boolean boolean box -> nat/#f +;; Returns #f if bad, positive nat if good, 0 if ran out of fuel +;; If bad, places bad subvalue in irritant-b, if box +(define (check* x0 fuel0 visited-t + stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles? + irritant-b) + (define no-mutable? (not allow-mutable?)) + (define no-mutable-hash/prefab? (or no-mutable? (eq? allow-mutable? 'no-hash/prefab))) + (define no-cycle? (not allow-cycles?)) + (define no-impersonator? (not allow-impersonators?)) + (define (loop x fuel) + (if (and fuel (not (zero? fuel))) + (loop* x fuel) + fuel)) + (define (loop* x fuel) + (define (bad) (when irritant-b (set-box! irritant-b x)) #f) + (define-syntax-rule (with-mutable-check mutable? body ...) ;; don't use for hash or prefab + (cond [(and no-mutable? mutable?) + (bad)] + [else + body ...])) + (define-syntax-rule (with-cycle-check body ...) + (cond [(and visited-t (hash-ref visited-t x #f)) + => (lambda (status) + (cond [(and no-cycle? (eq? status 'traversing)) + (bad)] + [else + fuel]))] + [else + (when visited-t + (hash-set! visited-t x 'traversing)) + (begin0 (begin body ...) + (when visited-t + (hash-remove! visited-t x)))])) + ;; (eprintf "-- checking ~s, fuel ~s\n" x fuel) + (cond + ;; Immutable compound + [(and visited-t (list? x)) + ;; space optimization: if list (finite), no need to store all cdr pairs in cycle table + ;; don't do unless visited-t present, else expands fuel by arbitrary factors + (with-cycle-check + (for/fold ([fuel (sub1 fuel)]) ([e (in-list x)] #:break (not fuel)) + (loop e fuel)))] + [(pair? x) + (with-cycle-check + (let ([fuel (loop (car x) (sub1 fuel))]) + (loop (cdr x) fuel)))] + ;; Atomic + [(or (null? x) + (boolean? x) + (number? x) + (char? x) + (keyword? x) + (regexp? x) + (byte-regexp? x) + (extflonum? x)) + fuel] + [(symbol? x) + (cond [(symbol-interned? x) + fuel] + [(symbol-unreadable? x) + (if allow-unreadable? fuel (bad))] + [else ;; uninterned + (if (eq? allow-unreadable? #t) fuel (bad))])] + ;; Mutable flat + [(or (string? x) + (bytes? x)) + (with-mutable-check (not (immutable? x)) + fuel)] + [(or (fxvector? x) + (flvector? x) + (extflvector? x)) + (with-mutable-check (not (immutable? x)) + fuel)] + ;; Syntax + [(syntax? x) + (case stx-mode + ((atomic) fuel) + ((compound) (loop (syntax-e x) fuel)) + (else (bad)))] + ;; Impersonators and chaperones + [(and no-impersonator? (impersonator? x)) ;; else continue to chaperoned type + (bad)] + [(and no-impersonator? (chaperone? x)) ;; else continue to impersonated type + (bad)] + [else + (with-cycle-check + (cond + ;; Mutable (maybe) compound + [(vector? x) + (with-mutable-check (not (immutable? x)) + (for/fold ([fuel fuel]) ([e (in-vector x)] #:break (not fuel)) + (loop e fuel)))] + [(box? x) + (with-mutable-check (not (immutable? x)) + (loop (unbox x) (sub1 fuel)))] + [(prefab-struct-key x) + => (lambda (key) + (cond [(and no-mutable-hash/prefab? (mutable-prefab-key? key)) + (bad)] + [else + ;; traverse key, since contains arbitrary auto-value + (let ([fuel (loop key fuel)]) + (loop (struct->vector x) fuel))]))] + [(hash? x) + (cond [(and no-mutable-hash/prefab? (not (immutable? x))) + (bad)] + [else + (for/fold ([fuel fuel]) ([(k v) (in-hash x)] #:break (not fuel)) + (let ([fuel (loop k fuel)]) + (loop v fuel)))])] + ;; Bad + [else + (bad)]))])) + (loop x0 fuel0)) + +;; mutable-prefab-key? : prefab-key -> boolean +(define (mutable-prefab-key? key) + ;; A prefab-key is either + ;; - symbol + ;; - (list* symbol maybe-nat maybe-list maybe-vector prefab-key) + ;; where mutable fields indicated by vector + ;; This code is probably overly general; racket seems to normalize keys. + (let loop ([k key]) + (and (pair? k) + (or (and (vector? (car k)) + (positive? (vector-length (car k)))) + (loop (cdr k)))))) diff --git a/6-11/racket/collects/syntax/parse/private/litconv.rkt b/6-11/racket/collects/syntax/parse/private/litconv.rkt new file mode 100644 index 0000000..559791f --- /dev/null +++ b/6-11/racket/collects/syntax/parse/private/litconv.rkt @@ -0,0 +1,284 @@ +#lang racket/base +(require (for-syntax racket/base + racket/lazy-require + "sc.rkt" + "lib.rkt" + syntax/parse/private/kws + racket/syntax) + syntax/parse/private/residual-ct ;; keep abs. path + stxparse-info/parse/private/residual) ;; keep abs. path +(begin-for-syntax + (lazy-require + [syntax/private/keyword (options-select-value parse-keyword-options)] + [stxparse-info/parse/private/rep ;; keep abs. path + (parse-kw-formals + check-conventions-rules + check-datum-literals-list + create-aux-def)])) +;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require) +;; Without this, dependencies don't get collected. +(require racket/runtime-path racket/syntax (for-meta 2 '#%kernel)) +(define-runtime-module-path-index _unused_ 'stxparse-info/parse/private/rep) + +(provide define-conventions + define-literal-set + literal-set->predicate + kernel-literals) + +(define-syntax (define-conventions stx) + + (define-syntax-class header + #:description "name or name with formal parameters" + #:commit + (pattern name:id + #:with formals #'() + #:attr arity (arity 0 0 null null)) + (pattern (name:id . formals) + #:attr arity (parse-kw-formals #'formals #:context stx))) + + (syntax-parse stx + [(define-conventions h:header rule ...) + (let () + (define rules (check-conventions-rules #'(rule ...) stx)) + (define rxs (map car rules)) + (define dens0 (map cadr rules)) + (define den+defs-list + (for/list ([den0 (in-list dens0)]) + (let-values ([(den defs) (create-aux-def den0)]) + (cons den defs)))) + (define dens (map car den+defs-list)) + (define defs (apply append (map cdr den+defs-list))) + + (define/with-syntax (rx ...) rxs) + (define/with-syntax (def ...) defs) + (define/with-syntax (parser ...) + (map den:delayed-parser dens)) + (define/with-syntax (class-name ...) + (map den:delayed-class dens)) + + ;; FIXME: could move make-den:delayed to user of conventions + ;; and eliminate from residual.rkt + #'(begin + (define-syntax h.name + (make-conventions + (quote-syntax get-parsers) + (lambda () + (let ([class-names (list (quote-syntax class-name) ...)]) + (map list + (list 'rx ...) + (map make-den:delayed + (generate-temporaries class-names) + class-names)))))) + (define get-parsers + (lambda formals + def ... + (list parser ...)))))])) + +(define-for-syntax (check-phase-level stx ctx) + (unless (or (exact-integer? (syntax-e stx)) + (eq? #f (syntax-e stx))) + (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx)) + stx) + +;; check-litset-list : stx stx -> (listof (cons id literalset)) +(define-for-syntax (check-litset-list stx ctx) + (syntax-case stx () + [(litset-id ...) + (for/list ([litset-id (syntax->list #'(litset-id ...))]) + (let* ([val (and (identifier? litset-id) + (syntax-local-value/record litset-id literalset?))]) + (if val + (cons litset-id val) + (raise-syntax-error #f "expected literal set name" ctx litset-id))))] + [_ (raise-syntax-error #f "expected list of literal set names" ctx stx)])) + +;; check-literal-entry/litset : stx stx -> (list id id) +(define-for-syntax (check-literal-entry/litset stx ctx) + (syntax-case stx () + [(internal external) + (and (identifier? #'internal) (identifier? #'external)) + (list #'internal #'external)] + [id + (identifier? #'id) + (list #'id #'id)] + [_ (raise-syntax-error #f "expected literal entry" ctx stx)])) + +(define-for-syntax (check-duplicate-literals ctx imports lits datum-lits) + (let ([lit-t (make-hasheq)]) ;; sym => #t + (define (check+enter! key blame-stx) + (when (hash-ref lit-t key #f) + (raise-syntax-error #f (format "duplicate literal: ~a" key) ctx blame-stx)) + (hash-set! lit-t key #t)) + (for ([id+litset (in-list imports)]) + (let ([litset-id (car id+litset)] + [litset (cdr id+litset)]) + (for ([entry (in-list (literalset-literals litset))]) + (cond [(lse:lit? entry) + (check+enter! (lse:lit-internal entry) litset-id)] + [(lse:datum-lit? entry) + (check+enter! (lse:datum-lit-internal entry) litset-id)])))) + (for ([datum-lit (in-list datum-lits)]) + (let ([internal (den:datum-lit-internal datum-lit)]) + (check+enter! (syntax-e internal) internal))) + (for ([lit (in-list lits)]) + (check+enter! (syntax-e (car lit)) (car lit))))) + +(define-syntax (define-literal-set stx) + (syntax-case stx () + [(define-literal-set name . rest) + (let-values ([(chunks rest) + (parse-keyword-options + #'rest + `((#:literal-sets ,check-litset-list) + (#:datum-literals ,check-datum-literals-list) + (#:phase ,check-phase-level) + (#:for-template) + (#:for-syntax) + (#:for-label)) + #:incompatible '((#:phase #:for-template #:for-syntax #:for-label)) + #:context stx + #:no-duplicates? #t)]) + (unless (identifier? #'name) + (raise-syntax-error #f "expected identifier" stx #'name)) + (let ([relphase + (cond [(assq '#:for-template chunks) -1] + [(assq '#:for-syntax chunks) 1] + [(assq '#:for-label chunks) #f] + [else (options-select-value chunks '#:phase #:default 0)])] + [datum-lits + (options-select-value chunks '#:datum-literals #:default null)] + [lits (syntax-case rest () + [( (lit ...) ) + (for/list ([lit (in-list (syntax->list #'(lit ...)))]) + (check-literal-entry/litset lit stx))] + [_ (raise-syntax-error #f "bad syntax" stx)])] + [imports (options-select-value chunks '#:literal-sets #:default null)]) + (check-duplicate-literals stx imports lits datum-lits) + (with-syntax ([((internal external) ...) lits] + [(datum-internal ...) (map den:datum-lit-internal datum-lits)] + [(datum-external ...) (map den:datum-lit-external datum-lits)] + [(litset-id ...) (map car imports)] + [relphase relphase]) + #`(begin + (define phase-of-literals + (and 'relphase + (+ (variable-reference->module-base-phase (#%variable-reference)) + 'relphase))) + (define-syntax name + (make-literalset + (append (literalset-literals (syntax-local-value (quote-syntax litset-id))) + ... + (list (make-lse:lit 'internal + (quote-syntax external) + (quote-syntax phase-of-literals)) + ... + (make-lse:datum-lit 'datum-internal + 'datum-external) + ...)))) + (begin-for-syntax/once + (for ([x (in-list (syntax->list #'(external ...)))]) + (unless (identifier-binding x 'relphase) + (raise-syntax-error #f + (format "literal is unbound in phase ~a~a~a" + 'relphase + (case 'relphase + ((1) " (for-syntax)") + ((-1) " (for-template)") + ((#f) " (for-label)") + (else "")) + " relative to the enclosing module") + (quote-syntax #,stx) x))))))))])) + +#| +NOTES ON PHASES AND BINDINGS + +(module M .... + .... (define-literal-set LS #:phase PL ....) + ....) + +For the expansion of the define-literal-set form, the bindings of the literals +can be accessed by (identifier-binding lit PL), because the phase of the enclosing +module (M) is 0. + +LS may be used, however, in a context where the phase of the enclosing +module is not 0, so each instantiation of LS needs to calculate the +phase of M and add that to PL. + +-- + +Normally, literal sets that define the same name conflict. But it +would be nice to allow them to both be imported in the case where they +refer to the same binding. + +Problem: Can't do the check eagerly, because the binding of L may +change between when define-literal-set is compiled and the comparison +involving L. For example: + + (module M racket + (require stxparse-info/parse) + (define-literal-set LS (lambda)) + (require (only-in some-other-lang lambda)) + .... LS ....) + +The expansion of the LS definition sees a different lambda than the +one that the literal in LS actually refers to. + +Similarly, a literal in LS might not be defined when the expander +runs, but might get defined later. (Although I think that will already +cause an error, so don't worry about that case.) +|# + +;; FIXME: keep one copy of each identifier (?) + +(define-syntax (literal-set->predicate stx) + (syntax-case stx () + [(literal-set->predicate litset-id) + (let ([val (and (identifier? #'litset-id) + (syntax-local-value/record #'litset-id literalset?))]) + (unless val (raise-syntax-error #f "expected literal set name" stx #'litset-id)) + (let ([lits (literalset-literals val)]) + (with-syntax ([((lit phase-var) ...) + (for/list ([lit (in-list lits)] + #:when (lse:lit? lit)) + (list (lse:lit-external lit) (lse:lit-phase lit)))] + [(datum-lit ...) + (for/list ([lit (in-list lits)] + #:when (lse:datum-lit? lit)) + (lse:datum-lit-external lit))]) + #'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...) + '(datum-lit ...)))))])) + +(define (make-literal-set-predicate lits datum-lits) + (lambda (x [phase (syntax-local-phase-level)]) + (or (for/or ([lit (in-list lits)]) + (let ([lit-id (car lit)] + [lit-phase (cadr lit)]) + (free-identifier=? x lit-id phase lit-phase))) + (and (memq (syntax-e x) datum-lits) #t)))) + +;; Literal sets + +(define-literal-set kernel-literals + (begin + begin0 + define-values + define-syntaxes + define-values-for-syntax ;; kept for compat. + begin-for-syntax + set! + let-values + letrec-values + #%plain-lambda + case-lambda + if + quote + quote-syntax + letrec-syntaxes+values + with-continuation-mark + #%expression + #%plain-app + #%top + #%datum + #%variable-reference + module module* #%provide #%require #%declare + #%plain-module-begin)) diff --git a/6-11/racket/collects/syntax/parse/private/make.rkt b/6-11/racket/collects/syntax/parse/private/make.rkt new file mode 100644 index 0000000..8a4f744 --- /dev/null +++ b/6-11/racket/collects/syntax/parse/private/make.rkt @@ -0,0 +1,43 @@ +#lang racket/base +(require (for-syntax racket/base + racket/struct-info)) +(provide make) + +;; get-struct-info : identifier stx -> struct-info-list +(define-for-syntax (get-struct-info id ctx) + (define (bad-struct-name x) + (raise-syntax-error #f "expected struct name" ctx x)) + (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))) + +;; (make struct-name field-expr ...) +;; Checks that correct number of fields given. +(define-syntax (make stx) + (syntax-case stx () + [(make S expr ...) + (let () + (define info (get-struct-info #'S stx)) + (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, got ~s)" + (syntax-e #'S) + num-slots + num-provided) + stx))) + (with-syntax ([constructor constructor]) + (syntax-property #'(constructor expr ...) + 'disappeared-use + #'S)))])) diff --git a/6-11/racket/collects/syntax/parse/private/runtime-progress.rkt b/6-11/racket/collects/syntax/parse/private/runtime-progress.rkt new file mode 100644 index 0000000..f76f154 --- /dev/null +++ b/6-11/racket/collects/syntax/parse/private/runtime-progress.rkt @@ -0,0 +1,257 @@ +#lang racket/base +(require racket/list + syntax/parse/private/minimatch) +(provide ps-empty + ps-add-car + ps-add-cdr + ps-add-stx + ps-add-unbox + ps-add-unvector + ps-add-unpstruct + ps-add-opaque + ps-add-post + ps-add + (struct-out ord) + + ps-pop-opaque + ps-pop-ord + ps-pop-post + ps-context-syntax + ps-difference + + (struct-out failure) + failure* + + expect? + (struct-out expect:thing) + (struct-out expect:atom) + (struct-out expect:literal) + (struct-out expect:message) + (struct-out expect:disj) + (struct-out expect:proper-pair) + + es-add-thing + es-add-message + es-add-atom + es-add-literal + es-add-proper-pair) + +;; FIXME: add phase to expect:literal + +;; == Failure == + +#| +A Failure is (failure PS ExpectStack) + +A FailureSet is one of + - Failure + - (cons FailureSet FailureSet) + +A FailFunction = (FailureSet -> Answer) +|# +(define-struct failure (progress expectstack) #:prefab) + +;; failure* : PS ExpectStack/#f -> Failure/#t +(define (failure* ps es) (if es (failure ps es) #t)) + +;; == Progress == + +#| +Progress (PS) is a non-empty list of Progress Frames (PF). + +A Progress Frame (PF) is one of + - stx ;; "Base" frame, or ~parse/#:with term + - 'car ;; car of pair; also vector->list, unbox, struct->list, etc + - nat ;; Represents that many repeated cdrs + - 'post ;; late/post-traversal check + - #s(ord group index) ;; ~and subpattern, only comparable w/in group + - 'opaque + +The error-reporting context (ie, syntax-parse #:context arg) is always +the final frame. + +All non-stx frames (eg car, cdr) interpreted as applying to nearest following +stx frame. + +A stx frame is introduced + - always at base (that is, by syntax-parse) + - if syntax-parse has #:context arg, then two stx frames at bottom: + (list to-match-stx context-stx) + - by #:with/~parse + - by #:fail-*/#:when/~fail & stx + +Interpretation: later frames are applied first. + eg, (list 'car 1 stx) + means ( car of ( cdr once of stx ) ) + NOT apply car, then apply cdr once, then stop +|# +(define-struct ord (group index) #:prefab) + +(define (ps-empty stx ctx) + (if (eq? stx ctx) + (list stx) + (list stx ctx))) +(define (ps-add-car parent) + (cons 'car parent)) +(define (ps-add-cdr parent [times 1]) + (if (zero? times) + parent + (match (car parent) + [(? exact-positive-integer? n) + (cons (+ times n) (cdr parent))] + [_ + (cons times parent)]))) +(define (ps-add-stx parent stx) + (cons stx parent)) +(define (ps-add-unbox parent) + (ps-add-car parent)) +(define (ps-add-unvector parent) + (ps-add-car parent)) +(define (ps-add-unpstruct parent) + (ps-add-car parent)) +(define (ps-add-opaque parent) + (cons 'opaque parent)) +(define (ps-add parent frame) + (cons frame parent)) +(define (ps-add-post parent) + (cons 'post parent)) + +;; ps-context-syntax : Progress -> syntax +(define (ps-context-syntax ps) + ;; Bottom frame is always syntax + (last ps)) + +;; ps-difference : PS PS -> nat +;; Returns N s.t. B = (ps-add-cdr^N A) +(define (ps-difference a b) + (define-values (a-cdrs a-base) + (match a + [(cons (? exact-positive-integer? a-cdrs) a-base) + (values a-cdrs a-base)] + [_ (values 0 a)])) + (define-values (b-cdrs b-base) + (match b + [(cons (? exact-positive-integer? b-cdrs) b-base) + (values b-cdrs b-base)] + [_ (values 0 b)])) + (unless (eq? a-base b-base) + (error 'ps-difference "INTERNAL ERROR: ~e does not extend ~e" b a)) + (- b-cdrs a-cdrs)) + +;; ps-pop-opaque : PS -> PS +;; Used to continue with progress from opaque head pattern. +(define (ps-pop-opaque ps) + (match ps + [(cons (? exact-positive-integer? n) (cons 'opaque ps*)) + (ps-add-cdr ps* n)] + [(cons 'opaque ps*) + ps*] + [_ (error 'ps-pop-opaque "INTERNAL ERROR: opaque frame not found: ~e" ps)])) + +;; ps-pop-ord : PS -> PS +(define (ps-pop-ord ps) + (match ps + [(cons (? exact-positive-integer? n) (cons (? ord?) ps*)) + (ps-add-cdr ps* n)] + [(cons (? ord?) ps*) + ps*] + [_ (error 'ps-pop-ord "INTERNAL ERROR: ord frame not found: ~e" ps)])) + +;; ps-pop-post : PS -> PS +(define (ps-pop-post ps) + (match ps + [(cons (? exact-positive-integer? n) (cons 'post ps*)) + (ps-add-cdr ps* n)] + [(cons 'post ps*) + ps*] + [_ (error 'ps-pop-post "INTERNAL ERROR: post frame not found: ~e" ps)])) + + +;; == Expectations == + +#| +There are multiple types that use the same structures, optimized for +different purposes. + +-- During parsing, the goal is to minimize/consolidate allocations. + +An ExpectStack (during parsing) is one of + - (expect:thing Progress String Boolean String/#f ExpectStack) + * (expect:message String ExpectStack) + * (expect:atom Datum ExpectStack) + * (expect:literal Identifier ExpectStack) + * (expect:proper-pair FirstDesc ExpectStack) + * #t + +The *-marked variants can only occur at the top of the stack (ie, not +in the next field of another Expect). The top of the stack contains +the most specific information. + +An ExpectStack can also be #f, which means no failure tracking is +requested (and thus no more ExpectStacks should be allocated). + +-- During reporting, the goal is ease of manipulation. + +An ExpectList (during reporting) is (listof Expect). + +An Expect is one of + - (expect:thing #f String #t String/#f StxIdx) + * (expect:message String StxIdx) + * (expect:atom Datum StxIdx) + * (expect:literal Identifier StxIdx) + * (expect:proper-pair FirstDesc StxIdx) + * (expect:disj (NEListof Expect) StxIdx) + - '... + +A StxIdx is (cons Syntax Nat) + +That is, the next link is replaced with the syntax+index of the term +being complained about. An expect:thing's progress is replaced with #f. + +An expect:disj never contains a '... or another expect:disj. + +We write ExpectList when the most specific information comes first and +RExpectList when the most specific information comes last. +|# +(struct expect:thing (term description transparent? role next) #:prefab) +(struct expect:message (message next) #:prefab) +(struct expect:atom (atom next) #:prefab) +(struct expect:literal (literal next) #:prefab) +(struct expect:disj (expects next) #:prefab) +(struct expect:proper-pair (first-desc next) #:prefab) + +(define (expect? x) + (or (expect:thing? x) + (expect:message? x) + (expect:atom? x) + (expect:literal? x) + (expect:disj? x) + (expect:proper-pair? x))) + +(define (es-add-thing ps description transparent? role next) + (if (and next description) + (expect:thing ps description transparent? role next) + next)) + +(define (es-add-message message next) + (if (and next message) + (expect:message message next) + next)) + +(define (es-add-atom atom next) + (and next (expect:atom atom next))) + +(define (es-add-literal literal next) + (and next (expect:literal literal next))) + +(define (es-add-proper-pair first-desc next) + (and next (expect:proper-pair first-desc next))) + +#| +A FirstDesc is one of + - #f -- unknown, multiple possible, etc + - string -- description + - (list 'any) + - (list 'literal symbol) + - (list 'datum datum) +|# diff --git a/6-11/racket/collects/syntax/parse/private/txlift.rkt b/6-11/racket/collects/syntax/parse/private/txlift.rkt new file mode 100644 index 0000000..57c5497 --- /dev/null +++ b/6-11/racket/collects/syntax/parse/private/txlift.rkt @@ -0,0 +1,45 @@ +#lang racket/base +(require (for-template racket/base)) +(provide txlift + get-txlifts-as-definitions + with-txlifts + call/txlifts) + +;; Like lifting definitions, but within a single transformer. + +;; current-liftbox : Parameter of [#f or (Listof (list Id Stx))] +(define current-liftbox (make-parameter #f)) + +(define (call/txlifts proc) + (parameterize ((current-liftbox (box null))) + (proc))) + +(define (txlift expr) + (let ([liftbox (current-liftbox)]) + (check 'txlift liftbox) + (let ([var (car (generate-temporaries '(txlift)))]) + (set-box! liftbox (cons (list var expr) (unbox liftbox))) + var))) + +(define (get-txlifts) + (let ([liftbox (current-liftbox)]) + (check 'get-txlifts liftbox) + (reverse (unbox liftbox)))) + +(define (get-txlifts-as-definitions) + (let ([liftbox (current-liftbox)]) + (check 'get-txlifts-as-definitions liftbox) + (map (lambda (p) + #`(define #,@p)) + (reverse (unbox liftbox))))) + +(define (check who lb) + (unless (box? lb) + (error who "not in a txlift-catching context"))) + +(define (with-txlifts proc) + (call/txlifts + (lambda () + (let ([v (proc)]) + (with-syntax ([((var rhs) ...) (get-txlifts)]) + #`(let* ([var rhs] ...) #,v)))))) diff --git a/scribblings/stxparse-info.scrbl-6-11 b/6-11/stxparse-info.scrbl similarity index 100% rename from scribblings/stxparse-info.scrbl-6-11 rename to 6-11/stxparse-info.scrbl diff --git a/6-12/racket/collects/syntax/parse/define.rkt b/6-12/racket/collects/syntax/parse/define.rkt new file mode 100644 index 0000000..28e5148 --- /dev/null +++ b/6-12/racket/collects/syntax/parse/define.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require (for-syntax racket/base + stxparse-info/parse + "private/sc.rkt")) +(provide define-simple-macro + define-syntax-parser + (for-syntax (all-from-out stxparse-info/parse))) + +(define-syntax (define-simple-macro stx) + (syntax-parse stx + [(define-simple-macro (~and (macro:id . _) pattern) . body) + #`(define-syntax macro + (syntax-parser/template + #,((make-syntax-introducer) stx) + [pattern . body]))])) + +(define-simple-macro (define-syntax-parser macro:id option-or-clause ...) + (define-syntax macro + (syntax-parser option-or-clause ...))) + diff --git a/6-12/racket/collects/syntax/parse/experimental/dset.rkt b/6-12/racket/collects/syntax/parse/experimental/dset.rkt new file mode 100644 index 0000000..57c53e5 --- /dev/null +++ b/6-12/racket/collects/syntax/parse/experimental/dset.rkt @@ -0,0 +1,54 @@ +#lang racket/base + +;; A dset is an `equal?`-based set, but it preserves order based on +;; the history of additions, so that if items are added in a +;; deterministic order, they come back out in a deterministic order. + +(provide dset + dset-empty? + dset->list + dset-add + dset-union + dset-subtract + dset-filter) + +(define dset + (case-lambda + [() (hash)] + [(e) (hash e 0)])) + +(define (dset-empty? ds) + (zero? (hash-count ds))) + +(define (dset->list ds) + (map cdr + (sort (for/list ([(k v) (in-hash ds)]) + (cons v k)) + < + #:key car))) + +(define (dset-add ds e) + (if (hash-ref ds e #f) + ds + (hash-set ds e (hash-count ds)))) + +(define (dset-union ds1 ds2) + (cond + [((hash-count ds1) . > . (hash-count ds2)) + (dset-union ds2 ds1)] + [else + (for/fold ([ds2 ds2]) ([e (dset->list ds1)]) + (dset-add ds2 e))])) + +(define (dset-subtract ds1 ds2) + ;; ! takes O(size(ds2)) time ! + (for/fold ([r (dset)]) ([e (in-list (dset->list ds1))]) + (if (hash-ref ds2 e #f) + r + (dset-add r e)))) + +(define (dset-filter ds pred) + (for/fold ([r (dset)]) ([e (in-list (dset->list ds))]) + (if (pred e) + (dset-add r e) + r))) diff --git a/6-12/racket/collects/syntax/parse/experimental/eh.rkt b/6-12/racket/collects/syntax/parse/experimental/eh.rkt new file mode 100644 index 0000000..f8e1b09 --- /dev/null +++ b/6-12/racket/collects/syntax/parse/experimental/eh.rkt @@ -0,0 +1,5 @@ +#lang racket/base +(require "../private/sc.rkt" + syntax/parse/private/keywords) +(provide ~eh-var + define-eh-alternative-set) diff --git a/6-12/racket/collects/syntax/parse/lib/function-header.rkt b/6-12/racket/collects/syntax/parse/lib/function-header.rkt new file mode 100644 index 0000000..79e80f3 --- /dev/null +++ b/6-12/racket/collects/syntax/parse/lib/function-header.rkt @@ -0,0 +1,112 @@ +#lang racket/base + +(require "../../parse.rkt" + "../experimental/template.rkt" + racket/dict) + +(provide function-header formal formals) + +(define-syntax-class function-header + (pattern ((~or header:function-header name:id) . args:formals) + #:attr params + (template ((?@ . (?? header.params ())) + . args.params)))) + +(define-syntax-class formals + #:attributes (params) + (pattern (arg:formal ...) + #:attr params #'(arg.name ...) + #:fail-when (check-duplicate-identifier (syntax->list #'params)) + "duplicate argument name" + #:fail-when (check-duplicate (attribute arg.kw) + #:same? (λ (x y) + (and x y (equal? (syntax-e x) + (syntax-e y))))) + "duplicate keyword for argument" + #:fail-when (invalid-option-placement + (attribute arg.name) (attribute arg.default)) + "default-value expression missing") + (pattern (arg:formal ... . rest:id) + #:attr params #'(arg.name ... rest) + #:fail-when (check-duplicate-identifier (syntax->list #'params)) + "duplicate argument name" + #:fail-when (check-duplicate (attribute arg.kw) + #:same? (λ (x y) + (and x y (equal? (syntax-e x) + (syntax-e y))))) + "duplicate keyword for argument" + #:fail-when (invalid-option-placement + (attribute arg.name) (attribute arg.default)) + "default-value expression missing")) + +(define-splicing-syntax-class formal + #:attributes (name kw default) + (pattern name:id + #:attr kw #f + #:attr default #f) + (pattern [name:id default] + #:attr kw #f) + (pattern (~seq kw:keyword name:id) + #:attr default #f) + (pattern (~seq kw:keyword [name:id default]))) + +;; invalid-option-placement : (Listof Id) (Listof Syntax/#f) -> Id/#f +;; Checks for mandatory argument after optional argument; if found, returns +;; identifier of mandatory argument. +(define (invalid-option-placement names defaults) + ;; find-mandatory : (Listof Id) (Listof Syntax/#f) -> Id/#f + ;; Finds first name w/o corresponding default. + (define (find-mandatory names defaults) + (for/first ([name (in-list names)] + [default (in-list defaults)] + #:when (not default)) + name)) + ;; Skip through mandatory args until first optional found, then search + ;; for another mandatory. + (let loop ([names names] [defaults defaults]) + (cond [(or (null? names) (null? defaults)) + #f] + [(eq? (car defaults) #f) ;; mandatory + (loop (cdr names) (cdr defaults))] + [else ;; found optional + (find-mandatory (cdr names) (cdr defaults))]))) + +;; Copied from unstable/list +;; check-duplicate : (listof X) +;; #:key (X -> K) +;; #:same? (or/c (K K -> bool) dict?) +;; -> X or #f +(define (check-duplicate items + #:key [key values] + #:same? [same? equal?]) + (cond [(procedure? same?) + (cond [(eq? same? equal?) + (check-duplicate/t items key (make-hash) #t)] + [(eq? same? eq?) + (check-duplicate/t items key (make-hasheq) #t)] + [(eq? same? eqv?) + (check-duplicate/t items key (make-hasheqv) #t)] + [else + (check-duplicate/list items key same?)])] + [(dict? same?) + (let ([dict same?]) + (if (dict-mutable? dict) + (check-duplicate/t items key dict #t) + (check-duplicate/t items key dict #f)))])) +(define (check-duplicate/t items key table mutating?) + (let loop ([items items] [table table]) + (and (pair? items) + (let ([key-item (key (car items))]) + (if (dict-ref table key-item #f) + (car items) + (loop (cdr items) (if mutating? + (begin (dict-set! table key-item #t) table) + (dict-set table key-item #t)))))))) +(define (check-duplicate/list items key same?) + (let loop ([items items] [sofar null]) + (and (pair? items) + (let ([key-item (key (car items))]) + (if (for/or ([prev (in-list sofar)]) + (same? key-item prev)) + (car items) + (loop (cdr items) (cons key-item sofar))))))) diff --git a/6-12/racket/collects/syntax/parse/private/3d-stx.rkt b/6-12/racket/collects/syntax/parse/private/3d-stx.rkt new file mode 100644 index 0000000..b5083d5 --- /dev/null +++ b/6-12/racket/collects/syntax/parse/private/3d-stx.rkt @@ -0,0 +1,250 @@ +#lang racket/base +(require (only-in '#%flfxnum flvector? fxvector?) + (only-in '#%extfl extflonum? extflvector?)) +(provide 2d-stx? + check-datum) + +;; Checks for 3D syntax (syntax that contains unwritable values, etc) + +(define INIT-FUEL #e1e6) + +;; TO DO: +;; - extension via proc (any -> list/#f), +;; value considered good if result is list, all values in list are good + +;; -- + +#| +Some other predicates one might like to have: + - would (read (write x)) succeed and be equal/similar to x? + - would (datum->syntax #f x) succeed? + - would (syntax->datum (datum->syntax #f x)) succeed and be equal/similar to x? + - would (eval (read (write (compile `(quote ,x))))) succeed and be equal/similar to x? + +where equal/similar could mean one of the following: + - equal?, which equates eg (vector 1 2 3) and (vector-immutable 1 2 3) + - equal? relaxed to equate eg mutable and immutable hashes (but not prefabs) + - equal? but also requiring same mutability at every point + +Some aux definitions: + +(define (rt x) + (define-values (in out) (make-pipe)) + (write x out) + (close-output-port out) + (read in)) + +(define (wrsd x) + (define-values (in out) (make-pipe)) + (write x out) + (close-output-port out) + (syntax->datum (read-syntax #f in))) + +(define (dsd x) + (syntax->datum (datum->syntax #f x))) + +(define (evalc x) ;; mimics compiled zo-file constraints + (eval (rt (compile `(quote ,x))))) + +How mutability behaves: + - for vectors, boxes: + - read always mutable + - read-syntax always immutable + - (dsd x) always immutable + - (evalc x) always immutable + - for hashes: + - read always immutable + - (dsd x) same as x + - (evalc x) always immutable (!!!) + - for prefab structs: + - read same as x + - read-syntax same as x + - (dsd x) same as x + - (evalc x) same as x + +Symbols + - (dsd x) same as x + - (evalc x) preserves interned, unreadable, makes new uninterned (loses eq-ness) + +Chaperones allow the lazy generation of infinite trees of data +undetectable by eq?-based cycle detection. Might be helpful to have +chaperone-eq? (not recursive, just chaperones of same object) and +chaperone-eq?-hash-code, to use with make-custom-hash.) + +Impersonators allow the lazy generation of infinite trees of data, +period. + +|# + +;; ---- + +;; 2d-stx? : any ... -> boolean +;; Would (write (compile `(quote-syntax ,x))) succeed? +;; If traverse-syntax? is #t, recurs into existing syntax +;; If traverse-syntax? is #f, assumes existing stxobjs are 2d, and only +;; checks if *new* 3d syntax would be created. +(define (2d-stx? x + #:traverse-syntax? [traverse-syntax? #t] + #:irritant [irritant-box #f]) + (check-datum x + #:syntax-mode (if traverse-syntax? 'compound 'atomic) + #:allow-impersonators? #f + #:allow-mutable? 'no-hash/prefab + #:allow-unreadable-symbols? #t + #:allow-cycles? #t + #:irritant irritant-box)) + +;; ---- + +;; check-datum : any ... -> boolean +;; where StxMode = (U 'atomic 'compound #f) +;; Returns nat if x is "good", #f if "bad" +;; If irritant-b is a box, the first bad subvalue found is put in the box. +;; If visited-t is a hash, it is used to detect cycles. +(define (check-datum x + #:syntax-mode [stx-mode #f] + #:allow-impersonators? [allow-impersonators? #f] + #:allow-mutable? [allow-mutable? #f] + #:allow-unreadable-symbols? [allow-unreadable? #f] + #:allow-cycles? [allow-cycles? #f] + #:irritant [irritant-b #f]) + ;; Try once with some fuel. If runs out of fuel, try again with cycle checking. + (define (run fuel visited-t) + (check* x fuel visited-t + stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles? + irritant-b)) + (let ([result (run INIT-FUEL #f)]) + (cond [(not (equal? result 0)) ;; nat>0 or #f + (and result #t)] + [else + ;; (eprintf "out of fuel, restarting\n") + (and (run +inf.0 (make-hasheq)) #t)]))) + +;; check* : any nat/+inf.0 StxMode boolean boolean boolean box -> nat/#f +;; Returns #f if bad, positive nat if good, 0 if ran out of fuel +;; If bad, places bad subvalue in irritant-b, if box +(define (check* x0 fuel0 visited-t + stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles? + irritant-b) + (define no-mutable? (not allow-mutable?)) + (define no-mutable-hash/prefab? (or no-mutable? (eq? allow-mutable? 'no-hash/prefab))) + (define no-cycle? (not allow-cycles?)) + (define no-impersonator? (not allow-impersonators?)) + (define (loop x fuel) + (if (and fuel (not (zero? fuel))) + (loop* x fuel) + fuel)) + (define (loop* x fuel) + (define (bad) (when irritant-b (set-box! irritant-b x)) #f) + (define-syntax-rule (with-mutable-check mutable? body ...) ;; don't use for hash or prefab + (cond [(and no-mutable? mutable?) + (bad)] + [else + body ...])) + (define-syntax-rule (with-cycle-check body ...) + (cond [(and visited-t (hash-ref visited-t x #f)) + => (lambda (status) + (cond [(and no-cycle? (eq? status 'traversing)) + (bad)] + [else + fuel]))] + [else + (when visited-t + (hash-set! visited-t x 'traversing)) + (begin0 (begin body ...) + (when visited-t + (hash-remove! visited-t x)))])) + ;; (eprintf "-- checking ~s, fuel ~s\n" x fuel) + (cond + ;; Immutable compound + [(and visited-t (list? x)) + ;; space optimization: if list (finite), no need to store all cdr pairs in cycle table + ;; don't do unless visited-t present, else expands fuel by arbitrary factors + (with-cycle-check + (for/fold ([fuel (sub1 fuel)]) ([e (in-list x)] #:break (not fuel)) + (loop e fuel)))] + [(pair? x) + (with-cycle-check + (let ([fuel (loop (car x) (sub1 fuel))]) + (loop (cdr x) fuel)))] + ;; Atomic + [(or (null? x) + (boolean? x) + (number? x) + (char? x) + (keyword? x) + (regexp? x) + (byte-regexp? x) + (extflonum? x)) + fuel] + [(symbol? x) + (cond [(symbol-interned? x) + fuel] + [(symbol-unreadable? x) + (if allow-unreadable? fuel (bad))] + [else ;; uninterned + (if (eq? allow-unreadable? #t) fuel (bad))])] + ;; Mutable flat + [(or (string? x) + (bytes? x)) + (with-mutable-check (not (immutable? x)) + fuel)] + [(or (fxvector? x) + (flvector? x) + (extflvector? x)) + (with-mutable-check (not (immutable? x)) + fuel)] + ;; Syntax + [(syntax? x) + (case stx-mode + ((atomic) fuel) + ((compound) (loop (syntax-e x) fuel)) + (else (bad)))] + ;; Impersonators and chaperones + [(and no-impersonator? (impersonator? x)) ;; else continue to chaperoned type + (bad)] + [(and no-impersonator? (chaperone? x)) ;; else continue to impersonated type + (bad)] + [else + (with-cycle-check + (cond + ;; Mutable (maybe) compound + [(vector? x) + (with-mutable-check (not (immutable? x)) + (for/fold ([fuel fuel]) ([e (in-vector x)] #:break (not fuel)) + (loop e fuel)))] + [(box? x) + (with-mutable-check (not (immutable? x)) + (loop (unbox x) (sub1 fuel)))] + [(prefab-struct-key x) + => (lambda (key) + (cond [(and no-mutable-hash/prefab? (mutable-prefab-key? key)) + (bad)] + [else + ;; traverse key, since contains arbitrary auto-value + (let ([fuel (loop key fuel)]) + (loop (struct->vector x) fuel))]))] + [(hash? x) + (cond [(and no-mutable-hash/prefab? (not (immutable? x))) + (bad)] + [else + (for/fold ([fuel fuel]) ([(k v) (in-hash x)] #:break (not fuel)) + (let ([fuel (loop k fuel)]) + (loop v fuel)))])] + ;; Bad + [else + (bad)]))])) + (loop x0 fuel0)) + +;; mutable-prefab-key? : prefab-key -> boolean +(define (mutable-prefab-key? key) + ;; A prefab-key is either + ;; - symbol + ;; - (list* symbol maybe-nat maybe-list maybe-vector prefab-key) + ;; where mutable fields indicated by vector + ;; This code is probably overly general; racket seems to normalize keys. + (let loop ([k key]) + (and (pair? k) + (or (and (vector? (car k)) + (positive? (vector-length (car k)))) + (loop (cdr k)))))) diff --git a/6-12/racket/collects/syntax/parse/private/litconv.rkt b/6-12/racket/collects/syntax/parse/private/litconv.rkt new file mode 100644 index 0000000..559791f --- /dev/null +++ b/6-12/racket/collects/syntax/parse/private/litconv.rkt @@ -0,0 +1,284 @@ +#lang racket/base +(require (for-syntax racket/base + racket/lazy-require + "sc.rkt" + "lib.rkt" + syntax/parse/private/kws + racket/syntax) + syntax/parse/private/residual-ct ;; keep abs. path + stxparse-info/parse/private/residual) ;; keep abs. path +(begin-for-syntax + (lazy-require + [syntax/private/keyword (options-select-value parse-keyword-options)] + [stxparse-info/parse/private/rep ;; keep abs. path + (parse-kw-formals + check-conventions-rules + check-datum-literals-list + create-aux-def)])) +;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require) +;; Without this, dependencies don't get collected. +(require racket/runtime-path racket/syntax (for-meta 2 '#%kernel)) +(define-runtime-module-path-index _unused_ 'stxparse-info/parse/private/rep) + +(provide define-conventions + define-literal-set + literal-set->predicate + kernel-literals) + +(define-syntax (define-conventions stx) + + (define-syntax-class header + #:description "name or name with formal parameters" + #:commit + (pattern name:id + #:with formals #'() + #:attr arity (arity 0 0 null null)) + (pattern (name:id . formals) + #:attr arity (parse-kw-formals #'formals #:context stx))) + + (syntax-parse stx + [(define-conventions h:header rule ...) + (let () + (define rules (check-conventions-rules #'(rule ...) stx)) + (define rxs (map car rules)) + (define dens0 (map cadr rules)) + (define den+defs-list + (for/list ([den0 (in-list dens0)]) + (let-values ([(den defs) (create-aux-def den0)]) + (cons den defs)))) + (define dens (map car den+defs-list)) + (define defs (apply append (map cdr den+defs-list))) + + (define/with-syntax (rx ...) rxs) + (define/with-syntax (def ...) defs) + (define/with-syntax (parser ...) + (map den:delayed-parser dens)) + (define/with-syntax (class-name ...) + (map den:delayed-class dens)) + + ;; FIXME: could move make-den:delayed to user of conventions + ;; and eliminate from residual.rkt + #'(begin + (define-syntax h.name + (make-conventions + (quote-syntax get-parsers) + (lambda () + (let ([class-names (list (quote-syntax class-name) ...)]) + (map list + (list 'rx ...) + (map make-den:delayed + (generate-temporaries class-names) + class-names)))))) + (define get-parsers + (lambda formals + def ... + (list parser ...)))))])) + +(define-for-syntax (check-phase-level stx ctx) + (unless (or (exact-integer? (syntax-e stx)) + (eq? #f (syntax-e stx))) + (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx)) + stx) + +;; check-litset-list : stx stx -> (listof (cons id literalset)) +(define-for-syntax (check-litset-list stx ctx) + (syntax-case stx () + [(litset-id ...) + (for/list ([litset-id (syntax->list #'(litset-id ...))]) + (let* ([val (and (identifier? litset-id) + (syntax-local-value/record litset-id literalset?))]) + (if val + (cons litset-id val) + (raise-syntax-error #f "expected literal set name" ctx litset-id))))] + [_ (raise-syntax-error #f "expected list of literal set names" ctx stx)])) + +;; check-literal-entry/litset : stx stx -> (list id id) +(define-for-syntax (check-literal-entry/litset stx ctx) + (syntax-case stx () + [(internal external) + (and (identifier? #'internal) (identifier? #'external)) + (list #'internal #'external)] + [id + (identifier? #'id) + (list #'id #'id)] + [_ (raise-syntax-error #f "expected literal entry" ctx stx)])) + +(define-for-syntax (check-duplicate-literals ctx imports lits datum-lits) + (let ([lit-t (make-hasheq)]) ;; sym => #t + (define (check+enter! key blame-stx) + (when (hash-ref lit-t key #f) + (raise-syntax-error #f (format "duplicate literal: ~a" key) ctx blame-stx)) + (hash-set! lit-t key #t)) + (for ([id+litset (in-list imports)]) + (let ([litset-id (car id+litset)] + [litset (cdr id+litset)]) + (for ([entry (in-list (literalset-literals litset))]) + (cond [(lse:lit? entry) + (check+enter! (lse:lit-internal entry) litset-id)] + [(lse:datum-lit? entry) + (check+enter! (lse:datum-lit-internal entry) litset-id)])))) + (for ([datum-lit (in-list datum-lits)]) + (let ([internal (den:datum-lit-internal datum-lit)]) + (check+enter! (syntax-e internal) internal))) + (for ([lit (in-list lits)]) + (check+enter! (syntax-e (car lit)) (car lit))))) + +(define-syntax (define-literal-set stx) + (syntax-case stx () + [(define-literal-set name . rest) + (let-values ([(chunks rest) + (parse-keyword-options + #'rest + `((#:literal-sets ,check-litset-list) + (#:datum-literals ,check-datum-literals-list) + (#:phase ,check-phase-level) + (#:for-template) + (#:for-syntax) + (#:for-label)) + #:incompatible '((#:phase #:for-template #:for-syntax #:for-label)) + #:context stx + #:no-duplicates? #t)]) + (unless (identifier? #'name) + (raise-syntax-error #f "expected identifier" stx #'name)) + (let ([relphase + (cond [(assq '#:for-template chunks) -1] + [(assq '#:for-syntax chunks) 1] + [(assq '#:for-label chunks) #f] + [else (options-select-value chunks '#:phase #:default 0)])] + [datum-lits + (options-select-value chunks '#:datum-literals #:default null)] + [lits (syntax-case rest () + [( (lit ...) ) + (for/list ([lit (in-list (syntax->list #'(lit ...)))]) + (check-literal-entry/litset lit stx))] + [_ (raise-syntax-error #f "bad syntax" stx)])] + [imports (options-select-value chunks '#:literal-sets #:default null)]) + (check-duplicate-literals stx imports lits datum-lits) + (with-syntax ([((internal external) ...) lits] + [(datum-internal ...) (map den:datum-lit-internal datum-lits)] + [(datum-external ...) (map den:datum-lit-external datum-lits)] + [(litset-id ...) (map car imports)] + [relphase relphase]) + #`(begin + (define phase-of-literals + (and 'relphase + (+ (variable-reference->module-base-phase (#%variable-reference)) + 'relphase))) + (define-syntax name + (make-literalset + (append (literalset-literals (syntax-local-value (quote-syntax litset-id))) + ... + (list (make-lse:lit 'internal + (quote-syntax external) + (quote-syntax phase-of-literals)) + ... + (make-lse:datum-lit 'datum-internal + 'datum-external) + ...)))) + (begin-for-syntax/once + (for ([x (in-list (syntax->list #'(external ...)))]) + (unless (identifier-binding x 'relphase) + (raise-syntax-error #f + (format "literal is unbound in phase ~a~a~a" + 'relphase + (case 'relphase + ((1) " (for-syntax)") + ((-1) " (for-template)") + ((#f) " (for-label)") + (else "")) + " relative to the enclosing module") + (quote-syntax #,stx) x))))))))])) + +#| +NOTES ON PHASES AND BINDINGS + +(module M .... + .... (define-literal-set LS #:phase PL ....) + ....) + +For the expansion of the define-literal-set form, the bindings of the literals +can be accessed by (identifier-binding lit PL), because the phase of the enclosing +module (M) is 0. + +LS may be used, however, in a context where the phase of the enclosing +module is not 0, so each instantiation of LS needs to calculate the +phase of M and add that to PL. + +-- + +Normally, literal sets that define the same name conflict. But it +would be nice to allow them to both be imported in the case where they +refer to the same binding. + +Problem: Can't do the check eagerly, because the binding of L may +change between when define-literal-set is compiled and the comparison +involving L. For example: + + (module M racket + (require stxparse-info/parse) + (define-literal-set LS (lambda)) + (require (only-in some-other-lang lambda)) + .... LS ....) + +The expansion of the LS definition sees a different lambda than the +one that the literal in LS actually refers to. + +Similarly, a literal in LS might not be defined when the expander +runs, but might get defined later. (Although I think that will already +cause an error, so don't worry about that case.) +|# + +;; FIXME: keep one copy of each identifier (?) + +(define-syntax (literal-set->predicate stx) + (syntax-case stx () + [(literal-set->predicate litset-id) + (let ([val (and (identifier? #'litset-id) + (syntax-local-value/record #'litset-id literalset?))]) + (unless val (raise-syntax-error #f "expected literal set name" stx #'litset-id)) + (let ([lits (literalset-literals val)]) + (with-syntax ([((lit phase-var) ...) + (for/list ([lit (in-list lits)] + #:when (lse:lit? lit)) + (list (lse:lit-external lit) (lse:lit-phase lit)))] + [(datum-lit ...) + (for/list ([lit (in-list lits)] + #:when (lse:datum-lit? lit)) + (lse:datum-lit-external lit))]) + #'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...) + '(datum-lit ...)))))])) + +(define (make-literal-set-predicate lits datum-lits) + (lambda (x [phase (syntax-local-phase-level)]) + (or (for/or ([lit (in-list lits)]) + (let ([lit-id (car lit)] + [lit-phase (cadr lit)]) + (free-identifier=? x lit-id phase lit-phase))) + (and (memq (syntax-e x) datum-lits) #t)))) + +;; Literal sets + +(define-literal-set kernel-literals + (begin + begin0 + define-values + define-syntaxes + define-values-for-syntax ;; kept for compat. + begin-for-syntax + set! + let-values + letrec-values + #%plain-lambda + case-lambda + if + quote + quote-syntax + letrec-syntaxes+values + with-continuation-mark + #%expression + #%plain-app + #%top + #%datum + #%variable-reference + module module* #%provide #%require #%declare + #%plain-module-begin)) diff --git a/6-12/racket/collects/syntax/parse/private/make.rkt b/6-12/racket/collects/syntax/parse/private/make.rkt new file mode 100644 index 0000000..8a4f744 --- /dev/null +++ b/6-12/racket/collects/syntax/parse/private/make.rkt @@ -0,0 +1,43 @@ +#lang racket/base +(require (for-syntax racket/base + racket/struct-info)) +(provide make) + +;; get-struct-info : identifier stx -> struct-info-list +(define-for-syntax (get-struct-info id ctx) + (define (bad-struct-name x) + (raise-syntax-error #f "expected struct name" ctx x)) + (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))) + +;; (make struct-name field-expr ...) +;; Checks that correct number of fields given. +(define-syntax (make stx) + (syntax-case stx () + [(make S expr ...) + (let () + (define info (get-struct-info #'S stx)) + (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, got ~s)" + (syntax-e #'S) + num-slots + num-provided) + stx))) + (with-syntax ([constructor constructor]) + (syntax-property #'(constructor expr ...) + 'disappeared-use + #'S)))])) diff --git a/6-12/racket/collects/syntax/parse/private/runtime-progress.rkt b/6-12/racket/collects/syntax/parse/private/runtime-progress.rkt new file mode 100644 index 0000000..f76f154 --- /dev/null +++ b/6-12/racket/collects/syntax/parse/private/runtime-progress.rkt @@ -0,0 +1,257 @@ +#lang racket/base +(require racket/list + syntax/parse/private/minimatch) +(provide ps-empty + ps-add-car + ps-add-cdr + ps-add-stx + ps-add-unbox + ps-add-unvector + ps-add-unpstruct + ps-add-opaque + ps-add-post + ps-add + (struct-out ord) + + ps-pop-opaque + ps-pop-ord + ps-pop-post + ps-context-syntax + ps-difference + + (struct-out failure) + failure* + + expect? + (struct-out expect:thing) + (struct-out expect:atom) + (struct-out expect:literal) + (struct-out expect:message) + (struct-out expect:disj) + (struct-out expect:proper-pair) + + es-add-thing + es-add-message + es-add-atom + es-add-literal + es-add-proper-pair) + +;; FIXME: add phase to expect:literal + +;; == Failure == + +#| +A Failure is (failure PS ExpectStack) + +A FailureSet is one of + - Failure + - (cons FailureSet FailureSet) + +A FailFunction = (FailureSet -> Answer) +|# +(define-struct failure (progress expectstack) #:prefab) + +;; failure* : PS ExpectStack/#f -> Failure/#t +(define (failure* ps es) (if es (failure ps es) #t)) + +;; == Progress == + +#| +Progress (PS) is a non-empty list of Progress Frames (PF). + +A Progress Frame (PF) is one of + - stx ;; "Base" frame, or ~parse/#:with term + - 'car ;; car of pair; also vector->list, unbox, struct->list, etc + - nat ;; Represents that many repeated cdrs + - 'post ;; late/post-traversal check + - #s(ord group index) ;; ~and subpattern, only comparable w/in group + - 'opaque + +The error-reporting context (ie, syntax-parse #:context arg) is always +the final frame. + +All non-stx frames (eg car, cdr) interpreted as applying to nearest following +stx frame. + +A stx frame is introduced + - always at base (that is, by syntax-parse) + - if syntax-parse has #:context arg, then two stx frames at bottom: + (list to-match-stx context-stx) + - by #:with/~parse + - by #:fail-*/#:when/~fail & stx + +Interpretation: later frames are applied first. + eg, (list 'car 1 stx) + means ( car of ( cdr once of stx ) ) + NOT apply car, then apply cdr once, then stop +|# +(define-struct ord (group index) #:prefab) + +(define (ps-empty stx ctx) + (if (eq? stx ctx) + (list stx) + (list stx ctx))) +(define (ps-add-car parent) + (cons 'car parent)) +(define (ps-add-cdr parent [times 1]) + (if (zero? times) + parent + (match (car parent) + [(? exact-positive-integer? n) + (cons (+ times n) (cdr parent))] + [_ + (cons times parent)]))) +(define (ps-add-stx parent stx) + (cons stx parent)) +(define (ps-add-unbox parent) + (ps-add-car parent)) +(define (ps-add-unvector parent) + (ps-add-car parent)) +(define (ps-add-unpstruct parent) + (ps-add-car parent)) +(define (ps-add-opaque parent) + (cons 'opaque parent)) +(define (ps-add parent frame) + (cons frame parent)) +(define (ps-add-post parent) + (cons 'post parent)) + +;; ps-context-syntax : Progress -> syntax +(define (ps-context-syntax ps) + ;; Bottom frame is always syntax + (last ps)) + +;; ps-difference : PS PS -> nat +;; Returns N s.t. B = (ps-add-cdr^N A) +(define (ps-difference a b) + (define-values (a-cdrs a-base) + (match a + [(cons (? exact-positive-integer? a-cdrs) a-base) + (values a-cdrs a-base)] + [_ (values 0 a)])) + (define-values (b-cdrs b-base) + (match b + [(cons (? exact-positive-integer? b-cdrs) b-base) + (values b-cdrs b-base)] + [_ (values 0 b)])) + (unless (eq? a-base b-base) + (error 'ps-difference "INTERNAL ERROR: ~e does not extend ~e" b a)) + (- b-cdrs a-cdrs)) + +;; ps-pop-opaque : PS -> PS +;; Used to continue with progress from opaque head pattern. +(define (ps-pop-opaque ps) + (match ps + [(cons (? exact-positive-integer? n) (cons 'opaque ps*)) + (ps-add-cdr ps* n)] + [(cons 'opaque ps*) + ps*] + [_ (error 'ps-pop-opaque "INTERNAL ERROR: opaque frame not found: ~e" ps)])) + +;; ps-pop-ord : PS -> PS +(define (ps-pop-ord ps) + (match ps + [(cons (? exact-positive-integer? n) (cons (? ord?) ps*)) + (ps-add-cdr ps* n)] + [(cons (? ord?) ps*) + ps*] + [_ (error 'ps-pop-ord "INTERNAL ERROR: ord frame not found: ~e" ps)])) + +;; ps-pop-post : PS -> PS +(define (ps-pop-post ps) + (match ps + [(cons (? exact-positive-integer? n) (cons 'post ps*)) + (ps-add-cdr ps* n)] + [(cons 'post ps*) + ps*] + [_ (error 'ps-pop-post "INTERNAL ERROR: post frame not found: ~e" ps)])) + + +;; == Expectations == + +#| +There are multiple types that use the same structures, optimized for +different purposes. + +-- During parsing, the goal is to minimize/consolidate allocations. + +An ExpectStack (during parsing) is one of + - (expect:thing Progress String Boolean String/#f ExpectStack) + * (expect:message String ExpectStack) + * (expect:atom Datum ExpectStack) + * (expect:literal Identifier ExpectStack) + * (expect:proper-pair FirstDesc ExpectStack) + * #t + +The *-marked variants can only occur at the top of the stack (ie, not +in the next field of another Expect). The top of the stack contains +the most specific information. + +An ExpectStack can also be #f, which means no failure tracking is +requested (and thus no more ExpectStacks should be allocated). + +-- During reporting, the goal is ease of manipulation. + +An ExpectList (during reporting) is (listof Expect). + +An Expect is one of + - (expect:thing #f String #t String/#f StxIdx) + * (expect:message String StxIdx) + * (expect:atom Datum StxIdx) + * (expect:literal Identifier StxIdx) + * (expect:proper-pair FirstDesc StxIdx) + * (expect:disj (NEListof Expect) StxIdx) + - '... + +A StxIdx is (cons Syntax Nat) + +That is, the next link is replaced with the syntax+index of the term +being complained about. An expect:thing's progress is replaced with #f. + +An expect:disj never contains a '... or another expect:disj. + +We write ExpectList when the most specific information comes first and +RExpectList when the most specific information comes last. +|# +(struct expect:thing (term description transparent? role next) #:prefab) +(struct expect:message (message next) #:prefab) +(struct expect:atom (atom next) #:prefab) +(struct expect:literal (literal next) #:prefab) +(struct expect:disj (expects next) #:prefab) +(struct expect:proper-pair (first-desc next) #:prefab) + +(define (expect? x) + (or (expect:thing? x) + (expect:message? x) + (expect:atom? x) + (expect:literal? x) + (expect:disj? x) + (expect:proper-pair? x))) + +(define (es-add-thing ps description transparent? role next) + (if (and next description) + (expect:thing ps description transparent? role next) + next)) + +(define (es-add-message message next) + (if (and next message) + (expect:message message next) + next)) + +(define (es-add-atom atom next) + (and next (expect:atom atom next))) + +(define (es-add-literal literal next) + (and next (expect:literal literal next))) + +(define (es-add-proper-pair first-desc next) + (and next (expect:proper-pair first-desc next))) + +#| +A FirstDesc is one of + - #f -- unknown, multiple possible, etc + - string -- description + - (list 'any) + - (list 'literal symbol) + - (list 'datum datum) +|# diff --git a/6-12/racket/collects/syntax/parse/private/txlift.rkt b/6-12/racket/collects/syntax/parse/private/txlift.rkt new file mode 100644 index 0000000..57c5497 --- /dev/null +++ b/6-12/racket/collects/syntax/parse/private/txlift.rkt @@ -0,0 +1,45 @@ +#lang racket/base +(require (for-template racket/base)) +(provide txlift + get-txlifts-as-definitions + with-txlifts + call/txlifts) + +;; Like lifting definitions, but within a single transformer. + +;; current-liftbox : Parameter of [#f or (Listof (list Id Stx))] +(define current-liftbox (make-parameter #f)) + +(define (call/txlifts proc) + (parameterize ((current-liftbox (box null))) + (proc))) + +(define (txlift expr) + (let ([liftbox (current-liftbox)]) + (check 'txlift liftbox) + (let ([var (car (generate-temporaries '(txlift)))]) + (set-box! liftbox (cons (list var expr) (unbox liftbox))) + var))) + +(define (get-txlifts) + (let ([liftbox (current-liftbox)]) + (check 'get-txlifts liftbox) + (reverse (unbox liftbox)))) + +(define (get-txlifts-as-definitions) + (let ([liftbox (current-liftbox)]) + (check 'get-txlifts-as-definitions liftbox) + (map (lambda (p) + #`(define #,@p)) + (reverse (unbox liftbox))))) + +(define (check who lb) + (unless (box? lb) + (error who "not in a txlift-catching context"))) + +(define (with-txlifts proc) + (call/txlifts + (lambda () + (let ([v (proc)]) + (with-syntax ([((var rhs) ...) (get-txlifts)]) + #`(let* ([var rhs] ...) #,v)))))) diff --git a/scribblings/stxparse-info.scrbl-6-12 b/6-12/stxparse-info.scrbl similarity index 100% rename from scribblings/stxparse-info.scrbl-6-12 rename to 6-12/stxparse-info.scrbl diff --git a/6-90-0-29/racket/collects/syntax/parse/define.rkt b/6-90-0-29/racket/collects/syntax/parse/define.rkt new file mode 100644 index 0000000..28e5148 --- /dev/null +++ b/6-90-0-29/racket/collects/syntax/parse/define.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require (for-syntax racket/base + stxparse-info/parse + "private/sc.rkt")) +(provide define-simple-macro + define-syntax-parser + (for-syntax (all-from-out stxparse-info/parse))) + +(define-syntax (define-simple-macro stx) + (syntax-parse stx + [(define-simple-macro (~and (macro:id . _) pattern) . body) + #`(define-syntax macro + (syntax-parser/template + #,((make-syntax-introducer) stx) + [pattern . body]))])) + +(define-simple-macro (define-syntax-parser macro:id option-or-clause ...) + (define-syntax macro + (syntax-parser option-or-clause ...))) + diff --git a/6-90-0-29/racket/collects/syntax/parse/experimental/dset.rkt b/6-90-0-29/racket/collects/syntax/parse/experimental/dset.rkt new file mode 100644 index 0000000..57c53e5 --- /dev/null +++ b/6-90-0-29/racket/collects/syntax/parse/experimental/dset.rkt @@ -0,0 +1,54 @@ +#lang racket/base + +;; A dset is an `equal?`-based set, but it preserves order based on +;; the history of additions, so that if items are added in a +;; deterministic order, they come back out in a deterministic order. + +(provide dset + dset-empty? + dset->list + dset-add + dset-union + dset-subtract + dset-filter) + +(define dset + (case-lambda + [() (hash)] + [(e) (hash e 0)])) + +(define (dset-empty? ds) + (zero? (hash-count ds))) + +(define (dset->list ds) + (map cdr + (sort (for/list ([(k v) (in-hash ds)]) + (cons v k)) + < + #:key car))) + +(define (dset-add ds e) + (if (hash-ref ds e #f) + ds + (hash-set ds e (hash-count ds)))) + +(define (dset-union ds1 ds2) + (cond + [((hash-count ds1) . > . (hash-count ds2)) + (dset-union ds2 ds1)] + [else + (for/fold ([ds2 ds2]) ([e (dset->list ds1)]) + (dset-add ds2 e))])) + +(define (dset-subtract ds1 ds2) + ;; ! takes O(size(ds2)) time ! + (for/fold ([r (dset)]) ([e (in-list (dset->list ds1))]) + (if (hash-ref ds2 e #f) + r + (dset-add r e)))) + +(define (dset-filter ds pred) + (for/fold ([r (dset)]) ([e (in-list (dset->list ds))]) + (if (pred e) + (dset-add r e) + r))) diff --git a/6-90-0-29/racket/collects/syntax/parse/experimental/eh.rkt b/6-90-0-29/racket/collects/syntax/parse/experimental/eh.rkt new file mode 100644 index 0000000..f8e1b09 --- /dev/null +++ b/6-90-0-29/racket/collects/syntax/parse/experimental/eh.rkt @@ -0,0 +1,5 @@ +#lang racket/base +(require "../private/sc.rkt" + syntax/parse/private/keywords) +(provide ~eh-var + define-eh-alternative-set) diff --git a/6-90-0-29/racket/collects/syntax/parse/lib/function-header.rkt b/6-90-0-29/racket/collects/syntax/parse/lib/function-header.rkt new file mode 100644 index 0000000..79e80f3 --- /dev/null +++ b/6-90-0-29/racket/collects/syntax/parse/lib/function-header.rkt @@ -0,0 +1,112 @@ +#lang racket/base + +(require "../../parse.rkt" + "../experimental/template.rkt" + racket/dict) + +(provide function-header formal formals) + +(define-syntax-class function-header + (pattern ((~or header:function-header name:id) . args:formals) + #:attr params + (template ((?@ . (?? header.params ())) + . args.params)))) + +(define-syntax-class formals + #:attributes (params) + (pattern (arg:formal ...) + #:attr params #'(arg.name ...) + #:fail-when (check-duplicate-identifier (syntax->list #'params)) + "duplicate argument name" + #:fail-when (check-duplicate (attribute arg.kw) + #:same? (λ (x y) + (and x y (equal? (syntax-e x) + (syntax-e y))))) + "duplicate keyword for argument" + #:fail-when (invalid-option-placement + (attribute arg.name) (attribute arg.default)) + "default-value expression missing") + (pattern (arg:formal ... . rest:id) + #:attr params #'(arg.name ... rest) + #:fail-when (check-duplicate-identifier (syntax->list #'params)) + "duplicate argument name" + #:fail-when (check-duplicate (attribute arg.kw) + #:same? (λ (x y) + (and x y (equal? (syntax-e x) + (syntax-e y))))) + "duplicate keyword for argument" + #:fail-when (invalid-option-placement + (attribute arg.name) (attribute arg.default)) + "default-value expression missing")) + +(define-splicing-syntax-class formal + #:attributes (name kw default) + (pattern name:id + #:attr kw #f + #:attr default #f) + (pattern [name:id default] + #:attr kw #f) + (pattern (~seq kw:keyword name:id) + #:attr default #f) + (pattern (~seq kw:keyword [name:id default]))) + +;; invalid-option-placement : (Listof Id) (Listof Syntax/#f) -> Id/#f +;; Checks for mandatory argument after optional argument; if found, returns +;; identifier of mandatory argument. +(define (invalid-option-placement names defaults) + ;; find-mandatory : (Listof Id) (Listof Syntax/#f) -> Id/#f + ;; Finds first name w/o corresponding default. + (define (find-mandatory names defaults) + (for/first ([name (in-list names)] + [default (in-list defaults)] + #:when (not default)) + name)) + ;; Skip through mandatory args until first optional found, then search + ;; for another mandatory. + (let loop ([names names] [defaults defaults]) + (cond [(or (null? names) (null? defaults)) + #f] + [(eq? (car defaults) #f) ;; mandatory + (loop (cdr names) (cdr defaults))] + [else ;; found optional + (find-mandatory (cdr names) (cdr defaults))]))) + +;; Copied from unstable/list +;; check-duplicate : (listof X) +;; #:key (X -> K) +;; #:same? (or/c (K K -> bool) dict?) +;; -> X or #f +(define (check-duplicate items + #:key [key values] + #:same? [same? equal?]) + (cond [(procedure? same?) + (cond [(eq? same? equal?) + (check-duplicate/t items key (make-hash) #t)] + [(eq? same? eq?) + (check-duplicate/t items key (make-hasheq) #t)] + [(eq? same? eqv?) + (check-duplicate/t items key (make-hasheqv) #t)] + [else + (check-duplicate/list items key same?)])] + [(dict? same?) + (let ([dict same?]) + (if (dict-mutable? dict) + (check-duplicate/t items key dict #t) + (check-duplicate/t items key dict #f)))])) +(define (check-duplicate/t items key table mutating?) + (let loop ([items items] [table table]) + (and (pair? items) + (let ([key-item (key (car items))]) + (if (dict-ref table key-item #f) + (car items) + (loop (cdr items) (if mutating? + (begin (dict-set! table key-item #t) table) + (dict-set table key-item #t)))))))) +(define (check-duplicate/list items key same?) + (let loop ([items items] [sofar null]) + (and (pair? items) + (let ([key-item (key (car items))]) + (if (for/or ([prev (in-list sofar)]) + (same? key-item prev)) + (car items) + (loop (cdr items) (cons key-item sofar))))))) diff --git a/6-90-0-29/racket/collects/syntax/parse/private/3d-stx.rkt b/6-90-0-29/racket/collects/syntax/parse/private/3d-stx.rkt new file mode 100644 index 0000000..b5083d5 --- /dev/null +++ b/6-90-0-29/racket/collects/syntax/parse/private/3d-stx.rkt @@ -0,0 +1,250 @@ +#lang racket/base +(require (only-in '#%flfxnum flvector? fxvector?) + (only-in '#%extfl extflonum? extflvector?)) +(provide 2d-stx? + check-datum) + +;; Checks for 3D syntax (syntax that contains unwritable values, etc) + +(define INIT-FUEL #e1e6) + +;; TO DO: +;; - extension via proc (any -> list/#f), +;; value considered good if result is list, all values in list are good + +;; -- + +#| +Some other predicates one might like to have: + - would (read (write x)) succeed and be equal/similar to x? + - would (datum->syntax #f x) succeed? + - would (syntax->datum (datum->syntax #f x)) succeed and be equal/similar to x? + - would (eval (read (write (compile `(quote ,x))))) succeed and be equal/similar to x? + +where equal/similar could mean one of the following: + - equal?, which equates eg (vector 1 2 3) and (vector-immutable 1 2 3) + - equal? relaxed to equate eg mutable and immutable hashes (but not prefabs) + - equal? but also requiring same mutability at every point + +Some aux definitions: + +(define (rt x) + (define-values (in out) (make-pipe)) + (write x out) + (close-output-port out) + (read in)) + +(define (wrsd x) + (define-values (in out) (make-pipe)) + (write x out) + (close-output-port out) + (syntax->datum (read-syntax #f in))) + +(define (dsd x) + (syntax->datum (datum->syntax #f x))) + +(define (evalc x) ;; mimics compiled zo-file constraints + (eval (rt (compile `(quote ,x))))) + +How mutability behaves: + - for vectors, boxes: + - read always mutable + - read-syntax always immutable + - (dsd x) always immutable + - (evalc x) always immutable + - for hashes: + - read always immutable + - (dsd x) same as x + - (evalc x) always immutable (!!!) + - for prefab structs: + - read same as x + - read-syntax same as x + - (dsd x) same as x + - (evalc x) same as x + +Symbols + - (dsd x) same as x + - (evalc x) preserves interned, unreadable, makes new uninterned (loses eq-ness) + +Chaperones allow the lazy generation of infinite trees of data +undetectable by eq?-based cycle detection. Might be helpful to have +chaperone-eq? (not recursive, just chaperones of same object) and +chaperone-eq?-hash-code, to use with make-custom-hash.) + +Impersonators allow the lazy generation of infinite trees of data, +period. + +|# + +;; ---- + +;; 2d-stx? : any ... -> boolean +;; Would (write (compile `(quote-syntax ,x))) succeed? +;; If traverse-syntax? is #t, recurs into existing syntax +;; If traverse-syntax? is #f, assumes existing stxobjs are 2d, and only +;; checks if *new* 3d syntax would be created. +(define (2d-stx? x + #:traverse-syntax? [traverse-syntax? #t] + #:irritant [irritant-box #f]) + (check-datum x + #:syntax-mode (if traverse-syntax? 'compound 'atomic) + #:allow-impersonators? #f + #:allow-mutable? 'no-hash/prefab + #:allow-unreadable-symbols? #t + #:allow-cycles? #t + #:irritant irritant-box)) + +;; ---- + +;; check-datum : any ... -> boolean +;; where StxMode = (U 'atomic 'compound #f) +;; Returns nat if x is "good", #f if "bad" +;; If irritant-b is a box, the first bad subvalue found is put in the box. +;; If visited-t is a hash, it is used to detect cycles. +(define (check-datum x + #:syntax-mode [stx-mode #f] + #:allow-impersonators? [allow-impersonators? #f] + #:allow-mutable? [allow-mutable? #f] + #:allow-unreadable-symbols? [allow-unreadable? #f] + #:allow-cycles? [allow-cycles? #f] + #:irritant [irritant-b #f]) + ;; Try once with some fuel. If runs out of fuel, try again with cycle checking. + (define (run fuel visited-t) + (check* x fuel visited-t + stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles? + irritant-b)) + (let ([result (run INIT-FUEL #f)]) + (cond [(not (equal? result 0)) ;; nat>0 or #f + (and result #t)] + [else + ;; (eprintf "out of fuel, restarting\n") + (and (run +inf.0 (make-hasheq)) #t)]))) + +;; check* : any nat/+inf.0 StxMode boolean boolean boolean box -> nat/#f +;; Returns #f if bad, positive nat if good, 0 if ran out of fuel +;; If bad, places bad subvalue in irritant-b, if box +(define (check* x0 fuel0 visited-t + stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles? + irritant-b) + (define no-mutable? (not allow-mutable?)) + (define no-mutable-hash/prefab? (or no-mutable? (eq? allow-mutable? 'no-hash/prefab))) + (define no-cycle? (not allow-cycles?)) + (define no-impersonator? (not allow-impersonators?)) + (define (loop x fuel) + (if (and fuel (not (zero? fuel))) + (loop* x fuel) + fuel)) + (define (loop* x fuel) + (define (bad) (when irritant-b (set-box! irritant-b x)) #f) + (define-syntax-rule (with-mutable-check mutable? body ...) ;; don't use for hash or prefab + (cond [(and no-mutable? mutable?) + (bad)] + [else + body ...])) + (define-syntax-rule (with-cycle-check body ...) + (cond [(and visited-t (hash-ref visited-t x #f)) + => (lambda (status) + (cond [(and no-cycle? (eq? status 'traversing)) + (bad)] + [else + fuel]))] + [else + (when visited-t + (hash-set! visited-t x 'traversing)) + (begin0 (begin body ...) + (when visited-t + (hash-remove! visited-t x)))])) + ;; (eprintf "-- checking ~s, fuel ~s\n" x fuel) + (cond + ;; Immutable compound + [(and visited-t (list? x)) + ;; space optimization: if list (finite), no need to store all cdr pairs in cycle table + ;; don't do unless visited-t present, else expands fuel by arbitrary factors + (with-cycle-check + (for/fold ([fuel (sub1 fuel)]) ([e (in-list x)] #:break (not fuel)) + (loop e fuel)))] + [(pair? x) + (with-cycle-check + (let ([fuel (loop (car x) (sub1 fuel))]) + (loop (cdr x) fuel)))] + ;; Atomic + [(or (null? x) + (boolean? x) + (number? x) + (char? x) + (keyword? x) + (regexp? x) + (byte-regexp? x) + (extflonum? x)) + fuel] + [(symbol? x) + (cond [(symbol-interned? x) + fuel] + [(symbol-unreadable? x) + (if allow-unreadable? fuel (bad))] + [else ;; uninterned + (if (eq? allow-unreadable? #t) fuel (bad))])] + ;; Mutable flat + [(or (string? x) + (bytes? x)) + (with-mutable-check (not (immutable? x)) + fuel)] + [(or (fxvector? x) + (flvector? x) + (extflvector? x)) + (with-mutable-check (not (immutable? x)) + fuel)] + ;; Syntax + [(syntax? x) + (case stx-mode + ((atomic) fuel) + ((compound) (loop (syntax-e x) fuel)) + (else (bad)))] + ;; Impersonators and chaperones + [(and no-impersonator? (impersonator? x)) ;; else continue to chaperoned type + (bad)] + [(and no-impersonator? (chaperone? x)) ;; else continue to impersonated type + (bad)] + [else + (with-cycle-check + (cond + ;; Mutable (maybe) compound + [(vector? x) + (with-mutable-check (not (immutable? x)) + (for/fold ([fuel fuel]) ([e (in-vector x)] #:break (not fuel)) + (loop e fuel)))] + [(box? x) + (with-mutable-check (not (immutable? x)) + (loop (unbox x) (sub1 fuel)))] + [(prefab-struct-key x) + => (lambda (key) + (cond [(and no-mutable-hash/prefab? (mutable-prefab-key? key)) + (bad)] + [else + ;; traverse key, since contains arbitrary auto-value + (let ([fuel (loop key fuel)]) + (loop (struct->vector x) fuel))]))] + [(hash? x) + (cond [(and no-mutable-hash/prefab? (not (immutable? x))) + (bad)] + [else + (for/fold ([fuel fuel]) ([(k v) (in-hash x)] #:break (not fuel)) + (let ([fuel (loop k fuel)]) + (loop v fuel)))])] + ;; Bad + [else + (bad)]))])) + (loop x0 fuel0)) + +;; mutable-prefab-key? : prefab-key -> boolean +(define (mutable-prefab-key? key) + ;; A prefab-key is either + ;; - symbol + ;; - (list* symbol maybe-nat maybe-list maybe-vector prefab-key) + ;; where mutable fields indicated by vector + ;; This code is probably overly general; racket seems to normalize keys. + (let loop ([k key]) + (and (pair? k) + (or (and (vector? (car k)) + (positive? (vector-length (car k)))) + (loop (cdr k)))))) diff --git a/6-90-0-29/racket/collects/syntax/parse/private/litconv.rkt b/6-90-0-29/racket/collects/syntax/parse/private/litconv.rkt new file mode 100644 index 0000000..559791f --- /dev/null +++ b/6-90-0-29/racket/collects/syntax/parse/private/litconv.rkt @@ -0,0 +1,284 @@ +#lang racket/base +(require (for-syntax racket/base + racket/lazy-require + "sc.rkt" + "lib.rkt" + syntax/parse/private/kws + racket/syntax) + syntax/parse/private/residual-ct ;; keep abs. path + stxparse-info/parse/private/residual) ;; keep abs. path +(begin-for-syntax + (lazy-require + [syntax/private/keyword (options-select-value parse-keyword-options)] + [stxparse-info/parse/private/rep ;; keep abs. path + (parse-kw-formals + check-conventions-rules + check-datum-literals-list + create-aux-def)])) +;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require) +;; Without this, dependencies don't get collected. +(require racket/runtime-path racket/syntax (for-meta 2 '#%kernel)) +(define-runtime-module-path-index _unused_ 'stxparse-info/parse/private/rep) + +(provide define-conventions + define-literal-set + literal-set->predicate + kernel-literals) + +(define-syntax (define-conventions stx) + + (define-syntax-class header + #:description "name or name with formal parameters" + #:commit + (pattern name:id + #:with formals #'() + #:attr arity (arity 0 0 null null)) + (pattern (name:id . formals) + #:attr arity (parse-kw-formals #'formals #:context stx))) + + (syntax-parse stx + [(define-conventions h:header rule ...) + (let () + (define rules (check-conventions-rules #'(rule ...) stx)) + (define rxs (map car rules)) + (define dens0 (map cadr rules)) + (define den+defs-list + (for/list ([den0 (in-list dens0)]) + (let-values ([(den defs) (create-aux-def den0)]) + (cons den defs)))) + (define dens (map car den+defs-list)) + (define defs (apply append (map cdr den+defs-list))) + + (define/with-syntax (rx ...) rxs) + (define/with-syntax (def ...) defs) + (define/with-syntax (parser ...) + (map den:delayed-parser dens)) + (define/with-syntax (class-name ...) + (map den:delayed-class dens)) + + ;; FIXME: could move make-den:delayed to user of conventions + ;; and eliminate from residual.rkt + #'(begin + (define-syntax h.name + (make-conventions + (quote-syntax get-parsers) + (lambda () + (let ([class-names (list (quote-syntax class-name) ...)]) + (map list + (list 'rx ...) + (map make-den:delayed + (generate-temporaries class-names) + class-names)))))) + (define get-parsers + (lambda formals + def ... + (list parser ...)))))])) + +(define-for-syntax (check-phase-level stx ctx) + (unless (or (exact-integer? (syntax-e stx)) + (eq? #f (syntax-e stx))) + (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx)) + stx) + +;; check-litset-list : stx stx -> (listof (cons id literalset)) +(define-for-syntax (check-litset-list stx ctx) + (syntax-case stx () + [(litset-id ...) + (for/list ([litset-id (syntax->list #'(litset-id ...))]) + (let* ([val (and (identifier? litset-id) + (syntax-local-value/record litset-id literalset?))]) + (if val + (cons litset-id val) + (raise-syntax-error #f "expected literal set name" ctx litset-id))))] + [_ (raise-syntax-error #f "expected list of literal set names" ctx stx)])) + +;; check-literal-entry/litset : stx stx -> (list id id) +(define-for-syntax (check-literal-entry/litset stx ctx) + (syntax-case stx () + [(internal external) + (and (identifier? #'internal) (identifier? #'external)) + (list #'internal #'external)] + [id + (identifier? #'id) + (list #'id #'id)] + [_ (raise-syntax-error #f "expected literal entry" ctx stx)])) + +(define-for-syntax (check-duplicate-literals ctx imports lits datum-lits) + (let ([lit-t (make-hasheq)]) ;; sym => #t + (define (check+enter! key blame-stx) + (when (hash-ref lit-t key #f) + (raise-syntax-error #f (format "duplicate literal: ~a" key) ctx blame-stx)) + (hash-set! lit-t key #t)) + (for ([id+litset (in-list imports)]) + (let ([litset-id (car id+litset)] + [litset (cdr id+litset)]) + (for ([entry (in-list (literalset-literals litset))]) + (cond [(lse:lit? entry) + (check+enter! (lse:lit-internal entry) litset-id)] + [(lse:datum-lit? entry) + (check+enter! (lse:datum-lit-internal entry) litset-id)])))) + (for ([datum-lit (in-list datum-lits)]) + (let ([internal (den:datum-lit-internal datum-lit)]) + (check+enter! (syntax-e internal) internal))) + (for ([lit (in-list lits)]) + (check+enter! (syntax-e (car lit)) (car lit))))) + +(define-syntax (define-literal-set stx) + (syntax-case stx () + [(define-literal-set name . rest) + (let-values ([(chunks rest) + (parse-keyword-options + #'rest + `((#:literal-sets ,check-litset-list) + (#:datum-literals ,check-datum-literals-list) + (#:phase ,check-phase-level) + (#:for-template) + (#:for-syntax) + (#:for-label)) + #:incompatible '((#:phase #:for-template #:for-syntax #:for-label)) + #:context stx + #:no-duplicates? #t)]) + (unless (identifier? #'name) + (raise-syntax-error #f "expected identifier" stx #'name)) + (let ([relphase + (cond [(assq '#:for-template chunks) -1] + [(assq '#:for-syntax chunks) 1] + [(assq '#:for-label chunks) #f] + [else (options-select-value chunks '#:phase #:default 0)])] + [datum-lits + (options-select-value chunks '#:datum-literals #:default null)] + [lits (syntax-case rest () + [( (lit ...) ) + (for/list ([lit (in-list (syntax->list #'(lit ...)))]) + (check-literal-entry/litset lit stx))] + [_ (raise-syntax-error #f "bad syntax" stx)])] + [imports (options-select-value chunks '#:literal-sets #:default null)]) + (check-duplicate-literals stx imports lits datum-lits) + (with-syntax ([((internal external) ...) lits] + [(datum-internal ...) (map den:datum-lit-internal datum-lits)] + [(datum-external ...) (map den:datum-lit-external datum-lits)] + [(litset-id ...) (map car imports)] + [relphase relphase]) + #`(begin + (define phase-of-literals + (and 'relphase + (+ (variable-reference->module-base-phase (#%variable-reference)) + 'relphase))) + (define-syntax name + (make-literalset + (append (literalset-literals (syntax-local-value (quote-syntax litset-id))) + ... + (list (make-lse:lit 'internal + (quote-syntax external) + (quote-syntax phase-of-literals)) + ... + (make-lse:datum-lit 'datum-internal + 'datum-external) + ...)))) + (begin-for-syntax/once + (for ([x (in-list (syntax->list #'(external ...)))]) + (unless (identifier-binding x 'relphase) + (raise-syntax-error #f + (format "literal is unbound in phase ~a~a~a" + 'relphase + (case 'relphase + ((1) " (for-syntax)") + ((-1) " (for-template)") + ((#f) " (for-label)") + (else "")) + " relative to the enclosing module") + (quote-syntax #,stx) x))))))))])) + +#| +NOTES ON PHASES AND BINDINGS + +(module M .... + .... (define-literal-set LS #:phase PL ....) + ....) + +For the expansion of the define-literal-set form, the bindings of the literals +can be accessed by (identifier-binding lit PL), because the phase of the enclosing +module (M) is 0. + +LS may be used, however, in a context where the phase of the enclosing +module is not 0, so each instantiation of LS needs to calculate the +phase of M and add that to PL. + +-- + +Normally, literal sets that define the same name conflict. But it +would be nice to allow them to both be imported in the case where they +refer to the same binding. + +Problem: Can't do the check eagerly, because the binding of L may +change between when define-literal-set is compiled and the comparison +involving L. For example: + + (module M racket + (require stxparse-info/parse) + (define-literal-set LS (lambda)) + (require (only-in some-other-lang lambda)) + .... LS ....) + +The expansion of the LS definition sees a different lambda than the +one that the literal in LS actually refers to. + +Similarly, a literal in LS might not be defined when the expander +runs, but might get defined later. (Although I think that will already +cause an error, so don't worry about that case.) +|# + +;; FIXME: keep one copy of each identifier (?) + +(define-syntax (literal-set->predicate stx) + (syntax-case stx () + [(literal-set->predicate litset-id) + (let ([val (and (identifier? #'litset-id) + (syntax-local-value/record #'litset-id literalset?))]) + (unless val (raise-syntax-error #f "expected literal set name" stx #'litset-id)) + (let ([lits (literalset-literals val)]) + (with-syntax ([((lit phase-var) ...) + (for/list ([lit (in-list lits)] + #:when (lse:lit? lit)) + (list (lse:lit-external lit) (lse:lit-phase lit)))] + [(datum-lit ...) + (for/list ([lit (in-list lits)] + #:when (lse:datum-lit? lit)) + (lse:datum-lit-external lit))]) + #'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...) + '(datum-lit ...)))))])) + +(define (make-literal-set-predicate lits datum-lits) + (lambda (x [phase (syntax-local-phase-level)]) + (or (for/or ([lit (in-list lits)]) + (let ([lit-id (car lit)] + [lit-phase (cadr lit)]) + (free-identifier=? x lit-id phase lit-phase))) + (and (memq (syntax-e x) datum-lits) #t)))) + +;; Literal sets + +(define-literal-set kernel-literals + (begin + begin0 + define-values + define-syntaxes + define-values-for-syntax ;; kept for compat. + begin-for-syntax + set! + let-values + letrec-values + #%plain-lambda + case-lambda + if + quote + quote-syntax + letrec-syntaxes+values + with-continuation-mark + #%expression + #%plain-app + #%top + #%datum + #%variable-reference + module module* #%provide #%require #%declare + #%plain-module-begin)) diff --git a/6-90-0-29/racket/collects/syntax/parse/private/make.rkt b/6-90-0-29/racket/collects/syntax/parse/private/make.rkt new file mode 100644 index 0000000..8a4f744 --- /dev/null +++ b/6-90-0-29/racket/collects/syntax/parse/private/make.rkt @@ -0,0 +1,43 @@ +#lang racket/base +(require (for-syntax racket/base + racket/struct-info)) +(provide make) + +;; get-struct-info : identifier stx -> struct-info-list +(define-for-syntax (get-struct-info id ctx) + (define (bad-struct-name x) + (raise-syntax-error #f "expected struct name" ctx x)) + (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))) + +;; (make struct-name field-expr ...) +;; Checks that correct number of fields given. +(define-syntax (make stx) + (syntax-case stx () + [(make S expr ...) + (let () + (define info (get-struct-info #'S stx)) + (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, got ~s)" + (syntax-e #'S) + num-slots + num-provided) + stx))) + (with-syntax ([constructor constructor]) + (syntax-property #'(constructor expr ...) + 'disappeared-use + #'S)))])) diff --git a/6-90-0-29/racket/collects/syntax/parse/private/runtime-progress.rkt b/6-90-0-29/racket/collects/syntax/parse/private/runtime-progress.rkt new file mode 100644 index 0000000..f76f154 --- /dev/null +++ b/6-90-0-29/racket/collects/syntax/parse/private/runtime-progress.rkt @@ -0,0 +1,257 @@ +#lang racket/base +(require racket/list + syntax/parse/private/minimatch) +(provide ps-empty + ps-add-car + ps-add-cdr + ps-add-stx + ps-add-unbox + ps-add-unvector + ps-add-unpstruct + ps-add-opaque + ps-add-post + ps-add + (struct-out ord) + + ps-pop-opaque + ps-pop-ord + ps-pop-post + ps-context-syntax + ps-difference + + (struct-out failure) + failure* + + expect? + (struct-out expect:thing) + (struct-out expect:atom) + (struct-out expect:literal) + (struct-out expect:message) + (struct-out expect:disj) + (struct-out expect:proper-pair) + + es-add-thing + es-add-message + es-add-atom + es-add-literal + es-add-proper-pair) + +;; FIXME: add phase to expect:literal + +;; == Failure == + +#| +A Failure is (failure PS ExpectStack) + +A FailureSet is one of + - Failure + - (cons FailureSet FailureSet) + +A FailFunction = (FailureSet -> Answer) +|# +(define-struct failure (progress expectstack) #:prefab) + +;; failure* : PS ExpectStack/#f -> Failure/#t +(define (failure* ps es) (if es (failure ps es) #t)) + +;; == Progress == + +#| +Progress (PS) is a non-empty list of Progress Frames (PF). + +A Progress Frame (PF) is one of + - stx ;; "Base" frame, or ~parse/#:with term + - 'car ;; car of pair; also vector->list, unbox, struct->list, etc + - nat ;; Represents that many repeated cdrs + - 'post ;; late/post-traversal check + - #s(ord group index) ;; ~and subpattern, only comparable w/in group + - 'opaque + +The error-reporting context (ie, syntax-parse #:context arg) is always +the final frame. + +All non-stx frames (eg car, cdr) interpreted as applying to nearest following +stx frame. + +A stx frame is introduced + - always at base (that is, by syntax-parse) + - if syntax-parse has #:context arg, then two stx frames at bottom: + (list to-match-stx context-stx) + - by #:with/~parse + - by #:fail-*/#:when/~fail & stx + +Interpretation: later frames are applied first. + eg, (list 'car 1 stx) + means ( car of ( cdr once of stx ) ) + NOT apply car, then apply cdr once, then stop +|# +(define-struct ord (group index) #:prefab) + +(define (ps-empty stx ctx) + (if (eq? stx ctx) + (list stx) + (list stx ctx))) +(define (ps-add-car parent) + (cons 'car parent)) +(define (ps-add-cdr parent [times 1]) + (if (zero? times) + parent + (match (car parent) + [(? exact-positive-integer? n) + (cons (+ times n) (cdr parent))] + [_ + (cons times parent)]))) +(define (ps-add-stx parent stx) + (cons stx parent)) +(define (ps-add-unbox parent) + (ps-add-car parent)) +(define (ps-add-unvector parent) + (ps-add-car parent)) +(define (ps-add-unpstruct parent) + (ps-add-car parent)) +(define (ps-add-opaque parent) + (cons 'opaque parent)) +(define (ps-add parent frame) + (cons frame parent)) +(define (ps-add-post parent) + (cons 'post parent)) + +;; ps-context-syntax : Progress -> syntax +(define (ps-context-syntax ps) + ;; Bottom frame is always syntax + (last ps)) + +;; ps-difference : PS PS -> nat +;; Returns N s.t. B = (ps-add-cdr^N A) +(define (ps-difference a b) + (define-values (a-cdrs a-base) + (match a + [(cons (? exact-positive-integer? a-cdrs) a-base) + (values a-cdrs a-base)] + [_ (values 0 a)])) + (define-values (b-cdrs b-base) + (match b + [(cons (? exact-positive-integer? b-cdrs) b-base) + (values b-cdrs b-base)] + [_ (values 0 b)])) + (unless (eq? a-base b-base) + (error 'ps-difference "INTERNAL ERROR: ~e does not extend ~e" b a)) + (- b-cdrs a-cdrs)) + +;; ps-pop-opaque : PS -> PS +;; Used to continue with progress from opaque head pattern. +(define (ps-pop-opaque ps) + (match ps + [(cons (? exact-positive-integer? n) (cons 'opaque ps*)) + (ps-add-cdr ps* n)] + [(cons 'opaque ps*) + ps*] + [_ (error 'ps-pop-opaque "INTERNAL ERROR: opaque frame not found: ~e" ps)])) + +;; ps-pop-ord : PS -> PS +(define (ps-pop-ord ps) + (match ps + [(cons (? exact-positive-integer? n) (cons (? ord?) ps*)) + (ps-add-cdr ps* n)] + [(cons (? ord?) ps*) + ps*] + [_ (error 'ps-pop-ord "INTERNAL ERROR: ord frame not found: ~e" ps)])) + +;; ps-pop-post : PS -> PS +(define (ps-pop-post ps) + (match ps + [(cons (? exact-positive-integer? n) (cons 'post ps*)) + (ps-add-cdr ps* n)] + [(cons 'post ps*) + ps*] + [_ (error 'ps-pop-post "INTERNAL ERROR: post frame not found: ~e" ps)])) + + +;; == Expectations == + +#| +There are multiple types that use the same structures, optimized for +different purposes. + +-- During parsing, the goal is to minimize/consolidate allocations. + +An ExpectStack (during parsing) is one of + - (expect:thing Progress String Boolean String/#f ExpectStack) + * (expect:message String ExpectStack) + * (expect:atom Datum ExpectStack) + * (expect:literal Identifier ExpectStack) + * (expect:proper-pair FirstDesc ExpectStack) + * #t + +The *-marked variants can only occur at the top of the stack (ie, not +in the next field of another Expect). The top of the stack contains +the most specific information. + +An ExpectStack can also be #f, which means no failure tracking is +requested (and thus no more ExpectStacks should be allocated). + +-- During reporting, the goal is ease of manipulation. + +An ExpectList (during reporting) is (listof Expect). + +An Expect is one of + - (expect:thing #f String #t String/#f StxIdx) + * (expect:message String StxIdx) + * (expect:atom Datum StxIdx) + * (expect:literal Identifier StxIdx) + * (expect:proper-pair FirstDesc StxIdx) + * (expect:disj (NEListof Expect) StxIdx) + - '... + +A StxIdx is (cons Syntax Nat) + +That is, the next link is replaced with the syntax+index of the term +being complained about. An expect:thing's progress is replaced with #f. + +An expect:disj never contains a '... or another expect:disj. + +We write ExpectList when the most specific information comes first and +RExpectList when the most specific information comes last. +|# +(struct expect:thing (term description transparent? role next) #:prefab) +(struct expect:message (message next) #:prefab) +(struct expect:atom (atom next) #:prefab) +(struct expect:literal (literal next) #:prefab) +(struct expect:disj (expects next) #:prefab) +(struct expect:proper-pair (first-desc next) #:prefab) + +(define (expect? x) + (or (expect:thing? x) + (expect:message? x) + (expect:atom? x) + (expect:literal? x) + (expect:disj? x) + (expect:proper-pair? x))) + +(define (es-add-thing ps description transparent? role next) + (if (and next description) + (expect:thing ps description transparent? role next) + next)) + +(define (es-add-message message next) + (if (and next message) + (expect:message message next) + next)) + +(define (es-add-atom atom next) + (and next (expect:atom atom next))) + +(define (es-add-literal literal next) + (and next (expect:literal literal next))) + +(define (es-add-proper-pair first-desc next) + (and next (expect:proper-pair first-desc next))) + +#| +A FirstDesc is one of + - #f -- unknown, multiple possible, etc + - string -- description + - (list 'any) + - (list 'literal symbol) + - (list 'datum datum) +|# diff --git a/6-90-0-29/racket/collects/syntax/parse/private/txlift.rkt b/6-90-0-29/racket/collects/syntax/parse/private/txlift.rkt new file mode 100644 index 0000000..57c5497 --- /dev/null +++ b/6-90-0-29/racket/collects/syntax/parse/private/txlift.rkt @@ -0,0 +1,45 @@ +#lang racket/base +(require (for-template racket/base)) +(provide txlift + get-txlifts-as-definitions + with-txlifts + call/txlifts) + +;; Like lifting definitions, but within a single transformer. + +;; current-liftbox : Parameter of [#f or (Listof (list Id Stx))] +(define current-liftbox (make-parameter #f)) + +(define (call/txlifts proc) + (parameterize ((current-liftbox (box null))) + (proc))) + +(define (txlift expr) + (let ([liftbox (current-liftbox)]) + (check 'txlift liftbox) + (let ([var (car (generate-temporaries '(txlift)))]) + (set-box! liftbox (cons (list var expr) (unbox liftbox))) + var))) + +(define (get-txlifts) + (let ([liftbox (current-liftbox)]) + (check 'get-txlifts liftbox) + (reverse (unbox liftbox)))) + +(define (get-txlifts-as-definitions) + (let ([liftbox (current-liftbox)]) + (check 'get-txlifts-as-definitions liftbox) + (map (lambda (p) + #`(define #,@p)) + (reverse (unbox liftbox))))) + +(define (check who lb) + (unless (box? lb) + (error who "not in a txlift-catching context"))) + +(define (with-txlifts proc) + (call/txlifts + (lambda () + (let ([v (proc)]) + (with-syntax ([((var rhs) ...) (get-txlifts)]) + #`(let* ([var rhs] ...) #,v)))))) diff --git a/scribblings/stxparse-info.scrbl-6-90-0-29 b/6-90-0-29/stxparse-info.scrbl similarity index 100% rename from scribblings/stxparse-info.scrbl-6-90-0-29 rename to 6-90-0-29/stxparse-info.scrbl diff --git a/7-0-0-20/racket/collects/syntax/parse/define.rkt b/7-0-0-20/racket/collects/syntax/parse/define.rkt new file mode 100644 index 0000000..28e5148 --- /dev/null +++ b/7-0-0-20/racket/collects/syntax/parse/define.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require (for-syntax racket/base + stxparse-info/parse + "private/sc.rkt")) +(provide define-simple-macro + define-syntax-parser + (for-syntax (all-from-out stxparse-info/parse))) + +(define-syntax (define-simple-macro stx) + (syntax-parse stx + [(define-simple-macro (~and (macro:id . _) pattern) . body) + #`(define-syntax macro + (syntax-parser/template + #,((make-syntax-introducer) stx) + [pattern . body]))])) + +(define-simple-macro (define-syntax-parser macro:id option-or-clause ...) + (define-syntax macro + (syntax-parser option-or-clause ...))) + diff --git a/7-0-0-20/racket/collects/syntax/parse/experimental/dset.rkt b/7-0-0-20/racket/collects/syntax/parse/experimental/dset.rkt new file mode 100644 index 0000000..57c53e5 --- /dev/null +++ b/7-0-0-20/racket/collects/syntax/parse/experimental/dset.rkt @@ -0,0 +1,54 @@ +#lang racket/base + +;; A dset is an `equal?`-based set, but it preserves order based on +;; the history of additions, so that if items are added in a +;; deterministic order, they come back out in a deterministic order. + +(provide dset + dset-empty? + dset->list + dset-add + dset-union + dset-subtract + dset-filter) + +(define dset + (case-lambda + [() (hash)] + [(e) (hash e 0)])) + +(define (dset-empty? ds) + (zero? (hash-count ds))) + +(define (dset->list ds) + (map cdr + (sort (for/list ([(k v) (in-hash ds)]) + (cons v k)) + < + #:key car))) + +(define (dset-add ds e) + (if (hash-ref ds e #f) + ds + (hash-set ds e (hash-count ds)))) + +(define (dset-union ds1 ds2) + (cond + [((hash-count ds1) . > . (hash-count ds2)) + (dset-union ds2 ds1)] + [else + (for/fold ([ds2 ds2]) ([e (dset->list ds1)]) + (dset-add ds2 e))])) + +(define (dset-subtract ds1 ds2) + ;; ! takes O(size(ds2)) time ! + (for/fold ([r (dset)]) ([e (in-list (dset->list ds1))]) + (if (hash-ref ds2 e #f) + r + (dset-add r e)))) + +(define (dset-filter ds pred) + (for/fold ([r (dset)]) ([e (in-list (dset->list ds))]) + (if (pred e) + (dset-add r e) + r))) diff --git a/7-0-0-20/racket/collects/syntax/parse/experimental/eh.rkt b/7-0-0-20/racket/collects/syntax/parse/experimental/eh.rkt new file mode 100644 index 0000000..f8e1b09 --- /dev/null +++ b/7-0-0-20/racket/collects/syntax/parse/experimental/eh.rkt @@ -0,0 +1,5 @@ +#lang racket/base +(require "../private/sc.rkt" + syntax/parse/private/keywords) +(provide ~eh-var + define-eh-alternative-set) diff --git a/7-0-0-20/racket/collects/syntax/parse/lib/function-header.rkt b/7-0-0-20/racket/collects/syntax/parse/lib/function-header.rkt new file mode 100644 index 0000000..79e80f3 --- /dev/null +++ b/7-0-0-20/racket/collects/syntax/parse/lib/function-header.rkt @@ -0,0 +1,112 @@ +#lang racket/base + +(require "../../parse.rkt" + "../experimental/template.rkt" + racket/dict) + +(provide function-header formal formals) + +(define-syntax-class function-header + (pattern ((~or header:function-header name:id) . args:formals) + #:attr params + (template ((?@ . (?? header.params ())) + . args.params)))) + +(define-syntax-class formals + #:attributes (params) + (pattern (arg:formal ...) + #:attr params #'(arg.name ...) + #:fail-when (check-duplicate-identifier (syntax->list #'params)) + "duplicate argument name" + #:fail-when (check-duplicate (attribute arg.kw) + #:same? (λ (x y) + (and x y (equal? (syntax-e x) + (syntax-e y))))) + "duplicate keyword for argument" + #:fail-when (invalid-option-placement + (attribute arg.name) (attribute arg.default)) + "default-value expression missing") + (pattern (arg:formal ... . rest:id) + #:attr params #'(arg.name ... rest) + #:fail-when (check-duplicate-identifier (syntax->list #'params)) + "duplicate argument name" + #:fail-when (check-duplicate (attribute arg.kw) + #:same? (λ (x y) + (and x y (equal? (syntax-e x) + (syntax-e y))))) + "duplicate keyword for argument" + #:fail-when (invalid-option-placement + (attribute arg.name) (attribute arg.default)) + "default-value expression missing")) + +(define-splicing-syntax-class formal + #:attributes (name kw default) + (pattern name:id + #:attr kw #f + #:attr default #f) + (pattern [name:id default] + #:attr kw #f) + (pattern (~seq kw:keyword name:id) + #:attr default #f) + (pattern (~seq kw:keyword [name:id default]))) + +;; invalid-option-placement : (Listof Id) (Listof Syntax/#f) -> Id/#f +;; Checks for mandatory argument after optional argument; if found, returns +;; identifier of mandatory argument. +(define (invalid-option-placement names defaults) + ;; find-mandatory : (Listof Id) (Listof Syntax/#f) -> Id/#f + ;; Finds first name w/o corresponding default. + (define (find-mandatory names defaults) + (for/first ([name (in-list names)] + [default (in-list defaults)] + #:when (not default)) + name)) + ;; Skip through mandatory args until first optional found, then search + ;; for another mandatory. + (let loop ([names names] [defaults defaults]) + (cond [(or (null? names) (null? defaults)) + #f] + [(eq? (car defaults) #f) ;; mandatory + (loop (cdr names) (cdr defaults))] + [else ;; found optional + (find-mandatory (cdr names) (cdr defaults))]))) + +;; Copied from unstable/list +;; check-duplicate : (listof X) +;; #:key (X -> K) +;; #:same? (or/c (K K -> bool) dict?) +;; -> X or #f +(define (check-duplicate items + #:key [key values] + #:same? [same? equal?]) + (cond [(procedure? same?) + (cond [(eq? same? equal?) + (check-duplicate/t items key (make-hash) #t)] + [(eq? same? eq?) + (check-duplicate/t items key (make-hasheq) #t)] + [(eq? same? eqv?) + (check-duplicate/t items key (make-hasheqv) #t)] + [else + (check-duplicate/list items key same?)])] + [(dict? same?) + (let ([dict same?]) + (if (dict-mutable? dict) + (check-duplicate/t items key dict #t) + (check-duplicate/t items key dict #f)))])) +(define (check-duplicate/t items key table mutating?) + (let loop ([items items] [table table]) + (and (pair? items) + (let ([key-item (key (car items))]) + (if (dict-ref table key-item #f) + (car items) + (loop (cdr items) (if mutating? + (begin (dict-set! table key-item #t) table) + (dict-set table key-item #t)))))))) +(define (check-duplicate/list items key same?) + (let loop ([items items] [sofar null]) + (and (pair? items) + (let ([key-item (key (car items))]) + (if (for/or ([prev (in-list sofar)]) + (same? key-item prev)) + (car items) + (loop (cdr items) (cons key-item sofar))))))) diff --git a/7-0-0-20/racket/collects/syntax/parse/private/3d-stx.rkt b/7-0-0-20/racket/collects/syntax/parse/private/3d-stx.rkt new file mode 100644 index 0000000..b5083d5 --- /dev/null +++ b/7-0-0-20/racket/collects/syntax/parse/private/3d-stx.rkt @@ -0,0 +1,250 @@ +#lang racket/base +(require (only-in '#%flfxnum flvector? fxvector?) + (only-in '#%extfl extflonum? extflvector?)) +(provide 2d-stx? + check-datum) + +;; Checks for 3D syntax (syntax that contains unwritable values, etc) + +(define INIT-FUEL #e1e6) + +;; TO DO: +;; - extension via proc (any -> list/#f), +;; value considered good if result is list, all values in list are good + +;; -- + +#| +Some other predicates one might like to have: + - would (read (write x)) succeed and be equal/similar to x? + - would (datum->syntax #f x) succeed? + - would (syntax->datum (datum->syntax #f x)) succeed and be equal/similar to x? + - would (eval (read (write (compile `(quote ,x))))) succeed and be equal/similar to x? + +where equal/similar could mean one of the following: + - equal?, which equates eg (vector 1 2 3) and (vector-immutable 1 2 3) + - equal? relaxed to equate eg mutable and immutable hashes (but not prefabs) + - equal? but also requiring same mutability at every point + +Some aux definitions: + +(define (rt x) + (define-values (in out) (make-pipe)) + (write x out) + (close-output-port out) + (read in)) + +(define (wrsd x) + (define-values (in out) (make-pipe)) + (write x out) + (close-output-port out) + (syntax->datum (read-syntax #f in))) + +(define (dsd x) + (syntax->datum (datum->syntax #f x))) + +(define (evalc x) ;; mimics compiled zo-file constraints + (eval (rt (compile `(quote ,x))))) + +How mutability behaves: + - for vectors, boxes: + - read always mutable + - read-syntax always immutable + - (dsd x) always immutable + - (evalc x) always immutable + - for hashes: + - read always immutable + - (dsd x) same as x + - (evalc x) always immutable (!!!) + - for prefab structs: + - read same as x + - read-syntax same as x + - (dsd x) same as x + - (evalc x) same as x + +Symbols + - (dsd x) same as x + - (evalc x) preserves interned, unreadable, makes new uninterned (loses eq-ness) + +Chaperones allow the lazy generation of infinite trees of data +undetectable by eq?-based cycle detection. Might be helpful to have +chaperone-eq? (not recursive, just chaperones of same object) and +chaperone-eq?-hash-code, to use with make-custom-hash.) + +Impersonators allow the lazy generation of infinite trees of data, +period. + +|# + +;; ---- + +;; 2d-stx? : any ... -> boolean +;; Would (write (compile `(quote-syntax ,x))) succeed? +;; If traverse-syntax? is #t, recurs into existing syntax +;; If traverse-syntax? is #f, assumes existing stxobjs are 2d, and only +;; checks if *new* 3d syntax would be created. +(define (2d-stx? x + #:traverse-syntax? [traverse-syntax? #t] + #:irritant [irritant-box #f]) + (check-datum x + #:syntax-mode (if traverse-syntax? 'compound 'atomic) + #:allow-impersonators? #f + #:allow-mutable? 'no-hash/prefab + #:allow-unreadable-symbols? #t + #:allow-cycles? #t + #:irritant irritant-box)) + +;; ---- + +;; check-datum : any ... -> boolean +;; where StxMode = (U 'atomic 'compound #f) +;; Returns nat if x is "good", #f if "bad" +;; If irritant-b is a box, the first bad subvalue found is put in the box. +;; If visited-t is a hash, it is used to detect cycles. +(define (check-datum x + #:syntax-mode [stx-mode #f] + #:allow-impersonators? [allow-impersonators? #f] + #:allow-mutable? [allow-mutable? #f] + #:allow-unreadable-symbols? [allow-unreadable? #f] + #:allow-cycles? [allow-cycles? #f] + #:irritant [irritant-b #f]) + ;; Try once with some fuel. If runs out of fuel, try again with cycle checking. + (define (run fuel visited-t) + (check* x fuel visited-t + stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles? + irritant-b)) + (let ([result (run INIT-FUEL #f)]) + (cond [(not (equal? result 0)) ;; nat>0 or #f + (and result #t)] + [else + ;; (eprintf "out of fuel, restarting\n") + (and (run +inf.0 (make-hasheq)) #t)]))) + +;; check* : any nat/+inf.0 StxMode boolean boolean boolean box -> nat/#f +;; Returns #f if bad, positive nat if good, 0 if ran out of fuel +;; If bad, places bad subvalue in irritant-b, if box +(define (check* x0 fuel0 visited-t + stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles? + irritant-b) + (define no-mutable? (not allow-mutable?)) + (define no-mutable-hash/prefab? (or no-mutable? (eq? allow-mutable? 'no-hash/prefab))) + (define no-cycle? (not allow-cycles?)) + (define no-impersonator? (not allow-impersonators?)) + (define (loop x fuel) + (if (and fuel (not (zero? fuel))) + (loop* x fuel) + fuel)) + (define (loop* x fuel) + (define (bad) (when irritant-b (set-box! irritant-b x)) #f) + (define-syntax-rule (with-mutable-check mutable? body ...) ;; don't use for hash or prefab + (cond [(and no-mutable? mutable?) + (bad)] + [else + body ...])) + (define-syntax-rule (with-cycle-check body ...) + (cond [(and visited-t (hash-ref visited-t x #f)) + => (lambda (status) + (cond [(and no-cycle? (eq? status 'traversing)) + (bad)] + [else + fuel]))] + [else + (when visited-t + (hash-set! visited-t x 'traversing)) + (begin0 (begin body ...) + (when visited-t + (hash-remove! visited-t x)))])) + ;; (eprintf "-- checking ~s, fuel ~s\n" x fuel) + (cond + ;; Immutable compound + [(and visited-t (list? x)) + ;; space optimization: if list (finite), no need to store all cdr pairs in cycle table + ;; don't do unless visited-t present, else expands fuel by arbitrary factors + (with-cycle-check + (for/fold ([fuel (sub1 fuel)]) ([e (in-list x)] #:break (not fuel)) + (loop e fuel)))] + [(pair? x) + (with-cycle-check + (let ([fuel (loop (car x) (sub1 fuel))]) + (loop (cdr x) fuel)))] + ;; Atomic + [(or (null? x) + (boolean? x) + (number? x) + (char? x) + (keyword? x) + (regexp? x) + (byte-regexp? x) + (extflonum? x)) + fuel] + [(symbol? x) + (cond [(symbol-interned? x) + fuel] + [(symbol-unreadable? x) + (if allow-unreadable? fuel (bad))] + [else ;; uninterned + (if (eq? allow-unreadable? #t) fuel (bad))])] + ;; Mutable flat + [(or (string? x) + (bytes? x)) + (with-mutable-check (not (immutable? x)) + fuel)] + [(or (fxvector? x) + (flvector? x) + (extflvector? x)) + (with-mutable-check (not (immutable? x)) + fuel)] + ;; Syntax + [(syntax? x) + (case stx-mode + ((atomic) fuel) + ((compound) (loop (syntax-e x) fuel)) + (else (bad)))] + ;; Impersonators and chaperones + [(and no-impersonator? (impersonator? x)) ;; else continue to chaperoned type + (bad)] + [(and no-impersonator? (chaperone? x)) ;; else continue to impersonated type + (bad)] + [else + (with-cycle-check + (cond + ;; Mutable (maybe) compound + [(vector? x) + (with-mutable-check (not (immutable? x)) + (for/fold ([fuel fuel]) ([e (in-vector x)] #:break (not fuel)) + (loop e fuel)))] + [(box? x) + (with-mutable-check (not (immutable? x)) + (loop (unbox x) (sub1 fuel)))] + [(prefab-struct-key x) + => (lambda (key) + (cond [(and no-mutable-hash/prefab? (mutable-prefab-key? key)) + (bad)] + [else + ;; traverse key, since contains arbitrary auto-value + (let ([fuel (loop key fuel)]) + (loop (struct->vector x) fuel))]))] + [(hash? x) + (cond [(and no-mutable-hash/prefab? (not (immutable? x))) + (bad)] + [else + (for/fold ([fuel fuel]) ([(k v) (in-hash x)] #:break (not fuel)) + (let ([fuel (loop k fuel)]) + (loop v fuel)))])] + ;; Bad + [else + (bad)]))])) + (loop x0 fuel0)) + +;; mutable-prefab-key? : prefab-key -> boolean +(define (mutable-prefab-key? key) + ;; A prefab-key is either + ;; - symbol + ;; - (list* symbol maybe-nat maybe-list maybe-vector prefab-key) + ;; where mutable fields indicated by vector + ;; This code is probably overly general; racket seems to normalize keys. + (let loop ([k key]) + (and (pair? k) + (or (and (vector? (car k)) + (positive? (vector-length (car k)))) + (loop (cdr k)))))) diff --git a/7-0-0-20/racket/collects/syntax/parse/private/litconv.rkt b/7-0-0-20/racket/collects/syntax/parse/private/litconv.rkt new file mode 100644 index 0000000..559791f --- /dev/null +++ b/7-0-0-20/racket/collects/syntax/parse/private/litconv.rkt @@ -0,0 +1,284 @@ +#lang racket/base +(require (for-syntax racket/base + racket/lazy-require + "sc.rkt" + "lib.rkt" + syntax/parse/private/kws + racket/syntax) + syntax/parse/private/residual-ct ;; keep abs. path + stxparse-info/parse/private/residual) ;; keep abs. path +(begin-for-syntax + (lazy-require + [syntax/private/keyword (options-select-value parse-keyword-options)] + [stxparse-info/parse/private/rep ;; keep abs. path + (parse-kw-formals + check-conventions-rules + check-datum-literals-list + create-aux-def)])) +;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require) +;; Without this, dependencies don't get collected. +(require racket/runtime-path racket/syntax (for-meta 2 '#%kernel)) +(define-runtime-module-path-index _unused_ 'stxparse-info/parse/private/rep) + +(provide define-conventions + define-literal-set + literal-set->predicate + kernel-literals) + +(define-syntax (define-conventions stx) + + (define-syntax-class header + #:description "name or name with formal parameters" + #:commit + (pattern name:id + #:with formals #'() + #:attr arity (arity 0 0 null null)) + (pattern (name:id . formals) + #:attr arity (parse-kw-formals #'formals #:context stx))) + + (syntax-parse stx + [(define-conventions h:header rule ...) + (let () + (define rules (check-conventions-rules #'(rule ...) stx)) + (define rxs (map car rules)) + (define dens0 (map cadr rules)) + (define den+defs-list + (for/list ([den0 (in-list dens0)]) + (let-values ([(den defs) (create-aux-def den0)]) + (cons den defs)))) + (define dens (map car den+defs-list)) + (define defs (apply append (map cdr den+defs-list))) + + (define/with-syntax (rx ...) rxs) + (define/with-syntax (def ...) defs) + (define/with-syntax (parser ...) + (map den:delayed-parser dens)) + (define/with-syntax (class-name ...) + (map den:delayed-class dens)) + + ;; FIXME: could move make-den:delayed to user of conventions + ;; and eliminate from residual.rkt + #'(begin + (define-syntax h.name + (make-conventions + (quote-syntax get-parsers) + (lambda () + (let ([class-names (list (quote-syntax class-name) ...)]) + (map list + (list 'rx ...) + (map make-den:delayed + (generate-temporaries class-names) + class-names)))))) + (define get-parsers + (lambda formals + def ... + (list parser ...)))))])) + +(define-for-syntax (check-phase-level stx ctx) + (unless (or (exact-integer? (syntax-e stx)) + (eq? #f (syntax-e stx))) + (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx)) + stx) + +;; check-litset-list : stx stx -> (listof (cons id literalset)) +(define-for-syntax (check-litset-list stx ctx) + (syntax-case stx () + [(litset-id ...) + (for/list ([litset-id (syntax->list #'(litset-id ...))]) + (let* ([val (and (identifier? litset-id) + (syntax-local-value/record litset-id literalset?))]) + (if val + (cons litset-id val) + (raise-syntax-error #f "expected literal set name" ctx litset-id))))] + [_ (raise-syntax-error #f "expected list of literal set names" ctx stx)])) + +;; check-literal-entry/litset : stx stx -> (list id id) +(define-for-syntax (check-literal-entry/litset stx ctx) + (syntax-case stx () + [(internal external) + (and (identifier? #'internal) (identifier? #'external)) + (list #'internal #'external)] + [id + (identifier? #'id) + (list #'id #'id)] + [_ (raise-syntax-error #f "expected literal entry" ctx stx)])) + +(define-for-syntax (check-duplicate-literals ctx imports lits datum-lits) + (let ([lit-t (make-hasheq)]) ;; sym => #t + (define (check+enter! key blame-stx) + (when (hash-ref lit-t key #f) + (raise-syntax-error #f (format "duplicate literal: ~a" key) ctx blame-stx)) + (hash-set! lit-t key #t)) + (for ([id+litset (in-list imports)]) + (let ([litset-id (car id+litset)] + [litset (cdr id+litset)]) + (for ([entry (in-list (literalset-literals litset))]) + (cond [(lse:lit? entry) + (check+enter! (lse:lit-internal entry) litset-id)] + [(lse:datum-lit? entry) + (check+enter! (lse:datum-lit-internal entry) litset-id)])))) + (for ([datum-lit (in-list datum-lits)]) + (let ([internal (den:datum-lit-internal datum-lit)]) + (check+enter! (syntax-e internal) internal))) + (for ([lit (in-list lits)]) + (check+enter! (syntax-e (car lit)) (car lit))))) + +(define-syntax (define-literal-set stx) + (syntax-case stx () + [(define-literal-set name . rest) + (let-values ([(chunks rest) + (parse-keyword-options + #'rest + `((#:literal-sets ,check-litset-list) + (#:datum-literals ,check-datum-literals-list) + (#:phase ,check-phase-level) + (#:for-template) + (#:for-syntax) + (#:for-label)) + #:incompatible '((#:phase #:for-template #:for-syntax #:for-label)) + #:context stx + #:no-duplicates? #t)]) + (unless (identifier? #'name) + (raise-syntax-error #f "expected identifier" stx #'name)) + (let ([relphase + (cond [(assq '#:for-template chunks) -1] + [(assq '#:for-syntax chunks) 1] + [(assq '#:for-label chunks) #f] + [else (options-select-value chunks '#:phase #:default 0)])] + [datum-lits + (options-select-value chunks '#:datum-literals #:default null)] + [lits (syntax-case rest () + [( (lit ...) ) + (for/list ([lit (in-list (syntax->list #'(lit ...)))]) + (check-literal-entry/litset lit stx))] + [_ (raise-syntax-error #f "bad syntax" stx)])] + [imports (options-select-value chunks '#:literal-sets #:default null)]) + (check-duplicate-literals stx imports lits datum-lits) + (with-syntax ([((internal external) ...) lits] + [(datum-internal ...) (map den:datum-lit-internal datum-lits)] + [(datum-external ...) (map den:datum-lit-external datum-lits)] + [(litset-id ...) (map car imports)] + [relphase relphase]) + #`(begin + (define phase-of-literals + (and 'relphase + (+ (variable-reference->module-base-phase (#%variable-reference)) + 'relphase))) + (define-syntax name + (make-literalset + (append (literalset-literals (syntax-local-value (quote-syntax litset-id))) + ... + (list (make-lse:lit 'internal + (quote-syntax external) + (quote-syntax phase-of-literals)) + ... + (make-lse:datum-lit 'datum-internal + 'datum-external) + ...)))) + (begin-for-syntax/once + (for ([x (in-list (syntax->list #'(external ...)))]) + (unless (identifier-binding x 'relphase) + (raise-syntax-error #f + (format "literal is unbound in phase ~a~a~a" + 'relphase + (case 'relphase + ((1) " (for-syntax)") + ((-1) " (for-template)") + ((#f) " (for-label)") + (else "")) + " relative to the enclosing module") + (quote-syntax #,stx) x))))))))])) + +#| +NOTES ON PHASES AND BINDINGS + +(module M .... + .... (define-literal-set LS #:phase PL ....) + ....) + +For the expansion of the define-literal-set form, the bindings of the literals +can be accessed by (identifier-binding lit PL), because the phase of the enclosing +module (M) is 0. + +LS may be used, however, in a context where the phase of the enclosing +module is not 0, so each instantiation of LS needs to calculate the +phase of M and add that to PL. + +-- + +Normally, literal sets that define the same name conflict. But it +would be nice to allow them to both be imported in the case where they +refer to the same binding. + +Problem: Can't do the check eagerly, because the binding of L may +change between when define-literal-set is compiled and the comparison +involving L. For example: + + (module M racket + (require stxparse-info/parse) + (define-literal-set LS (lambda)) + (require (only-in some-other-lang lambda)) + .... LS ....) + +The expansion of the LS definition sees a different lambda than the +one that the literal in LS actually refers to. + +Similarly, a literal in LS might not be defined when the expander +runs, but might get defined later. (Although I think that will already +cause an error, so don't worry about that case.) +|# + +;; FIXME: keep one copy of each identifier (?) + +(define-syntax (literal-set->predicate stx) + (syntax-case stx () + [(literal-set->predicate litset-id) + (let ([val (and (identifier? #'litset-id) + (syntax-local-value/record #'litset-id literalset?))]) + (unless val (raise-syntax-error #f "expected literal set name" stx #'litset-id)) + (let ([lits (literalset-literals val)]) + (with-syntax ([((lit phase-var) ...) + (for/list ([lit (in-list lits)] + #:when (lse:lit? lit)) + (list (lse:lit-external lit) (lse:lit-phase lit)))] + [(datum-lit ...) + (for/list ([lit (in-list lits)] + #:when (lse:datum-lit? lit)) + (lse:datum-lit-external lit))]) + #'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...) + '(datum-lit ...)))))])) + +(define (make-literal-set-predicate lits datum-lits) + (lambda (x [phase (syntax-local-phase-level)]) + (or (for/or ([lit (in-list lits)]) + (let ([lit-id (car lit)] + [lit-phase (cadr lit)]) + (free-identifier=? x lit-id phase lit-phase))) + (and (memq (syntax-e x) datum-lits) #t)))) + +;; Literal sets + +(define-literal-set kernel-literals + (begin + begin0 + define-values + define-syntaxes + define-values-for-syntax ;; kept for compat. + begin-for-syntax + set! + let-values + letrec-values + #%plain-lambda + case-lambda + if + quote + quote-syntax + letrec-syntaxes+values + with-continuation-mark + #%expression + #%plain-app + #%top + #%datum + #%variable-reference + module module* #%provide #%require #%declare + #%plain-module-begin)) diff --git a/7-0-0-20/racket/collects/syntax/parse/private/make.rkt b/7-0-0-20/racket/collects/syntax/parse/private/make.rkt new file mode 100644 index 0000000..8a4f744 --- /dev/null +++ b/7-0-0-20/racket/collects/syntax/parse/private/make.rkt @@ -0,0 +1,43 @@ +#lang racket/base +(require (for-syntax racket/base + racket/struct-info)) +(provide make) + +;; get-struct-info : identifier stx -> struct-info-list +(define-for-syntax (get-struct-info id ctx) + (define (bad-struct-name x) + (raise-syntax-error #f "expected struct name" ctx x)) + (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))) + +;; (make struct-name field-expr ...) +;; Checks that correct number of fields given. +(define-syntax (make stx) + (syntax-case stx () + [(make S expr ...) + (let () + (define info (get-struct-info #'S stx)) + (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, got ~s)" + (syntax-e #'S) + num-slots + num-provided) + stx))) + (with-syntax ([constructor constructor]) + (syntax-property #'(constructor expr ...) + 'disappeared-use + #'S)))])) diff --git a/7-0-0-20/racket/collects/syntax/parse/private/runtime-progress.rkt b/7-0-0-20/racket/collects/syntax/parse/private/runtime-progress.rkt new file mode 100644 index 0000000..f76f154 --- /dev/null +++ b/7-0-0-20/racket/collects/syntax/parse/private/runtime-progress.rkt @@ -0,0 +1,257 @@ +#lang racket/base +(require racket/list + syntax/parse/private/minimatch) +(provide ps-empty + ps-add-car + ps-add-cdr + ps-add-stx + ps-add-unbox + ps-add-unvector + ps-add-unpstruct + ps-add-opaque + ps-add-post + ps-add + (struct-out ord) + + ps-pop-opaque + ps-pop-ord + ps-pop-post + ps-context-syntax + ps-difference + + (struct-out failure) + failure* + + expect? + (struct-out expect:thing) + (struct-out expect:atom) + (struct-out expect:literal) + (struct-out expect:message) + (struct-out expect:disj) + (struct-out expect:proper-pair) + + es-add-thing + es-add-message + es-add-atom + es-add-literal + es-add-proper-pair) + +;; FIXME: add phase to expect:literal + +;; == Failure == + +#| +A Failure is (failure PS ExpectStack) + +A FailureSet is one of + - Failure + - (cons FailureSet FailureSet) + +A FailFunction = (FailureSet -> Answer) +|# +(define-struct failure (progress expectstack) #:prefab) + +;; failure* : PS ExpectStack/#f -> Failure/#t +(define (failure* ps es) (if es (failure ps es) #t)) + +;; == Progress == + +#| +Progress (PS) is a non-empty list of Progress Frames (PF). + +A Progress Frame (PF) is one of + - stx ;; "Base" frame, or ~parse/#:with term + - 'car ;; car of pair; also vector->list, unbox, struct->list, etc + - nat ;; Represents that many repeated cdrs + - 'post ;; late/post-traversal check + - #s(ord group index) ;; ~and subpattern, only comparable w/in group + - 'opaque + +The error-reporting context (ie, syntax-parse #:context arg) is always +the final frame. + +All non-stx frames (eg car, cdr) interpreted as applying to nearest following +stx frame. + +A stx frame is introduced + - always at base (that is, by syntax-parse) + - if syntax-parse has #:context arg, then two stx frames at bottom: + (list to-match-stx context-stx) + - by #:with/~parse + - by #:fail-*/#:when/~fail & stx + +Interpretation: later frames are applied first. + eg, (list 'car 1 stx) + means ( car of ( cdr once of stx ) ) + NOT apply car, then apply cdr once, then stop +|# +(define-struct ord (group index) #:prefab) + +(define (ps-empty stx ctx) + (if (eq? stx ctx) + (list stx) + (list stx ctx))) +(define (ps-add-car parent) + (cons 'car parent)) +(define (ps-add-cdr parent [times 1]) + (if (zero? times) + parent + (match (car parent) + [(? exact-positive-integer? n) + (cons (+ times n) (cdr parent))] + [_ + (cons times parent)]))) +(define (ps-add-stx parent stx) + (cons stx parent)) +(define (ps-add-unbox parent) + (ps-add-car parent)) +(define (ps-add-unvector parent) + (ps-add-car parent)) +(define (ps-add-unpstruct parent) + (ps-add-car parent)) +(define (ps-add-opaque parent) + (cons 'opaque parent)) +(define (ps-add parent frame) + (cons frame parent)) +(define (ps-add-post parent) + (cons 'post parent)) + +;; ps-context-syntax : Progress -> syntax +(define (ps-context-syntax ps) + ;; Bottom frame is always syntax + (last ps)) + +;; ps-difference : PS PS -> nat +;; Returns N s.t. B = (ps-add-cdr^N A) +(define (ps-difference a b) + (define-values (a-cdrs a-base) + (match a + [(cons (? exact-positive-integer? a-cdrs) a-base) + (values a-cdrs a-base)] + [_ (values 0 a)])) + (define-values (b-cdrs b-base) + (match b + [(cons (? exact-positive-integer? b-cdrs) b-base) + (values b-cdrs b-base)] + [_ (values 0 b)])) + (unless (eq? a-base b-base) + (error 'ps-difference "INTERNAL ERROR: ~e does not extend ~e" b a)) + (- b-cdrs a-cdrs)) + +;; ps-pop-opaque : PS -> PS +;; Used to continue with progress from opaque head pattern. +(define (ps-pop-opaque ps) + (match ps + [(cons (? exact-positive-integer? n) (cons 'opaque ps*)) + (ps-add-cdr ps* n)] + [(cons 'opaque ps*) + ps*] + [_ (error 'ps-pop-opaque "INTERNAL ERROR: opaque frame not found: ~e" ps)])) + +;; ps-pop-ord : PS -> PS +(define (ps-pop-ord ps) + (match ps + [(cons (? exact-positive-integer? n) (cons (? ord?) ps*)) + (ps-add-cdr ps* n)] + [(cons (? ord?) ps*) + ps*] + [_ (error 'ps-pop-ord "INTERNAL ERROR: ord frame not found: ~e" ps)])) + +;; ps-pop-post : PS -> PS +(define (ps-pop-post ps) + (match ps + [(cons (? exact-positive-integer? n) (cons 'post ps*)) + (ps-add-cdr ps* n)] + [(cons 'post ps*) + ps*] + [_ (error 'ps-pop-post "INTERNAL ERROR: post frame not found: ~e" ps)])) + + +;; == Expectations == + +#| +There are multiple types that use the same structures, optimized for +different purposes. + +-- During parsing, the goal is to minimize/consolidate allocations. + +An ExpectStack (during parsing) is one of + - (expect:thing Progress String Boolean String/#f ExpectStack) + * (expect:message String ExpectStack) + * (expect:atom Datum ExpectStack) + * (expect:literal Identifier ExpectStack) + * (expect:proper-pair FirstDesc ExpectStack) + * #t + +The *-marked variants can only occur at the top of the stack (ie, not +in the next field of another Expect). The top of the stack contains +the most specific information. + +An ExpectStack can also be #f, which means no failure tracking is +requested (and thus no more ExpectStacks should be allocated). + +-- During reporting, the goal is ease of manipulation. + +An ExpectList (during reporting) is (listof Expect). + +An Expect is one of + - (expect:thing #f String #t String/#f StxIdx) + * (expect:message String StxIdx) + * (expect:atom Datum StxIdx) + * (expect:literal Identifier StxIdx) + * (expect:proper-pair FirstDesc StxIdx) + * (expect:disj (NEListof Expect) StxIdx) + - '... + +A StxIdx is (cons Syntax Nat) + +That is, the next link is replaced with the syntax+index of the term +being complained about. An expect:thing's progress is replaced with #f. + +An expect:disj never contains a '... or another expect:disj. + +We write ExpectList when the most specific information comes first and +RExpectList when the most specific information comes last. +|# +(struct expect:thing (term description transparent? role next) #:prefab) +(struct expect:message (message next) #:prefab) +(struct expect:atom (atom next) #:prefab) +(struct expect:literal (literal next) #:prefab) +(struct expect:disj (expects next) #:prefab) +(struct expect:proper-pair (first-desc next) #:prefab) + +(define (expect? x) + (or (expect:thing? x) + (expect:message? x) + (expect:atom? x) + (expect:literal? x) + (expect:disj? x) + (expect:proper-pair? x))) + +(define (es-add-thing ps description transparent? role next) + (if (and next description) + (expect:thing ps description transparent? role next) + next)) + +(define (es-add-message message next) + (if (and next message) + (expect:message message next) + next)) + +(define (es-add-atom atom next) + (and next (expect:atom atom next))) + +(define (es-add-literal literal next) + (and next (expect:literal literal next))) + +(define (es-add-proper-pair first-desc next) + (and next (expect:proper-pair first-desc next))) + +#| +A FirstDesc is one of + - #f -- unknown, multiple possible, etc + - string -- description + - (list 'any) + - (list 'literal symbol) + - (list 'datum datum) +|# diff --git a/7-0-0-20/racket/collects/syntax/parse/private/txlift.rkt b/7-0-0-20/racket/collects/syntax/parse/private/txlift.rkt new file mode 100644 index 0000000..57c5497 --- /dev/null +++ b/7-0-0-20/racket/collects/syntax/parse/private/txlift.rkt @@ -0,0 +1,45 @@ +#lang racket/base +(require (for-template racket/base)) +(provide txlift + get-txlifts-as-definitions + with-txlifts + call/txlifts) + +;; Like lifting definitions, but within a single transformer. + +;; current-liftbox : Parameter of [#f or (Listof (list Id Stx))] +(define current-liftbox (make-parameter #f)) + +(define (call/txlifts proc) + (parameterize ((current-liftbox (box null))) + (proc))) + +(define (txlift expr) + (let ([liftbox (current-liftbox)]) + (check 'txlift liftbox) + (let ([var (car (generate-temporaries '(txlift)))]) + (set-box! liftbox (cons (list var expr) (unbox liftbox))) + var))) + +(define (get-txlifts) + (let ([liftbox (current-liftbox)]) + (check 'get-txlifts liftbox) + (reverse (unbox liftbox)))) + +(define (get-txlifts-as-definitions) + (let ([liftbox (current-liftbox)]) + (check 'get-txlifts-as-definitions liftbox) + (map (lambda (p) + #`(define #,@p)) + (reverse (unbox liftbox))))) + +(define (check who lb) + (unless (box? lb) + (error who "not in a txlift-catching context"))) + +(define (with-txlifts proc) + (call/txlifts + (lambda () + (let ([v (proc)]) + (with-syntax ([((var rhs) ...) (get-txlifts)]) + #`(let* ([var rhs] ...) #,v)))))) diff --git a/7-0-0-20/stxparse-info.scrbl b/7-0-0-20/stxparse-info.scrbl new file mode 100644 index 0000000..902bb92 --- /dev/null +++ b/7-0-0-20/stxparse-info.scrbl @@ -0,0 +1,356 @@ +#lang scribble/manual +@require[racket/require + @for-label[stxparse-info/parse + stxparse-info/parse/experimental/template + stxparse-info/case + stxparse-info/current-pvars + (subtract-in racket/syntax stxparse-info/case) + (subtract-in racket/base stxparse-info/case)] + version-case + @for-syntax[racket/base] + "ovl.rkt"] + +@; Circumvent https://github.com/racket/scribble/issues/79 +@(require scribble/struct + scribble/decode) +@(define (nested-inset . vs) + (nested #:style 'inset vs)) + +@(version-case + [(version< (version) "6.4") + ] + [else + (require scribble/example) + (define ev ((make-eval-factory '(racket))))]) + +@title{@racketmodname[stxparse-info]: Track @racket[syntax-parse] and @racket[syntax-case] pattern vars} +@author[@author+email["Suzanne Soy" "racket@suzanne.soy"]] + +Source code: @url{https://github.com/jsmaniac/stxparse-info} + +@defmodule[stxparse-info] + +This library provides some patched versions of @orig:syntax-parse and of the +@orig:syntax-case family. These patched versions track which syntax pattern +variables are bound. This allows some libraries to change the way syntax +pattern variables work. + +For example, @tt{subtemplate} automatically derives temporary +identifiers when a template contains @racket[yᵢ …], and @racket[xᵢ] is a +pattern variable. To know from which @racket[varᵢ] the @racket[yᵢ …] +identifiers must be derived, @tt{subtemplate} needs to know which +syntax pattern variables are within scope. + +@section{Tracking currently-bound pattern variables with @racket[syntax-parse]} + +@defmodule[stxparse-info/parse] + +The module @racketmodname[stxparse-info/parse] provides patched versions of +@orig:syntax-parse, @orig:syntax-parser and @orig:define/syntax-parse which +track which syntax pattern variables are bound. + +@(ovl syntax/parse + syntax-parse + syntax-parser + define/syntax-parse) + +Additionally, the following identifiers are overridden as they are part of the +duplicated implementation of @racketmodname[syntax/parse]. + +@(ovl #:wrapper nested-inset + syntax/parse + ...+ + attribute + boolean + char + character + define-conventions + define-eh-alternative-set + define-literal-set + define-splicing-syntax-class + define-syntax-class + exact-integer + exact-nonnegative-integer + exact-positive-integer + expr + expr/c + id + identifier + integer + kernel-literals + keyword + literal-set->predicate + nat + number + pattern + static + str + syntax-parse-state-cons! + syntax-parse-state-ref + syntax-parse-state-set! + syntax-parse-state-update! + syntax-parse-track-literals + this-syntax + ~! + ~and + ~between + ~bind + ~commit + ~datum + ~delimit-cut + ~describe + ~do + ~fail + ~literal + ~not + ~once + ~optional + ~or + ~parse + ~peek + ~peek-not + ~post + ~rest + ~seq + ~undo + ~var) + +@(version-case + [(version>= (version) "6.9.0.6") + (ovl #:wrapper nested-inset + syntax/parse + ~alt + ~or*)] + [else (begin)]) + +@(ovl #:wrapper nested-inset + #:require (for-template syntax/parse) + syntax/parse + pattern-expander? + pattern-expander + prop:pattern-expander + syntax-local-syntax-parse-pattern-introduce) + +@section{Tracking currently-bound pattern variables with @racket[syntax-case]} + +@defmodule[stxparse-info/case] + +The module @racketmodname[stxparse-info/case] provides patched versions of +@orig:syntax-case, @orig:syntax-case*, @orig:with-syntax, +@orig:define/with-syntax, @orig:datum-case and @orig:with-datum which +track which syntax or datum pattern variables are bound. + +@(ovl racket/base + syntax-case + syntax-case* + with-syntax) + +@(ovl syntax/datum + datum-case + with-datum) + +@(ovl racket/syntax + define/with-syntax) + +@section{Reading and updating the list of currently-bound pattern variables} + +@defmodule[stxparse-info/current-pvars] + +@defproc[#:kind "procedure at phase 1" + (current-pvars) (listof identifier?)]{ + This for-syntax procedure returns the list of syntax pattern variables which + are known to be bound. The most recently bound variables are at the beginning + of the list. + + It is the responsibility of the reader to check that the identifiers are + bound, and that they are bound to syntax pattern variables, for example using + @racket[identifier-binding] and @racket[syntax-pattern-variable?]. This allows + libraries to also track variables bound by match-like forms, for example.} + +@defproc[#:kind "procedure at phase 1" + (current-pvars+unique) (listof (pairof identifier? identifier?))]{ + This for-syntax procedure works like @racket[current-pvars], but associates + each syntax pattern variable with an identifier containing a unique symbol + which is generated at each execution of the code recording the pattern + variable via @racket[with-pvars] or @racket[define-pvars]. + + The @racket[car] of each pair in the returned list is the syntax pattern + variable (as produced by @racket[current-pvars]). It is the responsibility of + the reader to check that the identifiers present in the @racket[car] of each + element of the returned list are bound, and that they are bound to syntax + pattern variables, for example using @racket[identifier-binding] and + @racket[syntax-pattern-variable?]. This allows libraries to also track + variables bound by match-like forms, for example. + + The @racket[cdr] of each pair is the identifier of a temporary variable. + Reading that temporary variable produces a @racket[gensym]-ed symbol, which + was generated at run-time at the point where @racket[with-pvars] or + @racket[define-pvars] was used to record the corresponding pattern variable. + + This can be used to associate run-time data with each syntax pattern + variable, via a weak hash table created with @racket[make-weak-hasheq]. For + example, the @tt{subtemplate} library implicitly derives + identifiers (similarly to @racket[generate-temporaries]) for uses of + @racket[yᵢ ...] from a @racket[xᵢ] pattern variable bearing the same + subscript. The generated identifiers are associated with @racket[xᵢ] via this + weak hash table mechanism, so that two uses of @racket[yᵢ ...] within the + scope of the same @racket[xᵢ] binding derive the same identifiers. + + The code @racket[(with-pvars (v) body)] roughly expands to: + + @racketblock[ + (let-values ([(tmp) (gensym 'v)]) + (letrec-syntaxes+values ([(shadow-current-pvars) + (list* (cons (quote-syntax v) + (quote-syntax tmp)) + old-current-pvars)]) + body))] + + @bold{Caveat:} this entails that the fresh symbol stored in @racket[tmp] is + generated when @racket[with-pvars] or @racket[define-pvars] is called, not + when the syntax pattern variable is actually bound. For example: + + @RACKETBLOCK[ + (define-syntax (get-current-pvars+unique stx) + #`'#,(current-pvars+unique)) + + (require racket/private/sc) + (let ([my-valvar (quote-syntax x)]) + (let-syntax ([my-pvar (make-syntax-mapping 0 (quote-syntax my-valvar))]) + (with-pvars (x) + (get-current-pvars+unique)) (code:comment "'([x . g123])") + (with-pvars (x) + (get-current-pvars+unique)))) (code:comment "'([x . g124])")] + + Under normal circumstances, @racket[with-pvars] @racket[define-pvars] should + be called immediately after binding the syntax pattern variable, but the code + above shows that it is technically possible to do otherwise. + + This caveat is not meant to dissuade the use of + @racket[current-pvars+unique], it rather serves as an explanation of the + behaviour encountered when @racket[with-pvars] or @racket[define-pvars] are + incorrectly used more than once to record the same pattern variable.} + +@defform[(with-pvars (pvar ...) . body) + #:contracts ([pvar identifier?])]{ + Prepends the given @racket[pvar ...] to the list of pattern variables which + are known to be bound. The @racket[pvar ...] are prepended in reverse order, + so within the body of + + @racketblock[(with-pvars (v₁ v₂ v₃) . body)] + + a call to the for-syntax function @racket[(current-pvars)] returns: + + @racketblock[(list* (quote-syntax v₃) (quote-syntax v₂) (quote-syntax v₁) + old-current-pvars)] + + This can be used to implement macros which work similarly to + @racket[syntax-parse] or @racket[syntax-case], and have them record the syntax + pattern variables which they bind. + + Note that the identifiers @racket[pvar ...] must already be bound to syntax + pattern variables when @racket[with-pvars] is used, e.g. + + @racketblock[ + (let-syntax ([v₁ (make-syntax-mapping depth (quote-syntax valvar))] + [v₂ (make-syntax-mapping depth (quote-syntax valvar))]) + (with-pvars (v₁ v₂) + code))] + + instead of: + + @racketblock[ + (with-pvars (v₁ v₂) + (let-syntax ([v₁ (make-syntax-mapping depth (quote-syntax valvar))] + [v₂ (make-syntax-mapping depth (quote-syntax valvar))]) + code))]} + +@defform[(define-pvars pvar ...) + #:contracts ([pvar identifier?])]{ + + Prepends the given @racket[pvar ...] to the list of pattern variables which + are known to be bound, in the same way as @racket[with-pvars]. Whereas + @racket[with-pvars] makes the modified list visible in the @racket[_body], + @racket[define-pvars] makes the modified list visible in the statements + following @racket[define-pvars]. @racket[define-pvars] can be used multiple + times within the same @racket[let] or equivalent. + + This can be used to implement macros which work similarly to + @racket[define/syntax-parse] or @racket[define/with-syntax], and have them + record the syntax pattern variables which they bind. + + @(version-case + [(version< (version) "6.4") + @RACKETBLOCK[ + (let () + (code:comment "Alternate version of define/syntax-parse which") + (code:comment "contains (define-pvars x) in its expanded form.") + (define/syntax-parse x #'1) + (define/syntax-parse y #'2) + (define-syntax (get-pvars stx) + #`'#,(current-pvars)) + (get-pvars)) + (code:comment "=> '(y x)")]] + [else + @examples[ + #:eval ev + #:hidden + (require stxparse-info/parse + stxparse-info/current-pvars + racket/syntax + (for-syntax racket/base))] + + @examples[ + #:eval ev + #:escape UNSYNTAX + (eval:check + (let () + (code:comment "Alternate version of define/syntax-parse which") + (code:comment "contains (define-pvars x) in its expanded form.") + (define/syntax-parse x #'1) + (define/syntax-parse y #'2) + (define-syntax (get-pvars stx) + #`'#,(current-pvars)) + (get-pvars)) + '(y x))]])} + +@section{Extensions to @racketmodname[syntax/parse/experimental/template]} + +@defmodule[stxparse-info/parse/experimental/template] + +@(orig syntax/parse/experimental/template + define-template-metafunction) + +@defidform[define-template-metafunction]{ + Overloaded version of @orig:define-template-metafunction from + @racketmodname[syntax/parse/experimental/template]. + + Note that currently, template metafunctions defined via + @racketmodname[stxparse-info/parse/experimental/template] are not compatible + with the forms from @racketmodname[syntax/parse/experimental/template], and + vice versa. There is a pending Pull Request which would make the necessary + primitives from @racketmodname[syntax/parse/experimental/template] public, so + hopefully this problem will be solved in future versions.} + +@defform[(syntax-local-template-metafunction-introduce stx)]{ + Like @racket[syntax-local-introduce], but for + @tech[#:doc '(lib "syntax/scribblings/syntax.scrbl")]{template metafunctions}. + + This change is also available in the package + @racketmodname{backport-template-pr1514}. It has been submitted as a Pull + Request to Racket, but can already be used in + @racketmodname[stxparse-info/parse/experimental/template] right now.} + +@(ovl syntax/parse/experimental/template + template + quasitemplate + template/loc + quasitemplate/loc) + +Additionally, the following identifiers are overridden as they are part of the +duplicated implementation of @racketmodname[syntax/parse]. + +@(ovl #:wrapper nested-inset + syntax/parse/experimental/template + ?? + ?@) diff --git a/7-3-0-1/racket/collects/syntax/parse/define.rkt b/7-3-0-1/racket/collects/syntax/parse/define.rkt new file mode 100644 index 0000000..28e5148 --- /dev/null +++ b/7-3-0-1/racket/collects/syntax/parse/define.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require (for-syntax racket/base + stxparse-info/parse + "private/sc.rkt")) +(provide define-simple-macro + define-syntax-parser + (for-syntax (all-from-out stxparse-info/parse))) + +(define-syntax (define-simple-macro stx) + (syntax-parse stx + [(define-simple-macro (~and (macro:id . _) pattern) . body) + #`(define-syntax macro + (syntax-parser/template + #,((make-syntax-introducer) stx) + [pattern . body]))])) + +(define-simple-macro (define-syntax-parser macro:id option-or-clause ...) + (define-syntax macro + (syntax-parser option-or-clause ...))) + diff --git a/7-3-0-1/racket/collects/syntax/parse/experimental/dset.rkt b/7-3-0-1/racket/collects/syntax/parse/experimental/dset.rkt new file mode 100644 index 0000000..57c53e5 --- /dev/null +++ b/7-3-0-1/racket/collects/syntax/parse/experimental/dset.rkt @@ -0,0 +1,54 @@ +#lang racket/base + +;; A dset is an `equal?`-based set, but it preserves order based on +;; the history of additions, so that if items are added in a +;; deterministic order, they come back out in a deterministic order. + +(provide dset + dset-empty? + dset->list + dset-add + dset-union + dset-subtract + dset-filter) + +(define dset + (case-lambda + [() (hash)] + [(e) (hash e 0)])) + +(define (dset-empty? ds) + (zero? (hash-count ds))) + +(define (dset->list ds) + (map cdr + (sort (for/list ([(k v) (in-hash ds)]) + (cons v k)) + < + #:key car))) + +(define (dset-add ds e) + (if (hash-ref ds e #f) + ds + (hash-set ds e (hash-count ds)))) + +(define (dset-union ds1 ds2) + (cond + [((hash-count ds1) . > . (hash-count ds2)) + (dset-union ds2 ds1)] + [else + (for/fold ([ds2 ds2]) ([e (dset->list ds1)]) + (dset-add ds2 e))])) + +(define (dset-subtract ds1 ds2) + ;; ! takes O(size(ds2)) time ! + (for/fold ([r (dset)]) ([e (in-list (dset->list ds1))]) + (if (hash-ref ds2 e #f) + r + (dset-add r e)))) + +(define (dset-filter ds pred) + (for/fold ([r (dset)]) ([e (in-list (dset->list ds))]) + (if (pred e) + (dset-add r e) + r))) diff --git a/7-3-0-1/racket/collects/syntax/parse/experimental/eh.rkt b/7-3-0-1/racket/collects/syntax/parse/experimental/eh.rkt new file mode 100644 index 0000000..f8e1b09 --- /dev/null +++ b/7-3-0-1/racket/collects/syntax/parse/experimental/eh.rkt @@ -0,0 +1,5 @@ +#lang racket/base +(require "../private/sc.rkt" + syntax/parse/private/keywords) +(provide ~eh-var + define-eh-alternative-set) diff --git a/7-3-0-1/racket/collects/syntax/parse/lib/function-header.rkt b/7-3-0-1/racket/collects/syntax/parse/lib/function-header.rkt new file mode 100644 index 0000000..79e80f3 --- /dev/null +++ b/7-3-0-1/racket/collects/syntax/parse/lib/function-header.rkt @@ -0,0 +1,112 @@ +#lang racket/base + +(require "../../parse.rkt" + "../experimental/template.rkt" + racket/dict) + +(provide function-header formal formals) + +(define-syntax-class function-header + (pattern ((~or header:function-header name:id) . args:formals) + #:attr params + (template ((?@ . (?? header.params ())) + . args.params)))) + +(define-syntax-class formals + #:attributes (params) + (pattern (arg:formal ...) + #:attr params #'(arg.name ...) + #:fail-when (check-duplicate-identifier (syntax->list #'params)) + "duplicate argument name" + #:fail-when (check-duplicate (attribute arg.kw) + #:same? (λ (x y) + (and x y (equal? (syntax-e x) + (syntax-e y))))) + "duplicate keyword for argument" + #:fail-when (invalid-option-placement + (attribute arg.name) (attribute arg.default)) + "default-value expression missing") + (pattern (arg:formal ... . rest:id) + #:attr params #'(arg.name ... rest) + #:fail-when (check-duplicate-identifier (syntax->list #'params)) + "duplicate argument name" + #:fail-when (check-duplicate (attribute arg.kw) + #:same? (λ (x y) + (and x y (equal? (syntax-e x) + (syntax-e y))))) + "duplicate keyword for argument" + #:fail-when (invalid-option-placement + (attribute arg.name) (attribute arg.default)) + "default-value expression missing")) + +(define-splicing-syntax-class formal + #:attributes (name kw default) + (pattern name:id + #:attr kw #f + #:attr default #f) + (pattern [name:id default] + #:attr kw #f) + (pattern (~seq kw:keyword name:id) + #:attr default #f) + (pattern (~seq kw:keyword [name:id default]))) + +;; invalid-option-placement : (Listof Id) (Listof Syntax/#f) -> Id/#f +;; Checks for mandatory argument after optional argument; if found, returns +;; identifier of mandatory argument. +(define (invalid-option-placement names defaults) + ;; find-mandatory : (Listof Id) (Listof Syntax/#f) -> Id/#f + ;; Finds first name w/o corresponding default. + (define (find-mandatory names defaults) + (for/first ([name (in-list names)] + [default (in-list defaults)] + #:when (not default)) + name)) + ;; Skip through mandatory args until first optional found, then search + ;; for another mandatory. + (let loop ([names names] [defaults defaults]) + (cond [(or (null? names) (null? defaults)) + #f] + [(eq? (car defaults) #f) ;; mandatory + (loop (cdr names) (cdr defaults))] + [else ;; found optional + (find-mandatory (cdr names) (cdr defaults))]))) + +;; Copied from unstable/list +;; check-duplicate : (listof X) +;; #:key (X -> K) +;; #:same? (or/c (K K -> bool) dict?) +;; -> X or #f +(define (check-duplicate items + #:key [key values] + #:same? [same? equal?]) + (cond [(procedure? same?) + (cond [(eq? same? equal?) + (check-duplicate/t items key (make-hash) #t)] + [(eq? same? eq?) + (check-duplicate/t items key (make-hasheq) #t)] + [(eq? same? eqv?) + (check-duplicate/t items key (make-hasheqv) #t)] + [else + (check-duplicate/list items key same?)])] + [(dict? same?) + (let ([dict same?]) + (if (dict-mutable? dict) + (check-duplicate/t items key dict #t) + (check-duplicate/t items key dict #f)))])) +(define (check-duplicate/t items key table mutating?) + (let loop ([items items] [table table]) + (and (pair? items) + (let ([key-item (key (car items))]) + (if (dict-ref table key-item #f) + (car items) + (loop (cdr items) (if mutating? + (begin (dict-set! table key-item #t) table) + (dict-set table key-item #t)))))))) +(define (check-duplicate/list items key same?) + (let loop ([items items] [sofar null]) + (and (pair? items) + (let ([key-item (key (car items))]) + (if (for/or ([prev (in-list sofar)]) + (same? key-item prev)) + (car items) + (loop (cdr items) (cons key-item sofar))))))) diff --git a/7-3-0-1/racket/collects/syntax/parse/private/3d-stx.rkt b/7-3-0-1/racket/collects/syntax/parse/private/3d-stx.rkt new file mode 100644 index 0000000..b5083d5 --- /dev/null +++ b/7-3-0-1/racket/collects/syntax/parse/private/3d-stx.rkt @@ -0,0 +1,250 @@ +#lang racket/base +(require (only-in '#%flfxnum flvector? fxvector?) + (only-in '#%extfl extflonum? extflvector?)) +(provide 2d-stx? + check-datum) + +;; Checks for 3D syntax (syntax that contains unwritable values, etc) + +(define INIT-FUEL #e1e6) + +;; TO DO: +;; - extension via proc (any -> list/#f), +;; value considered good if result is list, all values in list are good + +;; -- + +#| +Some other predicates one might like to have: + - would (read (write x)) succeed and be equal/similar to x? + - would (datum->syntax #f x) succeed? + - would (syntax->datum (datum->syntax #f x)) succeed and be equal/similar to x? + - would (eval (read (write (compile `(quote ,x))))) succeed and be equal/similar to x? + +where equal/similar could mean one of the following: + - equal?, which equates eg (vector 1 2 3) and (vector-immutable 1 2 3) + - equal? relaxed to equate eg mutable and immutable hashes (but not prefabs) + - equal? but also requiring same mutability at every point + +Some aux definitions: + +(define (rt x) + (define-values (in out) (make-pipe)) + (write x out) + (close-output-port out) + (read in)) + +(define (wrsd x) + (define-values (in out) (make-pipe)) + (write x out) + (close-output-port out) + (syntax->datum (read-syntax #f in))) + +(define (dsd x) + (syntax->datum (datum->syntax #f x))) + +(define (evalc x) ;; mimics compiled zo-file constraints + (eval (rt (compile `(quote ,x))))) + +How mutability behaves: + - for vectors, boxes: + - read always mutable + - read-syntax always immutable + - (dsd x) always immutable + - (evalc x) always immutable + - for hashes: + - read always immutable + - (dsd x) same as x + - (evalc x) always immutable (!!!) + - for prefab structs: + - read same as x + - read-syntax same as x + - (dsd x) same as x + - (evalc x) same as x + +Symbols + - (dsd x) same as x + - (evalc x) preserves interned, unreadable, makes new uninterned (loses eq-ness) + +Chaperones allow the lazy generation of infinite trees of data +undetectable by eq?-based cycle detection. Might be helpful to have +chaperone-eq? (not recursive, just chaperones of same object) and +chaperone-eq?-hash-code, to use with make-custom-hash.) + +Impersonators allow the lazy generation of infinite trees of data, +period. + +|# + +;; ---- + +;; 2d-stx? : any ... -> boolean +;; Would (write (compile `(quote-syntax ,x))) succeed? +;; If traverse-syntax? is #t, recurs into existing syntax +;; If traverse-syntax? is #f, assumes existing stxobjs are 2d, and only +;; checks if *new* 3d syntax would be created. +(define (2d-stx? x + #:traverse-syntax? [traverse-syntax? #t] + #:irritant [irritant-box #f]) + (check-datum x + #:syntax-mode (if traverse-syntax? 'compound 'atomic) + #:allow-impersonators? #f + #:allow-mutable? 'no-hash/prefab + #:allow-unreadable-symbols? #t + #:allow-cycles? #t + #:irritant irritant-box)) + +;; ---- + +;; check-datum : any ... -> boolean +;; where StxMode = (U 'atomic 'compound #f) +;; Returns nat if x is "good", #f if "bad" +;; If irritant-b is a box, the first bad subvalue found is put in the box. +;; If visited-t is a hash, it is used to detect cycles. +(define (check-datum x + #:syntax-mode [stx-mode #f] + #:allow-impersonators? [allow-impersonators? #f] + #:allow-mutable? [allow-mutable? #f] + #:allow-unreadable-symbols? [allow-unreadable? #f] + #:allow-cycles? [allow-cycles? #f] + #:irritant [irritant-b #f]) + ;; Try once with some fuel. If runs out of fuel, try again with cycle checking. + (define (run fuel visited-t) + (check* x fuel visited-t + stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles? + irritant-b)) + (let ([result (run INIT-FUEL #f)]) + (cond [(not (equal? result 0)) ;; nat>0 or #f + (and result #t)] + [else + ;; (eprintf "out of fuel, restarting\n") + (and (run +inf.0 (make-hasheq)) #t)]))) + +;; check* : any nat/+inf.0 StxMode boolean boolean boolean box -> nat/#f +;; Returns #f if bad, positive nat if good, 0 if ran out of fuel +;; If bad, places bad subvalue in irritant-b, if box +(define (check* x0 fuel0 visited-t + stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles? + irritant-b) + (define no-mutable? (not allow-mutable?)) + (define no-mutable-hash/prefab? (or no-mutable? (eq? allow-mutable? 'no-hash/prefab))) + (define no-cycle? (not allow-cycles?)) + (define no-impersonator? (not allow-impersonators?)) + (define (loop x fuel) + (if (and fuel (not (zero? fuel))) + (loop* x fuel) + fuel)) + (define (loop* x fuel) + (define (bad) (when irritant-b (set-box! irritant-b x)) #f) + (define-syntax-rule (with-mutable-check mutable? body ...) ;; don't use for hash or prefab + (cond [(and no-mutable? mutable?) + (bad)] + [else + body ...])) + (define-syntax-rule (with-cycle-check body ...) + (cond [(and visited-t (hash-ref visited-t x #f)) + => (lambda (status) + (cond [(and no-cycle? (eq? status 'traversing)) + (bad)] + [else + fuel]))] + [else + (when visited-t + (hash-set! visited-t x 'traversing)) + (begin0 (begin body ...) + (when visited-t + (hash-remove! visited-t x)))])) + ;; (eprintf "-- checking ~s, fuel ~s\n" x fuel) + (cond + ;; Immutable compound + [(and visited-t (list? x)) + ;; space optimization: if list (finite), no need to store all cdr pairs in cycle table + ;; don't do unless visited-t present, else expands fuel by arbitrary factors + (with-cycle-check + (for/fold ([fuel (sub1 fuel)]) ([e (in-list x)] #:break (not fuel)) + (loop e fuel)))] + [(pair? x) + (with-cycle-check + (let ([fuel (loop (car x) (sub1 fuel))]) + (loop (cdr x) fuel)))] + ;; Atomic + [(or (null? x) + (boolean? x) + (number? x) + (char? x) + (keyword? x) + (regexp? x) + (byte-regexp? x) + (extflonum? x)) + fuel] + [(symbol? x) + (cond [(symbol-interned? x) + fuel] + [(symbol-unreadable? x) + (if allow-unreadable? fuel (bad))] + [else ;; uninterned + (if (eq? allow-unreadable? #t) fuel (bad))])] + ;; Mutable flat + [(or (string? x) + (bytes? x)) + (with-mutable-check (not (immutable? x)) + fuel)] + [(or (fxvector? x) + (flvector? x) + (extflvector? x)) + (with-mutable-check (not (immutable? x)) + fuel)] + ;; Syntax + [(syntax? x) + (case stx-mode + ((atomic) fuel) + ((compound) (loop (syntax-e x) fuel)) + (else (bad)))] + ;; Impersonators and chaperones + [(and no-impersonator? (impersonator? x)) ;; else continue to chaperoned type + (bad)] + [(and no-impersonator? (chaperone? x)) ;; else continue to impersonated type + (bad)] + [else + (with-cycle-check + (cond + ;; Mutable (maybe) compound + [(vector? x) + (with-mutable-check (not (immutable? x)) + (for/fold ([fuel fuel]) ([e (in-vector x)] #:break (not fuel)) + (loop e fuel)))] + [(box? x) + (with-mutable-check (not (immutable? x)) + (loop (unbox x) (sub1 fuel)))] + [(prefab-struct-key x) + => (lambda (key) + (cond [(and no-mutable-hash/prefab? (mutable-prefab-key? key)) + (bad)] + [else + ;; traverse key, since contains arbitrary auto-value + (let ([fuel (loop key fuel)]) + (loop (struct->vector x) fuel))]))] + [(hash? x) + (cond [(and no-mutable-hash/prefab? (not (immutable? x))) + (bad)] + [else + (for/fold ([fuel fuel]) ([(k v) (in-hash x)] #:break (not fuel)) + (let ([fuel (loop k fuel)]) + (loop v fuel)))])] + ;; Bad + [else + (bad)]))])) + (loop x0 fuel0)) + +;; mutable-prefab-key? : prefab-key -> boolean +(define (mutable-prefab-key? key) + ;; A prefab-key is either + ;; - symbol + ;; - (list* symbol maybe-nat maybe-list maybe-vector prefab-key) + ;; where mutable fields indicated by vector + ;; This code is probably overly general; racket seems to normalize keys. + (let loop ([k key]) + (and (pair? k) + (or (and (vector? (car k)) + (positive? (vector-length (car k)))) + (loop (cdr k)))))) diff --git a/7-3-0-1/racket/collects/syntax/parse/private/litconv.rkt b/7-3-0-1/racket/collects/syntax/parse/private/litconv.rkt new file mode 100644 index 0000000..559791f --- /dev/null +++ b/7-3-0-1/racket/collects/syntax/parse/private/litconv.rkt @@ -0,0 +1,284 @@ +#lang racket/base +(require (for-syntax racket/base + racket/lazy-require + "sc.rkt" + "lib.rkt" + syntax/parse/private/kws + racket/syntax) + syntax/parse/private/residual-ct ;; keep abs. path + stxparse-info/parse/private/residual) ;; keep abs. path +(begin-for-syntax + (lazy-require + [syntax/private/keyword (options-select-value parse-keyword-options)] + [stxparse-info/parse/private/rep ;; keep abs. path + (parse-kw-formals + check-conventions-rules + check-datum-literals-list + create-aux-def)])) +;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require) +;; Without this, dependencies don't get collected. +(require racket/runtime-path racket/syntax (for-meta 2 '#%kernel)) +(define-runtime-module-path-index _unused_ 'stxparse-info/parse/private/rep) + +(provide define-conventions + define-literal-set + literal-set->predicate + kernel-literals) + +(define-syntax (define-conventions stx) + + (define-syntax-class header + #:description "name or name with formal parameters" + #:commit + (pattern name:id + #:with formals #'() + #:attr arity (arity 0 0 null null)) + (pattern (name:id . formals) + #:attr arity (parse-kw-formals #'formals #:context stx))) + + (syntax-parse stx + [(define-conventions h:header rule ...) + (let () + (define rules (check-conventions-rules #'(rule ...) stx)) + (define rxs (map car rules)) + (define dens0 (map cadr rules)) + (define den+defs-list + (for/list ([den0 (in-list dens0)]) + (let-values ([(den defs) (create-aux-def den0)]) + (cons den defs)))) + (define dens (map car den+defs-list)) + (define defs (apply append (map cdr den+defs-list))) + + (define/with-syntax (rx ...) rxs) + (define/with-syntax (def ...) defs) + (define/with-syntax (parser ...) + (map den:delayed-parser dens)) + (define/with-syntax (class-name ...) + (map den:delayed-class dens)) + + ;; FIXME: could move make-den:delayed to user of conventions + ;; and eliminate from residual.rkt + #'(begin + (define-syntax h.name + (make-conventions + (quote-syntax get-parsers) + (lambda () + (let ([class-names (list (quote-syntax class-name) ...)]) + (map list + (list 'rx ...) + (map make-den:delayed + (generate-temporaries class-names) + class-names)))))) + (define get-parsers + (lambda formals + def ... + (list parser ...)))))])) + +(define-for-syntax (check-phase-level stx ctx) + (unless (or (exact-integer? (syntax-e stx)) + (eq? #f (syntax-e stx))) + (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx)) + stx) + +;; check-litset-list : stx stx -> (listof (cons id literalset)) +(define-for-syntax (check-litset-list stx ctx) + (syntax-case stx () + [(litset-id ...) + (for/list ([litset-id (syntax->list #'(litset-id ...))]) + (let* ([val (and (identifier? litset-id) + (syntax-local-value/record litset-id literalset?))]) + (if val + (cons litset-id val) + (raise-syntax-error #f "expected literal set name" ctx litset-id))))] + [_ (raise-syntax-error #f "expected list of literal set names" ctx stx)])) + +;; check-literal-entry/litset : stx stx -> (list id id) +(define-for-syntax (check-literal-entry/litset stx ctx) + (syntax-case stx () + [(internal external) + (and (identifier? #'internal) (identifier? #'external)) + (list #'internal #'external)] + [id + (identifier? #'id) + (list #'id #'id)] + [_ (raise-syntax-error #f "expected literal entry" ctx stx)])) + +(define-for-syntax (check-duplicate-literals ctx imports lits datum-lits) + (let ([lit-t (make-hasheq)]) ;; sym => #t + (define (check+enter! key blame-stx) + (when (hash-ref lit-t key #f) + (raise-syntax-error #f (format "duplicate literal: ~a" key) ctx blame-stx)) + (hash-set! lit-t key #t)) + (for ([id+litset (in-list imports)]) + (let ([litset-id (car id+litset)] + [litset (cdr id+litset)]) + (for ([entry (in-list (literalset-literals litset))]) + (cond [(lse:lit? entry) + (check+enter! (lse:lit-internal entry) litset-id)] + [(lse:datum-lit? entry) + (check+enter! (lse:datum-lit-internal entry) litset-id)])))) + (for ([datum-lit (in-list datum-lits)]) + (let ([internal (den:datum-lit-internal datum-lit)]) + (check+enter! (syntax-e internal) internal))) + (for ([lit (in-list lits)]) + (check+enter! (syntax-e (car lit)) (car lit))))) + +(define-syntax (define-literal-set stx) + (syntax-case stx () + [(define-literal-set name . rest) + (let-values ([(chunks rest) + (parse-keyword-options + #'rest + `((#:literal-sets ,check-litset-list) + (#:datum-literals ,check-datum-literals-list) + (#:phase ,check-phase-level) + (#:for-template) + (#:for-syntax) + (#:for-label)) + #:incompatible '((#:phase #:for-template #:for-syntax #:for-label)) + #:context stx + #:no-duplicates? #t)]) + (unless (identifier? #'name) + (raise-syntax-error #f "expected identifier" stx #'name)) + (let ([relphase + (cond [(assq '#:for-template chunks) -1] + [(assq '#:for-syntax chunks) 1] + [(assq '#:for-label chunks) #f] + [else (options-select-value chunks '#:phase #:default 0)])] + [datum-lits + (options-select-value chunks '#:datum-literals #:default null)] + [lits (syntax-case rest () + [( (lit ...) ) + (for/list ([lit (in-list (syntax->list #'(lit ...)))]) + (check-literal-entry/litset lit stx))] + [_ (raise-syntax-error #f "bad syntax" stx)])] + [imports (options-select-value chunks '#:literal-sets #:default null)]) + (check-duplicate-literals stx imports lits datum-lits) + (with-syntax ([((internal external) ...) lits] + [(datum-internal ...) (map den:datum-lit-internal datum-lits)] + [(datum-external ...) (map den:datum-lit-external datum-lits)] + [(litset-id ...) (map car imports)] + [relphase relphase]) + #`(begin + (define phase-of-literals + (and 'relphase + (+ (variable-reference->module-base-phase (#%variable-reference)) + 'relphase))) + (define-syntax name + (make-literalset + (append (literalset-literals (syntax-local-value (quote-syntax litset-id))) + ... + (list (make-lse:lit 'internal + (quote-syntax external) + (quote-syntax phase-of-literals)) + ... + (make-lse:datum-lit 'datum-internal + 'datum-external) + ...)))) + (begin-for-syntax/once + (for ([x (in-list (syntax->list #'(external ...)))]) + (unless (identifier-binding x 'relphase) + (raise-syntax-error #f + (format "literal is unbound in phase ~a~a~a" + 'relphase + (case 'relphase + ((1) " (for-syntax)") + ((-1) " (for-template)") + ((#f) " (for-label)") + (else "")) + " relative to the enclosing module") + (quote-syntax #,stx) x))))))))])) + +#| +NOTES ON PHASES AND BINDINGS + +(module M .... + .... (define-literal-set LS #:phase PL ....) + ....) + +For the expansion of the define-literal-set form, the bindings of the literals +can be accessed by (identifier-binding lit PL), because the phase of the enclosing +module (M) is 0. + +LS may be used, however, in a context where the phase of the enclosing +module is not 0, so each instantiation of LS needs to calculate the +phase of M and add that to PL. + +-- + +Normally, literal sets that define the same name conflict. But it +would be nice to allow them to both be imported in the case where they +refer to the same binding. + +Problem: Can't do the check eagerly, because the binding of L may +change between when define-literal-set is compiled and the comparison +involving L. For example: + + (module M racket + (require stxparse-info/parse) + (define-literal-set LS (lambda)) + (require (only-in some-other-lang lambda)) + .... LS ....) + +The expansion of the LS definition sees a different lambda than the +one that the literal in LS actually refers to. + +Similarly, a literal in LS might not be defined when the expander +runs, but might get defined later. (Although I think that will already +cause an error, so don't worry about that case.) +|# + +;; FIXME: keep one copy of each identifier (?) + +(define-syntax (literal-set->predicate stx) + (syntax-case stx () + [(literal-set->predicate litset-id) + (let ([val (and (identifier? #'litset-id) + (syntax-local-value/record #'litset-id literalset?))]) + (unless val (raise-syntax-error #f "expected literal set name" stx #'litset-id)) + (let ([lits (literalset-literals val)]) + (with-syntax ([((lit phase-var) ...) + (for/list ([lit (in-list lits)] + #:when (lse:lit? lit)) + (list (lse:lit-external lit) (lse:lit-phase lit)))] + [(datum-lit ...) + (for/list ([lit (in-list lits)] + #:when (lse:datum-lit? lit)) + (lse:datum-lit-external lit))]) + #'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...) + '(datum-lit ...)))))])) + +(define (make-literal-set-predicate lits datum-lits) + (lambda (x [phase (syntax-local-phase-level)]) + (or (for/or ([lit (in-list lits)]) + (let ([lit-id (car lit)] + [lit-phase (cadr lit)]) + (free-identifier=? x lit-id phase lit-phase))) + (and (memq (syntax-e x) datum-lits) #t)))) + +;; Literal sets + +(define-literal-set kernel-literals + (begin + begin0 + define-values + define-syntaxes + define-values-for-syntax ;; kept for compat. + begin-for-syntax + set! + let-values + letrec-values + #%plain-lambda + case-lambda + if + quote + quote-syntax + letrec-syntaxes+values + with-continuation-mark + #%expression + #%plain-app + #%top + #%datum + #%variable-reference + module module* #%provide #%require #%declare + #%plain-module-begin)) diff --git a/7-3-0-1/racket/collects/syntax/parse/private/make.rkt b/7-3-0-1/racket/collects/syntax/parse/private/make.rkt new file mode 100644 index 0000000..8a4f744 --- /dev/null +++ b/7-3-0-1/racket/collects/syntax/parse/private/make.rkt @@ -0,0 +1,43 @@ +#lang racket/base +(require (for-syntax racket/base + racket/struct-info)) +(provide make) + +;; get-struct-info : identifier stx -> struct-info-list +(define-for-syntax (get-struct-info id ctx) + (define (bad-struct-name x) + (raise-syntax-error #f "expected struct name" ctx x)) + (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))) + +;; (make struct-name field-expr ...) +;; Checks that correct number of fields given. +(define-syntax (make stx) + (syntax-case stx () + [(make S expr ...) + (let () + (define info (get-struct-info #'S stx)) + (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, got ~s)" + (syntax-e #'S) + num-slots + num-provided) + stx))) + (with-syntax ([constructor constructor]) + (syntax-property #'(constructor expr ...) + 'disappeared-use + #'S)))])) diff --git a/7-3-0-1/racket/collects/syntax/parse/private/runtime-progress.rkt b/7-3-0-1/racket/collects/syntax/parse/private/runtime-progress.rkt new file mode 100644 index 0000000..f76f154 --- /dev/null +++ b/7-3-0-1/racket/collects/syntax/parse/private/runtime-progress.rkt @@ -0,0 +1,257 @@ +#lang racket/base +(require racket/list + syntax/parse/private/minimatch) +(provide ps-empty + ps-add-car + ps-add-cdr + ps-add-stx + ps-add-unbox + ps-add-unvector + ps-add-unpstruct + ps-add-opaque + ps-add-post + ps-add + (struct-out ord) + + ps-pop-opaque + ps-pop-ord + ps-pop-post + ps-context-syntax + ps-difference + + (struct-out failure) + failure* + + expect? + (struct-out expect:thing) + (struct-out expect:atom) + (struct-out expect:literal) + (struct-out expect:message) + (struct-out expect:disj) + (struct-out expect:proper-pair) + + es-add-thing + es-add-message + es-add-atom + es-add-literal + es-add-proper-pair) + +;; FIXME: add phase to expect:literal + +;; == Failure == + +#| +A Failure is (failure PS ExpectStack) + +A FailureSet is one of + - Failure + - (cons FailureSet FailureSet) + +A FailFunction = (FailureSet -> Answer) +|# +(define-struct failure (progress expectstack) #:prefab) + +;; failure* : PS ExpectStack/#f -> Failure/#t +(define (failure* ps es) (if es (failure ps es) #t)) + +;; == Progress == + +#| +Progress (PS) is a non-empty list of Progress Frames (PF). + +A Progress Frame (PF) is one of + - stx ;; "Base" frame, or ~parse/#:with term + - 'car ;; car of pair; also vector->list, unbox, struct->list, etc + - nat ;; Represents that many repeated cdrs + - 'post ;; late/post-traversal check + - #s(ord group index) ;; ~and subpattern, only comparable w/in group + - 'opaque + +The error-reporting context (ie, syntax-parse #:context arg) is always +the final frame. + +All non-stx frames (eg car, cdr) interpreted as applying to nearest following +stx frame. + +A stx frame is introduced + - always at base (that is, by syntax-parse) + - if syntax-parse has #:context arg, then two stx frames at bottom: + (list to-match-stx context-stx) + - by #:with/~parse + - by #:fail-*/#:when/~fail & stx + +Interpretation: later frames are applied first. + eg, (list 'car 1 stx) + means ( car of ( cdr once of stx ) ) + NOT apply car, then apply cdr once, then stop +|# +(define-struct ord (group index) #:prefab) + +(define (ps-empty stx ctx) + (if (eq? stx ctx) + (list stx) + (list stx ctx))) +(define (ps-add-car parent) + (cons 'car parent)) +(define (ps-add-cdr parent [times 1]) + (if (zero? times) + parent + (match (car parent) + [(? exact-positive-integer? n) + (cons (+ times n) (cdr parent))] + [_ + (cons times parent)]))) +(define (ps-add-stx parent stx) + (cons stx parent)) +(define (ps-add-unbox parent) + (ps-add-car parent)) +(define (ps-add-unvector parent) + (ps-add-car parent)) +(define (ps-add-unpstruct parent) + (ps-add-car parent)) +(define (ps-add-opaque parent) + (cons 'opaque parent)) +(define (ps-add parent frame) + (cons frame parent)) +(define (ps-add-post parent) + (cons 'post parent)) + +;; ps-context-syntax : Progress -> syntax +(define (ps-context-syntax ps) + ;; Bottom frame is always syntax + (last ps)) + +;; ps-difference : PS PS -> nat +;; Returns N s.t. B = (ps-add-cdr^N A) +(define (ps-difference a b) + (define-values (a-cdrs a-base) + (match a + [(cons (? exact-positive-integer? a-cdrs) a-base) + (values a-cdrs a-base)] + [_ (values 0 a)])) + (define-values (b-cdrs b-base) + (match b + [(cons (? exact-positive-integer? b-cdrs) b-base) + (values b-cdrs b-base)] + [_ (values 0 b)])) + (unless (eq? a-base b-base) + (error 'ps-difference "INTERNAL ERROR: ~e does not extend ~e" b a)) + (- b-cdrs a-cdrs)) + +;; ps-pop-opaque : PS -> PS +;; Used to continue with progress from opaque head pattern. +(define (ps-pop-opaque ps) + (match ps + [(cons (? exact-positive-integer? n) (cons 'opaque ps*)) + (ps-add-cdr ps* n)] + [(cons 'opaque ps*) + ps*] + [_ (error 'ps-pop-opaque "INTERNAL ERROR: opaque frame not found: ~e" ps)])) + +;; ps-pop-ord : PS -> PS +(define (ps-pop-ord ps) + (match ps + [(cons (? exact-positive-integer? n) (cons (? ord?) ps*)) + (ps-add-cdr ps* n)] + [(cons (? ord?) ps*) + ps*] + [_ (error 'ps-pop-ord "INTERNAL ERROR: ord frame not found: ~e" ps)])) + +;; ps-pop-post : PS -> PS +(define (ps-pop-post ps) + (match ps + [(cons (? exact-positive-integer? n) (cons 'post ps*)) + (ps-add-cdr ps* n)] + [(cons 'post ps*) + ps*] + [_ (error 'ps-pop-post "INTERNAL ERROR: post frame not found: ~e" ps)])) + + +;; == Expectations == + +#| +There are multiple types that use the same structures, optimized for +different purposes. + +-- During parsing, the goal is to minimize/consolidate allocations. + +An ExpectStack (during parsing) is one of + - (expect:thing Progress String Boolean String/#f ExpectStack) + * (expect:message String ExpectStack) + * (expect:atom Datum ExpectStack) + * (expect:literal Identifier ExpectStack) + * (expect:proper-pair FirstDesc ExpectStack) + * #t + +The *-marked variants can only occur at the top of the stack (ie, not +in the next field of another Expect). The top of the stack contains +the most specific information. + +An ExpectStack can also be #f, which means no failure tracking is +requested (and thus no more ExpectStacks should be allocated). + +-- During reporting, the goal is ease of manipulation. + +An ExpectList (during reporting) is (listof Expect). + +An Expect is one of + - (expect:thing #f String #t String/#f StxIdx) + * (expect:message String StxIdx) + * (expect:atom Datum StxIdx) + * (expect:literal Identifier StxIdx) + * (expect:proper-pair FirstDesc StxIdx) + * (expect:disj (NEListof Expect) StxIdx) + - '... + +A StxIdx is (cons Syntax Nat) + +That is, the next link is replaced with the syntax+index of the term +being complained about. An expect:thing's progress is replaced with #f. + +An expect:disj never contains a '... or another expect:disj. + +We write ExpectList when the most specific information comes first and +RExpectList when the most specific information comes last. +|# +(struct expect:thing (term description transparent? role next) #:prefab) +(struct expect:message (message next) #:prefab) +(struct expect:atom (atom next) #:prefab) +(struct expect:literal (literal next) #:prefab) +(struct expect:disj (expects next) #:prefab) +(struct expect:proper-pair (first-desc next) #:prefab) + +(define (expect? x) + (or (expect:thing? x) + (expect:message? x) + (expect:atom? x) + (expect:literal? x) + (expect:disj? x) + (expect:proper-pair? x))) + +(define (es-add-thing ps description transparent? role next) + (if (and next description) + (expect:thing ps description transparent? role next) + next)) + +(define (es-add-message message next) + (if (and next message) + (expect:message message next) + next)) + +(define (es-add-atom atom next) + (and next (expect:atom atom next))) + +(define (es-add-literal literal next) + (and next (expect:literal literal next))) + +(define (es-add-proper-pair first-desc next) + (and next (expect:proper-pair first-desc next))) + +#| +A FirstDesc is one of + - #f -- unknown, multiple possible, etc + - string -- description + - (list 'any) + - (list 'literal symbol) + - (list 'datum datum) +|# diff --git a/7-3-0-1/racket/collects/syntax/parse/private/txlift.rkt b/7-3-0-1/racket/collects/syntax/parse/private/txlift.rkt new file mode 100644 index 0000000..57c5497 --- /dev/null +++ b/7-3-0-1/racket/collects/syntax/parse/private/txlift.rkt @@ -0,0 +1,45 @@ +#lang racket/base +(require (for-template racket/base)) +(provide txlift + get-txlifts-as-definitions + with-txlifts + call/txlifts) + +;; Like lifting definitions, but within a single transformer. + +;; current-liftbox : Parameter of [#f or (Listof (list Id Stx))] +(define current-liftbox (make-parameter #f)) + +(define (call/txlifts proc) + (parameterize ((current-liftbox (box null))) + (proc))) + +(define (txlift expr) + (let ([liftbox (current-liftbox)]) + (check 'txlift liftbox) + (let ([var (car (generate-temporaries '(txlift)))]) + (set-box! liftbox (cons (list var expr) (unbox liftbox))) + var))) + +(define (get-txlifts) + (let ([liftbox (current-liftbox)]) + (check 'get-txlifts liftbox) + (reverse (unbox liftbox)))) + +(define (get-txlifts-as-definitions) + (let ([liftbox (current-liftbox)]) + (check 'get-txlifts-as-definitions liftbox) + (map (lambda (p) + #`(define #,@p)) + (reverse (unbox liftbox))))) + +(define (check who lb) + (unless (box? lb) + (error who "not in a txlift-catching context"))) + +(define (with-txlifts proc) + (call/txlifts + (lambda () + (let ([v (proc)]) + (with-syntax ([((var rhs) ...) (get-txlifts)]) + #`(let* ([var rhs] ...) #,v)))))) diff --git a/scribblings/stxparse-info.scrbl-7-3-0-1 b/7-3-0-1/stxparse-info.scrbl similarity index 100% rename from scribblings/stxparse-info.scrbl-7-3-0-1 rename to 7-3-0-1/stxparse-info.scrbl diff --git a/case/stxcase-scheme.rkt b/case/stxcase-scheme.rkt index e49f2d0..eeafe73 100644 --- a/case/stxcase-scheme.rkt +++ b/case/stxcase-scheme.rkt @@ -3,11 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../6-11/racket/collects/racket/private/stxcase-scheme.rkt")] - [(version< (version) "6.90.0.29") - ;; TODO: this seems like a bug, it should be 6-12 - (my-include "../6-11/racket/collects/racket/private/stxcase-scheme.rkt")] - [else - (my-include "../6-90-0-29/racket/collects/racket/private/stxcase-scheme.rkt")]) +(my-include "../" "/racket/collects/racket/private/stxcase-scheme.rkt") diff --git a/case/stxcase.rkt b/case/stxcase.rkt index fded7e8..0ac9e9b 100644 --- a/case/stxcase.rkt +++ b/case/stxcase.rkt @@ -3,11 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../6-11/racket/collects/racket/private/stxcase.rkt")] - [(version< (version) "6.90.0.29") - ;; TODO: this seems like a bug, it should be 6-12 - (my-include "../6-11/racket/collects/racket/private/stxcase.rkt")] - [else - (my-include "../6-90-0-29/racket/collects/racket/private/stxcase.rkt")]) +(my-include "../" "/racket/collects/racket/private/stxcase.rkt") diff --git a/case/stxloc.rkt b/case/stxloc.rkt index 4a4904a..37b5bfb 100644 --- a/case/stxloc.rkt +++ b/case/stxloc.rkt @@ -3,11 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../6-11/racket/collects/racket/private/stxloc.rkt")] - [(version< (version) "6.90.0.29") - ;; TODO: this seems like a bug, it should be 6-12 - (my-include "../6-11/racket/collects/racket/private/stxloc.rkt")] - [else - (my-include "../6-90-0-29/racket/collects/racket/private/stxloc.rkt")]) +(my-include "../" "/racket/collects/racket/private/stxloc.rkt") diff --git a/case/syntax.rkt b/case/syntax.rkt index 41fbc83..33c37a2 100644 --- a/case/syntax.rkt +++ b/case/syntax.rkt @@ -3,11 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../6-11/racket/collects/racket/private/syntax.rkt")] - [(version< (version) "6.90.0.29") - ;; TODO: this seems like a bug, it should be 6-12 - (my-include "../6-11/racket/collects/racket/private/syntax.rkt")] - [else - (my-include "../6-90-0-29/racket/collects/racket/private/syntax.rkt")]) +(my-include "../" "/racket/collects/racket/private/syntax.rkt") diff --git a/case/template.rkt b/case/template.rkt index b46e478..49c9abb 100644 --- a/case/template.rkt +++ b/case/template.rkt @@ -3,10 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (begin)] - [(version< (version) "6.90.0.29") - (begin)] - [else - (my-include "../6-90-0-29/racket/collects/racket/private/template.rkt")]) +(my-include "../" "/racket/collects/racket/private/template.rkt") diff --git a/case/with-stx.rkt b/case/with-stx.rkt index 2228da1..335bea7 100644 --- a/case/with-stx.rkt +++ b/case/with-stx.rkt @@ -3,11 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../6-11/racket/collects/racket/private/with-stx.rkt")] - [(version< (version) "6.90.0.29") - ;; TODO: this seems like a bug, should be 6-12 - (my-include "../6-11/racket/collects/racket/private/with-stx.rkt")] - [else - (my-include "../6-90-0-29/racket/collects/racket/private/with-stx.rkt")]) +(my-include "../" "/racket/collects/racket/private/with-stx.rkt") diff --git a/info.rkt b/info.rkt index 476b1b8..c66219f 100644 --- a/info.rkt +++ b/info.rkt @@ -11,6 +11,8 @@ "racket-doc" "at-exp-lib")) ;; for the documentation only (define scribblings '(("scribblings/stxparse-info.scrbl" () ("Syntax Extensions")))) +(define compile-omit-paths '("6-11" "6-12" "6-90-0-29" "7-0-0-20" "7-3-0-1")) (define pkg-desc "Description Here") (define version "0.0") (define pkg-authors '(Suzanne Soy)) + diff --git a/my-include.rkt b/my-include.rkt index 8e57ff9..f419dd6 100644 --- a/my-include.rkt +++ b/my-include.rkt @@ -1,15 +1,16 @@ #lang racket (provide my-include) -(require (for-syntax mzlib/etc)) +(require version-case + (for-syntax mzlib/etc)) -(define-syntax (my-include stx) - (syntax-case stx () - [(_ filename) - (string? (syntax-e #'filename)) - #'(begin - (define-syntax (tmp _stx) - (my-include2 (this-expression-source-directory filename) filename)) - (tmp))])) +(define-for-syntax (my-include1 esrcdir) + (lambda (filename) + (with-syntax ([esrcdir esrcdir] + [filename filename]) + #'(begin + (define-syntax (tmp _stx) + (my-include2 (this-expression-source-directory esrcdir) filename)) + (tmp))))) (define-for-syntax (my-include2 dirname filename) (let ([filename (build-path dirname @@ -21,4 +22,25 @@ [(-module name . rest) #'(begin (module name . rest) (require 'name) - (provide (all-from-out 'name)))]))) \ No newline at end of file + (provide (all-from-out 'name)))]))) + +(define-syntax (my-include stx) + (syntax-case stx () + [(_ updir filename) + (and (string? (syntax-e #'updir)) + (string? (syntax-e #'filename))) + (let ([-updir (syntax-e #'updir)] + [-filename (syntax-e #'filename)] + [my-include1 (my-include1 #'filename)] + [loc (lambda (x) (quasisyntax/loc #'filename #,x))]) + #`(version-case + [(version< (version) "6.11.0.900") + #,(my-include1 (loc (string-append -updir "6-11" -filename)))] + [(version< (version) "6.90.0.29") + #,(my-include1 (loc (string-append -updir "6-12" -filename)))] + [(version< (version) "7.0.0.20") + #,(my-include1 (loc (string-append -updir "6-90-0-29" -filename)))] + [(version< (version) "7.3.0.1") + #,(my-include1 (loc (string-append -updir "7-0-0-20" -filename)))] + [else + #,(my-include1 (loc (string-append -updir "7-3-0-1" -filename)))]))])) diff --git a/parse.rkt b/parse.rkt index c4f7309..64828f4 100644 --- a/parse.rkt +++ b/parse.rkt @@ -3,8 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "7.3.0.1") - (my-include "7-0-0-20/racket/collects/syntax/parse.rkt")] - [else - (my-include "7-3-0-1/racket/collects/syntax/parse.rkt")]) +(my-include "" "/racket/collects/syntax/parse.rkt") diff --git a/parse/debug.rkt b/parse/debug.rkt index 7809ddd..f671b3b 100644 --- a/parse/debug.rkt +++ b/parse/debug.rkt @@ -3,14 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../6-11/racket/collects/syntax/parse/debug.rkt")] - [(version< (version) "6.90.0.29") - (my-include "../6-12/racket/collects/syntax/parse/debug.rkt")] - [(version< (version) "7.0.0.20") - (my-include "../6-90-0-29/racket/collects/syntax/parse/debug.rkt")] - [(version< (version) "7.3.0.1") - (my-include "../7-0-0-20/racket/collects/syntax/parse/debug.rkt")] - [else - (my-include "../7-3-0-1/racket/collects/syntax/parse/debug.rkt")]) +(my-include "../" "/racket/collects/syntax/parse/debug.rkt") diff --git a/parse/define.rkt b/parse/define.rkt index 28e5148..a2a2f4c 100644 --- a/parse/define.rkt +++ b/parse/define.rkt @@ -1,20 +1,6 @@ #lang racket/base -(require (for-syntax racket/base - stxparse-info/parse - "private/sc.rkt")) -(provide define-simple-macro - define-syntax-parser - (for-syntax (all-from-out stxparse-info/parse))) - -(define-syntax (define-simple-macro stx) - (syntax-parse stx - [(define-simple-macro (~and (macro:id . _) pattern) . body) - #`(define-syntax macro - (syntax-parser/template - #,((make-syntax-introducer) stx) - [pattern . body]))])) - -(define-simple-macro (define-syntax-parser macro:id option-or-clause ...) - (define-syntax macro - (syntax-parser option-or-clause ...))) - +(#%require version-case + (for-syntax (only racket/base version) + (only racket/base #%app #%datum)) + stxparse-info/my-include) +(my-include "../" "/racket/collects/syntax/parse/define.rkt") diff --git a/parse/experimental/contract.rkt b/parse/experimental/contract.rkt index 7763155..27818cc 100644 --- a/parse/experimental/contract.rkt +++ b/parse/experimental/contract.rkt @@ -3,8 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "7.3.0.1") - (my-include "../../7-0-0-20/racket/collects/syntax/parse/experimental/contract.rkt")] - [else - (my-include "../../7-3-0-1/racket/collects/syntax/parse/experimental/contract.rkt")]) +(my-include "../../" "/racket/collects/syntax/parse/experimental/contract.rkt") diff --git a/parse/experimental/dset.rkt b/parse/experimental/dset.rkt index 57c53e5..ea35613 100644 --- a/parse/experimental/dset.rkt +++ b/parse/experimental/dset.rkt @@ -1,54 +1,6 @@ #lang racket/base - -;; A dset is an `equal?`-based set, but it preserves order based on -;; the history of additions, so that if items are added in a -;; deterministic order, they come back out in a deterministic order. - -(provide dset - dset-empty? - dset->list - dset-add - dset-union - dset-subtract - dset-filter) - -(define dset - (case-lambda - [() (hash)] - [(e) (hash e 0)])) - -(define (dset-empty? ds) - (zero? (hash-count ds))) - -(define (dset->list ds) - (map cdr - (sort (for/list ([(k v) (in-hash ds)]) - (cons v k)) - < - #:key car))) - -(define (dset-add ds e) - (if (hash-ref ds e #f) - ds - (hash-set ds e (hash-count ds)))) - -(define (dset-union ds1 ds2) - (cond - [((hash-count ds1) . > . (hash-count ds2)) - (dset-union ds2 ds1)] - [else - (for/fold ([ds2 ds2]) ([e (dset->list ds1)]) - (dset-add ds2 e))])) - -(define (dset-subtract ds1 ds2) - ;; ! takes O(size(ds2)) time ! - (for/fold ([r (dset)]) ([e (in-list (dset->list ds1))]) - (if (hash-ref ds2 e #f) - r - (dset-add r e)))) - -(define (dset-filter ds pred) - (for/fold ([r (dset)]) ([e (in-list (dset->list ds))]) - (if (pred e) - (dset-add r e) - r))) +(#%require version-case + (for-syntax (only racket/base version) + (only racket/base #%app #%datum)) + stxparse-info/my-include) +(my-include "../../" "/racket/collects/syntax/parse/experimental/dset.rkt") diff --git a/parse/experimental/eh.rkt b/parse/experimental/eh.rkt index f8e1b09..5c917f2 100644 --- a/parse/experimental/eh.rkt +++ b/parse/experimental/eh.rkt @@ -1,5 +1,6 @@ #lang racket/base -(require "../private/sc.rkt" - syntax/parse/private/keywords) -(provide ~eh-var - define-eh-alternative-set) +(#%require version-case + (for-syntax (only racket/base version) + (only racket/base #%app #%datum)) + stxparse-info/my-include) +(my-include "../../" "/racket/collects/syntax/parse/experimental/eh.rkt") diff --git a/parse/experimental/private/substitute.rkt b/parse/experimental/private/substitute.rkt index b6c647f..51708d5 100644 --- a/parse/experimental/private/substitute.rkt +++ b/parse/experimental/private/substitute.rkt @@ -3,8 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../../../6-11/racket/collects/syntax/parse/experimental/private/substitute.rkt")] - [else - (begin)]) +(my-include "../../../" "/racket/collects/syntax/parse/experimental/substitute.rkt") diff --git a/parse/experimental/provide.rkt b/parse/experimental/provide.rkt index 15e28eb..f830fa9 100644 --- a/parse/experimental/provide.rkt +++ b/parse/experimental/provide.rkt @@ -3,10 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../../6-11/racket/collects/syntax/parse/experimental/provide.rkt")] - [(version< (version) "6.90.0.29") - (my-include "../../6-12/racket/collects/syntax/parse/experimental/provide.rkt")] - [else - (my-include "../../6-90-0-29/racket/collects/syntax/parse/experimental/provide.rkt")]) +(my-include "../../" "/racket/collects/syntax/parse/experimental/provide.rkt") diff --git a/parse/experimental/reflect.rkt b/parse/experimental/reflect.rkt index e9c1f54..9d56058 100644 --- a/parse/experimental/reflect.rkt +++ b/parse/experimental/reflect.rkt @@ -3,12 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../../6-11/racket/collects/syntax/parse/experimental/reflect.rkt")] - [(version< (version) "6.90.0.29") - (my-include "../../6-12/racket/collects/syntax/parse/experimental/reflect.rkt")] - [(version< (version) "7.0.0.20") - (my-include "../../6-90-0-29/racket/collects/syntax/parse/experimental/reflect.rkt")] - [else - (my-include "../../7-0-0-20/racket/collects/syntax/parse/experimental/reflect.rkt")]) +(my-include "../../" "/racket/collects/syntax/parse/experimental/reflect.rkt") diff --git a/parse/experimental/specialize.rkt b/parse/experimental/specialize.rkt index 8ad42bd..603840a 100644 --- a/parse/experimental/specialize.rkt +++ b/parse/experimental/specialize.rkt @@ -3,10 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../../6-11/racket/collects/syntax/parse/experimental/specialize.rkt")] - [(version< (version) "6.90.0.29") - (my-include "../../6-12/racket/collects/syntax/parse/experimental/specialize.rkt")] - [else - (my-include "../../6-90-0-29/racket/collects/syntax/parse/experimental/specialize.rkt")]) +(my-include "../../" "/racket/collects/syntax/parse/experimental/specialize.rkt") diff --git a/parse/experimental/splicing.rkt b/parse/experimental/splicing.rkt index 83fe4d1..52e10ef 100644 --- a/parse/experimental/splicing.rkt +++ b/parse/experimental/splicing.rkt @@ -3,10 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../../6-11/racket/collects/syntax/parse/experimental/splicing.rkt")] - [(version< (version) "6.90.0.29") - (my-include "../../6-12/racket/collects/syntax/parse/experimental/splicing.rkt")] - [else - (my-include "../../6-90-0-29/racket/collects/syntax/parse/experimental/splicing.rkt")]) +(my-include "../../" "/racket/collects/syntax/parse/experimental/splicing.rkt") diff --git a/parse/experimental/template.rkt b/parse/experimental/template.rkt index 409ec1d..82626dd 100644 --- a/parse/experimental/template.rkt +++ b/parse/experimental/template.rkt @@ -3,10 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../../6-11/racket/collects/syntax/parse/experimental/template.rkt")] - [(version< (version) "6.90.0.29") - (my-include "../../6-12/racket/collects/syntax/parse/experimental/template.rkt")] - [else - (my-include "../../6-90-0-29/racket/collects/syntax/parse/experimental/template.rkt")]) +(my-include "../../" "/racket/collects/syntax/parse/experimental/template.rkt") diff --git a/parse/lib/function-header.rkt b/parse/lib/function-header.rkt index 79e80f3..afdc0f7 100644 --- a/parse/lib/function-header.rkt +++ b/parse/lib/function-header.rkt @@ -1,112 +1,6 @@ #lang racket/base - -(require "../../parse.rkt" - "../experimental/template.rkt" - racket/dict) - -(provide function-header formal formals) - -(define-syntax-class function-header - (pattern ((~or header:function-header name:id) . args:formals) - #:attr params - (template ((?@ . (?? header.params ())) - . args.params)))) - -(define-syntax-class formals - #:attributes (params) - (pattern (arg:formal ...) - #:attr params #'(arg.name ...) - #:fail-when (check-duplicate-identifier (syntax->list #'params)) - "duplicate argument name" - #:fail-when (check-duplicate (attribute arg.kw) - #:same? (λ (x y) - (and x y (equal? (syntax-e x) - (syntax-e y))))) - "duplicate keyword for argument" - #:fail-when (invalid-option-placement - (attribute arg.name) (attribute arg.default)) - "default-value expression missing") - (pattern (arg:formal ... . rest:id) - #:attr params #'(arg.name ... rest) - #:fail-when (check-duplicate-identifier (syntax->list #'params)) - "duplicate argument name" - #:fail-when (check-duplicate (attribute arg.kw) - #:same? (λ (x y) - (and x y (equal? (syntax-e x) - (syntax-e y))))) - "duplicate keyword for argument" - #:fail-when (invalid-option-placement - (attribute arg.name) (attribute arg.default)) - "default-value expression missing")) - -(define-splicing-syntax-class formal - #:attributes (name kw default) - (pattern name:id - #:attr kw #f - #:attr default #f) - (pattern [name:id default] - #:attr kw #f) - (pattern (~seq kw:keyword name:id) - #:attr default #f) - (pattern (~seq kw:keyword [name:id default]))) - -;; invalid-option-placement : (Listof Id) (Listof Syntax/#f) -> Id/#f -;; Checks for mandatory argument after optional argument; if found, returns -;; identifier of mandatory argument. -(define (invalid-option-placement names defaults) - ;; find-mandatory : (Listof Id) (Listof Syntax/#f) -> Id/#f - ;; Finds first name w/o corresponding default. - (define (find-mandatory names defaults) - (for/first ([name (in-list names)] - [default (in-list defaults)] - #:when (not default)) - name)) - ;; Skip through mandatory args until first optional found, then search - ;; for another mandatory. - (let loop ([names names] [defaults defaults]) - (cond [(or (null? names) (null? defaults)) - #f] - [(eq? (car defaults) #f) ;; mandatory - (loop (cdr names) (cdr defaults))] - [else ;; found optional - (find-mandatory (cdr names) (cdr defaults))]))) - -;; Copied from unstable/list -;; check-duplicate : (listof X) -;; #:key (X -> K) -;; #:same? (or/c (K K -> bool) dict?) -;; -> X or #f -(define (check-duplicate items - #:key [key values] - #:same? [same? equal?]) - (cond [(procedure? same?) - (cond [(eq? same? equal?) - (check-duplicate/t items key (make-hash) #t)] - [(eq? same? eq?) - (check-duplicate/t items key (make-hasheq) #t)] - [(eq? same? eqv?) - (check-duplicate/t items key (make-hasheqv) #t)] - [else - (check-duplicate/list items key same?)])] - [(dict? same?) - (let ([dict same?]) - (if (dict-mutable? dict) - (check-duplicate/t items key dict #t) - (check-duplicate/t items key dict #f)))])) -(define (check-duplicate/t items key table mutating?) - (let loop ([items items] [table table]) - (and (pair? items) - (let ([key-item (key (car items))]) - (if (dict-ref table key-item #f) - (car items) - (loop (cdr items) (if mutating? - (begin (dict-set! table key-item #t) table) - (dict-set table key-item #t)))))))) -(define (check-duplicate/list items key same?) - (let loop ([items items] [sofar null]) - (and (pair? items) - (let ([key-item (key (car items))]) - (if (for/or ([prev (in-list sofar)]) - (same? key-item prev)) - (car items) - (loop (cdr items) (cons key-item sofar))))))) +(#%require version-case + (for-syntax (only racket/base version) + (only racket/base #%app #%datum)) + stxparse-info/my-include) +(my-include "../../" "/racket/collects/syntax/parse/lib/function-header.rkt") diff --git a/parse/pre.rkt b/parse/pre.rkt index 502200c..9410ab9 100644 --- a/parse/pre.rkt +++ b/parse/pre.rkt @@ -3,12 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../6-11/racket/collects/syntax/parse/pre.rkt")] - [(version< (version) "6.90.0.29") - (my-include "../6-12/racket/collects/syntax/parse/pre.rkt")] - [(version< (version) "7.0.0.20") - (my-include "../6-90-0-29/racket/collects/syntax/parse/pre.rkt")] - [else - (my-include "../7-0-0-20/racket/collects/syntax/parse/pre.rkt")]) +(my-include "../" "/racket/collects/syntax/parse/pre.rkt") diff --git a/parse/private/3d-stx.rkt b/parse/private/3d-stx.rkt index b5083d5..8f429c1 100644 --- a/parse/private/3d-stx.rkt +++ b/parse/private/3d-stx.rkt @@ -1,250 +1,7 @@ #lang racket/base -(require (only-in '#%flfxnum flvector? fxvector?) - (only-in '#%extfl extflonum? extflvector?)) -(provide 2d-stx? - check-datum) +(#%require version-case + (for-syntax (only racket/base version) + (only racket/base #%app #%datum)) + stxparse-info/my-include) +(my-include "../../" "/racket/collects/syntax/parse/private/3d-stx.rkt") -;; Checks for 3D syntax (syntax that contains unwritable values, etc) - -(define INIT-FUEL #e1e6) - -;; TO DO: -;; - extension via proc (any -> list/#f), -;; value considered good if result is list, all values in list are good - -;; -- - -#| -Some other predicates one might like to have: - - would (read (write x)) succeed and be equal/similar to x? - - would (datum->syntax #f x) succeed? - - would (syntax->datum (datum->syntax #f x)) succeed and be equal/similar to x? - - would (eval (read (write (compile `(quote ,x))))) succeed and be equal/similar to x? - -where equal/similar could mean one of the following: - - equal?, which equates eg (vector 1 2 3) and (vector-immutable 1 2 3) - - equal? relaxed to equate eg mutable and immutable hashes (but not prefabs) - - equal? but also requiring same mutability at every point - -Some aux definitions: - -(define (rt x) - (define-values (in out) (make-pipe)) - (write x out) - (close-output-port out) - (read in)) - -(define (wrsd x) - (define-values (in out) (make-pipe)) - (write x out) - (close-output-port out) - (syntax->datum (read-syntax #f in))) - -(define (dsd x) - (syntax->datum (datum->syntax #f x))) - -(define (evalc x) ;; mimics compiled zo-file constraints - (eval (rt (compile `(quote ,x))))) - -How mutability behaves: - - for vectors, boxes: - - read always mutable - - read-syntax always immutable - - (dsd x) always immutable - - (evalc x) always immutable - - for hashes: - - read always immutable - - (dsd x) same as x - - (evalc x) always immutable (!!!) - - for prefab structs: - - read same as x - - read-syntax same as x - - (dsd x) same as x - - (evalc x) same as x - -Symbols - - (dsd x) same as x - - (evalc x) preserves interned, unreadable, makes new uninterned (loses eq-ness) - -Chaperones allow the lazy generation of infinite trees of data -undetectable by eq?-based cycle detection. Might be helpful to have -chaperone-eq? (not recursive, just chaperones of same object) and -chaperone-eq?-hash-code, to use with make-custom-hash.) - -Impersonators allow the lazy generation of infinite trees of data, -period. - -|# - -;; ---- - -;; 2d-stx? : any ... -> boolean -;; Would (write (compile `(quote-syntax ,x))) succeed? -;; If traverse-syntax? is #t, recurs into existing syntax -;; If traverse-syntax? is #f, assumes existing stxobjs are 2d, and only -;; checks if *new* 3d syntax would be created. -(define (2d-stx? x - #:traverse-syntax? [traverse-syntax? #t] - #:irritant [irritant-box #f]) - (check-datum x - #:syntax-mode (if traverse-syntax? 'compound 'atomic) - #:allow-impersonators? #f - #:allow-mutable? 'no-hash/prefab - #:allow-unreadable-symbols? #t - #:allow-cycles? #t - #:irritant irritant-box)) - -;; ---- - -;; check-datum : any ... -> boolean -;; where StxMode = (U 'atomic 'compound #f) -;; Returns nat if x is "good", #f if "bad" -;; If irritant-b is a box, the first bad subvalue found is put in the box. -;; If visited-t is a hash, it is used to detect cycles. -(define (check-datum x - #:syntax-mode [stx-mode #f] - #:allow-impersonators? [allow-impersonators? #f] - #:allow-mutable? [allow-mutable? #f] - #:allow-unreadable-symbols? [allow-unreadable? #f] - #:allow-cycles? [allow-cycles? #f] - #:irritant [irritant-b #f]) - ;; Try once with some fuel. If runs out of fuel, try again with cycle checking. - (define (run fuel visited-t) - (check* x fuel visited-t - stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles? - irritant-b)) - (let ([result (run INIT-FUEL #f)]) - (cond [(not (equal? result 0)) ;; nat>0 or #f - (and result #t)] - [else - ;; (eprintf "out of fuel, restarting\n") - (and (run +inf.0 (make-hasheq)) #t)]))) - -;; check* : any nat/+inf.0 StxMode boolean boolean boolean box -> nat/#f -;; Returns #f if bad, positive nat if good, 0 if ran out of fuel -;; If bad, places bad subvalue in irritant-b, if box -(define (check* x0 fuel0 visited-t - stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles? - irritant-b) - (define no-mutable? (not allow-mutable?)) - (define no-mutable-hash/prefab? (or no-mutable? (eq? allow-mutable? 'no-hash/prefab))) - (define no-cycle? (not allow-cycles?)) - (define no-impersonator? (not allow-impersonators?)) - (define (loop x fuel) - (if (and fuel (not (zero? fuel))) - (loop* x fuel) - fuel)) - (define (loop* x fuel) - (define (bad) (when irritant-b (set-box! irritant-b x)) #f) - (define-syntax-rule (with-mutable-check mutable? body ...) ;; don't use for hash or prefab - (cond [(and no-mutable? mutable?) - (bad)] - [else - body ...])) - (define-syntax-rule (with-cycle-check body ...) - (cond [(and visited-t (hash-ref visited-t x #f)) - => (lambda (status) - (cond [(and no-cycle? (eq? status 'traversing)) - (bad)] - [else - fuel]))] - [else - (when visited-t - (hash-set! visited-t x 'traversing)) - (begin0 (begin body ...) - (when visited-t - (hash-remove! visited-t x)))])) - ;; (eprintf "-- checking ~s, fuel ~s\n" x fuel) - (cond - ;; Immutable compound - [(and visited-t (list? x)) - ;; space optimization: if list (finite), no need to store all cdr pairs in cycle table - ;; don't do unless visited-t present, else expands fuel by arbitrary factors - (with-cycle-check - (for/fold ([fuel (sub1 fuel)]) ([e (in-list x)] #:break (not fuel)) - (loop e fuel)))] - [(pair? x) - (with-cycle-check - (let ([fuel (loop (car x) (sub1 fuel))]) - (loop (cdr x) fuel)))] - ;; Atomic - [(or (null? x) - (boolean? x) - (number? x) - (char? x) - (keyword? x) - (regexp? x) - (byte-regexp? x) - (extflonum? x)) - fuel] - [(symbol? x) - (cond [(symbol-interned? x) - fuel] - [(symbol-unreadable? x) - (if allow-unreadable? fuel (bad))] - [else ;; uninterned - (if (eq? allow-unreadable? #t) fuel (bad))])] - ;; Mutable flat - [(or (string? x) - (bytes? x)) - (with-mutable-check (not (immutable? x)) - fuel)] - [(or (fxvector? x) - (flvector? x) - (extflvector? x)) - (with-mutable-check (not (immutable? x)) - fuel)] - ;; Syntax - [(syntax? x) - (case stx-mode - ((atomic) fuel) - ((compound) (loop (syntax-e x) fuel)) - (else (bad)))] - ;; Impersonators and chaperones - [(and no-impersonator? (impersonator? x)) ;; else continue to chaperoned type - (bad)] - [(and no-impersonator? (chaperone? x)) ;; else continue to impersonated type - (bad)] - [else - (with-cycle-check - (cond - ;; Mutable (maybe) compound - [(vector? x) - (with-mutable-check (not (immutable? x)) - (for/fold ([fuel fuel]) ([e (in-vector x)] #:break (not fuel)) - (loop e fuel)))] - [(box? x) - (with-mutable-check (not (immutable? x)) - (loop (unbox x) (sub1 fuel)))] - [(prefab-struct-key x) - => (lambda (key) - (cond [(and no-mutable-hash/prefab? (mutable-prefab-key? key)) - (bad)] - [else - ;; traverse key, since contains arbitrary auto-value - (let ([fuel (loop key fuel)]) - (loop (struct->vector x) fuel))]))] - [(hash? x) - (cond [(and no-mutable-hash/prefab? (not (immutable? x))) - (bad)] - [else - (for/fold ([fuel fuel]) ([(k v) (in-hash x)] #:break (not fuel)) - (let ([fuel (loop k fuel)]) - (loop v fuel)))])] - ;; Bad - [else - (bad)]))])) - (loop x0 fuel0)) - -;; mutable-prefab-key? : prefab-key -> boolean -(define (mutable-prefab-key? key) - ;; A prefab-key is either - ;; - symbol - ;; - (list* symbol maybe-nat maybe-list maybe-vector prefab-key) - ;; where mutable fields indicated by vector - ;; This code is probably overly general; racket seems to normalize keys. - (let loop ([k key]) - (and (pair? k) - (or (and (vector? (car k)) - (positive? (vector-length (car k)))) - (loop (cdr k)))))) diff --git a/parse/private/lib.rkt b/parse/private/lib.rkt index 4583d73..580fc55 100644 --- a/parse/private/lib.rkt +++ b/parse/private/lib.rkt @@ -3,12 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../../6-11/racket/collects/syntax/parse/private/lib.rkt")] - [(version< (version) "6.90.0.29") - (my-include "../../6-12/racket/collects/syntax/parse/private/lib.rkt")] - [(version< (version) "7.0.0.20") - (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/lib.rkt")] - [else - (my-include "../../7-3-0-1/racket/collects/syntax/parse/private/lib.rkt")]) +(my-include "../../" "/racket/collects/syntax/parse/private/lib.rkt") diff --git a/parse/private/litconv.rkt b/parse/private/litconv.rkt index 559791f..d618e5b 100644 --- a/parse/private/litconv.rkt +++ b/parse/private/litconv.rkt @@ -1,284 +1,6 @@ #lang racket/base -(require (for-syntax racket/base - racket/lazy-require - "sc.rkt" - "lib.rkt" - syntax/parse/private/kws - racket/syntax) - syntax/parse/private/residual-ct ;; keep abs. path - stxparse-info/parse/private/residual) ;; keep abs. path -(begin-for-syntax - (lazy-require - [syntax/private/keyword (options-select-value parse-keyword-options)] - [stxparse-info/parse/private/rep ;; keep abs. path - (parse-kw-formals - check-conventions-rules - check-datum-literals-list - create-aux-def)])) -;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require) -;; Without this, dependencies don't get collected. -(require racket/runtime-path racket/syntax (for-meta 2 '#%kernel)) -(define-runtime-module-path-index _unused_ 'stxparse-info/parse/private/rep) - -(provide define-conventions - define-literal-set - literal-set->predicate - kernel-literals) - -(define-syntax (define-conventions stx) - - (define-syntax-class header - #:description "name or name with formal parameters" - #:commit - (pattern name:id - #:with formals #'() - #:attr arity (arity 0 0 null null)) - (pattern (name:id . formals) - #:attr arity (parse-kw-formals #'formals #:context stx))) - - (syntax-parse stx - [(define-conventions h:header rule ...) - (let () - (define rules (check-conventions-rules #'(rule ...) stx)) - (define rxs (map car rules)) - (define dens0 (map cadr rules)) - (define den+defs-list - (for/list ([den0 (in-list dens0)]) - (let-values ([(den defs) (create-aux-def den0)]) - (cons den defs)))) - (define dens (map car den+defs-list)) - (define defs (apply append (map cdr den+defs-list))) - - (define/with-syntax (rx ...) rxs) - (define/with-syntax (def ...) defs) - (define/with-syntax (parser ...) - (map den:delayed-parser dens)) - (define/with-syntax (class-name ...) - (map den:delayed-class dens)) - - ;; FIXME: could move make-den:delayed to user of conventions - ;; and eliminate from residual.rkt - #'(begin - (define-syntax h.name - (make-conventions - (quote-syntax get-parsers) - (lambda () - (let ([class-names (list (quote-syntax class-name) ...)]) - (map list - (list 'rx ...) - (map make-den:delayed - (generate-temporaries class-names) - class-names)))))) - (define get-parsers - (lambda formals - def ... - (list parser ...)))))])) - -(define-for-syntax (check-phase-level stx ctx) - (unless (or (exact-integer? (syntax-e stx)) - (eq? #f (syntax-e stx))) - (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx)) - stx) - -;; check-litset-list : stx stx -> (listof (cons id literalset)) -(define-for-syntax (check-litset-list stx ctx) - (syntax-case stx () - [(litset-id ...) - (for/list ([litset-id (syntax->list #'(litset-id ...))]) - (let* ([val (and (identifier? litset-id) - (syntax-local-value/record litset-id literalset?))]) - (if val - (cons litset-id val) - (raise-syntax-error #f "expected literal set name" ctx litset-id))))] - [_ (raise-syntax-error #f "expected list of literal set names" ctx stx)])) - -;; check-literal-entry/litset : stx stx -> (list id id) -(define-for-syntax (check-literal-entry/litset stx ctx) - (syntax-case stx () - [(internal external) - (and (identifier? #'internal) (identifier? #'external)) - (list #'internal #'external)] - [id - (identifier? #'id) - (list #'id #'id)] - [_ (raise-syntax-error #f "expected literal entry" ctx stx)])) - -(define-for-syntax (check-duplicate-literals ctx imports lits datum-lits) - (let ([lit-t (make-hasheq)]) ;; sym => #t - (define (check+enter! key blame-stx) - (when (hash-ref lit-t key #f) - (raise-syntax-error #f (format "duplicate literal: ~a" key) ctx blame-stx)) - (hash-set! lit-t key #t)) - (for ([id+litset (in-list imports)]) - (let ([litset-id (car id+litset)] - [litset (cdr id+litset)]) - (for ([entry (in-list (literalset-literals litset))]) - (cond [(lse:lit? entry) - (check+enter! (lse:lit-internal entry) litset-id)] - [(lse:datum-lit? entry) - (check+enter! (lse:datum-lit-internal entry) litset-id)])))) - (for ([datum-lit (in-list datum-lits)]) - (let ([internal (den:datum-lit-internal datum-lit)]) - (check+enter! (syntax-e internal) internal))) - (for ([lit (in-list lits)]) - (check+enter! (syntax-e (car lit)) (car lit))))) - -(define-syntax (define-literal-set stx) - (syntax-case stx () - [(define-literal-set name . rest) - (let-values ([(chunks rest) - (parse-keyword-options - #'rest - `((#:literal-sets ,check-litset-list) - (#:datum-literals ,check-datum-literals-list) - (#:phase ,check-phase-level) - (#:for-template) - (#:for-syntax) - (#:for-label)) - #:incompatible '((#:phase #:for-template #:for-syntax #:for-label)) - #:context stx - #:no-duplicates? #t)]) - (unless (identifier? #'name) - (raise-syntax-error #f "expected identifier" stx #'name)) - (let ([relphase - (cond [(assq '#:for-template chunks) -1] - [(assq '#:for-syntax chunks) 1] - [(assq '#:for-label chunks) #f] - [else (options-select-value chunks '#:phase #:default 0)])] - [datum-lits - (options-select-value chunks '#:datum-literals #:default null)] - [lits (syntax-case rest () - [( (lit ...) ) - (for/list ([lit (in-list (syntax->list #'(lit ...)))]) - (check-literal-entry/litset lit stx))] - [_ (raise-syntax-error #f "bad syntax" stx)])] - [imports (options-select-value chunks '#:literal-sets #:default null)]) - (check-duplicate-literals stx imports lits datum-lits) - (with-syntax ([((internal external) ...) lits] - [(datum-internal ...) (map den:datum-lit-internal datum-lits)] - [(datum-external ...) (map den:datum-lit-external datum-lits)] - [(litset-id ...) (map car imports)] - [relphase relphase]) - #`(begin - (define phase-of-literals - (and 'relphase - (+ (variable-reference->module-base-phase (#%variable-reference)) - 'relphase))) - (define-syntax name - (make-literalset - (append (literalset-literals (syntax-local-value (quote-syntax litset-id))) - ... - (list (make-lse:lit 'internal - (quote-syntax external) - (quote-syntax phase-of-literals)) - ... - (make-lse:datum-lit 'datum-internal - 'datum-external) - ...)))) - (begin-for-syntax/once - (for ([x (in-list (syntax->list #'(external ...)))]) - (unless (identifier-binding x 'relphase) - (raise-syntax-error #f - (format "literal is unbound in phase ~a~a~a" - 'relphase - (case 'relphase - ((1) " (for-syntax)") - ((-1) " (for-template)") - ((#f) " (for-label)") - (else "")) - " relative to the enclosing module") - (quote-syntax #,stx) x))))))))])) - -#| -NOTES ON PHASES AND BINDINGS - -(module M .... - .... (define-literal-set LS #:phase PL ....) - ....) - -For the expansion of the define-literal-set form, the bindings of the literals -can be accessed by (identifier-binding lit PL), because the phase of the enclosing -module (M) is 0. - -LS may be used, however, in a context where the phase of the enclosing -module is not 0, so each instantiation of LS needs to calculate the -phase of M and add that to PL. - --- - -Normally, literal sets that define the same name conflict. But it -would be nice to allow them to both be imported in the case where they -refer to the same binding. - -Problem: Can't do the check eagerly, because the binding of L may -change between when define-literal-set is compiled and the comparison -involving L. For example: - - (module M racket - (require stxparse-info/parse) - (define-literal-set LS (lambda)) - (require (only-in some-other-lang lambda)) - .... LS ....) - -The expansion of the LS definition sees a different lambda than the -one that the literal in LS actually refers to. - -Similarly, a literal in LS might not be defined when the expander -runs, but might get defined later. (Although I think that will already -cause an error, so don't worry about that case.) -|# - -;; FIXME: keep one copy of each identifier (?) - -(define-syntax (literal-set->predicate stx) - (syntax-case stx () - [(literal-set->predicate litset-id) - (let ([val (and (identifier? #'litset-id) - (syntax-local-value/record #'litset-id literalset?))]) - (unless val (raise-syntax-error #f "expected literal set name" stx #'litset-id)) - (let ([lits (literalset-literals val)]) - (with-syntax ([((lit phase-var) ...) - (for/list ([lit (in-list lits)] - #:when (lse:lit? lit)) - (list (lse:lit-external lit) (lse:lit-phase lit)))] - [(datum-lit ...) - (for/list ([lit (in-list lits)] - #:when (lse:datum-lit? lit)) - (lse:datum-lit-external lit))]) - #'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...) - '(datum-lit ...)))))])) - -(define (make-literal-set-predicate lits datum-lits) - (lambda (x [phase (syntax-local-phase-level)]) - (or (for/or ([lit (in-list lits)]) - (let ([lit-id (car lit)] - [lit-phase (cadr lit)]) - (free-identifier=? x lit-id phase lit-phase))) - (and (memq (syntax-e x) datum-lits) #t)))) - -;; Literal sets - -(define-literal-set kernel-literals - (begin - begin0 - define-values - define-syntaxes - define-values-for-syntax ;; kept for compat. - begin-for-syntax - set! - let-values - letrec-values - #%plain-lambda - case-lambda - if - quote - quote-syntax - letrec-syntaxes+values - with-continuation-mark - #%expression - #%plain-app - #%top - #%datum - #%variable-reference - module module* #%provide #%require #%declare - #%plain-module-begin)) +(#%require version-case + (for-syntax (only racket/base version) + (only racket/base #%app #%datum)) + stxparse-info/my-include) +(my-include "../../" "/racket/collects/syntax/parse/private/litconv.rkt") diff --git a/parse/private/make.rkt b/parse/private/make.rkt index 8a4f744..1bc1df8 100644 --- a/parse/private/make.rkt +++ b/parse/private/make.rkt @@ -1,43 +1,6 @@ #lang racket/base -(require (for-syntax racket/base - racket/struct-info)) -(provide make) - -;; get-struct-info : identifier stx -> struct-info-list -(define-for-syntax (get-struct-info id ctx) - (define (bad-struct-name x) - (raise-syntax-error #f "expected struct name" ctx x)) - (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))) - -;; (make struct-name field-expr ...) -;; Checks that correct number of fields given. -(define-syntax (make stx) - (syntax-case stx () - [(make S expr ...) - (let () - (define info (get-struct-info #'S stx)) - (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, got ~s)" - (syntax-e #'S) - num-slots - num-provided) - stx))) - (with-syntax ([constructor constructor]) - (syntax-property #'(constructor expr ...) - 'disappeared-use - #'S)))])) +(#%require version-case + (for-syntax (only racket/base version) + (only racket/base #%app #%datum)) + stxparse-info/my-include) +(my-include "../../" "/racket/collects/syntax/parse/private/make.rkt") diff --git a/parse/private/opt.rkt b/parse/private/opt.rkt index 38c7881..997541e 100644 --- a/parse/private/opt.rkt +++ b/parse/private/opt.rkt @@ -3,8 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "7.0.0.20") - (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/opt.rkt")] - [else - (my-include "../../7-0-0-20/racket/collects/syntax/parse/private/opt.rkt")]) +(my-include "../../" "/racket/collects/syntax/parse/private/opt.rkt") diff --git a/parse/private/parse-aux.rkt b/parse/private/parse-aux.rkt index 779ce47..4916567 100644 --- a/parse/private/parse-aux.rkt +++ b/parse/private/parse-aux.rkt @@ -3,8 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../../6-11/racket/collects/syntax/parse/private/parse-aux.rkt")] - [else - (begin)]) +(my-include "../../" "/racket/collects/syntax/parse/private/parse-aux.rkt") diff --git a/parse/private/parse.rkt b/parse/private/parse.rkt index 9f03c27..28e5003 100644 --- a/parse/private/parse.rkt +++ b/parse/private/parse.rkt @@ -3,14 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../../6-11/racket/collects/syntax/parse/private/parse.rkt")] - [(version< (version) "6.90.0.29") - (my-include "../../6-12/racket/collects/syntax/parse/private/parse.rkt")] - [(version< (version) "7.0.0.20") - (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/parse.rkt")] - [(version< (version) "7.3.0.1") - (my-include "../../7-0-0-20/racket/collects/syntax/parse/private/parse.rkt")] - [else - (my-include "../../7-3-0-1/racket/collects/syntax/parse/private/parse.rkt")]) +(my-include "../../" "/racket/collects/syntax/parse/private/parse.rkt") diff --git a/parse/private/rep.rkt b/parse/private/rep.rkt index 8136a73..3a96c62 100644 --- a/parse/private/rep.rkt +++ b/parse/private/rep.rkt @@ -3,14 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../../6-11/racket/collects/syntax/parse/private/rep.rkt")] - [(version< (version) "6.90.0.29") - (my-include "../../6-12/racket/collects/syntax/parse/private/rep.rkt")] - [(version< (version) "7.0.0.20") - (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/rep.rkt")] - [(version< (version) "7.3.0.1") - (my-include "../../7-0-0-20/racket/collects/syntax/parse/private/rep.rkt")] - [else - (my-include "../../7-3-0-1/racket/collects/syntax/parse/private/rep.rkt")]) +(my-include "../../" "/racket/collects/syntax/parse/private/rep.rkt") diff --git a/parse/private/residual.rkt b/parse/private/residual.rkt index 5702578..368edc6 100644 --- a/parse/private/residual.rkt +++ b/parse/private/residual.rkt @@ -3,12 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../../6-11/racket/collects/syntax/parse/private/residual.rkt")] - [(version< (version) "6.90.0.29") - (my-include "../../6-12/racket/collects/syntax/parse/private/residual.rkt")] - [(version< (version) "7.0.0.20") - (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/residual.rkt")] - [else - (my-include "../../7-0-0-20/racket/collects/syntax/parse/private/residual.rkt")]) +(my-include "../../" "/racket/collects/syntax/parse/private/residual.rkt") diff --git a/parse/private/runtime-progress.rkt b/parse/private/runtime-progress.rkt index f76f154..9b50cd3 100644 --- a/parse/private/runtime-progress.rkt +++ b/parse/private/runtime-progress.rkt @@ -1,257 +1,6 @@ #lang racket/base -(require racket/list - syntax/parse/private/minimatch) -(provide ps-empty - ps-add-car - ps-add-cdr - ps-add-stx - ps-add-unbox - ps-add-unvector - ps-add-unpstruct - ps-add-opaque - ps-add-post - ps-add - (struct-out ord) - - ps-pop-opaque - ps-pop-ord - ps-pop-post - ps-context-syntax - ps-difference - - (struct-out failure) - failure* - - expect? - (struct-out expect:thing) - (struct-out expect:atom) - (struct-out expect:literal) - (struct-out expect:message) - (struct-out expect:disj) - (struct-out expect:proper-pair) - - es-add-thing - es-add-message - es-add-atom - es-add-literal - es-add-proper-pair) - -;; FIXME: add phase to expect:literal - -;; == Failure == - -#| -A Failure is (failure PS ExpectStack) - -A FailureSet is one of - - Failure - - (cons FailureSet FailureSet) - -A FailFunction = (FailureSet -> Answer) -|# -(define-struct failure (progress expectstack) #:prefab) - -;; failure* : PS ExpectStack/#f -> Failure/#t -(define (failure* ps es) (if es (failure ps es) #t)) - -;; == Progress == - -#| -Progress (PS) is a non-empty list of Progress Frames (PF). - -A Progress Frame (PF) is one of - - stx ;; "Base" frame, or ~parse/#:with term - - 'car ;; car of pair; also vector->list, unbox, struct->list, etc - - nat ;; Represents that many repeated cdrs - - 'post ;; late/post-traversal check - - #s(ord group index) ;; ~and subpattern, only comparable w/in group - - 'opaque - -The error-reporting context (ie, syntax-parse #:context arg) is always -the final frame. - -All non-stx frames (eg car, cdr) interpreted as applying to nearest following -stx frame. - -A stx frame is introduced - - always at base (that is, by syntax-parse) - - if syntax-parse has #:context arg, then two stx frames at bottom: - (list to-match-stx context-stx) - - by #:with/~parse - - by #:fail-*/#:when/~fail & stx - -Interpretation: later frames are applied first. - eg, (list 'car 1 stx) - means ( car of ( cdr once of stx ) ) - NOT apply car, then apply cdr once, then stop -|# -(define-struct ord (group index) #:prefab) - -(define (ps-empty stx ctx) - (if (eq? stx ctx) - (list stx) - (list stx ctx))) -(define (ps-add-car parent) - (cons 'car parent)) -(define (ps-add-cdr parent [times 1]) - (if (zero? times) - parent - (match (car parent) - [(? exact-positive-integer? n) - (cons (+ times n) (cdr parent))] - [_ - (cons times parent)]))) -(define (ps-add-stx parent stx) - (cons stx parent)) -(define (ps-add-unbox parent) - (ps-add-car parent)) -(define (ps-add-unvector parent) - (ps-add-car parent)) -(define (ps-add-unpstruct parent) - (ps-add-car parent)) -(define (ps-add-opaque parent) - (cons 'opaque parent)) -(define (ps-add parent frame) - (cons frame parent)) -(define (ps-add-post parent) - (cons 'post parent)) - -;; ps-context-syntax : Progress -> syntax -(define (ps-context-syntax ps) - ;; Bottom frame is always syntax - (last ps)) - -;; ps-difference : PS PS -> nat -;; Returns N s.t. B = (ps-add-cdr^N A) -(define (ps-difference a b) - (define-values (a-cdrs a-base) - (match a - [(cons (? exact-positive-integer? a-cdrs) a-base) - (values a-cdrs a-base)] - [_ (values 0 a)])) - (define-values (b-cdrs b-base) - (match b - [(cons (? exact-positive-integer? b-cdrs) b-base) - (values b-cdrs b-base)] - [_ (values 0 b)])) - (unless (eq? a-base b-base) - (error 'ps-difference "INTERNAL ERROR: ~e does not extend ~e" b a)) - (- b-cdrs a-cdrs)) - -;; ps-pop-opaque : PS -> PS -;; Used to continue with progress from opaque head pattern. -(define (ps-pop-opaque ps) - (match ps - [(cons (? exact-positive-integer? n) (cons 'opaque ps*)) - (ps-add-cdr ps* n)] - [(cons 'opaque ps*) - ps*] - [_ (error 'ps-pop-opaque "INTERNAL ERROR: opaque frame not found: ~e" ps)])) - -;; ps-pop-ord : PS -> PS -(define (ps-pop-ord ps) - (match ps - [(cons (? exact-positive-integer? n) (cons (? ord?) ps*)) - (ps-add-cdr ps* n)] - [(cons (? ord?) ps*) - ps*] - [_ (error 'ps-pop-ord "INTERNAL ERROR: ord frame not found: ~e" ps)])) - -;; ps-pop-post : PS -> PS -(define (ps-pop-post ps) - (match ps - [(cons (? exact-positive-integer? n) (cons 'post ps*)) - (ps-add-cdr ps* n)] - [(cons 'post ps*) - ps*] - [_ (error 'ps-pop-post "INTERNAL ERROR: post frame not found: ~e" ps)])) - - -;; == Expectations == - -#| -There are multiple types that use the same structures, optimized for -different purposes. - --- During parsing, the goal is to minimize/consolidate allocations. - -An ExpectStack (during parsing) is one of - - (expect:thing Progress String Boolean String/#f ExpectStack) - * (expect:message String ExpectStack) - * (expect:atom Datum ExpectStack) - * (expect:literal Identifier ExpectStack) - * (expect:proper-pair FirstDesc ExpectStack) - * #t - -The *-marked variants can only occur at the top of the stack (ie, not -in the next field of another Expect). The top of the stack contains -the most specific information. - -An ExpectStack can also be #f, which means no failure tracking is -requested (and thus no more ExpectStacks should be allocated). - --- During reporting, the goal is ease of manipulation. - -An ExpectList (during reporting) is (listof Expect). - -An Expect is one of - - (expect:thing #f String #t String/#f StxIdx) - * (expect:message String StxIdx) - * (expect:atom Datum StxIdx) - * (expect:literal Identifier StxIdx) - * (expect:proper-pair FirstDesc StxIdx) - * (expect:disj (NEListof Expect) StxIdx) - - '... - -A StxIdx is (cons Syntax Nat) - -That is, the next link is replaced with the syntax+index of the term -being complained about. An expect:thing's progress is replaced with #f. - -An expect:disj never contains a '... or another expect:disj. - -We write ExpectList when the most specific information comes first and -RExpectList when the most specific information comes last. -|# -(struct expect:thing (term description transparent? role next) #:prefab) -(struct expect:message (message next) #:prefab) -(struct expect:atom (atom next) #:prefab) -(struct expect:literal (literal next) #:prefab) -(struct expect:disj (expects next) #:prefab) -(struct expect:proper-pair (first-desc next) #:prefab) - -(define (expect? x) - (or (expect:thing? x) - (expect:message? x) - (expect:atom? x) - (expect:literal? x) - (expect:disj? x) - (expect:proper-pair? x))) - -(define (es-add-thing ps description transparent? role next) - (if (and next description) - (expect:thing ps description transparent? role next) - next)) - -(define (es-add-message message next) - (if (and next message) - (expect:message message next) - next)) - -(define (es-add-atom atom next) - (and next (expect:atom atom next))) - -(define (es-add-literal literal next) - (and next (expect:literal literal next))) - -(define (es-add-proper-pair first-desc next) - (and next (expect:proper-pair first-desc next))) - -#| -A FirstDesc is one of - - #f -- unknown, multiple possible, etc - - string -- description - - (list 'any) - - (list 'literal symbol) - - (list 'datum datum) -|# +(#%require version-case + (for-syntax (only racket/base version) + (only racket/base #%app #%datum)) + stxparse-info/my-include) +(my-include "../../" "/racket/collects/syntax/parse/private/runtime-progress.rkt") diff --git a/parse/private/runtime-reflect.rkt b/parse/private/runtime-reflect.rkt index 9ae2f8e..cddb367 100644 --- a/parse/private/runtime-reflect.rkt +++ b/parse/private/runtime-reflect.rkt @@ -3,10 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../../6-11/racket/collects/syntax/parse/private/runtime-reflect.rkt")] - [(version< (version) "6.90.0.29") - (my-include "../../6-12/racket/collects/syntax/parse/private/runtime-reflect.rkt")] - [else - (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/runtime-reflect.rkt")]) +(my-include "../../" "/racket/collects/syntax/parse/private/runtime-reflect.rkt") diff --git a/parse/private/runtime-report.rkt b/parse/private/runtime-report.rkt index 8d91a2c..9749c51 100644 --- a/parse/private/runtime-report.rkt +++ b/parse/private/runtime-report.rkt @@ -3,10 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../../6-11/racket/collects/syntax/parse/private/runtime-report.rkt")] - [(version< (version) "6.90.0.29") - (my-include "../../6-12/racket/collects/syntax/parse/private/runtime-report.rkt")] - [else - (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/runtime-report.rkt")]) +(my-include "../../" "/racket/collects/syntax/parse/private/runtime-report.rkt") diff --git a/parse/private/runtime.rkt b/parse/private/runtime.rkt index 43788c6..ed88431 100644 --- a/parse/private/runtime.rkt +++ b/parse/private/runtime.rkt @@ -3,10 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../../6-11/racket/collects/syntax/parse/private/runtime.rkt")] - [(version< (version) "6.90.0.29") - (my-include "../../6-12/racket/collects/syntax/parse/private/runtime.rkt")] - [else - (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/runtime.rkt")]) +(my-include "../../" "/racket/collects/syntax/parse/private/runtime.rkt") diff --git a/parse/private/sc.rkt b/parse/private/sc.rkt index 0787d7c..9be833d 100644 --- a/parse/private/sc.rkt +++ b/parse/private/sc.rkt @@ -3,12 +3,4 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "../../6-11/racket/collects/syntax/parse/private/sc.rkt")] - [(version< (version) "6.90.0.29") - (my-include "../../6-12/racket/collects/syntax/parse/private/sc.rkt")] - [(version< (version) "7.0.0.20") - (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/sc.rkt")] - [else - (my-include "../../7-0-0-20/racket/collects/syntax/parse/private/sc.rkt")]) +(my-include "../../" "/racket/collects/syntax/parse/private/sc.rkt") diff --git a/parse/private/txlift.rkt b/parse/private/txlift.rkt index 57c5497..5e75e99 100644 --- a/parse/private/txlift.rkt +++ b/parse/private/txlift.rkt @@ -1,45 +1,6 @@ #lang racket/base -(require (for-template racket/base)) -(provide txlift - get-txlifts-as-definitions - with-txlifts - call/txlifts) - -;; Like lifting definitions, but within a single transformer. - -;; current-liftbox : Parameter of [#f or (Listof (list Id Stx))] -(define current-liftbox (make-parameter #f)) - -(define (call/txlifts proc) - (parameterize ((current-liftbox (box null))) - (proc))) - -(define (txlift expr) - (let ([liftbox (current-liftbox)]) - (check 'txlift liftbox) - (let ([var (car (generate-temporaries '(txlift)))]) - (set-box! liftbox (cons (list var expr) (unbox liftbox))) - var))) - -(define (get-txlifts) - (let ([liftbox (current-liftbox)]) - (check 'get-txlifts liftbox) - (reverse (unbox liftbox)))) - -(define (get-txlifts-as-definitions) - (let ([liftbox (current-liftbox)]) - (check 'get-txlifts-as-definitions liftbox) - (map (lambda (p) - #`(define #,@p)) - (reverse (unbox liftbox))))) - -(define (check who lb) - (unless (box? lb) - (error who "not in a txlift-catching context"))) - -(define (with-txlifts proc) - (call/txlifts - (lambda () - (let ([v (proc)]) - (with-syntax ([((var rhs) ...) (get-txlifts)]) - #`(let* ([var rhs] ...) #,v)))))) +(#%require version-case + (for-syntax (only racket/base version) + (only racket/base #%app #%datum)) + stxparse-info/my-include) +(my-include "../../" "/racket/collects/syntax/parse/private/txlift.rkt") diff --git a/scribblings/stxparse-info.scrbl b/scribblings/stxparse-info.scrbl index d68a463..56af63e 100644 --- a/scribblings/stxparse-info.scrbl +++ b/scribblings/stxparse-info.scrbl @@ -3,12 +3,5 @@ (for-syntax (only racket/base version) (only racket/base #%app #%datum)) stxparse-info/my-include) -(version-case - [(version< (version) "6.11.0.900") - (my-include "stxparse-info.scrbl-6-11")] - [(version< (version) "6.90.0.29") - (my-include "stxparse-info.scrbl-6-12")] - [(version< (version) "7.3.0.1") - (my-include "stxparse-info.scrbl-6-90-0-29")] - [else - (my-include "stxparse-info.scrbl-7-3-0-1")]) +(my-include "../" "/stxparse-info.scrbl") +