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

match phase clean-up and minor contract-expansion improvement

Browse Source 
svn: r232
This commit is contained in:
Matthew Flatt 2005-06-22 21:31:11 +00:00
parent bc203f55b8
commit e4a71a9b3c
19 changed files with 99 additions and 154 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/mzlib/contract.ss
View File

@ -2516,17 +2516,18 @@ add struct contracts for immutable structs?
(define-syntax (coerce/select-contract stx)
(syntax-case stx ()
[(_ name val)
(syntax
(let ([x val])
(cond
[(contract? x)
(contract-proc x)]
[(and (procedure? x) (procedure-arity-includes? x 1))
(contract-proc (flat-contract x))]
[else
(error 'name
"expected contract or procedure of arity 1, got ~e"
x)])))]))
(syntax (coerce/select-contract/proc 'name val))]))
(define (coerce/select-contract/proc name x)
(cond
[(contract? x)
(contract-proc x)]
[(and (procedure? x) (procedure-arity-includes? x 1))
(contract-proc (flat-contract x))]
[else
(error name
"expected contract or procedure of arity 1, got ~e"
x)]))
;; coerce-contract : id (union contract? procedure-arity-1) -> contract
;; contract-proc = sym sym stx -> alpha -> alpha
@ -2535,17 +2536,17 @@ add struct contracts for immutable structs?
(define-syntax (coerce-contract stx)
(syntax-case stx ()
[(_ name val)
(syntax
(let ([x val])
(cond
[(contract? x) x]
[(and (procedure? x) (procedure-arity-includes? x 1))
(flat-contract x)]
[else
(error 'name
"expected contract or procedure of arity 1, got ~e"
x)])))]))
(syntax (coerce-contract/proc 'name val))]))
(define (coerce-contract/proc name x)
(cond
[(contract? x) x]
[(and (procedure? x) (procedure-arity-includes? x 1))
(flat-contract x)]
[else
(error name
"expected contract or procedure of arity 1, got ~e"
x)]))
;
;

11
collects/mzlib/match.ss
View File

@ -130,15 +130,16 @@
exn:misc:match-value
define-match-expander)
;; FIXME: match-helper and match-error should each be split
;; into a compile-time part and a run-time part.
(require-for-syntax "private/convert-pat.ss"
"private/match-helper.ss")
(require-for-template mzscheme (prefix plt: "private/match-internal-func.ss"))
(require (prefix plt: "private/match-internal-func.ss")
"private/match-expander.ss"
"private/match-helper.ss"
"private/match-error.ss")
"private/match-expander.ss"
"private/match-helper.ss"
"private/match-error.ss")
(define-syntax (match-lambda stx)
(syntax-case stx ()

4
collects/mzlib/plt-match.ss
View File

@ -138,7 +138,6 @@
match-let*
match-letrec
match-define
match:test-no-order
pregexp-match-with-error
exn:misc:match?
exn:misc:match-value
@ -148,8 +147,7 @@
(require "private/match-internal-func.ss"
"private/match-expander.ss"
"private/match-helper.ss"
"private/match-error.ss"
"private/render-helpers.ss")
"private/match-error.ss")
)

9
collects/mzlib/private/convert-pat.ss
View File

@ -3,13 +3,10 @@
"match-helper.ss"
"match-expander-struct.ss")
(require-for-template
mzscheme
"match-error.ss"
"match-helper.ss")
(require-for-template mzscheme
"match-error.ss")
(provide convert-pat handle-clauses convert-pats)
(provide convert-pat handle-clauses convert-pats)
;; these functions convert the patterns from the old syntax
;; to the new syntax

5
collects/mzlib/private/coupling-and-binding.scm
View File

@ -7,10 +7,7 @@
(require "test-structure.scm"
"match-helper.ss")
(require-for-template
mzscheme
"test-structure.scm"
"match-helper.ss")
(require-for-template mzscheme)
;;!(function couple-tests
;; (form (couple-tests test-list ks-func kf-func let-bound)

6
collects/mzlib/private/emit-assm.scm
View File

@ -6,10 +6,8 @@
(require "match-helper.ss"
"coupling-and-binding.scm")
(require-for-template
mzscheme
"match-helper.ss"
"coupling-and-binding.scm")
(require-for-template mzscheme)
;;!(function emit
;; (form (emit act-test-func ae let-bound sf bv kf ks)
;; ->

14
collects/mzlib/private/gen-match.ss
View File

@ -14,17 +14,9 @@
"tag-negate-tests.scm"
"convert-pat.ss")
(require-for-template
mzscheme
(lib "etc.ss")
(lib "stx.ss" "syntax")
"match-error.ss"
"coupling-and-binding.scm"
"update-counts.scm"
"update-binding-counts.scm"
"render-test-list.scm"
"reorder-tests.scm"
"tag-negate-tests.scm")
(require-for-template mzscheme
(lib "etc.ss")
"match-error.ss")
;;!(function mark-patlist
;; (form (mark-patlist clauses) -> marked-clause-list)

8
collects/mzlib/private/getter-setter.scm
View File

@ -6,12 +6,8 @@
"match-helper.ss"
"match-error.ss"
(lib "stx.ss" "syntax"))
(require-for-template
mzscheme
"coupling-and-binding.scm"
"match-helper.ss"
"match-error.ss"
(lib "stx.ss" "syntax"))
(require-for-template mzscheme
"match-error.ss")
;;!(function setter
;; (form (setter e ident let-bound) -> syntax)

3
collects/mzlib/private/match-expander.ss
View File

@ -1,8 +1,5 @@
(module match-expander mzscheme
(provide (all-defined))
;(require "match-expander-struct.ss")
(require-for-template "match-expander-struct.ss"
"match-error.ss")
(require-for-syntax "match-expander-struct.ss"
"match-error.ss")

4
collects/mzlib/private/match-helper.ss
View File

@ -8,9 +8,7 @@
"match-error.ss"
(lib "list.ss"))
(require-for-template mzscheme
(lib "struct.ss" "syntax")
(lib "syntax-utils.ss" "mzlib" "private"))
(require-for-template mzscheme)
;; define a syntax-transformer in terms of a two-argument function
(define-syntax define-proc

12
collects/mzlib/private/match-internal-func.ss
View File

@ -4,20 +4,12 @@
(require-for-syntax "gen-match.ss"
"match-helper.ss"
"match-error.ss"
#;"convert-pat.ss")
(require-for-template "gen-match.ss"
"match-helper.ss"
mzscheme)
"match-error.ss")
(require (lib "etc.ss")
(lib "list.ss")
"gen-match.ss"
"match-expander.ss"
"match-helper.ss"
"match-error.ss"
"render-helpers.ss")
"match-error.ss")
(define-syntax (match stx)

5
collects/mzlib/private/parse-quasi.scm
View File

@ -7,10 +7,7 @@
(lib "stx.ss" "syntax"))
(require-for-template mzscheme
"match-error.ss"
"match-helper.ss"
(lib "etc.ss")
(lib "stx.ss" "syntax"))
"match-error.ss")
;; Raise an error from a quasi-pattern
(define q-error

56
collects/mzlib/private/render-helpers.ss
View File

@ -10,64 +10,14 @@
"parse-quasi.scm"
(lib "list.ss"))
(require-for-template
mzscheme
"match-helper.ss"
"match-error.ss"
"emit-assm.scm"
"getter-setter.scm"
"parse-quasi.scm"
(lib "list.ss"))
(require-for-template mzscheme
(lib "list.ss")
"match-error.ss")
(provide (all-from "emit-assm.scm")
(all-from "getter-setter.scm")
(all-from "parse-quasi.scm"))
;;!(function match:test-no-order
;; (form (match:test-no-order tests l last-test ddk-num)
;; ->
;; bool)
;; (contract (list list test integer) -> bool))
;; This is a recursive depth first search for a sequence of
;; items in list l which will satisfy all of the tests in list
;; tests. This is used for list-no-order and hash-table patterns.
;; This function also handles ddk patterns by passing it the last
;; test before the ddk and the value of k.
(define (match:test-no-order tests l last-test ddk-num)
(define (handle-last-test test l)
(and (>= (length l) ddk-num)
(andmap test l)))
(define (dep-first-test head rest tests)
(cond ((null? tests)
(if last-test
(handle-last-test last-test (cons head rest))
#f))
((null? rest)
(if last-test
(and (= 0 ddk-num)
(= 1 (length tests))
((car tests) head))
(and (= 1 (length tests))
((car tests) head))))
(else (and (pair? tests)
((car tests) head)
(match:test-no-order (cdr tests)
rest
last-test
ddk-num)))))
; I think this is equivalent to
#;(ormap (lambda (elem)
(dep-first-test elem
(remove elem l)
tests))
l)
(let loop ((lst l))
(if (null? lst)
#f
(or (dep-first-test (car lst) (remove (car lst) l) tests)
(loop (cdr lst))))))
(define (append-if-necc sym stx)
(syntax-case stx ()
(() (syntax (list)))

16
collects/mzlib/private/render-test-list.scm
View File

@ -21,19 +21,9 @@
(require-for-syntax "match-helper.ss"
"match-expander-struct.ss")
(require-for-template
mzscheme
"match-expander-struct.ss"
"match-error.ss"
"match-helper.ss"
"test-structure.scm"
"coupling-and-binding.scm"
"update-counts.scm"
"update-binding-counts.scm"
"reorder-tests.scm"
;; the following are only used by render-test-list
"render-helpers.ss")
(require-for-template mzscheme
"match-error.ss"
"test-no-order.ss")
;; BEGIN SPECIAL-GENERATORS.SCM

3
collects/mzlib/private/reorder-tests.scm
View File

@ -6,8 +6,7 @@
(require "test-structure.scm")
(require-for-template mzscheme
"test-structure.scm")
(require-for-template mzscheme)
;; There really ought to be a stable sort in the std library.

2
collects/mzlib/private/tag-negate-tests.scm
View File

@ -1,8 +1,6 @@
(module tag-negate-tests mzscheme
(provide tag-negate-tests)
(require "test-structure.scm")
#;(require-for-template mzscheme
"test-structure.scm")
(define (tag-neg-test ls target-set)
(easy-tag ls #f target-set))

48
collects/mzlib/private/test-no-order.ss Normal file
View File

@ -0,0 +1,48 @@
(module test-no-order mzscheme
(require (lib "list.ss"))
(provide match:test-no-order)
;;!(function match:test-no-order
;; (form (match:test-no-order tests l last-test ddk-num)
;; ->
;; bool)
;; (contract (list list test integer) -> bool))
;; This is a recursive depth first search for a sequence of
;; items in list l which will satisfy all of the tests in list
;; tests. This is used for list-no-order and hash-table patterns.
;; This function also handles ddk patterns by passing it the last
;; test before the ddk and the value of k.
(define (match:test-no-order tests l last-test ddk-num)
(define (handle-last-test test l)
(and (>= (length l) ddk-num)
(andmap test l)))
(define (dep-first-test head rest tests)
(cond ((null? tests)
(if last-test
(handle-last-test last-test (cons head rest))
#f))
((null? rest)
(if last-test
(and (= 0 ddk-num)
(= 1 (length tests))
((car tests) head))
(and (= 1 (length tests))
((car tests) head))))
(else (and (pair? tests)
((car tests) head)
(match:test-no-order (cdr tests)
rest
last-test
ddk-num)))))
; I think this is equivalent to
#;(ormap (lambda (elem)
(dep-first-test elem
(remove elem l)
tests))
l)
(let loop ((lst l))
(if (null? lst)
#f
(or (dep-first-test (car lst) (remove (car lst) l) tests)
(loop (cdr lst)))))))

1
collects/mzlib/private/update-binding-counts.scm
View File

@ -3,7 +3,6 @@
(provide update-binding-counts update-binding-count)
(require "test-structure.scm")
(require-for-template "test-structure.scm")
(require (lib "etc.ss"))

3
collects/mzlib/private/update-counts.scm
View File

@ -7,9 +7,6 @@
(require "test-structure.scm"
"match-helper.ss")
#;(require-for-template "test-structure.scm"
"match-helper.ss")
;;!(function test-filter
;; (form (test-filter test-list) -> test-list)
;; (contract list -> list))