/usr/share/racket/pkgs/2d-lib/match.rkt is in racket-common 6.7-3.
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 121 122 123 124 125 126 127 128 129 130 | #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)]
[(first-arg second-arg) rhses])
(define-values (col-arg row-arg)
(if (< (syntax-column #'first-arg)
(syntax-column #'second-arg))
;; first argument is to the left of second, first is column
(values #'first-arg #'second-arg)
;; otherwise, second argument is either aligned with first
;; (in which case it's below, otherwise it wouldn't be second)
;; or second is to the left of first
;; either way, second is column
(values #'second-arg #'first-arg)))
(set! let-bindings (list* #`[row-x #,row-arg]
#`[col-x #,col-arg]
let-bindings))
(set! main-args #'(row-x col-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))]))))]))
|