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

Fix two bugs caused by clean ups, by adding requires of match-helper and provides of match:test-no-order.

Browse Source 
Fix totally broken handling of structs with immutable fields, as reported in bug 7398.

svn: r354
This commit is contained in:
Sam Tobin-Hochstadt 2005-07-05 22:22:02 +00:00
parent 4070be1c1a
commit b752dcddef
4 changed files with 40 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/mzlib/match.ss
View File

@ -1,25 +1,14 @@
;; (documentation (name match))
;; <pre>Pattern Matching Syntactic Extensions for Scheme
;;
;; All bugs or questions concerning this software should be directed to
;; Bruce Hauman <bhauman@cs.wcu.edu>. The latest version of this software
;; can be obtained from http://sol.cs.wcu.edu/~bhauman/scheme/pattern.php.
;;
;; Special thanks go out to:
;; Robert Bruce Findler for support and bug detection.
;; Doug Orleans for pointing out that pairs should be reused while
;; matching lists.
;;
;;
;; Originally written by Andrew K. Wright, 1993 (wright@research.nj.nec.com)
;; which in turn was adapted from code written by Bruce F. Duba, 1991.
;;
;; This software is in the public domain. Feel free to copy,
;; distribute, and modify this software as desired. No warranties
;; nor guarantees of any kind apply. Please return any improvements
;; or bug fixes to bhauman@cs.wcu.edu so that they may be included
;; in future releases.
;;
;; This macro package extends Scheme with several new expression forms.
;; Following is a brief summary of the new forms. See the associated
;; LaTeX documentation for a full description of their functionality.
@ -128,7 +117,8 @@
match-equality-test
exn:misc:match?
exn:misc:match-value
define-match-expander)
define-match-expander
match:test-no-order)
;; FIXME: match-helper and match-error should each be split
;; into a compile-time part and a run-time part.
@ -139,7 +129,8 @@
(require (prefix plt: "private/match-internal-func.ss")
"private/match-expander.ss"
"private/match-helper.ss"
"private/match-error.ss")
"private/match-error.ss"
"private/test-no-order.ss")
(define-syntax (match-lambda stx)
(syntax-case stx ()

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

@ -142,12 +142,14 @@
exn:misc:match?
exn:misc:match-value
match-equality-test
define-match-expander)
define-match-expander
match:test-no-order)
(require "private/match-internal-func.ss"
"private/match-expander.ss"
"private/match-helper.ss"
"private/match-error.ss")
"private/match-error.ss"
"private/test-no-order.ss")
)

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

@ -8,6 +8,8 @@
"match-error.ss"
(lib "list.ss"))
(require (only (lib "1.ss" "srfi") zip unzip2))
(require-for-template mzscheme)
;; define a syntax-transformer in terms of a two-argument function
@ -33,10 +35,10 @@
(string->symbol (apply string-append (map data->string l))))
;;!(function struct-pred-accessors-mutators
;; (form (struct-pred-accessors-mutators struct-name failure-thunk)
;; (form (struct-pred-accessors-mutators struct-name)
;; ->
;; (values pred accessors mutators parental-chain))
;; (contract (syntax-object (any -> void))
;; (contract (syntax-object)
;; ->
;; (values (any -> bool) list list)))
;; This function takes a syntax-object that is the name of a structure
@ -44,8 +46,8 @@
;; a predicate for the structure. The second is a list of accessors
;; in the same order as the fields of the structure declaration. The
;; third is a list of mutators for the structure also in the same
;; order. The last is a list of supertypes of this struct. The
;; failure thunk is invoked if the struct-name is not bound to a
;; order. The last is a list of supertypes of this struct. An
;; error is raised if the struct-name is not bound to a
;; structure.
(define (struct-pred-accessors-mutators struct-name)
(define accessors-index 3)
@ -56,23 +58,31 @@
(match:syntax-err struct-name
"not a defined structure"))
(define (local-val sn) (syntax-local-value sn failure-thunk))
(define (handle-acc-list l)
(reverse (filter (lambda (x) x) l)))
;; accessor/mutator lists are stored in reverse order, and can contain #f
;; we only filter out a mutator if the accessor is also false.
;; this function returns 2 lists of the same length if the inputs were the same length
(define (handle-acc/mut-lists accs muts)
(let*-values ([(filtered-lists) (filter (lambda (x) (car x)) (zip accs muts))]
[(accs muts) (unzip2 filtered-lists)])
(values (reverse accs)
(reverse muts))))
(define (get-lineage struct-name)
(let ([super (list-ref
(local-val struct-name)
super-type-index)])
(cond [(equal? super #t) '()]
[(equal? super #f) '()] ;; not sure what to do in case where super-type is unknown
(cond [(equal? super #t) '()] ;; no super type exists
[(equal? super #f) '()] ;; super type is unknown
[else (cons super (get-lineage super))])))
(define info-on-struct (local-val struct-name))
(define (get-info info-on-struct)
(values (handle-acc-list
(list-ref info-on-struct accessors-index))
(handle-acc-list
(list-ref info-on-struct mutators-index))
(list-ref info-on-struct pred-index)))
(let-values ([(accs muts)
(handle-acc/mut-lists
(list-ref info-on-struct accessors-index)
(list-ref info-on-struct mutators-index))])
(values accs muts
(list-ref info-on-struct pred-index))))
(unless (struct-declaration-info? info-on-struct) (failure-thunk))

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

@ -16,14 +16,17 @@
"match-expander-struct.ss"
;; the following are only used by render-test-list
"render-helpers.ss")
"render-helpers.ss"
"test-no-order.ss")
(require-for-syntax "match-helper.ss"
"match-expander-struct.ss")
"match-expander-struct.ss"
"test-no-order.ss")
(require-for-template mzscheme
"match-error.ss"
"test-no-order.ss")
"test-no-order.ss"
"match-helper.ss")
;; BEGIN SPECIAL-GENERATORS.SCM
@ -1218,6 +1221,7 @@
(lambda (cur-pat cur-mutator cur-accessor)
(syntax-case cur-pat (set! get!)
[(set! . rest)
(unless cur-mutator (match:syntax-err cur-pat "Cannot use set! pattern with immutable fields"))
(set/get-matcher 'set! ae stx (syntax rest)
#`(lambda (y)
(#,cur-mutator #,ae y)))]