commit e463102f09899100eecd39698b13556afee81f7f Author: Georges Dupéron Date: Thu Nov 10 17:32:48 2016 +0100 Initial commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..1a59348 --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +*~ +\#* +.\#* +.DS_Store +compiled/ +/doc/ diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..b665643 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,55 @@ +language: c + +# Based from: https://github.com/greghendershott/travis-racket + +# Optional: Remove to use Travis CI's older infrastructure. +sudo: false + +env: + global: + # Supply a global RACKET_DIR environment variable. This is where + # Racket will be installed. A good idea is to use ~/racket because + # that doesn't require sudo to install and is therefore compatible + # with Travis CI's newer container infrastructure. + - RACKET_DIR=~/racket + matrix: + # Supply at least one RACKET_VERSION environment variable. This is + # used by the install-racket.sh script (run at before_install, + # below) to select the version of Racket to download and install. + # + # Supply more than one RACKET_VERSION (as in the example below) to + # create a Travis-CI build matrix to test against multiple Racket + # versions. + - RACKET_VERSION=6.0 + - RACKET_VERSION=6.1 + - RACKET_VERSION=6.1.1 + - RACKET_VERSION=6.2 + - RACKET_VERSION=6.3 + - RACKET_VERSION=6.4 + - RACKET_VERSION=HEAD + +matrix: + allow_failures: +# - env: RACKET_VERSION=HEAD + fast_finish: true + +before_install: +- git clone https://github.com/greghendershott/travis-racket.git ~/travis-racket +- cat ~/travis-racket/install-racket.sh | bash # pipe to bash not sh! +- export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us + +install: + - raco pkg install --deps search-auto + +before_script: + +# Here supply steps such as raco make, raco test, etc. You can run +# `raco pkg install --deps search-auto` to install any required +# packages without it getting stuck on a confirmation prompt. +script: + - raco test -x -p backport-template-pr1514 + +after_success: + - raco setup --check-pkg-deps --pkgs backport-template-pr1514 + - raco pkg install --deps search-auto cover cover-coveralls + - raco cover -b -f coveralls -d $TRAVIS_BUILD_DIR/coverage . diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 index 0000000..0ffadc9 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,11 @@ +backport-template-pr1514 +Copyright (c) 2016 georges + +This package is distributed under the GNU Lesser General Public +License (LGPL). This means that you can link backport-template-pr1514 into proprietary +applications, provided you follow the rules stated in the LGPL. You +can also modify this package; if you distribute a modified version, +you must distribute it under the terms of the LGPL, which in +particular means that you must release the source code for the +modified software. See http://www.gnu.org/copyleft/lesser.html +for more information. diff --git a/README.md b/README.md new file mode 100644 index 0000000..18a5a61 --- /dev/null +++ b/README.md @@ -0,0 +1,19 @@ +backport-template-pr1514 +======================== + +Pull Request https://github.com/racket/racket/pull/1514 for syntax/parse/experimental/template, backported as a package, so that `syntax-local-template-metafunction-introduce` can be used on older versions. + +License +------- + +Racket +Copyright (c) 2010-2016 PLT Design Inc. + +Racket is distributed under the GNU Lesser General Public License +(LGPL). This implies that you may link Racket into proprietary +applications, provided you follow the rules stated in the LGPL. You can +also modify Racket; if you distribute a modified version, you must +distribute it under the terms of the LGPL, which in particular states +that you must release the source code for the modified software. + +See racket/src/COPYING_LESSER.txt for more information. diff --git a/experimental/dset.rkt b/experimental/dset.rkt new file mode 100644 index 0000000..57c53e5 --- /dev/null +++ b/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/experimental/private/substitute.rkt b/experimental/private/substitute.rkt new file mode 100644 index 0000000..df1be87 --- /dev/null +++ b/experimental/private/substitute.rkt @@ -0,0 +1,490 @@ +#lang racket/base +(require syntax/parse/private/minimatch + racket/private/promise + racket/private/stx) ;; syntax/stx +(provide translate + syntax-local-template-metafunction-introduce) + +#| +;; Doesn't seem to make much difference. +(require (rename-in racket/unsafe/ops + [unsafe-vector-ref vector-ref] + [unsafe-vector-set! vector-set!] + [unsafe-car car] + [unsafe-cdr cdr])) +|# + +;; ============================================================ + +#| +A Guide (G) is one of: + - '_ + - VarRef ;; no syntax check + - (vector 'check VarRef) ;; check value is syntax + - (cons G G) + - (vector 'vector G) + - (vector 'struct G) + - (vector 'box G) + - (vector 'dots HG (listof (vector-of VarRef)) nat (listof nat) G) + - (vector 'app HG G) + - (vector 'escaped G) + - (vector 'orelse G G) + - (vector 'metafun integer G) + - (vector 'copy-props G (listof symbol)) + - (vector 'set-props G (listof (cons symbol any))) + - (vector 'unsyntax VarRef) + - (vector 'relocate G) + +A HeadGuide (HG) is one of: + - G + - (vector 'app-opt H) + - (vector 'orelse-h H H) + - (vector 'splice G) + - (vector 'unsyntax-splicing VarRef) + +An VarRef is one of + - positive-exact-integer ;; represents depth=0 pvar ref or metafun ref + - negative-exact-integer ;; represents depth>0 pvar ref (within ellipsis) +|# + +(define (head-guide? x) + (match x + [(vector 'app-opt g) #t] + [(vector 'splice g) #t] + [(vector 'orelse-h g1 g2) #t] + [(vector 'unsyntax-splicing var) #t] + [_ #f])) + +;; ============================================================ + +;; Used to indicate absent pvar in template; ?? catches +;; Note: not an exn, don't need continuation marks +(struct absent-pvar (ctx v wanted-list?)) + +;; ============================================================ + +;; A translated-template is (vector loop-env -> syntax) +;; A loop-env is either a vector of values or a single value, +;; depending on lenv-mode of enclosing ellipsis ('dots) form. + +(define (translate stx g env-length) + (let ([f (translate-g stx stx g env-length 0)]) + (lambda (env lenv) + (unless (>= (vector-length env) env-length) + (error 'template "internal error: environment too short")) + (with-handlers ([absent-pvar? + (lambda (ap) + (err/not-syntax (absent-pvar-ctx ap) (absent-pvar-v ap)))]) + (f env lenv))))) + +;; lenv-mode is one of +;; - 'one ;; lenv is single value; address as -1 +;; - nat ;; lenv is vector; address as (- -1 index); 0 means no loop env + +(define (translate-g stx0 stx g env-length lenv-mode) + (define (loop stx g) (translate-g stx0 stx g env-length lenv-mode)) + (define (loop-h stx hg) (translate-hg stx0 stx hg env-length lenv-mode)) + (define (get index env lenv) (get-var index env lenv lenv-mode)) + + (match g + + ['_ (lambda (env lenv) stx)] + + [(? exact-integer? index) + (check-var index env-length lenv-mode) + (lambda (env lenv) (get index env lenv))] + + [(vector 'check index) + (check-var index env-length lenv-mode) + (lambda (env lenv) (check-stx stx (get index env lenv)))] + + [(cons g1 g2) + (let ([f1 (loop (stx-car stx) g1)] + [f2 (loop (stx-cdr stx) g2)]) + (cond [(syntax? stx) + (lambda (env lenv) + (restx stx (cons (f1 env lenv) (f2 env lenv))))] + [(eq? g1 '_) + (let ([c1 (stx-car stx)]) + (lambda (env lenv) + (cons c1 (f2 env lenv))))] + [(eq? g2 '_) + (let ([c2 (stx-cdr stx)]) + (lambda (env lenv) + (cons (f1 env lenv) c2)))] + [else + (lambda (env lenv) + (cons (f1 env lenv) (f2 env lenv)))]))] + + [(vector 'dots ghead henv nesting uptos gtail) + ;; At each nesting depth, indexes [0,upto) of lenv* vary; the rest are fixed. + ;; An alternative would be to have a list of henvs, but that would inhibit + ;; the nice simple vector reuse via vector-car/cdr!. + (let* ([lenv*-len (vector-length henv)] + [ghead-is-hg? (head-guide? ghead)] + [ftail (loop (stx-drop (add1 nesting) stx) gtail)]) + (for ([var (in-vector henv)]) + (check-var var env-length lenv-mode)) + (unless (= nesting (length uptos)) + (error 'template "internal error: wrong number of uptos")) + (let ([last-upto + (for/fold ([last 1]) ([upto (in-list uptos)]) + (unless (<= upto lenv*-len) + (error 'template "internal error: upto is too big")) + (unless (>= upto last) + (error 'template "internal error: uptos decreased: ~e" uptos)) + upto)]) + (unless (= lenv*-len last-upto) + (error 'template "internal error: last upto was not full env"))) + (cond [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?) + (equal? ghead '-1)) + ;; Fast path for (pvar ... . T) template + ;; - no list? or syntax? checks needed (because ghead is just raw varref, + ;; no 'check' wrapper) + ;; - avoid trivial map, just append + (let ([var-index (vector-ref henv 0)]) + (lambda (env lenv) + (let ([lenv* (get var-index env lenv)]) + (restx stx (append lenv* (ftail env lenv))))))] + [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?)) + ;; Fast path for (T ... . T) template + ;; - specialize lenv to avoid vector allocation/mutation + ;; - body is deforested (append (map _ _) _) preserving eval order + ;; - could try to eliminate 'check-list', but probably not worth the bother + (let* ([fhead (translate-g stx0 (stx-car stx) ghead env-length 'one)] + [var-index (vector-ref henv 0)]) + (lambda (env lenv) + (restx stx + (let ([lenv* (check-list/depth stx (get var-index env lenv) 1)]) + (let dotsloop ([lenv* lenv*]) + (if (null? lenv*) + (ftail env lenv) + (cons (fhead env (car lenv*)) + (dotsloop (cdr lenv*)))))))))] + [else + ;; Slow/general path for (H ...^n . T) + (let ([fhead (if ghead-is-hg? + (translate-hg stx0 (stx-car stx) ghead env-length lenv*-len) + (translate-g stx0 (stx-car stx) ghead env-length lenv*-len))]) + (lambda (env lenv) + #| + The template is "driven" by pattern variables bound to (listof^n syntax). + For example, in (H ... ... . T), the pvars of H have (listof (listof syntax)), + and we need a doubly-nested loop, like + (for/list ([stxlist^1 (in-list stxlist^2)]) + (for/list ([stx (in-list stxlist^1)]) + ___ fhead ___)) + Since we can have arbitrary numbers of ellipses, we have 'nestloop' recur + over ellipsis levels and 'dotsloop' recur over the contents of the pattern + variables' (listof^n syntax) values. + + Also, we reuse lenv vectors to reduce allocation. There is one aux lenv + vector per nesting level, preallocated in aux-lenvs. For continuation-safety + we must install a continuation barrier around metafunction applications. + |# + (define (nestloop lenv* nesting uptos aux-lenvs) + (cond [(zero? nesting) + (fhead env lenv*)] + [else + (let ([iters (check-lenv/get-iterations stx lenv*)]) + (let ([lenv** (car aux-lenvs)] + [aux-lenvs** (cdr aux-lenvs)] + [upto** (car uptos)] + [uptos** (cdr uptos)]) + (let dotsloop ([iters iters]) + (if (zero? iters) + null + (begin (vector-car/cdr! lenv** lenv* upto**) + (let ([row (nestloop lenv** (sub1 nesting) uptos** aux-lenvs**)]) + (cons row (dotsloop (sub1 iters)))))))))])) + (define initial-lenv* + (vector-map (lambda (index) (get index env lenv)) henv)) + (define aux-lenvs + (for/list ([depth (in-range nesting)]) (make-vector lenv*-len))) + + ;; Check initial-lenv* contains lists of right depths. + ;; At each nesting depth, indexes [0,upto) of lenv* vary; + ;; uptos is monotonic nondecreasing (every variable varies in inner + ;; loop---this is always counterintuitive to me). + (let checkloop ([depth nesting] [uptos uptos] [start 0]) + (when (pair? uptos) + (for ([v (in-vector initial-lenv* start (car uptos))]) + (check-list/depth stx v depth)) + (checkloop (sub1 depth) (cdr uptos) (car uptos)))) + + (define head-results + ;; if ghead-is-hg?, is (listof^(nesting+1) stx) -- extra listof for loop-h + ;; otherwise, is (listof^nesting stx) + (nestloop initial-lenv* nesting uptos aux-lenvs)) + (define tail-result (ftail env lenv)) + (restx stx + (nested-append head-results + (if ghead-is-hg? nesting (sub1 nesting)) + tail-result))))]))] + + [(vector 'app ghead gtail) + (let ([fhead (loop-h (stx-car stx) ghead)] + [ftail (loop (stx-cdr stx) gtail)]) + (lambda (env lenv) + (restx stx (append (fhead env lenv) (ftail env lenv)))))] + + [(vector 'escaped g1) + (loop (stx-cadr stx) g1)] + + [(vector 'orelse g1 g2) + (let ([f1 (loop (stx-cadr stx) g1)] + [f2 (loop (stx-caddr stx) g2)]) + (lambda (env lenv) + (with-handlers ([absent-pvar? + (lambda (_e) + (f2 env lenv))]) + (f1 env lenv))))] + + [(vector 'metafun index g1) + (let ([f1 (loop (stx-cdr stx) g1)]) + (check-var index env-length lenv-mode) + (lambda (env lenv) + (let ([v (restx stx (cons (stx-car stx) (f1 env lenv)))] + [mark (make-syntax-introducer)] + [old-mark (current-template-metafunction-introducer)] + [mf (get index env lenv)]) + (parameterize ((current-template-metafunction-introducer mark) + (old-template-metafunction-introducer old-mark)) + (let ([r (call-with-continuation-barrier (lambda () (mf (mark (old-mark v)))))]) + (unless (syntax? r) + (raise-syntax-error #f "result of template metafunction was not syntax" stx)) + (restx stx (old-mark (mark r))))))))] + + [(vector 'vector g1) + (let ([f1 (loop (vector->list (syntax-e stx)) g1)]) + (lambda (env lenv) + (restx stx (list->vector (f1 env lenv)))))] + + [(vector 'struct g1) + (let ([f1 (loop (cdr (vector->list (struct->vector (syntax-e stx)))) g1)] + [key (prefab-struct-key (syntax-e stx))]) + (lambda (env lenv) + (restx stx (apply make-prefab-struct key (f1 env lenv)))))] + + [(vector 'box g1) + (let ([f1 (loop (unbox (syntax-e stx)) g1)]) + (lambda (env lenv) + (restx stx (box (f1 env lenv)))))] + + [(vector 'copy-props g1 keys) + (let ([f1 (loop stx g1)]) + (lambda (env lenv) + (for/fold ([v (f1 env lenv)]) ([key (in-list keys)]) + (let ([pvalue (syntax-property stx key)]) + (if pvalue + (syntax-property v key pvalue) + v)))))] + + [(vector 'set-props g1 props-alist) + (let ([f1 (loop stx g1)]) + (lambda (env lenv) + (for/fold ([v (f1 env lenv)]) ([entry (in-list props-alist)]) + (syntax-property v (car entry) (cdr entry)))))] + + [(vector 'unsyntax var) + (let ([f1 (loop stx var)]) + (lambda (env lenv) + (restx stx (f1 env lenv))))] + + [(vector 'relocate g1 var) + (let ([f1 (loop stx g1)]) + (lambda (env lenv) + (let ([result (f1 env lenv)] + [loc (get var env lenv)]) + (if (or (syntax-source loc) + (syntax-position loc)) + (datum->syntax result (syntax-e result) loc result) + result))))])) + +(define (translate-hg stx0 stx hg env-length lenv-mode) + (define (loop stx g) (translate-g stx0 stx g env-length lenv-mode)) + (define (loop-h stx hg) (translate-hg stx0 stx hg env-length lenv-mode)) + (define (get index env lenv) (get-var index env lenv lenv-mode)) + + (match hg + + [(vector 'app-opt hg1) + (let ([f1 (loop-h (stx-cadr stx) hg1)]) + (lambda (env lenv) + (with-handlers ([absent-pvar? (lambda (_e) null)]) + (f1 env lenv))))] + + [(vector 'orelse-h hg1 hg2) + (let ([f1 (loop-h (stx-cadr stx) hg1)] + [f2 (loop-h (stx-caddr stx) hg2)]) + (lambda (env lenv) + (with-handlers ([absent-pvar? + (lambda (_e) + (f2 env lenv))]) + (f1 env lenv))))] + + [(vector 'splice g1) + (let ([f1 (loop (stx-cdr stx) g1)]) + (lambda (env lenv) + (let* ([v (f1 env lenv)] + [v* (stx->list v)]) + (unless (list? v*) + (raise-syntax-error 'template + "splicing template did not produce a syntax list" + stx)) + v*)))] + + [(vector 'unsyntax-splicing index) + (check-var index env-length lenv-mode) + (lambda (env lenv) + (let* ([v (get index env lenv)] + [v* (stx->list v)]) + (unless (list? v*) + (raise-syntax-error 'template + "unsyntax-splicing expression did not produce a syntax list" + stx)) + v*))] + + [_ + (let ([f (loop stx hg)]) + (lambda (env lenv) + (list (f env lenv))))])) + +(define (get-var index env lenv lenv-mode) + (cond [(positive? index) + (vector-ref env (sub1 index))] + [(negative? index) + (case lenv-mode + ((one) lenv) + (else (vector-ref lenv (- -1 index))))])) + +(define (check-var index env-length lenv-mode) + (cond [(positive? index) + (unless (< (sub1 index) env-length) + (error/bad-index index))] + [(negative? index) + (unless (< (- -1 index) + (case lenv-mode + ((one) 1) + (else lenv-mode))) + (error/bad-index))])) + +(define (check-lenv/get-iterations stx lenv) + (unless (list? (vector-ref lenv 0)) + (error 'template "pattern variable used in ellipsis pattern is not defined")) + (let ([len0 (length (vector-ref lenv 0))]) + (for ([v (in-vector lenv)]) + (unless (list? v) + (error 'template "pattern variable used in ellipsis pattern is not defined")) + (unless (= len0 (length v)) + (raise-syntax-error 'template + "incompatible ellipsis match counts for template" + stx))) + len0)) + +;; ---- + +(define current-template-metafunction-introducer + (make-parameter + (lambda (stx) + (if (syntax-transforming?) + (syntax-local-introduce stx) + stx)))) + +(define old-template-metafunction-introducer + (make-parameter #f)) + +(define (syntax-local-template-metafunction-introduce stx) + (let ([mark (current-template-metafunction-introducer)] + [old-mark (old-template-metafunction-introducer)]) + (unless old-mark + (error 'syntax-local-template-metafunction-introduce + "must be called within the dynamic extent of a template metafunction")) + (mark (old-mark stx)))) + +;; ---- + +(define (stx-cadr x) (stx-car (stx-cdr x))) +(define (stx-cddr x) (stx-cdr (stx-cdr x))) +(define (stx-caddr x) (stx-car (stx-cdr (stx-cdr x)))) + +(define (stx-drop n x) + (cond [(zero? n) x] + [else (stx-drop (sub1 n) (stx-cdr x))])) + +(define (restx basis val) + (if (syntax? basis) + (datum->syntax basis val basis) + val)) + +;; nested-append : (listof^(nesting+1) A) nat (listof A) -> (listof A) +;; (Actually, in practice onto is stx, so this is an improper append.) +(define (nested-append lst nesting onto) + (cond [(zero? nesting) (append lst onto)] + [(null? lst) onto] + [else (nested-append (car lst) (sub1 nesting) + (nested-append (cdr lst) nesting onto))])) + +(define (check-stx ctx v) + (let loop ([v v]) + (cond [(syntax? v) + v] + [(promise? v) + (loop (force v))] + [(eq? v #f) + (raise (absent-pvar ctx v #f))] + [else (err/not-syntax ctx v)]))) + +(define (check-list/depth ctx v0 depth0) + (let depthloop ([v v0] [depth depth0]) + (cond [(zero? depth) v] + [(and (= depth 1) (list? v)) v] + [else + (let loop ([v v]) + (cond [(null? v) + null] + [(pair? v) + (let ([new-car (depthloop (car v) (sub1 depth))] + [new-cdr (loop (cdr v))]) + ;; Don't copy unless necessary + (if (and (eq? new-car (car v)) (eq? new-cdr (cdr v))) + v + (cons new-car new-cdr)))] + [(promise? v) + (loop (force v))] + [(eq? v #f) + (raise (absent-pvar ctx v0 #t))] + [else + (err/not-syntax ctx v0)]))]))) + +;; Note: slightly different from error msg in syntax/parse/private/residual: +;; here says "contains" instead of "is bound to", because might be within list +(define (err/not-syntax ctx v) + (raise-syntax-error #f + (format "attribute contains non-syntax value\n value: ~e" v) + ctx)) + +(define (error/bad-index index) + (error 'template "internal error: bad index: ~e" index)) + +(define (vector-car/cdr! dest-v src-v upto) + (let ([len (vector-length dest-v)]) + (let loop ([i 0]) + (when (< i upto) + (let ([p (vector-ref src-v i)]) + (vector-set! dest-v i (car p)) + (vector-set! src-v i (cdr p))) + (loop (add1 i)))) + (let loop ([j upto]) + (when (< j len) + (vector-set! dest-v j (vector-ref src-v j)) + (loop (add1 j)))))) + +(define (vector-map f src-v) + (let* ([len (vector-length src-v)] + [dest-v (make-vector len)]) + (let loop ([i 0]) + (when (< i len) + (vector-set! dest-v i (f (vector-ref src-v i))) + (loop (add1 i)))) + dest-v)) diff --git a/experimental/template.rkt b/experimental/template.rkt new file mode 100644 index 0000000..b37242b --- /dev/null +++ b/experimental/template.rkt @@ -0,0 +1,660 @@ +#lang racket/base +(require (for-syntax racket/base + "dset.rkt" + racket/syntax + syntax/parse/private/minimatch + racket/private/stx ;; syntax/stx + racket/private/sc) + syntax/parse/private/residual + "private/substitute.rkt") +(provide template + template/loc + quasitemplate + quasitemplate/loc + define-template-metafunction + syntax-local-template-metafunction-introduce + ?? + ?@) + +#| +To do: +- improve error messages +|# + +#| +A Template (T) is one of: + - pvar + - const (including () and non-pvar identifiers) + - (metafunction . T) + - (H . T) + - (H ... . T), (H ... ... . T), etc + - (?? T T) + - #(T*) + - #s(prefab-struct-key T*) + * (unquote expr) + +A HeadTemplate (H) is one of: + - T + - (?? H) + - (?? H H) + - (?@ . T) + * (unquote-splicing expr) +|# + +(begin-for-syntax + (define (do-template ctx tstx quasi? loc-id) + (with-disappeared-uses + (parameterize ((current-syntax-context ctx) + (quasi (and quasi? (box null)))) + (let*-values ([(guide deps props-guide) (parse-template tstx loc-id)] + [(vars) + (for/list ([dep (in-vector deps)]) + (cond [(pvar? dep) (pvar-var dep)] + [(template-metafunction? dep) + (template-metafunction-var dep)] + [else + (error 'template + "internal error: bad environment entry: ~e" + dep)]))]) + (with-syntax ([t tstx]) + (syntax-arm + (cond [(equal? guide '1) + ;; was (template pvar), implies props-guide = '_ + (car vars)] + [(and (equal? guide '_) (equal? props-guide '_)) + #'(quote-syntax t)] + [else + (with-syntax ([guide guide] + [props-guide props-guide] + [vars-vector + (if (pair? vars) + #`(vector . #,vars) + #''#())] + [((un-var . un-form) ...) + (if quasi? (reverse (unbox (quasi))) null)]) + #'(let ([un-var (handle-unsyntax un-form)] ...) + (substitute (quote-syntax t) + 'props-guide + 'guide + vars-vector)))])))))))) + +(define-syntax (template stx) + (syntax-case stx () + [(template t) + (do-template stx #'t #f #f)] + [(template t #:properties (prop ...)) + (andmap identifier? (syntax->list #'(prop ...))) + (parameterize ((props-to-serialize (syntax->datum #'(prop ...))) + (props-to-transfer (syntax->datum #'(prop ...)))) + (do-template stx #'t #f #f))])) + +(define-syntax (quasitemplate stx) + (syntax-case stx () + [(quasitemplate t) + (do-template stx #'t #t #f)])) + +(define-syntaxes (template/loc quasitemplate/loc) + ;; FIXME: better to replace unsyntax form, shrink template syntax constant + (let ([make-tx + (lambda (quasi?) + (lambda (stx) + (syntax-case stx () + [(?/loc loc-expr t) + (syntax-arm + (with-syntax ([main-expr (do-template stx #'t quasi? #'loc-stx)]) + #'(let ([loc-stx (handle-loc '?/loc loc-expr)]) + main-expr)))])))]) + (values (make-tx #f) (make-tx #t)))) + +(define (handle-loc who x) + (if (syntax? x) + x + (raise-argument-error who "syntax?" x))) + +;; FIXME: what lexical context should result of expr get if not syntax? +(define-syntax handle-unsyntax + (syntax-rules (unsyntax unsyntax-splicing) + [(handle-syntax (unsyntax expr)) expr] + [(handle-syntax (unsyntax-splicing expr)) expr])) + +;; substitute-table : hash[stx => translated-template] +;; Cache for closure-compiled templates. Key is just syntax of +;; template, since eq? templates must have equal? guides. +(define substitute-table (make-weak-hasheq)) + +;; props-syntax-table : hash[stx => stx] +(define props-syntax-table (make-weak-hasheq)) + +(define (substitute stx props-guide g main-env) + (let* ([stx (if (eq? props-guide '_) + stx + (or (hash-ref props-syntax-table stx #f) + (let* ([pf (translate stx props-guide 0)] + [pstx (pf '#() #f)]) + (hash-set! props-syntax-table stx pstx) + pstx)))] + [f (or (hash-ref substitute-table stx #f) + (let ([f (translate stx g (vector-length main-env))]) + (hash-set! substitute-table stx f) + f))]) + (f main-env #f))) + +;; ---- + +(define-syntaxes (?? ?@) + (let ([tx (lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx))]) + (values tx tx))) + +;; ============================================================ + +#| +See private/substitute for definition of Guide (G) and HeadGuide (HG). + +A env-entry is one of + - (pvar syntax-mapping attribute-mapping/#f depth-delta) + - template-metafunction + +The depth-delta associated with a depth>0 pattern variable is the difference +between the pattern variable's depth and the depth at which it is used. (For +depth 0 pvars, it's #f.) For example, in + + (with-syntax ([x #'0] + [(y ...) #'(1 2)] + [((z ...) ...) #'((a b) (c d))]) + (template (((x y) ...) ...))) + +the depth-delta for x is #f, the depth-delta for y is 1, and the depth-delta for +z is 0. Coincidentally, the depth-delta is the same as the depth of the ellipsis +form at which the variable should be moved to the loop-env. That is, the +template above should be interpreted as roughly similar to + + (let ([x (pvar-value-of x)] + [y (pvar-value-of y)] + [z (pvar-value-of z)]) + (for ([Lz (in-list z)]) ;; depth 0 + (for ([Ly (in-list y)] ;; depth 1 + [Lz (in-list Lz)]) + (___ x Ly Lz ___)))) + +A Pre-Guide is like a Guide but with env-entry and (setof env-entry) +instead of integers and integer vectors. +|# + +(begin-for-syntax + (struct pvar (sm attr dd) #:prefab)) + +;; ============================================================ + +(define-syntax (define-template-metafunction stx) + (syntax-case stx () + [(dsm (id arg ...) . body) + #'(dsm id (lambda (arg ...) . body))] + [(dsm id expr) + (identifier? #'id) + (with-syntax ([(internal-id) (generate-temporaries #'(id))]) + #'(begin (define internal-id expr) + (define-syntax id + (template-metafunction (quote-syntax internal-id)))))])) + +(begin-for-syntax + (struct template-metafunction (var))) + +;; ============================================================ + +(begin-for-syntax + + ;; props-to-serialize determines what properties are saved even when + ;; code is compiled. (Unwritable values are dropped.) + ;; props-to-transfer determines what properties are transferred from + ;; template to stx constructed. + ;; If a property is in props-to-transfer but not props-to-serialize, + ;; compiling the module may have caused the property to disappear. + ;; If a property is in props-to-serialize but not props-to-transfer, + ;; it will show up only in constant subtrees. + ;; The behavior of 'syntax' is serialize '(), transfer '(paren-shape). + + ;; props-to-serialize : (parameterof (listof symbol)) + (define props-to-serialize (make-parameter '())) + + ;; props-to-transfer : (parameterof (listof symbol)) + (define props-to-transfer (make-parameter '(paren-shape))) + + ;; quasi : (parameterof (or/c #f (list^n (boxof QuasiPairs)))) + ;; each list wrapper represents nested quasi wrapping + ;; QuasiPairs = (listof (cons/c identifier syntax)) + (define quasi (make-parameter #f)) + + ;; parse-template : stx id/#f -> (values guide (vectorof env-entry) guide) + (define (parse-template t loc-id) + (let*-values ([(drivers pre-guide props-guide) (parse-t t 0 #f)] + [(drivers pre-guide) + (if loc-id + (let* ([loc-sm (make-syntax-mapping 0 loc-id)] + [loc-pvar (pvar loc-sm #f #f)]) + (values (dset-add drivers loc-pvar) + (relocate-guide pre-guide loc-pvar))) + (values drivers pre-guide))]) + (let* ([main-env (dset->env drivers (hash))] + [guide (guide-resolve-env pre-guide main-env)]) + (values guide + (index-hash->vector main-env) + props-guide)))) + + ;; dset->env : (dsetof env-entry) -> hash[env-entry => nat] + (define (dset->env drivers init-env) + (for/fold ([env init-env]) + ([pvar (in-list (dset->list drivers))] + [n (in-naturals (+ 1 (hash-count init-env)))]) + (hash-set env pvar n))) + + ;; guide-resolve-env : pre-guide hash[env-entry => nat] -> guide + (define (guide-resolve-env g0 main-env) + (define (loop g loop-env) + (define (get-index x) + (let ([loop-index (hash-ref loop-env x #f)]) + (if loop-index + (- loop-index) + (hash-ref main-env x)))) + (match g + ['_ '_] + [(cons g1 g2) + (cons (loop g1 loop-env) (loop g2 loop-env))] + [(? pvar? pvar) + (if (pvar-check? pvar) + (vector 'check (get-index pvar)) + (get-index pvar))] + [(vector 'dots head new-hdrivers/level nesting '#f tail) + (let-values ([(sub-loop-env r-uptos) + (for/fold ([env (hash)] [r-uptos null]) + ([new-hdrivers (in-list new-hdrivers/level)]) + (let ([new-env (dset->env new-hdrivers env)]) + (values new-env (cons (hash-count new-env) r-uptos))))]) + (let ([sub-loop-vector (index-hash->vector sub-loop-env get-index)]) + (vector 'dots + (loop head sub-loop-env) + sub-loop-vector + nesting + (reverse r-uptos) + (loop tail loop-env))))] + [(vector 'app head tail) + (vector 'app (loop head loop-env) (loop tail loop-env))] + [(vector 'escaped g1) + (vector 'escaped (loop g1 loop-env))] + [(vector 'orelse g1 g2) + (vector 'orelse (loop g1 loop-env) (loop g2 loop-env))] + [(vector 'orelse-h g1 g2) + (vector 'orelse-h (loop g1 loop-env) (loop g2 loop-env))] + [(vector 'metafun mf g1) + (vector 'metafun + (get-index mf) + (loop g1 loop-env))] + [(vector 'vector g1) + (vector 'vector (loop g1 loop-env))] + [(vector 'struct g1) + (vector 'struct (loop g1 loop-env))] + [(vector 'box g1) + (vector 'box (loop (unbox g) loop-env))] + [(vector 'copy-props g1 keys) + (vector 'copy-props (loop g1 loop-env) keys)] + [(vector 'set-props g1 props-alist) + (vector 'set-props (loop g1 loop-env) props-alist)] + [(vector 'app-opt g1) + (vector 'app-opt (loop g1 loop-env))] + [(vector 'splice g1) + (vector 'splice (loop g1 loop-env))] + [(vector 'unsyntax var) + (vector 'unsyntax (get-index var))] + [(vector 'unsyntax-splicing var) + (vector 'unsyntax-splicing (get-index var))] + [(vector 'relocate g1 var) + (vector 'relocate (loop g1 loop-env) (get-index var))] + [else (error 'template "internal error: bad pre-guide: ~e" g)])) + (loop g0 '#hash())) + + ;; ---------------------------------------- + + ;; relocate-gude : stx guide -> guide + (define (relocate-guide g0 loc-pvar) + (define (relocate g) + (vector 'relocate g loc-pvar)) + (define (error/no-relocate) + (wrong-syntax #f "cannot apply syntax location to template")) + (define (loop g) + (match g + ['_ + (relocate g)] + [(cons g1 g2) + (relocate g)] + [(? pvar? g) + g] + [(vector 'dots head new-hdrivers/level nesting '#f tail) + ;; Ideally, should error. For perfect backwards compatability, + ;; should relocate. But if there are zero iterations, that + ;; means we'd relocate tail (which might be bad). Making + ;; relocation depend on number of iterations would be + ;; complicated. So just ignore. + g] + [(vector 'escaped g1) + (vector 'escaped (loop g1))] + [(vector 'vector g1) + (relocate g)] + [(vector 'struct g1) + (relocate g)] + [(vector 'box g1) + (relocate g)] + [(vector 'copy-props g1 keys) + (vector 'copy-props (loop g1) keys)] + [(vector 'unsyntax var) + g] + ;; ---- + [(vector 'app ghead gtail) + (match ghead + [(vector 'unsyntax-splicing _) g] + [_ (error/no-relocate)])] + ;; ---- + [(vector 'orelse g1 g2) + (error/no-relocate)] + [(vector 'orelse-h g1 g2) + (error/no-relocate)] + [(vector 'metafun mf g1) + (error/no-relocate)] + [(vector 'app-opt g1) + (error/no-relocate)] + [(vector 'splice g1) + (error/no-relocate)] + [(vector 'unsyntax-splicing var) + g] + [else (error 'template "internal error: bad guide for relocation: ~e" g0)])) + (loop g0)) + + ;; ---------------------------------------- + + (define (wrap-props stx env-set pre-guide props-guide) + (let ([saved-prop-values + (if (syntax? stx) + (for/fold ([entries null]) ([prop (in-list (props-to-serialize))]) + (let ([v (syntax-property stx prop)]) + (if (and v (quotable? v)) + (cons (cons prop v) entries) + entries))) + null)] + [copy-props + (if (syntax? stx) + (for/list ([prop (in-list (props-to-transfer))] + #:when (syntax-property stx prop)) + prop) + null)]) + (values env-set + (cond [(eq? pre-guide '_) + ;; No need to copy props; already on constant + '_] + [(pair? copy-props) + (vector 'copy-props pre-guide copy-props)] + [else pre-guide]) + (if (pair? saved-prop-values) + (vector 'set-props props-guide saved-prop-values) + props-guide)))) + + (define (quotable? v) + (or (null? v) + (string? v) + (bytes? v) + (number? v) + (boolean? v) + (char? v) + (keyword? v) + (regexp? v) + (and (box? v) (quotable? (unbox v))) + (and (symbol? v) (symbol-interned? v)) + (and (pair? v) (quotable? (car v)) (quotable? (cdr v))) + (and (vector? v) (andmap quotable? (vector->list v))) + (and (prefab-struct-key v) (andmap quotable? (struct->vector v))))) + + (define (cons-guide g1 g2) + (if (and (eq? g1 '_) (eq? g2 '_)) '_ (cons g1 g2))) + + (define (list-guide . gs) + (foldr cons-guide '_ gs)) + + ;; parse-t : stx nat boolean -> (values (dsetof env-entry) pre-guide props-guide) + (define (parse-t t depth esc?) + (syntax-case t (?? ?@ unsyntax quasitemplate) + [id + (identifier? #'id) + (cond [(or (and (not esc?) + (or (free-identifier=? #'id (quote-syntax ...)) + (free-identifier=? #'id (quote-syntax ??)) + (free-identifier=? #'id (quote-syntax ?@)))) + (and (quasi) + (or (free-identifier=? #'id (quote-syntax unsyntax)) + (free-identifier=? #'id (quote-syntax unsyntax-splicing))))) + (wrong-syntax #'id "illegal use")] + [else + (let ([pvar (lookup #'id depth)]) + (cond [(pvar? pvar) + (values (dset pvar) pvar '_)] + [(template-metafunction? pvar) + (wrong-syntax t "illegal use of syntax metafunction")] + [else + (wrap-props #'id (dset) '_ '_)]))])] + [(mf . template) + (and (not esc?) + (identifier? #'mf) + (template-metafunction? (lookup #'mf #f))) + (let-values ([(mf) (lookup #'mf #f)] + [(drivers guide props-guide) (parse-t #'template depth esc?)]) + (values (dset-add drivers mf) + (vector 'metafun mf guide) + (cons-guide '_ props-guide)))] + [(unsyntax t1) + (quasi) + (let ([qval (quasi)]) + (cond [(box? qval) + (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-expr))]) + (set-box! qval (cons (cons #'tmp t) (unbox qval))) + (let* ([fake-sm (make-syntax-mapping 0 #'tmp)] + [fake-pvar (pvar fake-sm #f #f)]) + (values (dset fake-pvar) (vector 'unsyntax fake-pvar) '_)))] + [else + (parameterize ((quasi (car qval))) + (let-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)]) + (wrap-props t + drivers + (list-guide '_ guide) + (list-guide '_ props-guide))))]))] + [(quasitemplate t1) + ;; quasitemplate escapes inner unsyntaxes + (quasi) + (parameterize ((quasi (list (quasi)))) + (let-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)]) + (wrap-props t + drivers + (list-guide '_ guide) + (list-guide '_ props-guide))))] + [(DOTS template) + (and (not esc?) + (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) + (let-values ([(drivers guide props-guide) (parse-t #'template depth #t)]) + (values drivers (vector 'escaped guide) + (list-guide '_ props-guide)))] + [(?? t1 t2) + (not esc?) + (let-values ([(drivers1 guide1 props-guide1) (parse-t #'t1 depth esc?)] + [(drivers2 guide2 props-guide2) (parse-t #'t2 depth esc?)]) + (values (dset-union drivers1 drivers2) + (vector 'orelse guide1 guide2) + (list-guide '_ props-guide1 props-guide2)))] + [(head DOTS . tail) + (and (not esc?) + (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) + (let-values ([(nesting tail) + (let loop ([nesting 1] [tail #'tail]) + (syntax-case tail () + [(DOTS . tail) + (and (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) + (loop (add1 nesting) #'tail)] + [else (values nesting tail)]))]) + (let-values ([(hdrivers _hsplice? hguide hprops-guide) + (parse-h #'head (+ depth nesting) esc?)] + [(tdrivers tguide tprops-guide) + (parse-t tail depth esc?)]) + (when (dset-empty? hdrivers) + (wrong-syntax #'head "no pattern variables before ellipsis in template")) + (when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth))) + ;; FIXME: improve error message? + (let ([bad-dots + ;; select the nestingth (last) ellipsis as the bad one + (stx-car (stx-drop nesting t))]) + (wrong-syntax bad-dots "too many ellipses in template"))) + (wrap-props t + (dset-union hdrivers tdrivers) + ;; pre-guide hdrivers is (listof (setof pvar)) + ;; set of pvars new to each level + (let* ([hdrivers/level + (for/list ([i (in-range nesting)]) + (dset-filter hdrivers (pvar/dd<=? (+ depth i))))] + [new-hdrivers/level + (let loop ([raw hdrivers/level] [last (dset)]) + (cond [(null? raw) null] + [else + (cons (dset-subtract (car raw) last) + (loop (cdr raw) (car raw)))]))]) + (vector 'dots hguide new-hdrivers/level nesting #f tguide)) + (cons-guide hprops-guide (cons-guide '_ tprops-guide)))))] + [(head . tail) + (let-values ([(hdrivers hsplice? hguide hprops-guide) + (parse-h #'head depth esc?)] + [(tdrivers tguide tprops-guide) + (parse-t #'tail depth esc?)]) + (wrap-props t + (dset-union hdrivers tdrivers) + (cond [(and (eq? hguide '_) (eq? tguide '_)) '_] + [hsplice? (vector 'app hguide tguide)] + [else (cons hguide tguide)]) + (cons-guide hprops-guide tprops-guide)))] + [vec + (vector? (syntax-e #'vec)) + (let-values ([(drivers guide props-guide) + (parse-t (vector->list (syntax-e #'vec)) depth esc?)]) + (wrap-props t drivers + (if (eq? guide '_) '_ (vector 'vector guide)) + (if (eq? props-guide '_) '_ (vector 'vector props-guide))))] + [pstruct + (prefab-struct-key (syntax-e #'pstruct)) + (let-values ([(drivers guide props-guide) + (parse-t (cdr (vector->list (struct->vector (syntax-e #'pstruct)))) depth esc?)]) + (wrap-props t drivers + (if (eq? guide '_) '_ (vector 'struct guide)) + (if (eq? props-guide '_) '_ (vector 'struct props-guide))))] + [#&template + (let-values ([(drivers guide props-guide) + (parse-t #'template depth esc?)]) + (wrap-props t drivers + (if (eq? guide '_) '_ (vector 'box guide)) + (if (eq? props-guide '_) '_ (vector 'box props-guide))))] + [const + (wrap-props t (dset) '_ '_)])) + + ;; parse-h : stx nat boolean -> (values (dsetof env-entry) boolean pre-head-guide props-guide) + (define (parse-h h depth esc?) + (syntax-case h (?? ?@ unsyntax-splicing) + [(?? t) + (not esc?) + (let-values ([(drivers splice? guide props-guide) + (parse-h #'t depth esc?)]) + (values drivers #t + (vector 'app-opt guide) + (list-guide '_ props-guide)))] + [(?? t1 t2) + (not esc?) + (let-values ([(drivers1 splice?1 guide1 props-guide1) (parse-h #'t1 depth esc?)] + [(drivers2 splice?2 guide2 props-guide2) (parse-h #'t2 depth esc?)]) + (values (dset-union drivers1 drivers2) + (or splice?1 splice?2) + (vector (if (or splice?1 splice?2) 'orelse-h 'orelse) + guide1 guide2) + (list-guide '_ props-guide1 props-guide2)))] + [(?@ . t) + (not esc?) + (let-values ([(drivers guide props-guide) (parse-t #'t depth esc?)]) + (values drivers #t (vector 'splice guide) (cons-guide '_ props-guide)))] + [(unsyntax-splicing t1) + (quasi) + (let ([qval (quasi)]) + (cond [(box? qval) + (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-splicing-expr))]) + (set-box! qval (cons (cons #'tmp h) (unbox qval))) + (let* ([fake-sm (make-syntax-mapping 0 #'tmp)] + [fake-pvar (pvar fake-sm #f #f)]) + (values (dset fake-pvar) #t (vector 'unsyntax-splicing fake-pvar) '_)))] + [else + (parameterize ((quasi (car qval))) + (let*-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)] + [(drivers guide props-guide) + (wrap-props h + drivers + (list-guide '_ guide) + (list-guide '_ props-guide))]) + (values drivers #f guide props-guide)))]))] + [t + (let-values ([(drivers guide props-guide) (parse-t #'t depth esc?)]) + (values drivers #f guide props-guide))])) + + (define (lookup id depth) + (let ([v (syntax-local-value/record id (lambda (v) (or (syntax-pattern-variable? v) + (template-metafunction? v))))]) + (cond [(syntax-pattern-variable? v) + (let* ([pvar-depth (syntax-mapping-depth v)] + [attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))] + [attr (and (attribute-mapping? attr) attr)]) + (cond [(not depth) ;; not looking for pvars, only for metafuns + #f] + [(zero? pvar-depth) + (pvar v attr #f)] + [(>= depth pvar-depth) + (pvar v attr (- depth pvar-depth))] + [else + (wrong-syntax id "missing ellipses with pattern variable in template")]))] + [(template-metafunction? v) + v] + [else + ;; id is a literal; check that for all x s.t. id = x.y, x is not an attribute + (for ([pfx (in-list (dotted-prefixes id))]) + (let ([pfx-v (syntax-local-value pfx (lambda () #f))]) + (when (and (syntax-pattern-variable? pfx-v) + (let ([valvar (syntax-mapping-valvar pfx-v)]) + (attribute-mapping? (syntax-local-value valvar (lambda () #f))))) + (wrong-syntax id "undefined nested attribute of attribute `~a'" (syntax-e pfx))))) + #f]))) + + (define (dotted-prefixes id) + (let* ([id-string (symbol->string (syntax-e id))] + [dot-locations (map car (regexp-match-positions* #rx"\\.[^.]" id-string))]) + (for/list ([loc (in-list dot-locations)]) + (datum->syntax id (string->symbol (substring id-string 0 loc)))))) + + (define (index-hash->vector hash [f values]) + (let ([vec (make-vector (hash-count hash))]) + (for ([(value index) (in-hash hash)]) + (vector-set! vec (sub1 index) (f value))) + vec)) + + (define ((pvar/dd<=? expected-dd) x) + (match x + [(pvar sm attr dd) (and dd (<= dd expected-dd))] + [_ #f])) + + (define (pvar-var x) + (match x + [(pvar sm '#f dd) (syntax-mapping-valvar sm)] + [(pvar sm attr dd) (attribute-mapping-var attr)])) + + (define (pvar-check? x) + (match x + [(pvar sm '#f dd) #f] + [(pvar sm attr dd) (not (attribute-mapping-syntax? attr))])) + + (define (stx-drop n x) + (cond [(zero? n) x] + [else (stx-drop (sub1 n) (stx-cdr x))])) + ) diff --git a/info.rkt b/info.rkt new file mode 100644 index 0000000..9ff41f7 --- /dev/null +++ b/info.rkt @@ -0,0 +1,9 @@ +#lang info +(define collection "backport-template-pr1514") +(define deps '("base" + "rackunit-lib")) +(define build-deps '("scribble-lib" "racket-doc")) +(define scribblings '(("scribblings/backport-template-pr1514.scrbl" ()))) +(define pkg-desc "Description Here") +(define version "0.0") +(define pkg-authors '(georges)) diff --git a/main.rkt b/main.rkt new file mode 100644 index 0000000..216dcac --- /dev/null +++ b/main.rkt @@ -0,0 +1,35 @@ +#lang racket/base + +(module+ test + (require rackunit)) + +;; Notice +;; To install (from within the package directory): +;; $ raco pkg install +;; To install (once uploaded to pkgs.racket-lang.org): +;; $ raco pkg install <> +;; To uninstall: +;; $ raco pkg remove <> +;; To view documentation: +;; $ raco docs <> +;; +;; For your convenience, we have included a LICENSE.txt file, which links to +;; the GNU Lesser General Public License. +;; If you would prefer to use a different license, replace LICENSE.txt with the +;; desired license. +;; +;; Some users like to add a `private/` directory, place auxiliary files there, +;; and require them in `main.rkt`. +;; +;; See the current version of the racket style guide here: +;; http://docs.racket-lang.org/style/index.html + +;; Code here + +(module+ test + ;; Tests to be run with raco test + ) + +(module+ main + ;; Main entry point, executed when run with the `racket` executable or DrRacket. + ) diff --git a/scribblings/backport-template-pr1514.scrbl b/scribblings/backport-template-pr1514.scrbl new file mode 100644 index 0000000..693a329 --- /dev/null +++ b/scribblings/backport-template-pr1514.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[@for-label[backport-template-pr1514 + racket/base]] + +@title{backport-template-pr1514} +@author{georges} + +@defmodule[backport-template-pr1514] + +Package Description Here