suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

changed to lang scheme/base

Browse Source 
svn: r11527
This commit is contained in:
Robby Findler 2008-09-02 18:34:18 +00:00
parent 44b62899fa
commit 898edef55e
1 changed files with 144 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

290
collects/redex/private/matcher.ss
View File

@ -1,3 +1,5 @@
#lang scheme/base
#| #|
Note: the patterns described in the doc.txt file are Note: the patterns described in the doc.txt file are
@ -9,12 +11,10 @@ reduction (And other) macros do this transformation
before the pattern compiler is invoked. before the pattern compiler is invoked.
|# |#
(module matcher mzscheme (require scheme/list
(require (lib "list.ss") scheme/match
(lib "match.ss") scheme/contract
(lib "etc.ss") "underscore-allowed.ss")
(lib "contract.ss")
"underscore-allowed.ss")
(define-struct compiled-pattern (cp)) (define-struct compiled-pattern (cp))
@ -24,8 +24,8 @@ before the pattern compiler is invoked.
;; nt = (make-nt sym (listof rhs)) ;; nt = (make-nt sym (listof rhs))
;; rhs = (make-rhs single-pattern (listof var-info??)) ;; rhs = (make-rhs single-pattern (listof var-info??))
;; single-pattern = sexp ;; single-pattern = sexp
(define-struct nt (name rhs) (make-inspector)) (define-struct nt (name rhs) #:inspector (make-inspector))
(define-struct rhs (pattern var-info) (make-inspector)) (define-struct rhs (pattern var-info) #:inspector (make-inspector))
;; var = (make-var sym sexp) ;; var = (make-var sym sexp)
;; patterns are sexps with `var's embedded ;; patterns are sexps with `var's embedded
@ -39,7 +39,7 @@ before the pattern compiler is invoked.
;; by merge-multiples/remove, a helper function called from match-pattern ;; by merge-multiples/remove, a helper function called from match-pattern
(define-values (make-bindings bindings-table bindings?) (define-values (make-bindings bindings-table bindings?)
(let () (let ()
(define-struct bindings (table) (make-inspector)) ;; for testing, add inspector (define-struct bindings (table) #:inspector (make-inspector)) ;; for testing, add inspector
(values (lambda (table) (values (lambda (table)
(unless (and (list? table) (unless (and (list? table)
(andmap (λ (x) (or (bind? x) (mismatch-bind? x))) table)) (andmap (λ (x) (or (bind? x) (mismatch-bind? x))) table))
@ -48,18 +48,18 @@ before the pattern compiler is invoked.
bindings-table bindings-table
bindings?))) bindings?)))
(define-struct bind (name exp) (make-inspector)) ;; for testing, add inspector (define-struct bind (name exp) #:inspector (make-inspector)) ;; for testing, add inspector
(define-struct mismatch-bind (name exp) (make-inspector)) ;; for testing, add inspector (define-struct mismatch-bind (name exp) #:inspector (make-inspector)) ;; for testing, add inspector
;; repeat = (make-repeat compiled-pattern (listof rib) (union #f symbol) boolean) ;; repeat = (make-repeat compiled-pattern (listof rib) (union #f symbol) boolean)
(define-struct repeat (pat empty-bindings suffix mismatch?) (make-inspector)) ;; inspector for tests below (define-struct repeat (pat empty-bindings suffix mismatch?) #:inspector (make-inspector)) ;; inspector for tests below
;; compiled-pattern : exp (union #f none sym) -> (union #f (listof mtch)) ;; compiled-pattern : exp (union #f none sym) -> (union #f (listof mtch))
;; mtch = (make-mtch bindings sexp[context w/none-inside for the hole] (union none sexp[hole])) ;; mtch = (make-mtch bindings sexp[context w/none-inside for the hole] (union none sexp[hole]))
;; mtch is short for "match" ;; mtch is short for "match"
(define-values (mtch-bindings mtch-context mtch-hole make-mtch mtch?) (define-values (mtch-bindings mtch-context mtch-hole make-mtch mtch?)
(let () (let ()
(define-struct mtch (bindings context hole) (make-inspector)) (define-struct mtch (bindings context hole) #:inspector (make-inspector))
(values mtch-bindings (values mtch-bindings
mtch-context mtch-context
mtch-hole mtch-hole
@ -77,12 +77,12 @@ before the pattern compiler is invoked.
(define (none? x) (eq? x none)) (define (none? x) (eq? x none))
;; compiled-lang : (make-compiled-lang (listof nt) ;; compiled-lang : (make-compiled-lang (listof nt)
;; hash-table[sym -o> compiled-pattern] ;; hash[sym -o> compiled-pattern]
;; hash-table[sym -o> compiled-pattern] ;; hash[sym -o> compiled-pattern]
;; hash-table[sym -o> compiled-pattern] ;; hash[sym -o> compiled-pattern]
;; hash-table[sym -o> boolean]) ;; hash[sym -o> boolean])
;; hash-table[sexp[pattern] -o> (cons compiled-pattern boolean)] ;; hash[sexp[pattern] -o> (cons compiled-pattern boolean)]
;; hash-table[sexp[pattern] -o> (cons compiled-pattern boolean)] ;; hash[sexp[pattern] -o> (cons compiled-pattern boolean)]
;; pict-builder ;; pict-builder
;; (listof symbol) ;; (listof symbol)
;; (listof (listof symbol))) -- keeps track of `primary' non-terminals ;; (listof (listof symbol))) -- keeps track of `primary' non-terminals
@ -95,28 +95,28 @@ before the pattern compiler is invoked.
nt-map)) nt-map))
;; lookup-binding : bindings (union sym (cons sym sym)) [(-> any)] -> any ;; lookup-binding : bindings (union sym (cons sym sym)) [(-> any)] -> any
(define lookup-binding (define (lookup-binding bindings
(opt-lambda (bindings sym
sym [fail (lambda ()
[fail (lambda () (error 'lookup-binding "didn't find ~e in ~e" sym bindings))]) (error 'lookup-binding "didn't find ~e in ~e" sym bindings))])
(let loop ([ribs (bindings-table bindings)]) (let loop ([ribs (bindings-table bindings)])
(cond (cond
[(null? ribs) (fail)] [(null? ribs) (fail)]
[else [else
(let ([rib (car ribs)]) (let ([rib (car ribs)])
(if (and (bind? rib) (equal? (bind-name rib) sym)) (if (and (bind? rib) (equal? (bind-name rib) sym))
(bind-exp rib) (bind-exp rib)
(loop (cdr ribs))))])))) (loop (cdr ribs))))])))
;; compile-language : language-pict-info[see pict.ss] (listof nt) (listof (listof sym)) -> compiled-lang ;; compile-language : language-pict-info[see pict.ss] (listof nt) (listof (listof sym)) -> compiled-lang
(define (compile-language pict-info lang nt-map) (define (compile-language pict-info lang nt-map)
(let* ([clang-ht (make-hash-table)] (let* ([clang-ht (make-hasheq)]
[clang-list-ht (make-hash-table)] [clang-list-ht (make-hasheq)]
[across-ht (make-hash-table)] [across-ht (make-hasheq)]
[across-list-ht (make-hash-table)] [across-list-ht (make-hasheq)]
[has-hole-ht (build-has-hole-ht lang)] [has-hole-ht (build-has-hole-ht lang)]
[cache (make-hash-table 'equal)] [cache (make-hash)]
[bind-names-cache (make-hash-table 'equal)] [bind-names-cache (make-hash)]
[literals (extract-literals lang)] [literals (extract-literals lang)]
[clang (make-compiled-lang lang clang-ht clang-list-ht [clang (make-compiled-lang lang clang-ht clang-list-ht
across-ht across-list-ht across-ht across-list-ht
@ -137,10 +137,10 @@ before the pattern compiler is invoked.
(compile-pattern/cross? clang (rhs-pattern rhs) prefix-cross? #f)]) (compile-pattern/cross? clang (rhs-pattern rhs) prefix-cross? #f)])
(let ([add-to-ht (let ([add-to-ht
(lambda (ht) (lambda (ht)
(hash-table-put! (hash-set!
ht ht
(nt-name nt) (nt-name nt)
(cons compiled-pattern (hash-table-get ht (nt-name nt)))))]) (cons compiled-pattern (hash-ref ht (nt-name nt)))))])
(when (may-be-non-list-pattern? (rhs-pattern rhs) (when (may-be-non-list-pattern? (rhs-pattern rhs)
non-list-nt-table) non-list-nt-table)
(add-to-ht ht)) (add-to-ht ht))
@ -151,13 +151,13 @@ before the pattern compiler is invoked.
lang))] lang))]
[init-ht [init-ht
(lambda (ht) (lambda (ht)
(for-each (lambda (nt) (hash-table-put! ht (nt-name nt) null)) (for-each (lambda (nt) (hash-set! ht (nt-name nt) null))
lang))]) lang))])
(init-ht clang-ht) (init-ht clang-ht)
(init-ht clang-list-ht) (init-ht clang-list-ht)
(hash-table-for-each (hash-for-each
clang-ht clang-ht
(lambda (nt rhs) (lambda (nt rhs)
(when (has-underscore? nt) (when (has-underscore? nt)
@ -166,8 +166,8 @@ before the pattern compiler is invoked.
(let ([compatible-context-language (let ([compatible-context-language
(build-compatible-context-language clang-ht lang)]) (build-compatible-context-language clang-ht lang)])
(for-each (lambda (nt) (for-each (lambda (nt)
(hash-table-put! across-ht (nt-name nt) null) (hash-set! across-ht (nt-name nt) null)
(hash-table-put! across-list-ht (nt-name nt) null)) (hash-set! across-list-ht (nt-name nt) null))
compatible-context-language) compatible-context-language)
(do-compilation clang-ht clang-list-ht lang #t) (do-compilation clang-ht clang-list-ht lang #t)
(do-compilation across-ht across-list-ht compatible-context-language #f) (do-compilation across-ht across-list-ht compatible-context-language #f)
@ -175,13 +175,13 @@ before the pattern compiler is invoked.
;; extract-literals : (listof nt) -> (listof symbol) ;; extract-literals : (listof nt) -> (listof symbol)
(define (extract-literals nts) (define (extract-literals nts)
(let ([literals-ht (make-hash-table)] (let ([literals-ht (make-hasheq)]
[nt-names (map nt-name nts)]) [nt-names (map nt-name nts)])
(for-each (λ (nt) (for-each (λ (nt)
(for-each (λ (rhs) (extract-literals/pat nt-names (rhs-pattern rhs) literals-ht)) (for-each (λ (rhs) (extract-literals/pat nt-names (rhs-pattern rhs) literals-ht))
(nt-rhs nt))) (nt-rhs nt)))
nts) nts)
(hash-table-map literals-ht (λ (x y) x)))) (hash-map literals-ht (λ (x y) x))))
;; extract-literals/pat : (listof sym) pattern ht -> void ;; extract-literals/pat : (listof sym) pattern ht -> void
;; inserts the literals mentioned in pat into ht ;; inserts the literals mentioned in pat into ht
@ -200,7 +200,7 @@ before the pattern compiler is invoked.
(unless (regexp-match #rx"_" (symbol->string s)) (unless (regexp-match #rx"_" (symbol->string s))
(unless (regexp-match #rx"^\\.\\.\\." (symbol->string s)) (unless (regexp-match #rx"^\\.\\.\\." (symbol->string s))
(unless (memq s nts) (unless (memq s nts)
(hash-table-put! ht s #t))))] (hash-set! ht s #t))))]
[`(name ,name ,pat) (loop pat)] [`(name ,name ,pat) (loop pat)]
[`(in-hole ,p1 ,p2) [`(in-hole ,p1 ,p2)
(loop p1) (loop p1)
@ -215,7 +215,7 @@ before the pattern compiler is invoked.
(loop (car l-pat)) (loop (car l-pat))
(l-loop (cdr l-pat))))]))) (l-loop (cdr l-pat))))])))
; build-has-hole-ht : (listof nt) -> hash-table[symbol -o> boolean] ; build-has-hole-ht : (listof nt) -> hash[symbol -o> boolean]
; produces a map of nonterminal -> whether that nonterminal could produce a hole ; produces a map of nonterminal -> whether that nonterminal could produce a hole
(define (build-has-hole-ht lang) (define (build-has-hole-ht lang)
(build-nt-property (build-nt-property
@ -226,7 +226,7 @@ before the pattern compiler is invoked.
[`number #f] [`number #f]
[`string #f] [`string #f]
[`variable #f] [`variable #f]
[`(variable-except ,@(vars ...)) #f] [`(variable-except ,vars ...) #f]
[`(variable-prefix ,var) #f] [`(variable-prefix ,var) #f]
[`variable-not-otherwise-mentioned #f] [`variable-not-otherwise-mentioned #f]
[`hole #t] [`hole #t]
@ -248,31 +248,31 @@ before the pattern compiler is invoked.
(lambda (lst) (ormap values lst)))) (lambda (lst) (ormap values lst))))
;; build-nt-property : lang (pattern[not-non-terminal] (pattern -> boolean) -> boolean) boolean ;; build-nt-property : lang (pattern[not-non-terminal] (pattern -> boolean) -> boolean) boolean
;; -> hash-table[symbol[nt] -> boolean] ;; -> hash[symbol[nt] -> boolean]
(define (build-nt-property lang test-rhs conservative-answer combine-rhss) (define (build-nt-property lang test-rhs conservative-answer combine-rhss)
(let ([ht (make-hash-table)] (let ([ht (make-hasheq)]
[rhs-ht (make-hash-table)]) [rhs-ht (make-hasheq)])
(for-each (for-each
(lambda (nt) (lambda (nt)
(hash-table-put! rhs-ht (nt-name nt) (nt-rhs nt)) (hash-set! rhs-ht (nt-name nt) (nt-rhs nt))
(hash-table-put! ht (nt-name nt) 'unknown)) (hash-set! ht (nt-name nt) 'unknown))
lang) lang)
(let () (let ()
(define (check-nt nt-sym) (define (check-nt nt-sym)
(let ([current (hash-table-get ht nt-sym)]) (let ([current (hash-ref ht nt-sym)])
(case current (case current
[(unknown) [(unknown)
(hash-table-put! ht nt-sym 'computing) (hash-set! ht nt-sym 'computing)
(let ([answer (combine-rhss (let ([answer (combine-rhss
(map (lambda (x) (check-rhs (rhs-pattern x))) (map (lambda (x) (check-rhs (rhs-pattern x)))
(hash-table-get rhs-ht nt-sym)))]) (hash-ref rhs-ht nt-sym)))])
(hash-table-put! ht nt-sym answer) (hash-set! ht nt-sym answer)
answer)] answer)]
[(computing) conservative-answer] [(computing) conservative-answer]
[else current]))) [else current])))
(define (check-rhs rhs) (define (check-rhs rhs)
(cond (cond
[(hash-table-maps? ht rhs) [(hash-maps? ht rhs)
(check-nt rhs)] (check-nt rhs)]
[else (test-rhs rhs check-rhs)])) [else (test-rhs rhs check-rhs)]))
(for-each (lambda (nt) (check-nt (nt-name nt))) (for-each (lambda (nt) (check-nt (nt-name nt)))
@ -342,14 +342,14 @@ before the pattern compiler is invoked.
[`number (lambda (l) 'number)] [`number (lambda (l) 'number)]
[`string (lambda (l) 'string)] [`string (lambda (l) 'string)]
[`variable (lambda (l) 'variable)] [`variable (lambda (l) 'variable)]
[`(variable-except ,@(vars ...)) (lambda (l) pattern)] [`(variable-except ,vars ...) (lambda (l) pattern)]
[`(variable-prefix ,var) (lambda (l) pattern)] [`(variable-prefix ,var) (lambda (l) pattern)]
[`variable-not-otherwise-mentioned (λ (l) pattern)] [`variable-not-otherwise-mentioned (λ (l) pattern)]
[`hole (lambda (l) 'hole)] [`hole (lambda (l) 'hole)]
[(? string?) (lambda (l) pattern)] [(? string?) (lambda (l) pattern)]
[(? symbol?) [(? symbol?)
(cond (cond
[(hash-table-get clang-ht pattern #f) [(hash-ref clang-ht pattern #f)
(set! count (+ count 1)) (set! count (+ count 1))
(lambda (l) (lambda (l)
(let ([fst (car (unbox l))]) (let ([fst (car (unbox l))])
@ -423,7 +423,7 @@ before the pattern compiler is invoked.
(lambda (l) pattern)])) (lambda (l) pattern)]))
count))) count)))
;; build-list-nt-label : lang -> hash-table[symbol -o> boolean] ;; build-list-nt-label : lang -> hash[symbol -o> boolean]
(define (build-list-nt-label lang) (define (build-list-nt-label lang)
(build-nt-property (build-nt-property
lang lang
@ -439,7 +439,7 @@ before the pattern compiler is invoked.
(may-be-list-pattern?/internal (may-be-list-pattern?/internal
pattern pattern
(lambda (sym) (lambda (sym)
(hash-table-get list-nt-table (symbol->nt sym) #t)) (hash-ref list-nt-table (symbol->nt sym) #t))
loop))) loop)))
(define (may-be-list-pattern?/internal pattern handle-symbol recur) (define (may-be-list-pattern?/internal pattern handle-symbol recur)
@ -448,7 +448,7 @@ before the pattern compiler is invoked.
[`number #f] [`number #f]
[`string #f] [`string #f]
[`variable #f] [`variable #f]
[`(variable-except ,@(vars ...)) #f] [`(variable-except ,vars ...) #f]
[`variable-not-otherwise-mentioned #f] [`variable-not-otherwise-mentioned #f]
[`(variable-prefix ,var) #f] [`(variable-prefix ,var) #f]
[`hole #t] [`hole #t]
@ -470,7 +470,7 @@ before the pattern compiler is invoked.
(or (null? pattern) (pair? pattern))])) (or (null? pattern) (pair? pattern))]))
;; build-non-list-nt-label : lang -> hash-table[symbol -o> boolean] ;; build-non-list-nt-label : lang -> hash[symbol -o> boolean]
(define (build-non-list-nt-label lang) (define (build-non-list-nt-label lang)
(build-nt-property (build-nt-property
lang lang
@ -486,7 +486,7 @@ before the pattern compiler is invoked.
(may-be-non-list-pattern?/internal (may-be-non-list-pattern?/internal
pattern pattern
(lambda (sym) (lambda (sym)
(hash-table-get non-list-nt-table (symbol->nt sym) #t)) (hash-ref non-list-nt-table (symbol->nt sym) #t))
loop))) loop)))
(define (may-be-non-list-pattern?/internal pattern handle-sym recur) (define (may-be-non-list-pattern?/internal pattern handle-sym recur)
@ -495,7 +495,7 @@ before the pattern compiler is invoked.
[`number #t] [`number #t]
[`string #t] [`string #t]
[`variable #t] [`variable #t]
[`(variable-except ,@(vars ...)) #t] [`(variable-except vars ...) #t]
[`variable-not-otherwise-mentioned #t] [`variable-not-otherwise-mentioned #t]
[`(variable-prefix ,prefix) #t] [`(variable-prefix ,prefix) #t]
[`hole #t] [`hole #t]
@ -542,10 +542,10 @@ before the pattern compiler is invoked.
(let/ec fail (let/ec fail
(let ( (let (
;; match-ht : sym -o> sexp ;; match-ht : sym -o> sexp
[match-ht (make-hash-table 'equal)] [match-ht (make-hash)]
;; mismatch-ht : sym -o> hash-table[sexp -o> #t] ;; mismatch-ht : sym -o> hash[sexp -o> #t]
[mismatch-ht (make-hash-table 'equal)] [mismatch-ht (make-hash)]
[ribs (bindings-table (mtch-bindings match))]) [ribs (bindings-table (mtch-bindings match))])
(for-each (for-each
@ -554,39 +554,38 @@ before the pattern compiler is invoked.
[(bind? rib) [(bind? rib)
(let ([name (bind-name rib)] (let ([name (bind-name rib)]
[exp (bind-exp rib)]) [exp (bind-exp rib)])
(let ([previous-exp (hash-table-get match-ht name uniq)]) (let ([previous-exp (hash-ref match-ht name uniq)])
(cond (cond
[(eq? previous-exp uniq) [(eq? previous-exp uniq)
(hash-table-put! match-ht name exp)] (hash-set! match-ht name exp)]
[else [else
(unless (equal? exp previous-exp) (unless (equal? exp previous-exp)
(fail #f))])))] (fail #f))])))]
[(mismatch-bind? rib) [(mismatch-bind? rib)
(let* ([name (mismatch-bind-name rib)] (let* ([name (mismatch-bind-name rib)]
[exp (mismatch-bind-exp rib)] [exp (mismatch-bind-exp rib)]
[priors (hash-table-get mismatch-ht name uniq)]) [priors (hash-ref mismatch-ht name uniq)])
(when (eq? priors uniq) (when (eq? priors uniq)
(let ([table (make-hash-table 'equal)]) (let ([table (make-hash)])
(hash-table-put! mismatch-ht name table) (hash-set! mismatch-ht name table)
(set! priors table))) (set! priors table)))
(when (hash-table-get priors exp #f) (when (hash-ref priors exp #f)
(fail #f)) (fail #f))
(hash-table-put! priors exp #t))])) (hash-set! priors exp #t))]))
ribs) ribs)
(make-mtch (make-mtch
(make-bindings (hash-table-map match-ht make-bind)) (make-bindings (hash-map match-ht make-bind))
(mtch-context match) (mtch-context match)
(mtch-hole match))))) (mtch-hole match)))))
;; compile-pattern : compiled-lang pattern boolean (listof sym) -> compiled-pattern ;; compile-pattern : compiled-lang pattern boolean (listof sym) -> compiled-pattern
(define compile-pattern (define (compile-pattern clang pattern bind-names?)
(opt-lambda (clang pattern bind-names?) (let-values ([(pattern has-hole?) (compile-pattern/cross? clang pattern #t bind-names?)])
(let-values ([(pattern has-hole?) (compile-pattern/cross? clang pattern #t bind-names?)]) (make-compiled-pattern pattern)))
(make-compiled-pattern pattern))))
;; name-to-key/binding : hash-table[symbol -o> key-wrap] ;; name-to-key/binding : hash[symbol -o> key-wrap]
(define name-to-key/binding (make-hash-table)) (define name-to-key/binding (make-hasheq))
(define-struct key-wrap (sym) (make-inspector)) (define-struct key-wrap (sym) #:inspector (make-inspector))
;; compile-pattern/cross? : compiled-lang pattern boolean boolean -> (values compiled-pattern boolean) ;; compile-pattern/cross? : compiled-lang pattern boolean boolean -> (values compiled-pattern boolean)
(define (compile-pattern/cross? clang pattern prefix-cross? bind-names?) (define (compile-pattern/cross? clang pattern prefix-cross? bind-names?)
@ -603,13 +602,13 @@ before the pattern compiler is invoked.
(compiled-lang-cache clang)))) (compiled-lang-cache clang))))
(define (compile-pattern/cache pattern compiled-pattern-cache) (define (compile-pattern/cache pattern compiled-pattern-cache)
(let ([compiled-cache (hash-table-get compiled-pattern-cache pattern uniq)]) (let ([compiled-cache (hash-ref compiled-pattern-cache pattern uniq)])
(cond (cond
[(eq? compiled-cache uniq) [(eq? compiled-cache uniq)
(let-values ([(compiled-pattern has-hole?) (let-values ([(compiled-pattern has-hole?)
(true-compile-pattern pattern)]) (true-compile-pattern pattern)])
(let ([val (list (memoize compiled-pattern has-hole?) has-hole?)]) (let ([val (list (memoize compiled-pattern has-hole?) has-hole?)])
(hash-table-put! compiled-pattern-cache pattern val) (hash-set! compiled-pattern-cache pattern val)
(apply values val)))] (apply values val)))]
[else [else
(apply values compiled-cache)]))) (apply values compiled-cache)])))
@ -618,7 +617,7 @@ before the pattern compiler is invoked.
(match pattern (match pattern
[(? (lambda (x) (eq? x '....))) [(? (lambda (x) (eq? x '....)))
(error 'compile-language "the pattern .... can only be used in extend-language")] (error 'compile-language "the pattern .... can only be used in extend-language")]
[`(variable-except ,@(vars ...)) [`(variable-except ,vars ...)
(values (values
(lambda (exp hole-info) (lambda (exp hole-info)
(and (symbol? exp) (and (symbol? exp)
@ -666,11 +665,11 @@ before the pattern compiler is invoked.
[(has-underscore? pattern) [(has-underscore? pattern)
(let*-values ([(binder before-underscore) (let*-values ([(binder before-underscore)
(let ([before (split-underscore pattern)]) (let ([before (split-underscore pattern)])
(unless (or (hash-table-maps? clang-ht before) (unless (or (hash-maps? clang-ht before)
(memq before underscore-allowed)) (memq before underscore-allowed))
(error 'compile-pattern "before underscore must be either a non-terminal ~a or a built-in pattern, found ~a in ~s" (error 'compile-pattern "before underscore must be either a non-terminal ~a or a built-in pattern, found ~a in ~s"
before before
(format "~s" (list* 'one 'of: (hash-table-map clang-ht (λ (x y) x)))) (format "~s" (list* 'one 'of: (hash-map clang-ht (λ (x y) x))))
pattern)) pattern))
(values pattern before))] (values pattern before))]
[(match-raw-name has-hole?) [(match-raw-name has-hole?)
@ -689,11 +688,11 @@ before the pattern compiler is invoked.
(symbol-append pre-id '- pre-id) (symbol-append pre-id '- pre-id)
pre-id)]) pre-id)])
(cond (cond
[(hash-table-maps? across-ht id) [(hash-maps? across-ht id)
(values (values
(lambda (exp hole-info) (lambda (exp hole-info)
(match-nt (hash-table-get across-list-ht id) (match-nt (hash-ref across-list-ht id)
(hash-table-get across-ht id) (hash-ref across-ht id)
id exp hole-info)) id exp hole-info))
#t)] #t)]
[else [else
@ -763,7 +762,7 @@ before the pattern compiler is invoked.
(define (non-underscore-binder? pattern) (define (non-underscore-binder? pattern)
(and bind-names? (and bind-names?
(or (hash-table-maps? clang-ht pattern) (or (hash-maps? clang-ht pattern)
(memq pattern underscore-allowed)))) (memq pattern underscore-allowed))))
;; compile-id-pattern : symbol[with-out-underscore] -> (values <compiled-pattern-proc> boolean) ;; compile-id-pattern : symbol[with-out-underscore] -> (values <compiled-pattern-proc> boolean)
@ -776,10 +775,10 @@ before the pattern compiler is invoked.
[(? is-non-terminal?) [(? is-non-terminal?)
(values (values
(lambda (exp hole-info) (lambda (exp hole-info)
(match-nt (hash-table-get clang-list-ht pat) (match-nt (hash-ref clang-list-ht pat)
(hash-table-get clang-ht pat) (hash-ref clang-ht pat)
pat exp hole-info)) pat exp hole-info))
(hash-table-get has-hole-ht pat))] (hash-ref has-hole-ht pat))]
[else [else
(values (values
(lambda (exp hole-info) (lambda (exp hole-info)
@ -789,7 +788,7 @@ before the pattern compiler is invoked.
none)))) none))))
#f)])) #f)]))
(define (is-non-terminal? sym) (hash-table-maps? clang-ht sym)) (define (is-non-terminal? sym) (hash-maps? clang-ht sym))
;; simple-match : sym (any -> bool) -> (values <compiled-pattern> boolean) ;; simple-match : sym (any -> bool) -> (values <compiled-pattern> boolean)
;; does a match based on a built-in Scheme predicate ;; does a match based on a built-in Scheme predicate
@ -861,9 +860,9 @@ before the pattern compiler is invoked.
(define cache-size 350) (define cache-size 350)
(define (set-cache-size! cs) (set! cache-size cs)) (define (set-cache-size! cs) (set! cache-size cs))
;; original version, but without closure allocation in hash-table lookup ;; original version, but without closure allocation in hash lookup
(define (memoize/key f key-fn statsbox) (define (memoize/key f key-fn statsbox)
(let ([ht (make-hash-table 'equal)] (let ([ht (make-hash)]
[entries 0]) [entries 0])
(lambda (x y) (lambda (x y)
(if cache-size (if cache-size
@ -871,40 +870,40 @@ before the pattern compiler is invoked.
;(record-cache-test! statsbox) ;(record-cache-test! statsbox)
(unless (< entries cache-size) (unless (< entries cache-size)
(set! entries 0) (set! entries 0)
(set! ht (make-hash-table 'equal))) (set! ht (make-hash)))
(let ([ans (hash-table-get ht key uniq)]) (let ([ans (hash-ref ht key uniq)])
(cond (cond
[(eq? ans uniq) [(eq? ans uniq)
;(record-cache-miss! statsbox) ;(record-cache-miss! statsbox)
(set! entries (+ entries 1)) (set! entries (+ entries 1))
(let ([res (f x y)]) (let ([res (f x y)])
(hash-table-put! ht key res) (hash-set! ht key res)
res)] res)]
[else [else
ans]))) ans])))
(f x y))))) (f x y)))))
;; hash-table version, but with an extra hash-table that tells when to evict cache entries ;; hash version, but with an extra hash that tells when to evict cache entries
#; #;
(define (memoize/key f key-fn statsbox) (define (memoize/key f key-fn statsbox)
(let* ([cache-size 50] (let* ([cache-size 50]
[ht (make-hash-table 'equal)] [ht (make-hash)]
[uniq (gensym)] [uniq (gensym)]
[when-to-evict-table (make-hash-table)] [when-to-evict-table (make-hasheq)]
[pointer 0]) [pointer 0])
(lambda (x y) (lambda (x y)
(record-cache-test! statsbox) (record-cache-test! statsbox)
(let* ([key (key-fn x y)] (let* ([key (key-fn x y)]
[value-in-cache (hash-table-get ht key uniq)]) [value-in-cache (hash-ref ht key uniq)])
(cond (cond
[(eq? value-in-cache uniq) [(eq? value-in-cache uniq)
(record-cache-miss! statsbox) (record-cache-miss! statsbox)
(let ([res (f x y)]) (let ([res (f x y)])
(let ([to-remove (hash-table-get when-to-evict-table pointer uniq)]) (let ([to-remove (hash-ref when-to-evict-table pointer uniq)])
(unless (eq? uniq to-remove) (unless (eq? uniq to-remove)
(hash-table-remove! ht to-remove))) (hash-remove! ht to-remove)))
(hash-table-put! when-to-evict-table pointer key) (hash-set! when-to-evict-table pointer key)
(hash-table-put! ht key res) (hash-set! ht key res)
(set! pointer (modulo (+ pointer 1) cache-size)) (set! pointer (modulo (+ pointer 1) cache-size))
res)] res)]
[else [else
@ -978,25 +977,25 @@ before the pattern compiler is invoked.
;; didnt hit yet, continue searchign ;; didnt hit yet, continue searchign
(loop previous1 current (cdr current) (+ i 1))]))]))])]))))) (loop previous1 current (cdr current) (+ i 1))]))]))])])))))
;; hash-table version, but with a vector that tells when to evict cache entries ;; hash version, but with a vector that tells when to evict cache entries
#; #;
(define (memoize/key f key-fn statsbox) (define (memoize/key f key-fn statsbox)
(let* ([cache-size 50] (let* ([cache-size 50]
[ht (make-hash-table 'equal)] [ht (make-hash)]
[uniq (gensym)] [uniq (gensym)]
[vector (make-vector cache-size uniq)] ;; vector is only used to evict things from the hash-table [vector (make-vector cache-size uniq)] ;; vector is only used to evict things from the hash
[pointer 0]) [pointer 0])
(lambda (x y) (lambda (x y)
(let* ([key (key-fn x y)] (let* ([key (key-fn x y)]
[value-in-cache (hash-table-get ht key uniq)]) [value-in-cache (hash-ref ht key uniq)])
(cond (cond
[(eq? value-in-cache uniq) [(eq? value-in-cache uniq)
(let ([res (f x y)]) (let ([res (f x y)])
(let ([to-remove (vector-ref vector pointer)]) (let ([to-remove (vector-ref vector pointer)])
(unless (eq? uniq to-remove) (unless (eq? uniq to-remove)
(hash-table-remove! ht to-remove))) (hash-remove! ht to-remove)))
(vector-set! vector pointer key) (vector-set! vector pointer key)
(hash-table-put! ht key res) (hash-set! ht key res)
(set! pointer (modulo (+ pointer 1) cache-size)) (set! pointer (modulo (+ pointer 1) cache-size))
res)] res)]
[else [else
@ -1038,7 +1037,7 @@ before the pattern compiler is invoked.
;; original version ;; original version
#; #;
(define (memoize/key f key-fn statsbox) (define (memoize/key f key-fn statsbox)
(let ([ht (make-hash-table 'equal)] (let ([ht (make-hash)]
[entries 0]) [entries 0])
(lambda (x y) (lambda (x y)
(record-cache-test! statsbox) (record-cache-test! statsbox)
@ -1048,12 +1047,12 @@ before the pattern compiler is invoked.
(set! entries (+ entries 1)) (set! entries (+ entries 1))
(record-cache-miss! statsbox) (record-cache-miss! statsbox)
(let ([res (f x y)]) (let ([res (f x y)])
(hash-table-put! ht key res) (hash-set! ht key res)
res))]) res))])
(unless (< entries 200) ; 10000 was original size (unless (< entries 200) ; 10000 was original size
(set! entries 0) (set! entries 0)
(set! ht (make-hash-table 'equal))) (set! ht (make-hash)))
(hash-table-get ht key compute/cache))))) (hash-ref ht key compute/cache)))))
(define (record-cache-miss! statsbox) (define (record-cache-miss! statsbox)
(set-cache-stats-hits! statsbox (sub1 (cache-stats-hits statsbox))) (set-cache-stats-hits! statsbox (sub1 (cache-stats-hits statsbox)))
@ -1062,7 +1061,7 @@ before the pattern compiler is invoked.
(define (record-cache-test! statsbox) (define (record-cache-test! statsbox)
(set-cache-stats-hits! statsbox (add1 (cache-stats-hits statsbox)))) (set-cache-stats-hits! statsbox (add1 (cache-stats-hits statsbox))))
(define-struct cache-stats (name misses hits)) (define-struct cache-stats (name misses hits) #:mutable)
(define (new-cache-stats name) (make-cache-stats name 0 0)) (define (new-cache-stats name) (make-cache-stats name 0 0))
(define w/hole (new-cache-stats "hole")) (define w/hole (new-cache-stats "hole"))
@ -1270,30 +1269,30 @@ before the pattern compiler is invoked.
(map (map
(lambda (single-match) (lambda (single-match)
(let ([single-bindings (mtch-bindings single-match)]) (let ([single-bindings (mtch-bindings single-match)])
(let ([rib-ht (make-hash-table 'equal)] (let ([rib-ht (make-hash)]
[mismatch-rib-ht (make-hash-table 'equal)]) [mismatch-rib-ht (make-hash)])
(for-each (for-each
(lambda (multiple-rib) (lambda (multiple-rib)
(cond (cond
[(bind? multiple-rib) [(bind? multiple-rib)
(hash-table-put! rib-ht (bind-name multiple-rib) (bind-exp multiple-rib))] (hash-set! rib-ht (bind-name multiple-rib) (bind-exp multiple-rib))]
[(mismatch-bind? multiple-rib) [(mismatch-bind? multiple-rib)
(hash-table-put! mismatch-rib-ht (mismatch-bind-name multiple-rib) (mismatch-bind-exp multiple-rib))])) (hash-set! mismatch-rib-ht (mismatch-bind-name multiple-rib) (mismatch-bind-exp multiple-rib))]))
(bindings-table multiple-bindings)) (bindings-table multiple-bindings))
(for-each (for-each
(lambda (single-rib) (lambda (single-rib)
(cond (cond
[(bind? single-rib) [(bind? single-rib)
(let* ([key (bind-name single-rib)] (let* ([key (bind-name single-rib)]
[rst (hash-table-get rib-ht key '())]) [rst (hash-ref rib-ht key '())])
(hash-table-put! rib-ht key (cons (bind-exp single-rib) rst)))] (hash-set! rib-ht key (cons (bind-exp single-rib) rst)))]
[(mismatch-bind? single-rib) [(mismatch-bind? single-rib)
(let* ([key (mismatch-bind-name single-rib)] (let* ([key (mismatch-bind-name single-rib)]
[rst (hash-table-get mismatch-rib-ht key '())]) [rst (hash-ref mismatch-rib-ht key '())])
(hash-table-put! mismatch-rib-ht key (cons (mismatch-bind-exp single-rib) rst)))])) (hash-set! mismatch-rib-ht key (cons (mismatch-bind-exp single-rib) rst)))]))
(bindings-table single-bindings)) (bindings-table single-bindings))
(make-mtch (make-bindings (append (hash-table-map rib-ht make-bind) (make-mtch (make-bindings (append (hash-map rib-ht make-bind)
(hash-table-map mismatch-rib-ht make-mismatch-bind))) (hash-map mismatch-rib-ht make-mismatch-bind)))
(build-cons-context (build-cons-context
(mtch-context single-match) (mtch-context single-match)
(mtch-context multiple-match)) (mtch-context multiple-match))
@ -1339,14 +1338,14 @@ before the pattern compiler is invoked.
(cond (cond
[(null? rhss) [(null? rhss)
(if ht (if ht
(hash-table-map ht (λ (k v) k)) (hash-map ht (λ (k v) k))
#f)] #f)]
[else [else
(let ([mth (remove-bindings/filter ((car rhss) term hole-info))]) (let ([mth (remove-bindings/filter ((car rhss) term hole-info))])
(cond (cond
[mth [mth
(let ([ht (or ht (make-hash-table 'equal))]) (let ([ht (or ht (make-hash))])
(for-each (λ (x) (hash-table-put! ht x #t)) mth) (for-each (λ (x) (hash-set! ht x #t)) mth)
(loop (cdr rhss) ht))] (loop (cdr rhss) ht))]
[else [else
(loop (cdr rhss) ht)]))]))) (loop (cdr rhss) ht)]))])))
@ -1415,7 +1414,7 @@ before the pattern compiler is invoked.
(let loop ([pattern pattern] (let loop ([pattern pattern]
[ribs null]) [ribs null])
(match pattern (match pattern
[`(variable-except ,@(vars ...)) ribs] [`(variable-except ,vars ...) ribs]
[`(variable-prefix ,vars) ribs] [`(variable-prefix ,vars) ribs]
[`variable-not-otherwise-mentioned ribs] [`variable-not-otherwise-mentioned ribs]
@ -1480,8 +1479,8 @@ before the pattern compiler is invoked.
fst) fst)
mtchs)) mtchs))
(define (hash-table-maps? ht key) (define (hash-maps? ht key)
(not (eq? (hash-table-get ht key uniq) uniq))) (not (eq? (hash-ref ht key uniq) uniq)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -1508,7 +1507,7 @@ before the pattern compiler is invoked.
(define (context? x) #t) (define (context? x) #t)
(define-values (the-hole hole?) (define-values (the-hole hole?)
(let () (let ()
(define-struct hole () #f) (define-struct hole () #:inspector #f)
(define the-hole (make-hole)) (define the-hole (make-hole))
(values the-hole hole?))) (values the-hole hole?)))
@ -1542,11 +1541,11 @@ before the pattern compiler is invoked.
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; used in hash-table lookups to tell when something isn't in the table ;; used in hash lookups to tell when something isn't in the table
(define uniq (gensym)) (define uniq (gensym))
(provide/contract (provide/contract
(match-pattern (compiled-pattern? any/c . -> . (union false/c (listof mtch?)))) (match-pattern (compiled-pattern? any/c . -> . (or/c false/c (listof mtch?))))
(compile-pattern (-> compiled-lang? any/c boolean? (compile-pattern (-> compiled-lang? any/c boolean?
compiled-pattern?)) compiled-pattern?))
@ -1560,7 +1559,7 @@ before the pattern compiler is invoked.
(make-mtch (bindings? any/c any/c . -> . mtch?)) (make-mtch (bindings? any/c any/c . -> . mtch?))
(mtch-bindings (mtch? . -> . bindings?)) (mtch-bindings (mtch? . -> . bindings?))
(mtch-context (mtch? . -> . any/c)) (mtch-context (mtch? . -> . any/c))
(mtch-hole (mtch? . -> . (union none? any/c))) (mtch-hole (mtch? . -> . (or/c none? any/c)))
(make-bind (symbol? any/c . -> . bind?)) (make-bind (symbol? any/c . -> . bind?))
(bind? (any/c . -> . boolean?)) (bind? (any/c . -> . boolean?))
@ -1578,10 +1577,9 @@ before the pattern compiler is invoked.
build-flat-context build-flat-context
context?) context?)
(provide (struct nt (name rhs)) (provide (struct-out nt)
(struct rhs (pattern var-info)) (struct-out rhs)
(struct compiled-lang (struct-out compiled-lang)
(lang ht list-ht across-ht across-list-ht has-hole-ht cache pict-builder literals nt-map))
lookup-binding lookup-binding
@ -1593,4 +1591,4 @@ before the pattern compiler is invoked.
make-repeat make-repeat
the-hole hole? the-hole hole?
rewrite-ellipses rewrite-ellipses
build-compatible-context-language)) build-compatible-context-language)