diff options
| -rw-r--r-- | share/txr/stdlib/match.tl | 68 | ||||
| -rw-r--r-- | txr.1 | 71 |
2 files changed, 113 insertions, 26 deletions
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl index 9648901c..0a975134 100644 --- a/share/txr/stdlib/match.tl +++ b/share/txr/stdlib/match.tl @@ -59,26 +59,54 @@ (defvar *match-form*) (defun compile-struct-match (struct-pat obj-var) - (let* ((required-type (cadr struct-pat)) - (slot-pairs (plist-to-alist (cddr struct-pat))) - (required-slots [mapcar car slot-pairs]) - (slot-gensyms [mapcar gensym required-slots]) - (slot-patterns [mapcar cdr slot-pairs]) - (slot-matches [mapcar compile-match slot-patterns slot-gensyms]) - (slot-val-exprs [mapcar (ret ^(slot ,obj-var ',@1)) - required-slots]) - (guard (new match-guard - vars slot-gensyms - var-exprs slot-val-exprs - guard-expr ^(subtypep (typeof ,obj-var) - ',required-type)))) - (new compiled-match - pattern struct-pat - obj-var obj-var - guard-chain (cons guard (mappend .guard-chain slot-matches)) - test-expr ^(and ,*(mapcar .test-expr slot-matches)) - vars [mappend .vars slot-matches] - var-exprs [mappend .var-exprs slot-matches]))) + (tree-bind (op required-type . pairs) struct-pat + (let* ((loose-p (not (bindable required-type))) + (slot-pairs (plist-to-alist pairs)) + (required-slots [mapcar car slot-pairs]) + (slot-gensyms [mapcar gensym required-slots]) + (type-gensym (if loose-p + (gensym "type-"))) + (slot-patterns [mapcar cdr slot-pairs]) + (slot-matches [mapcar compile-match slot-patterns slot-gensyms]) + (type-match (if loose-p + (compile-match required-type type-gensym))) + (all-matches (if loose-p + (cons type-match slot-matches) + slot-matches)) + (slot-val-exprs [mapcar (ret ^(slot ,obj-var ',@1)) required-slots]) + (guard0 (if loose-p + (new match-guard + vars (list type-gensym) + var-exprs (list ^(struct-type ,obj-var)) + guard-expr ^(structp ,obj-var)))) + (guard1 (new match-guard + vars slot-gensyms + var-exprs slot-val-exprs + guard-expr (if loose-p + ^(and ,*(mapcar + (ret ^(slotp ,type-gensym ',@1)) + required-slots)) + ^(subtypep (typeof ,obj-var) + ',required-type))))) + (unless loose-p + (let ((type (find-struct-type required-type))) + (if type + (each ((slot required-slots)) + (unless (slotp type slot) + (compile-defr-warning *match-form* ^(slot . ,slot) + "~s has no slot ~s" + required-type slot))) + (compile-defr-warning *match-form* ^(struct-type . ,required-type) + "no such struct type: ~s" + required-type)))) + (new compiled-match + pattern struct-pat + obj-var obj-var + guard-chain ^(,*(if guard0 (list guard0)) ,guard1 + ,*(mappend .guard-chain all-matches)) + test-expr ^(and ,*(mapcar .test-expr all-matches)) + vars [mappend .vars all-matches] + var-exprs [mappend .var-exprs all-matches])))) (defun compile-var-match (sym obj-var) (or (null sym) (bindable sym) @@ -39782,16 +39782,28 @@ against the corresponding vector element. .NP* Structure match .synb .mets @(structure << name >> { slot-name << pattern }*) +.mets @(structure << pattern >> { slot-name << pattern }*) .syne .desc -The structure pattern operator matches a structure object. -The first argument of the pattern operator is a symbol which gives the name of -the structure type. The corresponding object being matched must be a structure -instance, and must be of this type, otherwise there is no match +The structure pattern operator matches a structure object. The operator +supports two modes of matching, the choice of which depends on whether the +first argument is a +.meta name +or a +.metn pattern . + +The first argument is considered a +.meta name +if it is a bindable symbol according to the +.code bindable +function. In this situation, the operator operates in +strict mode. Otherwise, the operator is in loose mode. The .meta name -is followed by zero or more +or +.meta pattern +argument is followed by zero or more .meta "slot-name pattern" pairs, which are not enclosed in lists, similarly to the way slots are presented in the @@ -39800,11 +39812,39 @@ struct syntax and in the argument conventions of the .code new macro. -Each +In strict mode, +.meta name +is assumed to be the name of an existing struct type. +The object being matched is tested whether it is a subtype of this type, as +if using the +.code subtypep +function. If it isn't, the match fails. + +In loose mode, the object being matched is tested whether it is a structure +object of any structure type. If it isn't, the match fails. + +In strict mode, each .meta "slot-name pattern" pair requires that the object's slot of that name contain a value which matches .metn pattern . +The operator assumes that all the +.metn slot-name -s +are slots of the struct type indicated by +.metn name . + +In loose mode, no assumption is made that the object actually has the +slots specified by the +.meta slot-name +arguments. The object's structure type is inquired to +determine whether it has each of those slots. If it doesn't, the match fails. +If the object has the required slots, then the values of those slots are +matched against the patterns. + +In loose mode, the +.meta pattern +given in the first argument position of the syntax is matched against the +object's structure type: the type itself, rather than its symbolic name. .TP* Examples: @@ -39815,6 +39855,25 @@ a value which matches (when-match @(struct time year 2021 month @m) #S(time year 2021 month 1) m) -> 1 + + ;; match any structure with name and value slots, + ;; whose name is foo, and extract the value. + + (defstruct widget () + name + value) + + (defstruct grommet () + name + value) + + (append-each ((obj (list (new grommet name "foo" value :grom) + (new widget name "foo" value :widg)))) + (when-match @(struct @type name "foo" value @v) obj + (list (list type v)))) + + --> ((#<struct-type grommet> :grom) + (#<struct-type widget> :widg)) .brev .SS* Quasiquote Operator Syntax |