Only in guile-master-20100512_new//examples: match_examples.scm
diff -crB guile-master-20100512/module/ice-9/match.scm guile-master-20100512_new//module/ice-9/match.scm
*** guile-master-20100512/module/ice-9/match.scm	2010-05-12 06:00:07.000000000 +0200
--- guile-master-20100512_new//module/ice-9/match.scm	2010-05-24 23:04:17.408064463 +0200
***************
*** 1,199 ****
! ;;; installed-scm-file
! 
! ;;;; 	Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
! ;;;;
! ;;;; This library is free software; you can redistribute it and/or
! ;;;; modify it under the terms of the GNU Lesser General Public
! ;;;; License as published by the Free Software Foundation; either
! ;;;; version 3 of the License, or (at your option) any later version.
! ;;;; 
! ;;;; This library is distributed in the hope that it will be useful,
! ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
! ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
! ;;;; Lesser General Public License for more details.
! ;;;; 
! ;;;; You should have received a copy of the GNU Lesser General Public
! ;;;; License along with this library; if not, write to the Free Software
! ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
! ;;;;
  
  (define-module (ice-9 match)
!   :use-module (ice-9 pretty-print)
!   :export (match match-lambda match-lambda* match-define
! 		 match-let match-let* match-letrec
! 		 define-structure define-const-structure
!                  match:andmap
! 		 match:error match:set-error
! 		 match:error-control match:set-error-control
! 		 match:structure-control match:set-structure-control
! 		 match:runtime-structures match:set-runtime-structures))
! 
! ;; The original code can be found at the Scheme Repository
! ;;
! ;;   http://www.cs.indiana.edu/scheme-repository/code.match.html
! ;;
! ;; or Andrew K. Wright's web page:
! ;;
! ;;   http://www.star-lab.com/wright/code.html
! 
! 
! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! ;; Pattern Matching Syntactic Extensions for Scheme
! ;;
! (define match:version "Version 1.19, Sep 15, 1995")
! ;;
! ;; Written by Andrew K. Wright, 1993 (address@hidden).
! ;; Adapted from code originally written by Bruce F. Duba, 1991.
! ;; This package also includes a modified version of Kent Dybvig's
! ;; define-structure (see Dybvig, R.K., The Scheme Programming Language,
! ;; Prentice-Hall, NJ, 1987).
! ;;
! ;; 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.
! ;;
! ;;
! ;;         match expressions:
! ;;
! ;; exp ::= ...
! ;;       | (match exp clause ...)
! ;;       | (match-lambda clause ...)
! ;;       | (match-lambda* clause ...)
! ;;       | (match-let ((pat exp) ...) body)
! ;;       | (match-let* ((pat exp) ...) body)
! ;;       | (match-letrec ((pat exp) ...) body)
! ;;       | (match-define pat exp)
! ;;
! ;; clause ::= (pat body) | (pat => exp)
! ;;
! ;;         patterns:                       matches:
! ;;
! ;; pat ::= identifier                      anything, and binds identifier
! ;;       | _                               anything
! ;;       | ()                              the empty list
! ;;       | #t                              #t
! ;;       | #f                              #f
! ;;       | string                          a string
! ;;       | number                          a number
! ;;       | character                       a character
! ;;       | 'sexp                           an s-expression
! ;;       | 'symbol                         a symbol (special case of s-expr)
! ;;       | (pat_1 ... pat_n)               list of n elements
! ;;       | (pat_1 ... pat_n . pat_{n+1})   list of n or more
! ;;       | (pat_1 ... pat_n pat_n+1 ooo)   list of n or more, each element
! ;;                                           of remainder must match pat_n+1
! ;;       | #(pat_1 ... pat_n)              vector of n elements
! ;;       | #(pat_1 ... pat_n pat_n+1 ooo)  vector of n or more, each element
! ;;                                           of remainder must match pat_n+1
! ;;       | #&pat                           box
! ;;       | ($ struct-name pat_1 ... pat_n) a structure
! ;;       | (= field pat)                   a field of a structure
! ;;       | (and pat_1 ... pat_n)           if all of pat_1 thru pat_n match
! ;;       | (or pat_1 ... pat_n)            if any of pat_1 thru pat_n match
! ;;       | (not pat_1 ... pat_n)           if all pat_1 thru pat_n don't match
! ;;       | (? predicate pat_1 ... pat_n)   if predicate true and all of
! ;;                                           pat_1 thru pat_n match
! ;;       | (set! identifier)               anything, and binds setter
! ;;       | (get! identifier)               anything, and binds getter
! ;;       | `qp                             a quasi-pattern
! ;;
! ;; ooo ::= ...                             zero or more
! ;;       | ___                             zero or more
! ;;       | ..k                             k or more
! ;;       | __k                             k or more
! ;;
! ;;         quasi-patterns:                 matches:
! ;;
! ;; qp  ::= ()                              the empty list
! ;;       | #t                              #t
! ;;       | #f                              #f
! ;;       | string                          a string
! ;;       | number                          a number
! ;;       | character                       a character
! ;;       | identifier                      a symbol
! ;;       | (qp_1 ... qp_n)                 list of n elements
! ;;       | (qp_1 ... qp_n . qp_{n+1})      list of n or more
! ;;       | (qp_1 ... qp_n qp_n+1 ooo)      list of n or more, each element
! ;;                                           of remainder must match qp_n+1
! ;;       | #(qp_1 ... qp_n)                vector of n elements
! ;;       | #(qp_1 ... qp_n qp_n+1 ooo)     vector of n or more, each element
! ;;                                           of remainder must match qp_n+1
! ;;       | #&qp                            box
! ;;       | ,pat                            a pattern
! ;;       | ,@pat                           a pattern
! ;;
! ;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $,
! ;; and, or, not, set!, get!, ..., ___) cannot be used as pattern variables.
! ;;
! ;;
! ;;         structure expressions:
! ;;
! ;; exp ::= ...
! ;;       | (define-structure (id_0 id_1 ... id_n))
! ;;       | (define-structure (id_0 id_1 ... id_n)
! ;;                           ((id_{n+1} exp_1) ... (id_{n+m} exp_m)))
! ;;       | (define-const-structure (id_0 arg_1 ... arg_n))
! ;;       | (define-const-structure (id_0 arg_1 ... arg_n)
! ;;                                 ((arg_{n+1} exp_1) ... (arg_{n+m} exp_m)))
! ;;
! ;; arg ::= id | (! id) | (@ id)
! ;;
! ;;
! ;; match:error-control controls what code is generated for failed matches.
! ;; Possible values:
! ;;  'unspecified - do nothing, ie., evaluate (cond [#f #f])
! ;;  'fail - call match:error, or die at car or cdr
! ;;  'error - call match:error with the unmatched value
! ;;  'match - call match:error with the unmatched value _and_
! ;;             the quoted match expression
! ;; match:error-control is set by calling match:set-error-control with
! ;; the new value.
! ;;
! ;; match:error is called for a failed match.
! ;; match:error is set by calling match:set-error with the new value.
! ;;
! ;; match:structure-control controls the uniqueness of structures
! ;; (does not exist for Scheme 48 version).
! ;; Possible values:
! ;;  'vector - (default) structures are vectors with a symbol in position 0
! ;;  'disjoint - structures are fully disjoint from all other values
! ;; match:structure-control is set by calling match:set-structure-control
! ;; with the new value.
! ;;
! ;; match:runtime-structures controls whether local structure declarations
! ;; generate new structures each time they are reached
! ;; (does not exist for Scheme 48 version).
! ;; Possible values:
! ;;  #t - (default) each runtime occurrence generates a new structure
! ;;  #f - each lexical occurrence generates a new structure
! ;;
! ;; End of user visible/modifiable stuff.
! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
! 
! (define match:error (lambda (val . args) (for-each pretty-print args) (error "no matching clause for " val)))
! (define match:andmap (lambda (f l) (if (null? l) (and) (and (f (car l)) (match:andmap f (cdr l))))))
! (define match:syntax-err (lambda (obj msg) (error msg obj)))
! (define match:disjoint-structure-tags (quote ()))
! (define match:make-structure-tag (lambda (name) (if (or (eq? match:structure-control (quote disjoint)) match:runtime-structures) (let ((tag (gensym))) (set! match:disjoint-structure-tags (cons tag match:disjoint-structure-tags)) tag) (string->symbol (string-append "<" (symbol->string name) ">")))))
! (define match:structure? (lambda (tag) (memq tag match:disjoint-structure-tags)))
! (define match:structure-control (quote vector))
! (define match:set-structure-control (lambda (v) (set! match:structure-control v)))
! (define match:set-error (lambda (v) (set! match:error v)))
! (define match:error-control (quote error))
! (define match:set-error-control (lambda (v) (set! match:error-control v)))
! (define match:disjoint-predicates (cons (quote null) (quote (pair? symbol? boolean? number? string? char? procedure? vector?))))
! (define match:vector-structures (quote ()))
! (define match:expanders (letrec ((genmatch (lambda (x clauses match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (blist (car eb-errf)) (plist (map (lambda (c) (let* ((x (bound (validate-pattern (car c)))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (fail (and (pair? (cdr c)) (pair? (cadr c)) (eq? (caadr c) (quote =>)) (symbol? (cadadr c)) (pair? (cdadr c)) (null? (cddadr c)) (pair? (cddr c)) (cadadr c))) (bv2 (if fail (cons fail bv) bv)) (body (if fail (cddr c) (cdr c)))) (set! blist (cons (quasiquote ((unquote code) (lambda (unquote bv2) (unquote-splicing body)))) (append bindings blist))) (list p code bv (and fail (gensym)) #f))) clauses)) (code (gen x (quote ()) plist (cdr eb-errf) length>= (gensym)))) (unreachable plist match-expr) (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing blist)) (unquote code))))))) (genletrec (lambda (pat exp body match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (plist (list (list p code bv #f #f))) (x (gensym)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gensym))) (gs (map (lambda (_) (gensym)) bv))) (unreachable plist match-expr) (quasiquote (letrec (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing (map (lambda (v) (quasiquote ((unquote v) #f))) bv)) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (unquote-splicing body))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))) (gendefine (lambda (pat exp match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (plist (list (list p code bv #f #f))) (x (gensym)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gensym))) (gs (map (lambda (_) (gensym)) bv))) (unreachable plist match-expr) (quasiquote (begin (unquote-splicing (map (lambda (v) (quasiquote (define (unquote v) #f))) bv)) (unquote (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (cond (#f #f)))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))))))) (pattern-var? (lambda (x) (and (symbol? x) (not (dot-dot-k? x)) (not (memq x (quote (quasiquote quote unquote unquote-splicing ? _ $ = and or not set! get! ... ___))))))) (dot-dot-k? (lambda (s) (and (symbol? s) (if (memq s (quote (... ___))) 0 (let* ((s (symbol->string s)) (n (string-length s))) (and (<= 3 n) (memq (string-ref s 0) (quote (#\. #\_))) (memq (string-ref s 1) (quote (#\. #\_))) (match:andmap char-numeric? (string->list (substring s 2 n))) (string->number (substring s 2 n)))))))) (error-maker (lambda (match-expr) (cond ((eq? match:error-control (quote unspecified)) (cons (quote ()) (lambda (x) (quasiquote (cond (#f #f)))))) ((memq match:error-control (quote (error fail))) (cons (quote ()) (lambda (x) (quasiquote (match:error (unquote x)))))) ((eq? match:error-control (quote match)) (let ((errf (gensym)) (arg (gensym))) (cons (quasiquote (((unquote errf) (lambda ((unquote arg)) (match:error (unquote arg) (quote (unquote match-expr))))))) (lambda (x) (quasiquote ((unquote errf) (unquote x))))))) (else (match:syntax-err (quote (unspecified error fail match)) "invalid value for match:error-control, legal values are"))))) (unreachable (lambda (plist match-expr) (for-each (lambda (x) (if (not (car (cddddr x))) (begin (display "Warning: unreachable pattern ") (display (car x)) (display " in ") (display match-expr) (newline)))) plist))) (validate-pattern (lambda (pattern) (letrec ((simple? (lambda (x) (or (string? x) (boolean? x) (char? x) (number? x) (null? x)))) (ordinary (lambda (p) (let ((g157 (lambda (x y) (cons (ordinary x) (ordinary y))))) (if (simple? p) ((lambda (p) p) p) (if (equal? p (quote _)) ((lambda () (quote _))) (if (pattern-var? p) ((lambda (p) p) p) (if (pair? p) (if (equal? (car p) (quote quasiquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (quasi p)) (cadr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote quote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote ?)) (if (and (pair? (cdr p)) (list? (cddr p))) ((lambda (pred ps) (quasiquote (? (unquote pred) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote =)) (if (and (pair? (cdr p)) (pair? (cddr p)) (null? (cdddr p))) ((lambda (sel p) (quasiquote (= (unquote sel) (unquote (ordinary p))))) (cadr p) (caddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote and)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (and (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote or)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (or (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote not)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (not (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote $)) (if (and (pair? (cdr p)) (symbol? (cadr p)) (list? (cddr p))) ((lambda (r ps) (quasiquote ($ (unquote r) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote set!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote get!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote unquote)) (g157 (car p) (cdr p)) (if (equal? (car p) (quote unquote-splicing)) (g157 (car p) (cdr p)) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (ordinary p)) (unquote ddk)))) (car p) (cadr p)) (g157 (car p) (cdr p))))))))))))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (and (not (null? rpl)) (dot-dot-k? (car rpl))) (reverse (cons (car rpl) (map ordinary (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern"))))))))))) (quasi (lambda (p) (let ((g178 (lambda (x y) (cons (quasi x) (quasi y))))) (if (simple? p) ((lambda (p) p) p) (if (symbol? p) ((lambda (p) (quasiquote (quote (unquote p)))) p) (if (pair? p) (if (equal? (car p) (quote unquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (ordinary p)) (cadr p)) (g178 (car p) (cdr p))) (if (and (pair? (car p)) (equal? (caar p) (quote unquote-splicing)) (pair? (cdar p)) (null? (cddar p))) (if (null? (cdr p)) ((lambda (p) (ordinary p)) (cadar p)) ((lambda (p y) (append (ordlist p) (quasi y))) (cadar p) (cdr p))) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (quasi p)) (unquote ddk)))) (car p) (cadr p)) (g178 (car p) (cdr p))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (dot-dot-k? (car rpl)) (reverse (cons (car rpl) (map quasi (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern")))))))))) (ordlist (lambda (p) (cond ((null? p) (quote ())) ((pair? p) (cons (ordinary (car p)) (ordlist (cdr p)))) (else (match:syntax-err pattern "invalid use of unquote-splicing in pattern")))))) (ordinary pattern)))) (bound (lambda (pattern) (letrec ((pred-bodies (quote ())) (bound (lambda (p a k) (cond ((eq? (quote _) p) (k p a)) ((symbol? p) (if (memq p a) (match:syntax-err pattern "duplicate variable in pattern")) (k p (cons p a))) ((and (pair? p) (eq? (quote quote) (car p))) (k p a)) ((and (pair? p) (eq? (quote ?) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (and (? (unquote (cadr p))) (unquote-splicing (cddr p)))) a k)) ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gensym))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (k (quasiquote (? (unquote g))) a))) (else (k p a)))) ((and (pair? p) (eq? (quote =) (car p))) (cond ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gensym))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (bound (quasiquote (= (unquote g) (unquote (caddr p)))) a k))) (else (bound (caddr p) a (lambda (p2 a) (k (quasiquote (= (unquote (cadr p)) (unquote p2))) a)))))) ((and (pair? p) (eq? (quote and) (car p))) (bound* (cdr p) a (lambda (p a) (k (quasiquote (and (unquote-splicing p))) a)))) ((and (pair? p) (eq? (quote or) (car p))) (bound (cadr p) a (lambda (first-p first-a) (let or* ((plist (cddr p)) (k (lambda (plist) (k (quasiquote (or (unquote first-p) (unquote-splicing plist))) first-a)))) (if (null? plist) (k plist) (bound (car plist) a (lambda (car-p car-a) (if (not (permutation car-a first-a)) (match:syntax-err pattern "variables of or-pattern differ in")) (or* (cdr plist) (lambda (cdr-p) (k (cons car-p cdr-p))))))))))) ((and (pair? p) (eq? (quote not) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (not (or (unquote-splicing (cdr p))))) a k)) (else (bound (cadr p) a (lambda (p2 a2) (if (not (permutation a a2)) (match:syntax-err p "no variables allowed in")) (k (quasiquote (not (unquote p2))) a)))))) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (bound (car p) a (lambda (q b) (let ((bvars (find-prefix b a))) (k (quasiquote ((unquote q) (unquote (cadr p)) (unquote bvars) (unquote (gensym)) (unquote (gensym)) (unquote (map (lambda (_) (gensym)) bvars)))) b))))) ((and (pair? p) (eq? (quote $) (car p))) (bound* (cddr p) a (lambda (p1 a) (k (quasiquote ($ (unquote (cadr p)) (unquote-splicing p1))) a)))) ((and (pair? p) (eq? (quote set!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((and (pair? p) (eq? (quote get!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((pair? p) (bound (car p) a (lambda (car-p a) (bound (cdr p) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) ((vector? p) (boundv (vector->list p) a (lambda (pl a) (k (list->vector pl) a)))) (else (k p a))))) (boundv (lambda (plist a k) (let ((g184 (lambda () (k plist a)))) (if (pair? plist) (if (and (pair? (cdr plist)) (dot-dot-k? (cadr plist)) (null? (cddr plist))) ((lambda () (bound plist a k))) (if (null? plist) (g184) ((lambda (x y) (bound x a (lambda (car-p a) (boundv y a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) (car plist) (cdr plist)))) (if (null? plist) (g184) (match:error plist)))))) (bound* (lambda (plist a k) (if (null? plist) (k plist a) (bound (car plist) a (lambda (car-p a) (bound* (cdr plist) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))))) (find-prefix (lambda (b a) (if (eq? b a) (quote ()) (cons (car b) (find-prefix (cdr b) a))))) (permutation (lambda (p1 p2) (and (= (length p1) (length p2)) (match:andmap (lambda (x1) (memq x1 p2)) p1))))) (bound pattern (quote ()) (lambda (p a) (list p (reverse a) pred-bodies)))))) (inline-let (lambda (let-exp) (letrec ((occ (lambda (x e) (let loop ((e e)) (cond ((pair? e) (+ (loop (car e)) (loop (cdr e)))) ((eq? x e) 1) (else 0))))) (subst (lambda (e old new) (let loop ((e e)) (cond ((pair? e) (cons (loop (car e)) (loop (cdr e)))) ((eq? old e) new) (else e))))) (const? (lambda (sexp) (or (symbol? sexp) (boolean? sexp) (string? sexp) (char? sexp) (number? sexp) (null? sexp) (and (pair? sexp) (eq? (car sexp) (quote quote)) (pair? (cdr sexp)) (symbol? (cadr sexp)) (null? (cddr sexp)))))) (isval? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (memq (car sexp) (quote (lambda quote match-lambda match-lambda*))))))) (small? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (eq? (car sexp) (quote lambda)) (pair? (cdr sexp)) (pair? (cddr sexp)) (const? (caddr sexp)) (null? (cdddr sexp))))))) (let loop ((b (cadr let-exp)) (new-b (quote ())) (e (caddr let-exp))) (cond ((null? b) (if (null? new-b) e (quasiquote (let (unquote (reverse new-b)) (unquote e))))) ((isval? (cadr (car b))) (let* ((x (caar b)) (n (occ x e))) (cond ((= 0 n) (loop (cdr b) new-b e)) ((or (= 1 n) (small? (cadr (car b)))) (loop (cdr b) new-b (subst e x (cadr (car b))))) (else (loop (cdr b) (cons (car b) new-b) e))))) (else (loop (cdr b) (cons (car b) new-b) e))))))) (gen (lambda (x sf plist erract length>= eta) (if (null? plist) (erract x) (let* ((v (quote ())) (val (lambda (x) (cdr (assq x v)))) (fail (lambda (sf) (gen x sf (cdr plist) erract length>= eta))) (success (lambda (sf) (set-car! (cddddr (car plist)) #t) (let* ((code (cadr (car plist))) (bv (caddr (car plist))) (fail-sym (cadddr (car plist)))) (if fail-sym (let ((ap (quasiquote ((unquote code) (unquote fail-sym) (unquote-splicing (map val bv)))))) (quasiquote (call-with-current-continuation (lambda ((unquote fail-sym)) (let (((unquote fail-sym) (lambda () ((unquote fail-sym) (unquote (fail sf)))))) (unquote ap)))))) (quasiquote ((unquote code) (unquote-splicing (map val bv))))))))) (let next ((p (caar plist)) (e x) (sf sf) (kf fail) (ks success)) (cond ((eq? (quote _) p) (ks sf)) ((symbol? p) (set! v (cons (cons p e) v)) (ks sf)) ((null? p) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((equal? p (quote (quote ()))) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((string? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((boolean? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((char? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((number? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote quote) (car p))) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote ?) (car p))) (let ((tst (quasiquote ((unquote (cadr p)) (unquote e))))) (emit tst sf kf ks))) ((and (pair? p) (eq? (quote =) (car p))) (next (caddr p) (quasiquote ((unquote (cadr p)) (unquote e))) sf kf ks)) ((and (pair? p) (eq? (quote and) (car p))) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (ks sf) (next (car p) e sf kf (lambda (sf) (loop (cdr p) sf)))))) ((and (pair? p) (eq? (quote or) (car p))) (let ((or-v v)) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (kf sf) (begin (set! v or-v) (next (car p) e sf (lambda (sf) (loop (cdr p) sf)) ks)))))) ((and (pair? p) (eq? (quote not) (car p))) (next (cadr p) e sf ks kf)) ((and (pair? p) (eq? (quote $) (car p))) (let* ((tag (cadr p)) (fields (cdr p)) (rlen (length fields)) (tst (quasiquote ((unquote (symbol-append tag (quote ?))) (unquote e))))) (emit tst sf kf (let rloop ((n 1)) (lambda (sf) (if (= n rlen) (ks sf) (next (list-ref fields n) (quasiquote ((unquote (symbol-append tag (quote -) n)) (unquote e))) sf kf (rloop (+ 1 n))))))))) ((and (pair? p) (eq? (quote set!) (car p))) (set! v (cons (cons (cadr p) (setter e p)) v)) (ks sf)) ((and (pair? p) (eq? (quote get!) (car p))) (set! v (cons (cons (cadr p) (getter e p)) v)) (ks sf)) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (emit (quasiquote (list? (unquote e))) sf kf (lambda (sf) (let* ((k (dot-dot-k? (cadr p))) (ks (lambda (sf) (let ((bound (list-ref p 2))) (cond ((eq? (car p) (quote _)) (ks sf)) ((null? bound) (let* ((ptst (next (car p) eta sf (lambda (sf) #f) (lambda (sf) #t))) (tst (if (and (pair? ptst) (symbol? (car ptst)) (pair? (cdr ptst)) (eq? eta (cadr ptst)) (null? (cddr ptst))) (car ptst) (quasiquote (lambda ((unquote eta)) (unquote ptst)))))) (assm (quasiquote (match:andmap (unquote tst) (unquote e))) (kf sf) (ks sf)))) ((and (symbol? (car p)) (equal? (list (car p)) bound)) (next (car p) e sf kf ks)) (else (let* ((gloop (list-ref p 3)) (ge (list-ref p 4)) (fresh (list-ref p 5)) (p1 (next (car p) (quasiquote (car (unquote ge))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (cdr (unquote ge)) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound (map (lambda (x) (quasiquote (reverse (unquote x)))) fresh)) v)) (quasiquote (let (unquote gloop) (((unquote ge) (unquote e)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (null? (unquote ge)) (unquote (ks sf)) (unquote p1))))))))))) (case k ((0) (ks sf)) ((1) (emit (quasiquote (pair? (unquote e))) sf kf ks)) (else (emit (quasiquote (((unquote length>=) (unquote k)) (unquote e))) sf kf ks))))))) ((pair? p) (emit (quasiquote (pair? (unquote e))) sf kf (lambda (sf) (next (car p) (add-a e) sf kf (lambda (sf) (next (cdr p) (add-d e) sf kf ks)))))) ((and (vector? p) (>= (vector-length p) 6) (dot-dot-k? (vector-ref p (- (vector-length p) 5)))) (let* ((vlen (- (vector-length p) 6)) (k (dot-dot-k? (vector-ref p (+ vlen 1)))) (minlen (+ vlen k)) (bound (vector-ref p (+ vlen 2)))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (assm (quasiquote (>= (vector-length (unquote e)) (unquote minlen))) (kf sf) ((let vloop ((n 0)) (lambda (sf) (cond ((not (= n vlen)) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n)))) ((eq? (vector-ref p vlen) (quote _)) (ks sf)) (else (let* ((gloop (vector-ref p (+ vlen 3))) (ind (vector-ref p (+ vlen 4))) (fresh (vector-ref p (+ vlen 5))) (p1 (next (vector-ref p vlen) (quasiquote (vector-ref (unquote e) (unquote ind))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (- (unquote ind) 1) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound fresh) v)) (quasiquote (let (unquote gloop) (((unquote ind) (- (vector-length (unquote e)) 1)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (> (unquote minlen) (unquote ind)) (unquote (ks sf)) (unquote p1))))))))) sf)))))) ((vector? p) (let ((vlen (vector-length p))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (emit (quasiquote (equal? (vector-length (unquote e)) (unquote vlen))) sf kf (let vloop ((n 0)) (lambda (sf) (if (= n vlen) (ks sf) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n))))))))))) (else (display "FATAL ERROR IN PATTERN MATCHER") (newline) (error #f "THIS NEVER HAPPENS")))))))) (emit (lambda (tst sf kf ks) (cond ((in tst sf) (ks sf)) ((in (quasiquote (not (unquote tst))) sf) (kf sf)) (else (let* ((e (cadr tst)) (implied (cond ((eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quasiquote ((string? (unquote e))))) ((boolean? p) (quasiquote ((boolean? (unquote e))))) ((char? p) (quasiquote ((char? (unquote e))))) ((number? p) (quasiquote ((number? (unquote e))))) ((and (pair? p) (eq? (quote quote) (car p))) (quasiquote ((symbol? (unquote e))))) (else (quote ()))))) ((eq? (car tst) (quote null?)) (quasiquote ((list? (unquote e))))) ((vec-structure? tst) (quasiquote ((vector? (unquote e))))) (else (quote ())))) (not-imp (case (car tst) ((list?) (quasiquote ((not (null? (unquote e)))))) (else (quote ())))) (s (ks (cons tst (append implied sf)))) (k (kf (cons (quasiquote (not (unquote tst))) (append not-imp sf))))) (assm tst k s)))))) (assm (lambda (tst f s) (cond ((equal? s f) s) ((and (eq? s #t) (eq? f #f)) tst) ((and (eq? (car tst) (quote pair?)) (memq match:error-control (quote (unspecified fail))) (memq (car f) (quote (cond match:error))) (guarantees s (cadr tst))) s) ((and (pair? s) (eq? (car s) (quote if)) (equal? (cadddr s) f)) (if (eq? (car (cadr s)) (quote and)) (quasiquote (if (and (unquote tst) (unquote-splicing (cdr (cadr s)))) (unquote (caddr s)) (unquote f))) (quasiquote (if (and (unquote tst) (unquote (cadr s))) (unquote (caddr s)) (unquote f))))) ((and (pair? s) (equal? (car s) (quote call-with-current-continuation)) (pair? (cdr s)) (pair? (cadr s)) (equal? (caadr s) (quote lambda)) (pair? (cdadr s)) (pair? (cadadr s)) (null? (cdr (cadadr s))) (pair? (cddadr s)) (pair? (car (cddadr s))) (equal? (caar (cddadr s)) (quote let)) (pair? (cdar (cddadr s))) (pair? (cadar (cddadr s))) (pair? (caadar (cddadr s))) (pair? (cdr (caadar (cddadr s)))) (pair? (cadr (caadar (cddadr s)))) (equal? (caadr (caadar (cddadr s))) (quote lambda)) (pair? (cdadr (caadar (cddadr s)))) (null? (cadadr (caadar (cddadr s)))) (pair? (cddadr (caadar (cddadr s)))) (pair? (car (cddadr (caadar (cddadr s))))) (pair? (cdar (cddadr (caadar (cddadr s))))) (null? (cddar (cddadr (caadar (cddadr s))))) (null? (cdr (cddadr (caadar (cddadr s))))) (null? (cddr (caadar (cddadr s)))) (null? (cdadar (cddadr s))) (pair? (cddar (cddadr s))) (null? (cdddar (cddadr s))) (null? (cdr (cddadr s))) (null? (cddr s)) (equal? f (cadar (cddadr (caadar (cddadr s)))))) (let ((k (car (cadadr s))) (fail (car (caadar (cddadr s)))) (s2 (caddar (cddadr s)))) (quasiquote (call-with-current-continuation (lambda ((unquote k)) (let (((unquote fail) (lambda () ((unquote k) (unquote f))))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))))) ((and #f (pair? s) (equal? (car s) (quote let)) (pair? (cdr s)) (pair? (cadr s)) (pair? (caadr s)) (pair? (cdaadr s)) (pair? (car (cdaadr s))) (equal? (caar (cdaadr s)) (quote lambda)) (pair? (cdar (cdaadr s))) (null? (cadar (cdaadr s))) (pair? (cddar (cdaadr s))) (null? (cdddar (cdaadr s))) (null? (cdr (cdaadr s))) (null? (cdadr s)) (pair? (cddr s)) (null? (cdddr s)) (equal? (caddar (cdaadr s)) f)) (let ((fail (caaadr s)) (s2 (caddr s))) (quasiquote (let (((unquote fail) (lambda () (unquote f)))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))) (else (quasiquote (if (unquote tst) (unquote s) (unquote f))))))) (guarantees (lambda (code x) (let ((a (add-a x)) (d (add-d x))) (let loop ((code code)) (cond ((not (pair? code)) #f) ((memq (car code) (quote (cond match:error))) #t) ((or (equal? code a) (equal? code d)) #t) ((eq? (car code) (quote if)) (or (loop (cadr code)) (and (loop (caddr code)) (loop (cadddr code))))) ((eq? (car code) (quote lambda)) #f) ((and (eq? (car code) (quote let)) (symbol? (cadr code))) #f) (else (or (loop (car code)) (loop (cdr code))))))))) (in (lambda (e l) (or (member e l) (and (eq? (car e) (quote list?)) (or (member (quasiquote (null? (unquote (cadr e)))) l) (member (quasiquote (pair? (unquote (cadr e)))) l))) (and (eq? (car e) (quote not)) (let* ((srch (cadr e)) (const-class (equal-test? srch))) (cond (const-class (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? const-class (car x)))) (equal? x (quasiquote (not ((unquote const-class) (unquote (cadr srch)))))) (and (equal? (cadr x) (cadr srch)) (equal-test? x) (not (equal? (caddr srch) (caddr x)))) (mem (cdr l))))))) ((disjoint? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? (car x) (car srch)))) (mem (cdr l))))))) ((eq? (car srch) (quote list?)) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (memq (car x) (quote (list? pair? null?))))) (mem (cdr l))))))) ((vec-structure? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (or (disjoint? x) (vec-structure? x)) (not (equal? (car x) (quote vector?))) (not (equal? (car x) (car srch)))) (equal? x (quasiquote (not (vector? (unquote (cadr srch)))))) (mem (cdr l))))))) (else #f))))))) (equal-test? (lambda (tst) (and (eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quote string?)) ((boolean? p) (quote boolean?)) ((char? p) (quote char?)) ((number? p) (quote number?)) ((and (pair? p) (pair? (cdr p)) (null? (cddr p)) (eq? (quote quote) (car p)) (symbol? (cadr p))) (quote symbol?)) (else #f)))))) (disjoint? (lambda (tst) (memq (car tst) match:disjoint-predicates))) (vec-structure? (lambda (tst) (memq (car tst) match:vector-structures))) (add-a (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cadr new) (cdr a)) (quasiquote (car (unquote a))))))) (add-d (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cddr new) (cdr a)) (quasiquote (cdr (unquote a))))))) (c---rs (quote ((car caar . cdar) (cdr cadr . cddr) (caar caaar . cdaar) (cadr caadr . cdadr) (cdar cadar . cddar) (cddr caddr . cdddr) (caaar caaaar . cdaaar) (caadr caaadr . cdaadr) (cadar caadar . cdadar) (caddr caaddr . cdaddr) (cdaar cadaar . cddaar) (cdadr cadadr . cddadr) (cddar caddar . cdddar) (cdddr cadddr . cddddr)))) (setter (lambda (e p) (let ((mk-setter (lambda (s) (symbol-append (quote set-) s (quote !))))) (cond ((not (pair? e)) (match:syntax-err p "unnested set! pattern")) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (vector-set! x (unquote (caddr e)) y))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-box! x y))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-car! x y))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-cdr! x y))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda (y) ((unquote (mk-setter (cddr a))) x y))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) ((unquote (mk-setter (car e))) x y))))))))) (getter (lambda (e p) (cond ((not (pair? e)) (match:syntax-err p "unnested get! pattern")) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (vector-ref x (unquote (caddr e))))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (unbox x))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (car x))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (cdr x))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda () ((unquote (cddr a)) x))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda () ((unquote (car e)) x)))))))) (get-c---rs (quote ((caar car . car) (cadr cdr . car) (cdar car . cdr) (cddr cdr . cdr) (caaar caar . car) (caadr cadr . car) (cadar cdar . car) (caddr cddr . car) (cdaar caar . cdr) (cdadr cadr . cdr) (cddar cdar . cdr) (cdddr cddr . cdr) (caaaar caaar . car) (caaadr caadr . car) (caadar cadar . car) (caaddr caddr . car) (cadaar cdaar . car) (cadadr cdadr . car) (caddar cddar . car) (cadddr cdddr . car) (cdaaar caaar . cdr) (cdaadr caadr . cdr) (cdadar cadar . cdr) (cdaddr caddr . cdr) (cddaar cdaar . cdr) (cddadr cdadr . cdr) (cdddar cddar . cdr) (cddddr cdddr . cdr)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l))))) (rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l))))) (rdc (lambda (l) (if (null? (cdr l)) (quote ()) (cons (car l) (rdc (cdr l))))))) (list genmatch genletrec gendefine pattern-var?)))
! (defmacro match args (cond ((and (list? args) (<= 1 (length args)) (match:andmap (lambda (y) (and (list? y) (<= 2 (length y)))) (cdr args))) (let* ((exp (car args)) (clauses (cdr args)) (e (if (symbol? exp) exp (gensym)))) (if (symbol? exp) ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))) (quasiquote (let (((unquote e) (unquote exp))) (unquote ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))))))))) (else (match:syntax-err (quasiquote (match (unquote-splicing args))) "syntax error in"))))
! (defmacro match-lambda args (if (and (list? args) (match:andmap (lambda (g195) (if (and (pair? g195) (list? (cdr g195))) (pair? (cdr g195)) #f)) args)) ((lambda () (let ((e (gensym))) (quasiquote (lambda ((unquote e)) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda (unquote-splicing args))) "syntax error in")))))
! (defmacro match-lambda* args (if (and (list? args) (match:andmap (lambda (g203) (if (and (pair? g203) (list? (cdr g203))) (pair? (cdr g203)) #f)) args)) ((lambda () (let ((e (gensym))) (quasiquote (lambda (unquote e) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda* (unquote-splicing args))) "syntax error in")))))
! (defmacro match-let args (let ((g227 (lambda (pat exp body) (quasiquote (match (unquote exp) ((unquote pat) (unquote-splicing body)))))) (g223 (lambda (pat exp body) (let ((g (map (lambda (x) (gensym)) pat)) (vpattern (list->vector pat))) (quasiquote (let (unquote (map list g exp)) (match (vector (unquote-splicing g)) ((unquote vpattern) (unquote-splicing body)))))))) (g215 (lambda () (match:syntax-err (quasiquote (match-let (unquote-splicing args))) "syntax error in"))) (g214 (lambda (p1 e1 p2 e2 body) (let ((g1 (gensym)) (g2 (gensym))) (quasiquote (let (((unquote g1) (unquote e1)) ((unquote g2) (unquote e2))) (match (cons (unquote g1) (unquote g2)) (((unquote p1) unquote p2) (unquote-splicing body)))))))) (g205 (cadddr match:expanders))) (if (pair? args) (if (symbol? (car args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g230 ((g231 (cadr args)) (g229 (quote ())) (g228 (quote ()))) (if (null? g231) (if (and (list? (cddr args)) (pair? (cddr args))) ((lambda (name pat exp body) (if (match:andmap (cadddr match:expanders) pat) (quasiquote (let (unquote-splicing args))) (quasiquote (letrec (((unquote name) (match-lambda* ((unquote pat) (unquote-splicing body))))) ((unquote name) (unquote-splicing exp)))))) (car args) (reverse g228) (reverse g229) (cddr args)) (g215)) (if (and (pair? (car g231)) (pair? (cdar g231)) (null? (cddar g231))) (g230 (cdr g231) (cons (cadar g231) g229) (cons (caar g231) g228)) (g215)))) (g215)) (if (list? (car args)) (if (match:andmap (lambda (g236) (if (and (pair? g236) (g205 (car g236)) (pair? (cdr g236))) (null? (cddr g236)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (let (unquote-splicing args))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (g215)))) (g215))))
! (defmacro match-let* args (let ((g245 (lambda () (match:syntax-err (quasiquote (match-let* (unquote-splicing args))) "syntax error in")))) (if (pair? args) (if (null? (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda (body) (quasiquote (let* (unquote-splicing args)))) (cdr args)) (g245)) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args)) (list? (cdar args)) (list? (cdr args)) (pair? (cdr args))) ((lambda (pat exp rest body) (if ((cadddr match:expanders) pat) (quasiquote (let (((unquote pat) (unquote exp))) (match-let* (unquote rest) (unquote-splicing body)))) (quasiquote (match (unquote exp) ((unquote pat) (match-let* (unquote rest) (unquote-splicing body))))))) (caaar args) (cadaar args) (cdar args) (cdr args)) (g245))) (g245))))
! (defmacro match-letrec args (let ((g269 (cadddr match:expanders)) (g268 (lambda (p1 e1 p2 e2 body) (quasiquote (match-letrec ((((unquote p1) unquote p2) (cons (unquote e1) (unquote e2)))) (unquote-splicing body))))) (g264 (lambda () (match:syntax-err (quasiquote (match-letrec (unquote-splicing args))) "syntax error in"))) (g263 (lambda (pat exp body) (quasiquote (match-letrec (((unquote (list->vector pat)) (vector (unquote-splicing exp)))) (unquote-splicing body))))) (g255 (lambda (pat exp body) ((cadr match:expanders) pat exp body (quasiquote (match-letrec (((unquote pat) (unquote exp))) (unquote-splicing body))))))) (if (pair? args) (if (list? (car args)) (if (match:andmap (lambda (g275) (if (and (pair? g275) (g269 (car g275)) (pair? (cdr g275))) (null? (cddr g275)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (letrec (unquote-splicing args))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (g264))) (g264))))
! (defmacro match-define args (let ((g279 (cadddr match:expanders)) (g278 (lambda () (match:syntax-err (quasiquote (match-define (unquote-splicing args))) "syntax error in")))) (if (pair? args) (if (g279 (car args)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda () (quasiquote (begin (define (unquote-splicing args)))))) (g278)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda (pat exp) ((caddr match:expanders) pat exp (quasiquote (match-define (unquote-splicing args))))) (car args) (cadr args)) (g278))) (g278))))
! (define match:runtime-structures #f)
! (define match:set-runtime-structures (lambda (v) (set! match:runtime-structures v)))
! (define match:primitive-vector? vector?)
! (defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote (defstruct (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296)))))
! (defmacro define-structure args (let ((g311 (lambda () (match:syntax-err (quasiquote (define-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ())) (g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote @)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x) (cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote (define-const-structure ((unquote name) (unquote-splicing (map mk-id id1))) (unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v)))) id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311)) (if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308 (cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311))) (g311))))
! (defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin (defstruct (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335)))))
--- 1,222 ----
! ;; 2010/05/20 - record matching for guile (Stefan Israelsson Tampe)
! ;; Modifying upstream version (match.upstream.scm) by Alex Shinn
  
  (define-module (ice-9 match)
!   #:use-module (srfi srfi-9)
!   #:export     (match-define match-let* match-let match-letrec match-lambda*
! 			     match-lambda match))
! 
! (define-syntax match
!   (syntax-rules ()
!     ((match)
!      (match-syntax-error "missing match expression"))
!     ((match atom)
!      (match-syntax-error "no match clauses"))
!     ((match (app ...) (pat . body) ...)
!      (let ((v (app ...)))
!        (match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
!     ((match #(vec ...) (pat . body) ...)
!      (let ((v #(vec ...)))
!        (match-next v (v (set! v)) (pat . body) ...)))
!     ((match atom (pat . body) ...)
!      (let ((v atom))
!        (match-next v (atom (set! atom)) (pat . body) ...)))
!     ))
! 
! (define-syntax match-two
!   (syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
!     ((match-two v () g+s (sk ...) fk i)
!      (if (null? v) (sk ... i) fk))
!     ((match-two v (quote p) g+s (sk ...) fk i)
!      (if (equal? v 'p) (sk ... i) fk))
!     ((match-two v (quasiquote p) . x)
!      (match-quasiquote v p . x))
!     ((match-two v (and) g+s (sk ...) fk i) (sk ... i))
!     ((match-two v (and p q ...) g+s sk fk i)
!      (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i))
!     ((match-two v (or) g+s sk fk i) fk)
!     ((match-two v (or p) . x)
!      (match-one v p . x))
!     ((match-two v (or p ...) g+s sk fk i)
!      (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
!     ((match-two v (not p) g+s (sk ...) fk i)
!      (match-one v p g+s (match-drop-ids fk) (sk ... i) i))
!     ((match-two v (get! getter) (g s) (sk ...) fk i)
!      (let ((getter (lambda () g))) (sk ... i)))
!     ((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
!      (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
!     ((match-two v (? pred . p) g+s sk fk i)
!      (if (pred v) (match-one v (and . p) g+s sk fk i) fk))
!     
!     ;; stis, added $ support!
!     ((match-two v ($ n) g-s sk fk i)
!      (if (n v) sk fk))
!     
!     ((match-two v ($ nn p ...) g+s sk fk i)
!      (if (nn v)
! 	 (match-$ (and) 0 (p ...) v sk fk i)
! 	 fk))
!      
!     ;; stis, added the possibility to use set! and get to records    
!     ((match-two v (= 0 m p) g+s sk fk i)
!      (let ((w  (struct-ref v m)))
!        (match-one w p ((struct-ref v m) (struct-set! v m)) sk fk i)))
! 
!     ((match-two v (= g s p) g+s sk fk i)
!      (let ((w (g v))) (match-one w p ((g v) (s v)) sk fk i)))
! 
!     ((match-two v (= proc p) g+s . x)
!      (let ((w (proc v))) '() (match-one w p . x)))
!     
!     ((match-two v (p ___ . r) g+s sk fk i)
!      (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()))
!     ((match-two v (p) g+s sk fk i)
!      (if (and (pair? v) (null? (cdr v)))
!          (let ((w (car v)))
!            (match-one w p ((car v) (set-car! v)) sk fk i))
!          fk))
!     ((match-two v (p *** q) g+s sk fk i)
!      (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
!     ((match-two v (p *** . q) g+s sk fk i)
!      (match-syntax-error "invalid use of ***" (p *** . q)))
!     ((match-two v (p . q) g+s sk fk i)
!      (if (pair? v)
!          (let ((w (car v)) (x (cdr v)))
!            (match-one w p ((car v) (set-car! v))
!                       (match-one x q ((cdr v) (set-cdr! v)) sk fk)
!                       fk
!                       i))
!          fk))
!     ((match-two v #(p ...) g+s . x)
!      (match-vector v 0 () (p ...) . x))
!     ((match-two v _ g+s (sk ...) fk i) (sk ... i))
!     ;; Not a pair or vector or special literal, test to see if it's a
!     ;; new symbol, in which case we just bind it, or if it's an
!     ;; already bound symbol or some other literal, in which case we
!     ;; compare it with EQUAL?.
!     ((match-two v x g+s (sk ...) fk (id ...))
!      (let-syntax
!          ((new-sym?
!            (syntax-rules (id ...)
!              ((new-sym? x sk2 fk2) sk2)
!              ((new-sym? y sk2 fk2) fk2))))
!        (new-sym? random-sym-to-match
!                  (let ((x v)) (sk ... (id ... x)))
!                  (if (equal? v x) (sk ... (id ...)) fk))))
!     ))
! 
! (define-syntax match-$
!   (lambda (x)
!     (syntax-case x ()
!       ((q (a ...) m (p1 p2 ...) . v)
!        (with-syntax ((m+1 (datum->syntax (syntax q) 
! 					 (+ (syntax->datum (syntax m)) 1))))
! 	 (syntax (match-$ (a ... (= 0 m p1)) m+1 (p2 ...) . v))))
!       ((_ newpat  m ()            v kt ke i)
!        (syntax (match-one v newpat () kt ke i))))))
! 
! ;;We must be able to extract vars in the new constructs!!
! (define-syntax match-extract-vars
!   (syntax-rules (_ ___ *** ? $ = quote quasiquote and or not get! set!)
!     ((match-extract-vars (? pred . p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars ($ rec . p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (= proc p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (= u m p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (quote x) (k ...) i v)
!      (k ... v))
!     ((match-extract-vars (quasiquote x) k i v)
!      (match-extract-quasiquote-vars x k i v (#t)))
!     ((match-extract-vars (and . p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (or . p) . x)
!      (match-extract-vars p . x))
!     ((match-extract-vars (not . p) . x)
!      (match-extract-vars p . x))
!     ;; A non-keyword pair, expand the CAR with a continuation to
!     ;; expand the CDR.
!     ((match-extract-vars (p q . r) k i v)
!      (match-check-ellipse
!       q
!       (match-extract-vars (p . r) k i v)
!       (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
!     ((match-extract-vars (p . q) k i v)
!      (match-extract-vars p (match-extract-vars-step q k i v) i ()))
!     ((match-extract-vars #(p ...) . x)
!      (match-extract-vars (p ...) . x))
!     ((match-extract-vars _ (k ...) i v)    (k ... v))
!     ((match-extract-vars ___ (k ...) i v)  (k ... v))
!     ((match-extract-vars *** (k ...) i v)  (k ... v))
!     ;; This is the main part, the only place where we might add a new
!     ;; var if it's an unbound symbol.
!     ((match-extract-vars p (k ...) (i ...) v)
!      (let-syntax
!          ((new-sym?
!            (syntax-rules (i ...)
!              ((new-sym? p sk fk) sk)
!              ((new-sym? x sk fk) fk))))
!        (new-sym? random-sym-to-match
!                  (k ... ((p p-ls) . v))
!                  (k ... v))))
!     ))
! 
! (defmacro match-define (arg code)
!   (let* ((vars  (unmemoize-expr
! 		 (macroexpand `((@ (ice-9 match) match-extract-vars) ,arg () () ()))))
! 	 (vars  (map car (car vars)))
! 	 (vars2 (map (lambda (x)    (gensym "x"))   vars))
! 	 (sets  (map (lambda (x y) `(set! ,x ,y))   vars2 vars))
! 	 (sets2 (map (lambda (x y) `(set! ,x ,y))   vars  vars2))
! 	 (lets  (map (lambda (x)   `(,x #f))        vars2))
! 	 (defs  (map (lambda (x)   `(define ,x #f)) vars)))
!     
!     `(begin
!        ,@defs
!        (let ,lets
! 	 (match ,code (,arg (begin ,@sets)))
! 	 ,@sets2))))
! 
! 
! ;;;Reading the rest from upstream
! 
! ;;Utility
! (define-syntax include-from-path/filtered
!   (lambda (x)
!     (define (hit? sexp reject-list)
!       (if (null? reject-list)
! 	  #f
! 	  (let ((h (car reject-list))
! 		(l (cdr reject-list)))
! 	    (if (and (pair? sexp)
! 		     (eq? 'define-syntax (car sexp))
! 		     (pair? (cdr sexp))
! 		     (eq? h (cadr sexp)))
! 		#t
! 		(hit? sexp l)))))
! 
!     (define (read-filtered reject-list file)
!       (with-input-from-file (%search-load-path file)
!         (lambda ()
!           (let loop ((sexp (read)) (out '()))
!             (cond
!              ((eof-object? sexp) (reverse out))
!              ((hit? sexp reject-list)
!               (loop (read) out))
!              (else
!               (loop (read) (cons sexp out))))))))
! 
!     (syntax-case x ()
!       ((_ reject-list file)
!        (with-syntax (((exp ...) (datum->syntax
!                                  x 
!                                  (read-filtered
!                                   (syntax->datum #'reject-list)
!                                   (syntax->datum #'file)))))
! 		    #'(begin exp ...))))))
! 
! (include-from-path/filtered
!  (match-extract-vars match-two match)
!  "ice-9/match.upstream.scm")
\ No newline at end of file
Only in guile-master-20100512_new//module/ice-9: match.scm~
Only in guile-master-20100512_new//module/ice-9: match.upstream.scm