/usr/share/racket/pkgs/2d-lib/match.rkt is in racket-common 6.3-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 | #lang racket/base
(require (for-syntax racket/base
(only-in racket/match/parse parse)
racket/match/patterns)
racket/match)
(provide 2dmatch)
(define-syntax (2dmatch stx)
(syntax-case stx ()
[(_ widths heights [(cell ...) rhs ...] ...)
(let ()
;; coord-to-content : hash[(list num num) -o> (listof syntax)]
(define coord-to-content (make-hash))
;; pattern-vars : hash[(list num num) -o> (listof identifier)]
;; for each cell on the boundary, tell us which vars are
;; bound in the corresponding pattern
(define pattern-vars (make-hash))
(define let-bindings '())
(define main-args #f)
(define (on-boundary? cells)
(ormap (λ (lst) (or (= 0 (list-ref lst 0))
(= 0 (list-ref lst 1))))
cells))
(define (cell-stx-object cell)
(if (hash-has-key? coord-to-content cell)
(datum->syntax #f " " (hash-ref coord-to-content cell))
#f))
;; build up the coord-to-content mapping for the
;; boundary cells and build up the pattern-vars table
(for ([cells-stx (in-list (syntax->list #'((cell ...) ...)))]
[rhses (in-list (syntax->list #'((rhs ...) ...)))])
(define cells (syntax->datum cells-stx))
(define rhses-lst (syntax->list rhses))
(cond
[(member (list 0 0) cells)
(unless (and rhses-lst (= 2 (length rhses-lst)))
(raise-syntax-error '2dmatch "cell at 0,0 must contain two expressions"
(cell-stx-object (car cells))))
(with-syntax ([(left-x right-x) (generate-temporaries rhses)]
[(left-arg right-arg) rhses])
(set! let-bindings (list* #`[right-x right-arg]
#`[left-x left-arg]
let-bindings))
(set! main-args #'(left-x right-x)))]
[(on-boundary? cells)
(unless (and rhses-lst (= 1 (length rhses-lst)))
(raise-syntax-error '2dmatch
(format
"cell at ~a,~a must contain exactly one match pattern, found ~a"
(list-ref (car cells) 0) (list-ref (car cells) 1)
(length rhses-lst))
stx
(cell-stx-object (car (syntax-e cells-stx)))))
(define pat (car rhses-lst))
(hash-set! pattern-vars (car cells) (bound-vars (parse pat)))])
(when (pair? rhses-lst)
(define pat (car rhses-lst))
(hash-set! coord-to-content (car cells) pat)))
;; build up the coord-to-content mapping for the non-boundary cells
;; use the pattern-vars table to build up the let-bindings that
;; bind identifiers to functions that end up getting called in the match clauses
(for ([cells-stx (in-list (syntax->list #'((cell ...) ...)))]
[rhses (in-list (syntax->list #'((rhs ...) ...)))])
(define cells (syntax->datum cells-stx))
(define rhses-lst (syntax->list rhses))
(unless (on-boundary? cells)
(when (null? (syntax-e rhses))
(raise-syntax-error '2dmatch
(format "cell at ~a,~a should not be empty"
(list-ref (car cells) 0)
(list-ref (car cells) 1))
stx))
(define horizontal-vars (hash-ref pattern-vars (list (list-ref (car cells) 0) 0)))
(define vertical-vars (hash-ref pattern-vars (list 0 (list-ref (car cells) 1))))
(define (intersect vs1 vs2)
(for/list ([v1 (in-list vs1)]
#:when (is-in? v1 vs2))
v1))
(define (is-in? v1 v2s)
(for/or ([v2 (in-list v2s)])
(free-identifier=? v1 v2)))
(for ([cell (in-list (cdr cells))])
(set! horizontal-vars (intersect horizontal-vars
(hash-ref pattern-vars (list (list-ref cell 0) 0))))
(set! vertical-vars (intersect vertical-vars
(hash-ref pattern-vars (list 0 (list-ref cell 1))))))
(with-syntax ([(id) (generate-temporaries (list (format "2d-~a-~a"
(list-ref (car cells) 0)
(list-ref (car cells) 1))))])
(define app #`(id #,@horizontal-vars #,@vertical-vars))
(for ([cell (in-list cells)])
(hash-set! coord-to-content cell app))
(set! let-bindings
(cons #`[id #,(syntax-property
#`(λ (#,@horizontal-vars #,@vertical-vars) #,@rhses)
'typechecker:called-in-tail-position
#t)]
let-bindings)))))
(define num-of-cols (length (syntax->list #'widths)))
(define num-of-rows (length (syntax->list #'heights)))
#`(let #,(reverse let-bindings)
(match*/derived #,main-args #,stx
#,@(for*/list ([x (in-range 1 num-of-cols)]
[y (in-range 1 num-of-rows)])
#`[(#,(hash-ref coord-to-content (list x 0))
#,(hash-ref coord-to-content (list 0 y)))
#,(hash-ref coord-to-content (list x y))]))))]))
|