commit c439b4b7f4bf58317da0c58b92675d167b0ef946 parent 22632ae7a93f6f951ddfda039dc6ed898e0f4e53 Author: Suzanne Soy <ligo@suzanne.soy> Date: Sat, 27 Feb 2021 02:06:59 +0000 fixed includes & paths Diffstat:
88 files changed, 107 insertions(+), 1279 deletions(-)
diff --git a/parse/define.rkt b/6-11/racket/collects/syntax/parse/define.rkt diff --git a/parse/experimental/dset.rkt b/6-11/racket/collects/syntax/parse/experimental/dset.rkt diff --git a/parse/experimental/eh.rkt b/6-11/racket/collects/syntax/parse/experimental/eh.rkt diff --git a/parse/lib/function-header.rkt b/6-11/racket/collects/syntax/parse/lib/function-header.rkt diff --git a/parse/private/3d-stx.rkt b/6-11/racket/collects/syntax/parse/private/3d-stx.rkt diff --git a/parse/private/litconv.rkt b/6-11/racket/collects/syntax/parse/private/litconv.rkt diff --git a/parse/private/make.rkt b/6-11/racket/collects/syntax/parse/private/make.rkt diff --git a/parse/private/runtime-progress.rkt b/6-11/racket/collects/syntax/parse/private/runtime-progress.rkt diff --git a/parse/private/txlift.rkt b/6-11/racket/collects/syntax/parse/private/txlift.rkt diff --git a/scribblings/stxparse-info.scrbl-6-11 b/6-11/stxparse-info.scrbl diff --git a/parse/define.rkt b/6-12/racket/collects/syntax/parse/define.rkt diff --git a/parse/experimental/dset.rkt b/6-12/racket/collects/syntax/parse/experimental/dset.rkt diff --git a/parse/experimental/eh.rkt b/6-12/racket/collects/syntax/parse/experimental/eh.rkt diff --git a/parse/lib/function-header.rkt b/6-12/racket/collects/syntax/parse/lib/function-header.rkt diff --git a/parse/private/3d-stx.rkt b/6-12/racket/collects/syntax/parse/private/3d-stx.rkt diff --git a/parse/private/litconv.rkt b/6-12/racket/collects/syntax/parse/private/litconv.rkt diff --git a/parse/private/make.rkt b/6-12/racket/collects/syntax/parse/private/make.rkt diff --git a/parse/private/runtime-progress.rkt b/6-12/racket/collects/syntax/parse/private/runtime-progress.rkt diff --git a/parse/private/txlift.rkt b/6-12/racket/collects/syntax/parse/private/txlift.rkt diff --git a/scribblings/stxparse-info.scrbl-6-12 b/6-12/stxparse-info.scrbl diff --git a/parse/define.rkt b/6-90-0-29/racket/collects/syntax/parse/define.rkt diff --git a/parse/experimental/dset.rkt b/6-90-0-29/racket/collects/syntax/parse/experimental/dset.rkt diff --git a/parse/experimental/eh.rkt b/6-90-0-29/racket/collects/syntax/parse/experimental/eh.rkt diff --git a/parse/lib/function-header.rkt b/6-90-0-29/racket/collects/syntax/parse/lib/function-header.rkt diff --git a/parse/private/3d-stx.rkt b/6-90-0-29/racket/collects/syntax/parse/private/3d-stx.rkt diff --git a/parse/private/litconv.rkt b/6-90-0-29/racket/collects/syntax/parse/private/litconv.rkt diff --git a/parse/private/make.rkt b/6-90-0-29/racket/collects/syntax/parse/private/make.rkt diff --git a/parse/private/runtime-progress.rkt b/6-90-0-29/racket/collects/syntax/parse/private/runtime-progress.rkt diff --git a/parse/private/txlift.rkt b/6-90-0-29/racket/collects/syntax/parse/private/txlift.rkt diff --git a/scribblings/stxparse-info.scrbl-6-90-0-29 b/6-90-0-29/stxparse-info.scrbl diff --git a/parse/define.rkt b/7-0-0-20/racket/collects/syntax/parse/define.rkt diff --git a/parse/experimental/dset.rkt b/7-0-0-20/racket/collects/syntax/parse/experimental/dset.rkt diff --git a/parse/experimental/eh.rkt b/7-0-0-20/racket/collects/syntax/parse/experimental/eh.rkt diff --git a/parse/lib/function-header.rkt b/7-0-0-20/racket/collects/syntax/parse/lib/function-header.rkt diff --git a/parse/private/3d-stx.rkt b/7-0-0-20/racket/collects/syntax/parse/private/3d-stx.rkt diff --git a/parse/private/litconv.rkt b/7-0-0-20/racket/collects/syntax/parse/private/litconv.rkt diff --git a/parse/private/make.rkt b/7-0-0-20/racket/collects/syntax/parse/private/make.rkt diff --git a/parse/private/runtime-progress.rkt b/7-0-0-20/racket/collects/syntax/parse/private/runtime-progress.rkt diff --git a/parse/private/txlift.rkt b/7-0-0-20/racket/collects/syntax/parse/private/txlift.rkt diff --git a/scribblings/stxparse-info.scrbl-6-90-0-29 b/7-0-0-20/stxparse-info.scrbl diff --git a/parse/define.rkt b/7-3-0-1/racket/collects/syntax/parse/define.rkt diff --git a/parse/experimental/dset.rkt b/7-3-0-1/racket/collects/syntax/parse/experimental/dset.rkt diff --git a/parse/experimental/eh.rkt b/7-3-0-1/racket/collects/syntax/parse/experimental/eh.rkt diff --git a/parse/lib/function-header.rkt b/7-3-0-1/racket/collects/syntax/parse/lib/function-header.rkt diff --git a/parse/private/3d-stx.rkt b/7-3-0-1/racket/collects/syntax/parse/private/3d-stx.rkt diff --git a/parse/private/litconv.rkt b/7-3-0-1/racket/collects/syntax/parse/private/litconv.rkt diff --git a/parse/private/make.rkt b/7-3-0-1/racket/collects/syntax/parse/private/make.rkt diff --git a/parse/private/runtime-progress.rkt b/7-3-0-1/racket/collects/syntax/parse/private/runtime-progress.rkt diff --git a/parse/private/txlift.rkt b/7-3-0-1/racket/collects/syntax/parse/private/txlift.rkt diff --git a/scribblings/stxparse-info.scrbl-7-3-0-1 b/7-3-0-1/stxparse-info.scrbl diff --git 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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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") +