public inbox for kawa@sourceware.org
 help / color / mirror / Atom feed
* questions on libraries, pattern matching etc
@ 2019-12-15 23:47 Ben
  2019-12-16  0:59 ` Per Bothner
  0 siblings, 1 reply; 9+ messages in thread
From: Ben @ 2019-12-15 23:47 UTC (permalink / raw)
  To: kawa

hi
I'd like to test how I can use pattern match in Kawa. First I did try to use Kawas pattern matching function, but from what I saw it is a bit limited, for example there is no matching of lists. Thats why I did try to use the famous match.scm code from Alex Shinn. In order to exclude potential collitions with Kawas 'match', I renamed all 'match' strings in  to 'pmatch' and renamed also the file to 'pmatch.scm'

kawa -Dkawa.import.path=".:libs/kawa/*.scm" t.scm

---- t.scm ---
(import pmatch)

(pmatch (list 11 99 )
   (( a b )
      (display a)
      (display b))
   (_  (display "gaga")))

=> 11 99
-------

But I also get the following warning :

/libs/kawa/pmatch.scm:88:34: warning - no use of failure


Do you know how I can prevent that warning?
Ben



----- match.scm ----

     1	;;;; match.scm -- portable hygienic pattern matcher
     2	;;
     3	;; This code is written by Alex Shinn and placed in the
     4	;; Public Domain.  All warranties are disclaimed.
     5	
     6	;; This is a full superset of the popular MATCH package by Andrew
     7	;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks
     8	;; in R6RS SYNTAX-RULES), and thus preserving hygiene.
     9	
    10	;; This is a simple generative pattern matcher - each pattern is
    11	;; expanded into the required tests, calling a failure continuation if
    12	;; the tests fail.  This makes the logic easy to follow and extend,
    13	;; but produces sub-optimal code in cases where you have many similar
    14	;; clauses due to repeating the same tests.  Nonetheless a smart
    15	;; compiler should be able to remove the redundant tests.  For
    16	;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance
    17	;; hit.
    18	
    19	;; The original version was written on 2006/11/29 and described in the
    20	;; following Usenet post:
    21	;;   http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd
    22	;; and is still available at
    23	;;   http://synthcode.com/scheme/match-simple.scm
    24	;; A variant of this file which uses COND-EXPAND in a few places can
    25	;; be found at
    26	;;   http://synthcode.com/scheme/match-cond-expand.scm
    27	;;
    28	;; 2008/03/20 - fixing bug where (a ...) matched non-lists
    29	;; 2008/03/15 - removing redundant check in vector patterns
    30	;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell)
    31	;; 2007/09/04 - fixing quasiquote patterns
    32	;; 2007/07/21 - allowing ellipse patterns in non-final list positions
    33	;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse
    34	;;              (thanks to Taylor Campbell)
    35	;; 2007/04/08 - clean up, commenting
    36	;; 2006/12/24 - bugfixes
    37	;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set!
    38	
    39	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    40	;; force compile-time syntax errors with useful messages
    41	
    42	(define-syntax match-syntax-error
    43	  (syntax-rules ()
    44	    ((_)
    45	     (match-syntax-error "invalid match-syntax-error usage"))))
    46	
    47	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    48	
    49	;; The basic interface.  MATCH just performs some basic syntax
    50	;; validation, binds the match expression to a temporary variable `v',
    51	;; and passes it on to MATCH-NEXT.  It's a constant throughout the
    52	;; code below that the binding `v' is a direct variable reference, not
    53	;; an expression.
    54	
    55	(define-syntax match
    56	  (syntax-rules ()
    57	    ((match)
    58	     (match-syntax-error "missing match expression"))
    59	    ((match atom)
    60	     (match-syntax-error "missing match clause"))
    61	    ((match (app ...) (pat . body) ...)
    62	     (let ((v (app ...)))
    63	       (match-next v (app ...) (set! (app ...)) (pat . body) ...)))
    64	    ((match #(vec ...) (pat . body) ...)
    65	     (let ((v #(vec ...)))
    66	       (match-next v v (set! v) (pat . body) ...)))
    67	    ((match atom (pat . body) ...)
    68	     (match-next atom atom (set! atom) (pat . body) ...))
    69	    ))
    70	
    71	;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
    72	;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
    73	;; clauses.  `g' and `s' are the get! and set! expressions
    74	;; respectively.
    75	
    76	(define-syntax match-next
    77	  (syntax-rules (=>)
    78	    ;; no more clauses, the match failed
    79	    ((match-next v g s)
    80	     (error 'match "no matching pattern"))
    81	    ;; named failure continuation
    82	    ((match-next v g s (pat (=> failure) . body) . rest)
    83	     (let ((failure (lambda () (match-next v g s . rest))))
    84	       ;; match-one analyzes the pattern for us
    85	       (match-one v pat g s (match-drop-ids (begin . body)) (failure) ())))
    86	    ;; anonymous failure continuation, give it a dummy name
    87	    ((match-next v g s (pat . body) . rest)
    88	     (match-next v g s (pat (=> failure) . body) . rest))))
    89	
    90	;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to
    91	;; MATCH-TWO.
    92	
    93	(define-syntax match-one
    94	  (syntax-rules ()
    95	    ;; If it's a list of two values, check to see if the second one is
    96	    ;; an ellipse and handle accordingly, otherwise go to MATCH-TWO.
    97	    ((match-one v (p q . r) g s sk fk i)
    98	     (match-check-ellipse
    99	      q
   100	      (match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ())
   101	      (match-two v (p q . r) g s sk fk i)))
   102	    ;; Otherwise, go directly to MATCH-TWO.
   103	    ((match-one . x)
   104	     (match-two . x))))
   105	
   106	;; This is the guts of the pattern matcher.  We are passed a lot of
   107	;; information in the form:
   108	;;
   109	;;   (match-two var pattern getter setter success-k fail-k (ids ...))
   110	;;
   111	;; usually abbreviated
   112	;;
   113	;;   (match-two v p g s sk fk i)
   114	;;
   115	;; where VAR is the symbol name of the current variable we are
   116	;; matching, PATTERN is the current pattern, getter and setter are the
   117	;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding
   118	;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure
   119	;; continuation (which is just a thunk call and is thus safe to expand
   120	;; multiple times) and IDS are the list of identifiers bound in the
   121	;; pattern so far.
   122	
   123	(define-syntax match-two
   124	  (syntax-rules (_ ___ quote quasiquote ? $ = and or not set! get!)
   125	    ((match-two v () g s (sk ...) fk i)
   126	     (if (null? v) (sk ... i) fk))
   127	    ((match-two v (quote p) g s (sk ...) fk i)
   128	     (if (equal? v 'p) (sk ... i) fk))
   129	    ((match-two v (quasiquote p) g s sk fk i)
   130	     (match-quasiquote v p g s sk fk i))
   131	    ((match-two v (and) g s (sk ...) fk i) (sk ... i))
   132	    ((match-two v (and p q ...) g s sk fk i)
   133	     (match-one v p g s (match-one v (and q ...) g s sk fk) fk i))
   134	    ((match-two v (or) g s sk fk i) fk)
   135	    ((match-two v (or p) g s sk fk i)
   136	     (match-one v p g s sk fk i))
   137	    ((match-two v (or p ...) g s sk fk i)
   138	     (match-extract-vars (or p ...)
   139	                         (match-gen-or v (p ...) g s sk fk i)
   140	                         i
   141	                         ()))
   142	    ((match-two v (not p) g s (sk ...) fk i)
   143	     (match-one v p g s (match-drop-ids fk) (sk ... i) i))
   144	    ((match-two v (get! getter) g s (sk ...) fk i)
   145	     (let ((getter (lambda () g))) (sk ... i)))
   146	    ((match-two v (set! setter) g (s ...) (sk ...) fk i)
   147	     (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
   148	    ((match-two v (? pred p ...) g s sk fk i)
   149	     (if (pred v) (match-one v (and p ...) g s sk fk i) fk))
   150	    ((match-two v (= proc p) g s sk fk i)
   151	     (let ((w (proc v)))
   152	       (match-one w p g s sk fk i)))
   153	    ((match-two v (p ___ . r) g s sk fk i)
   154	     (match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ()))
   155	    ((match-two v (p) g s sk fk i)
   156	     (if (and (pair? v) (null? (cdr v)))
   157	       (let ((w (car v)))
   158	         (match-one w p (car v) (set-car! v) sk fk i))
   159	       fk))
   160	    ((match-two v (p . q) g s sk fk i)
   161	     (if (pair? v)
   162	       (let ((w (car v)) (x (cdr v)))
   163	         (match-one w p (car v) (set-car! v)
   164	                    (match-one x q (cdr v) (set-cdr! v) sk fk)
   165	                    fk
   166	                    i))
   167	       fk))
   168	    ((match-two v #(p ...) g s sk fk i)
   169	     (match-vector v 0 () (p ...) sk fk i))
   170	    ((match-two v _ g s (sk ...) fk i) (sk ... i))
   171	    ;; Not a pair or vector or special literal, test to see if it's a
   172	    ;; new symbol, in which case we just bind it, or if it's an
   173	    ;; already bound symbol or some other literal, in which case we
   174	    ;; compare it with EQUAL?.
   175	    ((match-two v x g s (sk ...) fk (id ...))
   176	     (let-syntax
   177	         ((new-sym?
   178	           (syntax-rules (id ...)
   179	             ((new-sym? x sk2 fk2) sk2)
   180	             ((new-sym? y sk2 fk2) fk2))))
   181	       (new-sym? random-sym-to-match
   182	                 (let ((x v)) (sk ... (id ... x)))
   183	                 (if (equal? v x) (sk ... (id ...)) fk))))
   184	    ))
   185	
   186	;; QUASIQUOTE patterns
   187	
   188	(define-syntax match-quasiquote
   189	  (syntax-rules (unquote unquote-splicing quasiquote)
   190	    ((_ v (unquote p) g s sk fk i)
   191	     (match-one v p g s sk fk i))
   192	    ((_ v ((unquote-splicing p) . rest) g s sk fk i)
   193	     (if (pair? v)
   194	       (match-one v
   195	                  (p . tmp)
   196	                  (match-quasiquote tmp rest g s sk fk)
   197	                  fk
   198	                  i)
   199	       fk))
   200	    ((_ v (quasiquote p) g s sk fk i . depth)
   201	     (match-quasiquote v p g s sk fk i #f . depth))
   202	    ((_ v (unquote p) g s sk fk i x . depth)
   203	     (match-quasiquote v p g s sk fk i . depth))
   204	    ((_ v (unquote-splicing p) g s sk fk i x . depth)
   205	     (match-quasiquote v p g s sk fk i . depth))
   206	    ((_ v (p . q) g s sk fk i . depth)
   207	     (if (pair? v)
   208	       (let ((w (car v)) (x (cdr v)))
   209	         (match-quasiquote
   210	          w p g s
   211	          (match-quasiquote-step x q g s sk fk depth)
   212	          fk i . depth))
   213	       fk))
   214	    ((_ v #(elt ...) g s sk fk i . depth)
   215	     (if (vector? v)
   216	       (let ((ls (vector->list v)))
   217	         (match-quasiquote ls (elt ...) g s sk fk i . depth))
   218	       fk))
   219	    ((_ v x g s sk fk i . depth)
   220	     (match-one v 'x g s sk fk i))))
   221	
   222	(define-syntax match-quasiquote-step
   223	  (syntax-rules ()
   224	    ((match-quasiquote-step x q g s sk fk depth i)
   225	     (match-quasiquote x q g s sk fk i . depth))
   226	    ))
   227	
   228	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   229	;; Utilities
   230	
   231	;; A CPS utility that takes two values and just expands into the
   232	;; first.
   233	(define-syntax match-drop-ids
   234	  (syntax-rules ()
   235	    ((_ expr ids ...) expr)))
   236	
   237	;; Generating OR clauses just involves binding the success
   238	;; continuation into a thunk which takes the identifiers common to
   239	;; each OR clause, and trying each clause, calling the thunk as soon
   240	;; as we succeed.
   241	
   242	(define-syntax match-gen-or
   243	  (syntax-rules ()
   244	    ((_ v p g s (sk ...) fk (i ...) ((id id-ls) ...))
   245	     (let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
   246	       (match-gen-or-step
   247	        v p g s (match-drop-ids (sk2 id ...)) fk (i ...))))))
   248	
   249	(define-syntax match-gen-or-step
   250	  (syntax-rules ()
   251	    ((_ v () g s sk fk i)
   252	     ;; no OR clauses, call the failure continuation
   253	     fk)
   254	    ((_ v (p) g s sk fk i)
   255	     ;; last (or only) OR clause, just expand normally
   256	     (match-one v p g s sk fk i))
   257	    ((_ v (p . q) g s sk fk i)
   258	     ;; match one and try the remaining on failure
   259	     (match-one v p g s sk (match-gen-or-step v q g s sk fk i) i))
   260	    ))
   261	
   262	;; We match a pattern (p ...) by matching the pattern p in a loop on
   263	;; each element of the variable, accumulating the bound ids into lists.
   264	
   265	;; Look at the body - it's just a named let loop, matching each
   266	;; element in turn to the same pattern.  This illustrates the
   267	;; simplicity of this generative-style pattern matching.  It would be
   268	;; just as easy to implement a tree searching pattern.
   269	
   270	(define-syntax match-gen-ellipses
   271	  (syntax-rules ()
   272	    ((_ v p () g s (sk ...) fk i ((id id-ls) ...))
   273	     (match-check-identifier p
   274	       ;; simplest case equivalent to ( . p), just bind the list
   275	       (let ((p v))
   276	         (if (list? p)
   277	             (sk ... i)
   278	             fk))
   279	       ;; simple case, match all elements of the list
   280	       (let loop ((ls v) (id-ls '()) ...)
   281	         (cond
   282	           ((null? ls)
   283	            (let ((id (reverse id-ls)) ...) (sk ... i)))
   284	           ((pair? ls)
   285	            (let ((w (car ls)))
   286	              (match-one w p (car ls) (set-car! ls)
   287	                         (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
   288	                         fk i)))
   289	           (else
   290	            fk)))))
   291	    ((_ v p (r ...) g s (sk ...) fk i ((id id-ls) ...))
   292	     ;; general case, trailing patterns to match
   293	     (match-verify-no-ellipses
   294	      (r ...)
   295	      (let* ((tail-len (length '(r ...)))
   296	             (ls v)
   297	             (len (length ls)))
   298	        (if (< len tail-len)
   299	            fk
   300	            (let loop ((ls ls) (n len) (id-ls '()) ...)
   301	              (cond
   302	                ((= n tail-len)
   303	                 (let ((id (reverse id-ls)) ...)
   304	                   (match-one ls (r ...) #f #f (sk ... i) fk i)))
   305	                ((pair? ls)
   306	                 (let ((w (car ls)))
   307	                   (match-one w p (car ls) (set-car! ls)
   308	                              (match-drop-ids
   309	                               (loop (cdr ls) (- n 1) (cons id id-ls) ...))
   310	                              fk
   311	                              i)))
   312	                (else
   313	                 fk)))))))
   314	    ))
   315	
   316	(define-syntax match-verify-no-ellipses
   317	  (syntax-rules ()
   318	    ((_ (x . y) sk)
   319	     (match-check-ellipse
   320	      x
   321	      (match-syntax-error
   322	       "multiple ellipse patterns not allowed at same level")
   323	      (match-verify-no-ellipses y sk)))
   324	    ((_ x sk) sk)
   325	    ))
   326	
   327	;; Vector patterns are just more of the same, with the slight
   328	;; exception that we pass around the current vector index being
   329	;; matched.
   330	
   331	(define-syntax match-vector
   332	  (syntax-rules (___)
   333	    ((_ v n pats (p q) sk fk i)
   334	     (match-check-ellipse q
   335	                          (match-vector-ellipses v n pats p sk fk i)
   336	                          (match-vector-two v n pats (p q) sk fk i)))
   337	    ((_ v n pats (p ___) sk fk i)
   338	     (match-vector-ellipses v n pats p sk fk i))
   339	    ((_ . x)
   340	     (match-vector-two . x))))
   341	
   342	;; Check the exact vector length, then check each element in turn.
   343	
   344	(define-syntax match-vector-two
   345	  (syntax-rules ()
   346	    ((_ v n ((pat index) ...) () sk fk i)
   347	     (if (vector? v)
   348	       (let ((len (vector-length v)))
   349	         (if (= len n)
   350	           (match-vector-step v ((pat index) ...) sk fk i)
   351	           fk))
   352	       fk))
   353	    ((_ v n (pats ...) (p . q) sk fk i)
   354	     (match-vector v (+ n 1) (pats ... (p n)) q sk fk i))
   355	    ))
   356	
   357	(define-syntax match-vector-step
   358	  (syntax-rules ()
   359	    ((_ v () (sk ...) fk i) (sk ... i))
   360	    ((_ v ((pat index) . rest) sk fk i)
   361	     (let ((w (vector-ref v index)))
   362	       (match-one w pat (vector-ref v index) (vector-set! v index)
   363	                  (match-vector-step v rest sk fk)
   364	                  fk i)))))
   365	
   366	;; With a vector ellipse pattern we first check to see if the vector
   367	;; length is at least the required length.
   368	
   369	(define-syntax match-vector-ellipses
   370	  (syntax-rules ()
   371	    ((_ v n ((pat index) ...) p sk fk i)
   372	     (if (vector? v)
   373	       (let ((len (vector-length v)))
   374	         (if (>= len n)
   375	           (match-vector-step v ((pat index) ...)
   376	                              (match-vector-tail v p n len sk fk)
   377	                              fk i)
   378	           fk))
   379	       fk))))
   380	
   381	(define-syntax match-vector-tail
   382	  (syntax-rules ()
   383	    ((_ v p n len sk fk i)
   384	     (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))
   385	
   386	(define-syntax match-vector-tail-two
   387	  (syntax-rules ()
   388	    ((_ v p n len (sk ...) fk i ((id id-ls) ...))
   389	     (let loop ((j n) (id-ls '()) ...)
   390	       (if (>= j len)
   391	         (let ((id (reverse id-ls)) ...) (sk ... i))
   392	         (let ((w (vector-ref v j)))
   393	           (match-one w p (vector-ref v j) (vetor-set! v j)
   394	                      (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
   395	                      fk i)))))))
   396	
   397	;; Extract all identifiers in a pattern.  A little more complicated
   398	;; than just looking for symbols, we need to ignore special keywords
   399	;; and not pattern forms (such as the predicate expression in ?
   400	;; patterns).
   401	;;
   402	;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))
   403	
   404	(define-syntax match-extract-vars
   405	  (syntax-rules (_ ___ ? $ = quote quasiquote and or not get! set!)
   406	    ((match-extract-vars (? pred . p) k i v)
   407	     (match-extract-vars p k i v))
   408	    ((match-extract-vars ($ rec . p) k i v)
   409	     (match-extract-vars p k i v))
   410	    ((match-extract-vars (= proc p) k i v)
   411	     (match-extract-vars p k i v))
   412	    ((match-extract-vars (quote x) (k ...) i v)
   413	     (k ... v))
   414	    ((match-extract-vars (quasiquote x) k i v)
   415	     (match-extract-quasiquote-vars x k i v (#t)))
   416	    ((match-extract-vars (and . p) k i v)
   417	     (match-extract-vars p k i v))
   418	    ((match-extract-vars (or . p) k i v)
   419	     (match-extract-vars p k i v))
   420	    ((match-extract-vars (not . p) k i v)
   421	     (match-extract-vars p k i v))
   422	    ;; A non-keyword pair, expand the CAR with a continuation to
   423	    ;; expand the CDR.
   424	    ((match-extract-vars (p q . r) k i v)
   425	     (match-check-ellipse
   426	      q
   427	      (match-extract-vars (p . r) k i v)
   428	      (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
   429	    ((match-extract-vars (p . q) k i v)
   430	     (match-extract-vars p (match-extract-vars-step q k i v) i ()))
   431	    ((match-extract-vars #(p ...) k i v)
   432	     (match-extract-vars (p ...) k i v))
   433	    ((match-extract-vars _ (k ...) i v)    (k ... v))
   434	    ((match-extract-vars ___ (k ...) i v)  (k ... v))
   435	    ;; This is the main part, the only place where we might add a new
   436	    ;; var if it's an unbound symbol.
   437	    ((match-extract-vars p (k ...) (i ...) v)
   438	     (let-syntax
   439	         ((new-sym?
   440	           (syntax-rules (i ...)
   441	             ((new-sym? p sk fk) sk)
   442	             ((new-sym? x sk fk) fk))))
   443	       (new-sym? random-sym-to-match
   444	                 (k ... ((p p-ls) . v))
   445	                 (k ... v))))
   446	    ))
   447	
   448	;; Stepper used in the above so it can expand the CAR and CDR
   449	;; separately.
   450	
   451	(define-syntax match-extract-vars-step
   452	  (syntax-rules ()
   453	    ((_ p k i v ((v2 v2-ls) ...))
   454	     (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))
   455	    ))
   456	
   457	(define-syntax match-extract-quasiquote-vars
   458	  (syntax-rules (quasiquote unquote unquote-splicing)
   459	    ((match-extract-quasiquote-vars (quasiquote x) k i v d)
   460	     (match-extract-quasiquote-vars x k i v (#t . d)))
   461	    ((match-extract-quasiquote-vars (unquote-splicing x) k i v d)
   462	     (match-extract-quasiquote-vars (unquote x) k i v d))
   463	    ((match-extract-quasiquote-vars (unquote x) k i v (#t))
   464	     (match-extract-vars x k i v))
   465	    ((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
   466	     (match-extract-quasiquote-vars x k i v d))
   467	    ((match-extract-quasiquote-vars (x . y) k i v (#t . d))
   468	     (match-extract-quasiquote-vars
   469	      x
   470	      (match-extract-quasiquote-vars-step y k i v d) i ()))
   471	    ((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
   472	     (match-extract-quasiquote-vars (x ...) k i v d))
   473	    ((match-extract-quasiquote-vars x (k ...) i v (#t . d))
   474	     (k ... v))
   475	    ))
   476	
   477	(define-syntax match-extract-quasiquote-vars-step
   478	  (syntax-rules ()
   479	    ((_ x k i v d ((v2 v2-ls) ...))
   480	     (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
   481	    ))
   482	
   483	
   484	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   485	;; Gimme some sugar baby.
   486	
   487	(define-syntax match-lambda
   488	  (syntax-rules ()
   489	    ((_ clause ...) (lambda (expr) (match expr clause ...)))))
   490	
   491	(define-syntax match-lambda*
   492	  (syntax-rules ()
   493	    ((_ clause ...) (lambda expr (match expr clause ...)))))
   494	
   495	(define-syntax match-let
   496	  (syntax-rules ()
   497	    ((_ (vars ...) . body)
   498	     (match-let/helper let () () (vars ...) . body))
   499	    ((_ loop . rest)
   500	     (match-named-let loop () . rest))))
   501	
   502	(define-syntax match-letrec
   503	  (syntax-rules ()
   504	    ((_ vars . body) (match-let/helper letrec () () vars . body))))
   505	
   506	(define-syntax match-let/helper
   507	  (syntax-rules ()
   508	    ((_ let ((var expr) ...) () () . body)
   509	     (let ((var expr) ...) . body))
   510	    ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
   511	     (let ((var expr) ...)
   512	       (match-let* ((pat tmp) ...)
   513	         . body)))
   514	    ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
   515	     (match-let/helper
   516	      let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
   517	    ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
   518	     (match-let/helper
   519	      let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
   520	    ((_ let (v ...) (p ...) ((a expr) . rest) . body)
   521	     (match-let/helper let (v ... (a expr)) (p ...) rest . body))
   522	    ))
   523	
   524	(define-syntax match-named-let
   525	  (syntax-rules ()
   526	    ((_ loop ((pat expr var) ...) () . body)
   527	     (let loop ((var expr) ...)
   528	       (match-let ((pat var) ...)
   529	         . body)))
   530	    ((_ loop (v ...) ((pat expr) . rest) . body)
   531	     (match-named-let loop (v ... (pat expr tmp)) rest . body))))
   532	
   533	(define-syntax match-let*
   534	  (syntax-rules ()
   535	    ((_ () . body)
   536	     (begin . body))
   537	    ((_ ((pat expr) . rest) . body)
   538	     (match expr (pat (match-let* rest . body))))))
   539	
   540	
   541	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   542	;; Otherwise COND-EXPANDed bits.
   543	
   544	;; This *should* work, but doesn't :(
   545	;;   (define-syntax match-check-ellipse
   546	;;     (syntax-rules (...)
   547	;;       ((_ ... sk fk) sk)
   548	;;       ((_ x sk fk) fk)))
   549	
   550	;; This is a little more complicated, and introduces a new let-syntax,
   551	;; but should work portably in any R[56]RS Scheme.  Taylor Campbell
   552	;; originally came up with the idea.
   553	(define-syntax match-check-ellipse
   554	  (syntax-rules ()
   555	    ;; these two aren't necessary but provide fast-case failures
   556	    ((match-check-ellipse (a . b) success-k failure-k) failure-k)
   557	    ((match-check-ellipse #(a ...) success-k failure-k) failure-k)
   558	    ;; matching an atom
   559	    ((match-check-ellipse id success-k failure-k)
   560	     (let-syntax ((ellipse? (syntax-rules ()
   561	                              ;; iff `id' is `...' here then this will
   562	                              ;; match a list of any length
   563	                              ((ellipse? (foo id) sk fk) sk)
   564	                              ((ellipse? other sk fk) fk))))
   565	       ;; this list of three elements will only many the (foo id) list
   566	       ;; above if `id' is `...'
   567	       (ellipse? (a b c) success-k failure-k)))))
   568	
   569	
   570	;; This is portable but can be more efficient with non-portable
   571	;; extensions.  This trick was originally discovered by Oleg Kiselyov.
   572	
   573	(define-syntax match-check-identifier
   574	  (syntax-rules ()
   575	    ;; fast-case failures, lists and vectors are not identifiers
   576	    ((_ (x . y) success-k failure-k) failure-k)
   577	    ((_ #(x ...) success-k failure-k) failure-k)
   578	    ;; x is an atom
   579	    ((_ x success-k failure-k)
   580	     (let-syntax
   581	         ((sym?
   582	           (syntax-rules ()
   583	             ;; if the symbol `abracadabra' matches x, then x is a
   584	             ;; symbol
   585	             ((sym? x sk fk) sk)
   586	             ;; otherwise x is a non-symbol datum
   587	             ((sym? y sk fk) fk))))
   588	       (sym? abracadabra success-k failure-k)))
   589	    ))
   590	
   591	(match (list 11 99)
   592	       ((a b ) (display a)))

^ permalink raw reply	[flat|nested] 9+ messages in thread

end of thread, other threads:[~2020-07-01  4:52 UTC | newest]

Thread overview: 9+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2019-12-15 23:47 questions on libraries, pattern matching etc Ben
2019-12-16  0:59 ` Per Bothner
2020-02-19 21:39   ` Duncan Mak
2020-02-20 11:00     ` Kjetil Matheussen
2020-06-29 20:50   ` Duncan Mak
2020-06-29 21:49     ` Per Bothner
2020-06-30  4:38       ` Duncan Mak
2020-06-30  5:48         ` Per Bothner
2020-07-01  4:52         ` Per Bothner

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).