From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: stefan Newsgroups: gmane.lisp.guile.devel Subject: Re: fmatch Date: Mon, 24 May 2010 23:05:08 +0200 Message-ID: <201005242305.08448.stefan.tampe@spray.se> References: <201005062239.32992.stefan.tampe@spray.se> <201005231747.23855.stefan.tampe@spray.se> <87eih1xdt1.fsf@gnu.org> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: Multipart/Mixed; boundary="Boundary-00=_Eou+Legj22R2p3x" X-Trace: dough.gmane.org 1274737499 15625 80.91.229.12 (24 May 2010 21:44:59 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Mon, 24 May 2010 21:44:59 +0000 (UTC) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Mon May 24 23:44:57 2010 connect(): No such file or directory Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1OGfRp-0000Ac-Ig for guile-devel@m.gmane.org; Mon, 24 May 2010 23:44:56 +0200 Original-Received: from localhost ([127.0.0.1]:52006 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1OGfRn-0001kH-BT for guile-devel@m.gmane.org; Mon, 24 May 2010 17:44:31 -0400 Original-Received: from [140.186.70.92] (port=57645 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1OGfRS-0001cE-73 for guile-devel@gnu.org; Mon, 24 May 2010 17:44:18 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.69) (envelope-from ) id 1OGfRJ-0004E8-W8 for guile-devel@gnu.org; Mon, 24 May 2010 17:44:09 -0400 Original-Received: from spsmtp02oc.mail2world.com ([74.202.142.198]:4539) by eggs.gnu.org with esmtp (Exim 4.69) (envelope-from ) id 1OGfRJ-0004Dn-9W for guile-devel@gnu.org; Mon, 24 May 2010 17:44:01 -0400 Original-Received: from mail pickup service by spsmtp02oc.mail2world.com with Microsoft SMTPSVC; Mon, 24 May 2010 14:43:57 -0700 auth-sender: stefan.tampe@spray.se Original-Received: from 82.182.254.46 unverified ([82.182.254.46]) by spsmtp02oc.mail2world.com with Mail2World SMTP Server; Mon, 24 May 2010 14:43:53 -0700 User-Agent: KMail/1.12.4 (Linux/2.6.31.12-0.2-desktop; KDE/4.3.5; x86_64; ; ) In-Reply-To: <87eih1xdt1.fsf@gnu.org> X-OriginalArrivalTime: 24 May 2010 21:43:57.0415 (UTC) FILETIME=[36A25F70:01CAFB8A] X-detected-operating-system: by eggs.gnu.org: Windows 2000 SP4, XP SP1+ X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:10362 Archived-At: --Boundary-00=_Eou+Legj22R2p3x Content-Type: Text/Plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable is this better? /Stefan On Monday 24 May 2010 10:08:58 pm Ludovic Court=C3=A8s wrote: > Hello! >=20 > stefan writes: > > On Saturday 22 May 2010 11:03:12 pm Ludovic Court=C3=A8s wrote: > >> Hi! > >> > >> stefan writes: > >> > Shall we say that we use the slightly modified version of (ice-9 > >> > match) that ypu dug up for now! > >> > >> Hmm, yes? Please send an actual patch against Guile master, so we have > >> something concrete do discuss. :-) > > > > In this mail a patch is made for discussions. It's not upstream ready > > but intended for further discussions. >=20 > Thanks! Your patch inserts a modified version of Shinn=E2=80=99s match as > (ice-9 match). I=E2=80=99d prefer to have the upstream version unmodifie= d, say > as =E2=80=98match.upstream.scm=E2=80=99, and have =E2=80=98match.scm=E2= =80=99 just =E2=80=98include-from-path=E2=80=99 > that file, along with defining any necessary macros for compatibility > (see, e.g., how =E2=80=98sxml/ssax.scm=E2=80=99 does that.) >=20 > Could you look into it? >=20 > Thanks, > Ludo=E2=80=99. >=20 --Boundary-00=_Eou+Legj22R2p3x Content-Type: text/x-patch; charset="UTF-8"; name="match.patch" Content-Transfer-Encoding: quoted-printable Content-Disposition: attachment; filename="match.patch" Only in guile-master-20100512_new//examples: match_examples.scm diff -crB guile-master-20100512/module/ice-9/match.scm guile-master-2010051= 2_new//module/ice-9/match.scm *** guile-master-20100512/module/ice-9/match.scm 2010-05-12 06:00:07.000000= 000 +0200 =2D-- guile-master-20100512_new//module/ice-9/match.scm 2010-05-24 23:04:17= =2E408064463 +0200 *************** *** 1,199 **** ! ;;; installed-scm-file !=20 ! ;;;; 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. ! ;;;;=20 ! ;;;; 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. ! ;;;;=20 ! ;;;; 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 ! ;;;; =20 (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)) !=20 ! ;; 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 !=20 ! =0C ! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ! ;; Pattern Matching Syntactic Extensions for Scheme ! ;; ! (define match:version "Version 1.19, Sep 15, 1995") ! ;; ! ;; Written by Andrew K. Wright, 1993 (wright@research.nj.nec.com). ! ;; 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 ::=3D ... ! ;; | (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 ::=3D (pat body) | (pat =3D> exp) ! ;; ! ;; patterns: matches: ! ;; ! ;; pat ::=3D identifier anything, and binds identifi= er ! ;; | _ 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-ex= pr) ! ;; | (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 elem= ent ! ;; of remainder must match pat_= n+1 ! ;; | #&pat box ! ;; | ($ struct-name pat_1 ... pat_n) a structure ! ;; | (=3D field pat) a field of a structure ! ;; | (and pat_1 ... pat_n) if all of pat_1 thru pat_n mat= ch ! ;; | (or pat_1 ... pat_n) if any of pat_1 thru pat_n mat= ch ! ;; | (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 ::=3D ... zero or more ! ;; | ___ zero or more ! ;; | ..k k or more ! ;; | __k k or more ! ;; ! ;; quasi-patterns: matches: ! ;; ! ;; qp ::=3D () 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 elem= ent ! ;; 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 variable= s. ! ;; ! ;; ! ;; structure expressions: ! ;; ! ;; exp ::=3D ... ! ;; | (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 ::=3D 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. ! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; !=20 ! (define match:error (lambda (val . args) (for-each pretty-print args) (er= ror "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:struct= ure-control (quote disjoint)) match:runtime-structures) (let ((tag (gensym)= )) (set! match:disjoint-structure-tags (cons tag match:disjoint-structure-t= ags)) tag) (string->symbol (string-append "<" (symbol->string name) ">"))))) ! (define match:structure? (lambda (tag) (memq tag match:disjoint-structure= =2Dtags))) ! (define match:structure-control (quote vector)) ! (define match:set-structure-control (lambda (v) (set! match:structure-con= trol 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>=3D (gensym)) (eb-errf (error-maker match-expr)) (blist (ca= r 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 =3D>)) (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) (unquot= e-splicing body)))) (append bindings blist))) (list p code bv (and fail (ge= nsym)) #f))) clauses)) (code (gen x (quote ()) plist (cdr eb-errf) length>= =3D (gensym)))) (unreachable plist match-expr) (inline-let (quasiquote (let= (((unquote length>=3D) (lambda (n) (lambda (l) (>=3D (length l) n)))) (unq= uote-splicing blist)) (unquote code))))))) (genletrec (lambda (pat exp body= match-expr) (let* ((length>=3D (gensym)) (eb-errf (error-maker match-expr)= ) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (c= addr x)) (code (gensym)) (plist (list (list p code bv #f #f))) (x (gensym))= (m (gen x (quote ()) plist (cdr eb-errf) length>=3D (gensym))) (gs (map (l= ambda (_) (gensym)) bv))) (unreachable plist match-expr) (quasiquote (letre= c (((unquote length>=3D) (lambda (n) (lambda (l) (>=3D (length l) n)))) (un= quote-splicing (map (lambda (v) (quasiquote ((unquote v) #f))) bv)) ((unquo= te x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing= (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (u= nquote-splicing body))) (unquote-splicing bindings) (unquote-splicing (car = eb-errf))) (unquote m)))))) (gendefine (lambda (pat exp match-expr) (let* (= (length>=3D (gensym)) (eb-errf (error-maker match-expr)) (x (bound (validat= e-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gens= ym)) (plist (list (list p code bv #f #f))) (x (gensym)) (m (gen x (quote ()= ) plist (cdr eb-errf) length>=3D (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= =2Dlet (quasiquote (let (((unquote length>=3D) (lambda (n) (lambda (l) (>= =3D (length l) n)))) ((unquote x) (unquote exp)) ((unquote code) (lambda (u= nquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote = v) (unquote g)))) bv gs)) (cond (#f #f)))) (unquote-splicing bindings) (unq= uote-splicing (car eb-errf))) (unquote m)))))))))) (pattern-var? (lambda (x= ) (and (symbol? x) (not (dot-dot-k? x)) (not (memq x (quote (quasiquote quo= te unquote unquote-splicing ? _ $ =3D and or not set! get! ... ___))))))) (= dot-dot-k? (lambda (s) (and (symbol? s) (if (memq s (quote (... ___))) 0 (l= et* ((s (symbol->string s)) (n (string-length s))) (and (<=3D 3 n) (memq (s= tring-ref s 0) (quote (#\. #\_))) (memq (string-ref s 1) (quote (#\. #\_)))= (match:andmap char-numeric? (string->list (substring s 2 n))) (string->num= ber (substring s 2 n)))))))) (error-maker (lambda (match-expr) (cond ((eq? = match:error-control (quote unspecified)) (cons (quote ()) (lambda (x) (quas= iquote (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 (un= quote arg) (quote (unquote match-expr))))))) (lambda (x) (quasiquote ((unqu= ote errf) (unquote x))))))) (else (match:syntax-err (quote (unspecified err= or 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))) (vali= date-pattern (lambda (pattern) (letrec ((simple? (lambda (x) (or (string? x= ) (boolean? x) (char? x) (number? x) (null? x)))) (ordinary (lambda (p) (le= t ((g157 (lambda (x y) (cons (ordinary x) (ordinary y))))) (if (simple? p) = ((lambda (p) p) p) (if (equal? p (quote _)) ((lambda () (quote _))) (if (pa= ttern-var? p) ((lambda (p) p) p) (if (pair? p) (if (equal? (car p) (quote q= uasiquote)) (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)) (i= f (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? (cd= dr 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 =3D)) (if (and (pair? (cdr p)) (pair? (cddr p)) (null? (cd= ddr p))) ((lambda (sel p) (quasiquote (=3D (unquote sel) (unquote (ordinary= p))))) (cadr p) (caddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (qu= ote and)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquo= te (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-sp= licing (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 ordi= nary 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? (cdd= r p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quot= e 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 unqu= ote)) (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 vec= tor (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-splic= ing)) (pair? (cdar p)) (null? (cddar p))) (if (null? (cdr p)) ((lambda (p) = (ordinary p)) (cadar p)) ((lambda (p y) (append (ordlist p) (quasi y))) (ca= dar p) (cdr p))) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cdd= r p))) ((lambda (p ddk) (quasiquote ((unquote (quasi p)) (unquote ddk)))) (= car p) (cadr p)) (g178 (car p) (cdr p))))) (if (vector? p) ((lambda (p) (le= t* ((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) (con= s (ordinary (car p)) (ordlist (cdr p)))) (else (match:syntax-err pattern "i= nvalid use of unquote-splicing in pattern")))))) (ordinary pattern)))) (bou= nd (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:syn= tax-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 (? (unqu= ote (cadr p))) (unquote-splicing (cddr p)))) a k)) ((or (not (symbol? (cadr= p))) (memq (cadr p) a)) (let ((g (gensym))) (set! pred-bodies (cons (quasi= quote ((unquote g) (unquote (cadr p)))) pred-bodies)) (k (quasiquote (? (un= quote g))) a))) (else (k p a)))) ((and (pair? p) (eq? (quote =3D) (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= =2Dbodies)) (bound (quasiquote (=3D (unquote g) (unquote (caddr p)))) a k))= ) (else (bound (caddr p) a (lambda (p2 a) (k (quasiquote (=3D (unquote (cad= r p)) (unquote p2))) a)))))) ((and (pair? p) (eq? (quote and) (car p))) (bo= und* (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 (fir= st-p first-a) (let or* ((plist (cddr p)) (k (lambda (plist) (k (quasiquote = (or (unquote first-p) (unquote-splicing plist))) first-a)))) (if (null? pli= st) (k plist) (bound (car plist) a (lambda (car-p car-a) (if (not (permutat= ion car-a first-a)) (match:syntax-err pattern "variables of or-pattern diff= er 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))) (bo= und (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)))))) ((an= d (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) (unquot= e (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 (cad= r 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 (cad= r 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= =2D>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) (m= atch:error plist)))))) (bound* (lambda (plist a k) (if (null? plist) (k pli= st 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 (e= q? b a) (quote ()) (cons (car b) (find-prefix (cdr b) a))))) (permutation (= lambda (p1 p2) (and (=3D (length p1) (length p2)) (match:andmap (lambda (x1= ) (memq x1 p2)) p1))))) (bound pattern (quote ()) (lambda (p a) (list p (re= verse a) pred-bodies)))))) (inline-let (lambda (let-exp) (letrec ((occ (lam= bda (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) (str= ing? 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*))))))) (sm= all? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (eq? (car sexp) (qu= ote 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 ((=3D 0 n) (loop (cdr b) new-b e)) ((or (= =3D 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>=3D e= ta) (if (null? plist) (erract x) (let* ((v (quote ())) (val (lambda (x) (cd= r (assq x v)))) (fail (lambda (sf) (gen x sf (cdr plist) erract length>=3D = eta))) (success (lambda (sf) (set-car! (cddddr (car plist)) #t) (let* ((cod= e (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-continua= tion (lambda ((unquote fail-sym)) (let (((unquote fail-sym) (lambda () ((un= quote fail-sym) (unquote (fail sf)))))) (unquote ap)))))) (quasiquote ((unq= uote 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 (quasiq= uote (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 q= uote) (car p))) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf k= s)) ((and (pair? p) (eq? (quote ?) (car p))) (let ((tst (quasiquote ((unquo= te (cadr p)) (unquote e))))) (emit tst sf kf ks))) ((and (pair? p) (eq? (qu= ote =3D) (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 o= r-v) (next (car p) e sf (lambda (sf) (loop (cdr p) sf)) ks)))))) ((and (pai= r? 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 (le= ngth fields)) (tst (quasiquote ((unquote (symbol-append tag (quote ?))) (un= quote e))))) (emit tst sf kf (let rloop ((n 1)) (lambda (sf) (if (=3D n rle= n) (ks sf) (next (list-ref fields n) (quasiquote ((unquote (symbol-append t= ag (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= =2Dk? (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 (n= ext (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 (ca= r 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-sp= licing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))= ) bound fresh)))))))) (set! v (append (map cons bound (map (lambda (x) (qua= siquote (reverse (unquote x)))) fresh)) v)) (quasiquote (let (unquote gloop= ) (((unquote ge) (unquote e)) (unquote-splicing (map (lambda (x) (quasiquot= e ((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>= =3D) (unquote k)) (unquote e))) sf kf ks))))))) ((pair? p) (emit (quasiquot= e (pair? (unquote e))) sf kf (lambda (sf) (next (car p) (add-a e) sf kf (la= mbda (sf) (next (cdr p) (add-d e) sf kf ks)))))) ((and (vector? p) (>=3D (v= ector-length p) 6) (dot-dot-k? (vector-ref p (- (vector-length p) 5)))) (le= t* ((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 (>=3D (vector-= length (unquote e)) (unquote minlen))) (kf sf) ((let vloop ((n 0)) (lambda = (sf) (cond ((not (=3D n vlen)) (next (vector-ref p n) (quasiquote (vector-r= ef (unquote e) (unquote n))) sf kf (vloop (+ 1 n)))) ((eq? (vector-ref p vl= en) (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 (ve= ctor-ref p vlen) (quasiquote (vector-ref (unquote e) (unquote ind))) sf kf = (lambda (sf) (quasiquote ((unquote gloop) (- (unquote ind) 1) (unquote-spli= cing (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)) (un= quote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fres= h))) (if (> (unquote minlen) (unquote ind)) (unquote (ks sf)) (unquote p1))= ))))))) sf)))))) ((vector? p) (let ((vlen (vector-length p))) (emit (quasiq= uote (vector? (unquote e))) sf kf (lambda (sf) (emit (quasiquote (equal? (v= ector-length (unquote e)) (unquote vlen))) sf kf (let vloop ((n 0)) (lambda= (sf) (if (=3D n vlen) (ks sf) (next (vector-ref p n) (quasiquote (vector-r= ef (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 (quas= iquote (not (unquote tst))) sf) (kf sf)) (else (let* ((e (cadr tst)) (impli= ed (cond ((eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((str= ing? p) (quasiquote ((string? (unquote e))))) ((boolean? p) (quasiquote ((b= oolean? (unquote e))))) ((char? p) (quasiquote ((char? (unquote e))))) ((nu= mber? 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-s= tructure? tst) (quasiquote ((vector? (unquote e))))) (else (quote ())))) (n= ot-imp (case (car tst) ((list?) (quasiquote ((not (null? (unquote e)))))) (= else (quote ())))) (s (ks (cons tst (append implied sf)))) (k (kf (cons (qu= asiquote (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 ts= t) (unquote-splicing (cdr (cadr s)))) (unquote (caddr s)) (unquote f))) (qu= asiquote (if (and (unquote tst) (unquote (cadr s))) (unquote (caddr s)) (un= quote f))))) ((and (pair? s) (equal? (car s) (quote call-with-current-conti= nuation)) (pair? (cdr s)) (pair? (cadr s)) (equal? (caadr s) (quote lambda)= ) (pair? (cdadr s)) (pair? (cadadr s)) (null? (cdr (cadadr s))) (pair? (cdd= adr s)) (pair? (car (cddadr s))) (equal? (caar (cddadr s)) (quote let)) (pa= ir? (cdar (cddadr s))) (pair? (cadar (cddadr s))) (pair? (caadar (cddadr s)= )) (pair? (cdr (caadar (cddadr s)))) (pair? (cadr (caadar (cddadr s)))) (eq= ual? (caadr (caadar (cddadr s))) (quote lambda)) (pair? (cdadr (caadar (cdd= adr s)))) (null? (cadadr (caadar (cddadr s)))) (pair? (cddadr (caadar (cdda= dr s)))) (pair? (car (cddadr (caadar (cddadr s))))) (pair? (cdar (cddadr (c= aadar (cddadr s))))) (null? (cddar (cddadr (caadar (cddadr s))))) (null? (c= dr (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 (caada= r (cddadr s)))))) (let ((k (car (cadadr s))) (fail (car (caadar (cddadr s))= )) (s2 (caddar (cddadr s)))) (quasiquote (call-with-current-continuation (l= ambda ((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)) (p= air? (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 (cd= aadr s))) (null? (cdadr s)) (pair? (cddr s)) (null? (cdddr s)) (equal? (cad= dar (cdaadr s)) f)) (let ((fail (caaadr s)) (s2 (caddr s))) (quasiquote (le= t (((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= =2Dd 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 (ca= r 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))) (c= ond (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 (c= ar x)))) (equal? x (quasiquote (not ((unquote const-class) (unquote (cadr s= rch)))))) (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 src= h)) (disjoint? x) (not (equal? (car x) (car srch)))) (mem (cdr l))))))) ((e= q? (car srch) (quote list?)) (let mem ((l l)) (if (null? l) #f (let ((x (ca= r 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? (ca= dr x) (cadr srch)) (or (disjoint? x) (vec-structure? x)) (not (equal? (car = x) (quote vector?))) (not (equal? (car x) (car srch)))) (equal? x (quasiquo= te (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 bool= ean?)) ((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 (c= ar tst) match:disjoint-predicates))) (vec-structure? (lambda (tst) (memq (c= ar 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 (unqu= ote a))))))) (c---rs (quote ((car caar . cdar) (cdr cadr . cddr) (caar caaa= r . cdaar) (cadr caadr . cdadr) (cdar cadar . cddar) (cddr caddr . cdddr) (= caaar caaaar . cdaaar) (caadr caaadr . cdaadr) (cadar caadar . cdadar) (cad= dr caaddr . cdaddr) (cdaar cadaar . cddaar) (cdadr cadadr . cddadr) (cddar = caddar . cdddar) (cdddr cadddr . cddddr)))) (setter (lambda (e p) (let ((mk= =2Dsetter (lambda (s) (symbol-append (quote set-) s (quote !))))) (cond ((n= ot (pair? e)) (match:syntax-err p "unnested set! pattern")) ((eq? (car e) (= quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (v= ector-set! x (unquote (caddr e)) y))))) ((eq? (car e) (quote unbox)) (quasi= quote (let ((x (unquote (cadr e)))) (lambda (y) (set-box! x y))))) ((eq? (c= ar e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (s= et-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---r= s))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) = (lambda (y) ((unquote (mk-setter (cddr a))) x y))))))) (else (quasiquote (l= et ((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)))) (la= mbda () (unbox x))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unqu= ote (cadr e)))) (lambda () (car x))))) ((eq? (car e) (quote cdr)) (quasiquo= te (let ((x (unquote (cadr e)))) (lambda () (cdr x))))) ((let ((a (assq (ca= r e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote= (cadr e))))) (lambda () ((unquote (cddr a)) x))))))) (else (quasiquote (le= t ((x (unquote (cadr e)))) (lambda () ((unquote (car e)) x)))))))) (get-c--= =2Drs (quote ((caar car . car) (cadr cdr . car) (cdar car . cdr) (cddr cdr = =2E cdr) (caaar caar . car) (caadr cadr . car) (cadar cdar . car) (caddr cd= dr . car) (cdaar caar . cdr) (cdadr cadr . cdr) (cddar cdar . cdr) (cdddr c= ddr . 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) (cda= dar 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) (s= ymbol->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) (i= f (null? (cdr l)) (quote ()) (cons (car l) (rdc (cdr l))))))) (list genmatc= h genletrec gendefine pattern-var?))) ! (defmacro match args (cond ((and (list? args) (<=3D 1 (length args)) (mat= ch:andmap (lambda (y) (and (list? y) (<=3D 2 (length y)))) (cdr args))) (le= t* ((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))) (u= nquote ((car match:expanders) e clauses (quasiquote (match (unquote-splicin= g args)))))))))) (else (match:syntax-err (quasiquote (match (unquote-splici= ng 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)) arg= s)) ((lambda () (let ((e (gensym))) (quasiquote (lambda ((unquote e)) (matc= h (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)) ar= gs)) ((lambda () (let ((e (gensym))) (quasiquote (lambda (unquote e) (match= (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (q= uasiquote (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 (lamb= da (pat exp body) (let ((g (map (lambda (x) (gensym)) pat)) (vpattern (list= =2D>vector pat))) (quasiquote (let (unquote (map list g exp)) (match (vecto= r (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 (g= ensym)) (g2 (gensym))) (quasiquote (let (((unquote g1) (unquote e1)) ((unqu= ote g2) (unquote e2))) (match (cons (unquote g1) (unquote g2)) (((unquote p= 1) 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 (((unq= uote name) (match-lambda* ((unquote pat) (unquote-splicing body))))) ((unqu= ote name) (unquote-splicing exp)))))) (car args) (reverse g228) (reverse g2= 29) (cddr args)) (g215)) (if (and (pair? (car g231)) (pair? (cdar g231)) (n= ull? (cddar g231))) (g230 (cdr g231) (cons (cadar g231) g229) (cons (caar g= 231) g228)) (g215)))) (g215)) (if (list? (car args)) (if (match:andmap (lam= bda (g236) (if (and (pair? g236) (g205 (car g236)) (pair? (cdr g236))) (nul= l? (cddr g236)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr ar= gs))) ((lambda () (quasiquote (let (unquote-splicing args))))) (let g218 ((= g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g21= 5) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g= 218 (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 ((g21= 9 (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))))) (i= f (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null= ? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (p= air? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdad= ar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 = (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cd= ar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (= cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quot= e ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pai= r? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if= (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (c= dr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let= g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g2= 19) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (r= everse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g= 219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons= (caar g219) g216)) (g215)))))) (if (pair? (car args)) (if (and (pair? (caa= r args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)= ) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaa= r args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (q= uote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar= g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (co= ns (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar= args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar arg= s))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (ca= daar 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 (c= dr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let = g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g21= 9) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (re= verse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g2= 19)) (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 (an= d (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g= 219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (g215))))= (g215)))) ! (defmacro match-let* args (let ((g245 (lambda () (match:syntax-err (quasi= quote (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 arg= s)) (null? (cddaar args)) (list? (cdar args)) (list? (cdr args)) (pair? (cd= r 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) (cada= ar 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 arg= s))) "syntax error in"))) (g263 (lambda (pat exp body) (quasiquote (match-l= etrec (((unquote (list->vector pat)) (vector (unquote-splicing exp)))) (unq= uote-splicing body))))) (g255 (lambda (pat exp body) ((cadr match:expanders= ) pat exp body (quasiquote (match-letrec (((unquote pat) (unquote exp))) (u= nquote-splicing body))))))) (if (pair? args) (if (list? (car args)) (if (ma= tch:andmap (lambda (g275) (if (and (pair? g275) (g269 (car g275)) (pair? (c= dr 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 (n= ull? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (c= ddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g2= 56)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (c= dadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (li= st? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caada= r 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 (c= adar 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? (cdda= r 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 g25= 9)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar= g259) g257) (cons (caar g259) g256)) (g264)))))) (if (pair? (car args)) (i= f (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 (q= uote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g= 259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cad= ar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar ar= gs)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args)))= (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g26= 8 (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? (cdda= r 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? (c= dr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args= )) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g2= 59))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g= 264))))) (g264))) (g264)))) ! (defmacro match-define args (let ((g279 (cadddr match:expanders)) (g278 (= lambda () (match:syntax-err (quasiquote (match-define (unquote-splicing arg= s))) "syntax error in")))) (if (pair? args) (if (g279 (car args)) (if (and = (pair? (cdr args)) (null? (cddr args))) ((lambda () (quasiquote (begin (def= ine (unquote-splicing args)))))) (g278)) (if (and (pair? (cdr args)) (null?= (cddr args))) ((lambda (pat exp) ((caddr match:expanders) pat exp (quasiqu= ote (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-stru= ctures v))) ! (define match:primitive-vector? vector?) ! (defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lamb= da () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (c= adr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-n= ame (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)) (i= f (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lam= bda (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)= =3D> (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ = 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiqu= ote (defstruct (unquote-splicing args))) "syntax error in")))) (if (and (pa= ir? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pa= ir? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g= 299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constr= uctor predicate fields) (let* ((selectors (map selector-name fields)) (muta= tors (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= =2Dvector?)) ((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-ve= ctor? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (no= t (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-structure= s (cons predicate match:vector-structures)))) (else (match:syntax-err (quot= e (vector disjoint)) "invalid value for match:structure-control, legal valu= es are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structure= s (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unqu= ote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote = selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (u= nquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (=3D (vector-l= ength obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unq= uote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasi= quote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) se= lectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (qu= asiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote= i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (revers= e 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 na= me) (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? (c= ar 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 m= k-id id1))) (unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) = (unquote v)))) id2 val)))))) (caar args) (cdar args) (reverse g306) (revers= e g307)) (g311)) (if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cd= dar g309))) (g308 (cdr g309) (cons (cadar g309) g307) (cons (caar g309) g30= 6)) (g311)))) (g311))) (g311)))) ! (defmacro define-const-structure args (let ((field? (lambda (id) (if (sym= bol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (= pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((l= ambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (ha= s-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) =3D> (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)) ((num= ber? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (matc= h: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-con= st-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cda= r args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quo= te ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) = (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (nul= l? 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 ra= w-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index= (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-appen= d name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i = (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (nu= ll? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor= ))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (nam= es1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map fie= ld-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote = names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (u= nquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing= (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quot= e _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-= name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unqu= ote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-n= ame field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (u= nquote (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)) (g3= 35)) (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) (co= ns (car g329) g327)) (g335)))) (g335))) (g335))))) =2D-- 1,222 ---- ! ;; 2010/05/20 - record matching for guile (Stefan Israelsson Tampe) ! ;; Modifying upstream version (match.upstream.scm) by Alex Shinn =20 (define-module (ice-9 match) ! #:use-module (srfi srfi-9) ! #:export (match-define match-let* match-let match-letrec match-lamb= da* ! match-lambda match)) !=20 ! (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) ...))) ! )) !=20 ! (define-syntax match-two ! (syntax-rules (_ ___ *** quote quasiquote ? $ =3D 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)) ! =20 ! ;; stis, added $ support! ! ((match-two v ($ n) g-s sk fk i) ! (if (n v) sk fk)) ! =20 ! ((match-two v ($ nn p ...) g+s sk fk i) ! (if (nn v) ! (match-$ (and) 0 (p ...) v sk fk i) ! fk)) ! =20 ! ;; stis, added the possibility to use set! and get to records =20 ! ((match-two v (=3D 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))) !=20 ! ((match-two v (=3D g s p) g+s sk fk i) ! (let ((w (g v))) (match-one w p ((g v) (s v)) sk fk i))) !=20 ! ((match-two v (=3D proc p) g+s . x) ! (let ((w (proc v))) '() (match-one w p . x))) ! =20 ! ((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)))) ! )) !=20 ! (define-syntax match-$ ! (lambda (x) ! (syntax-case x () ! ((q (a ...) m (p1 p2 ...) . v) ! (with-syntax ((m+1 (datum->syntax (syntax q)=20 ! (+ (syntax->datum (syntax m)) 1)))) ! (syntax (match-$ (a ... (=3D 0 m p1)) m+1 (p2 ...) . v)))) ! ((_ newpat m () v kt ke i) ! (syntax (match-one v newpat () kt ke i)))))) !=20 ! ;;We must be able to extract vars in the new constructs!! ! (define-syntax match-extract-vars ! (syntax-rules (_ ___ *** ? $ =3D 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 (=3D proc p) . x) ! (match-extract-vars p . x)) ! ((match-extract-vars (=3D 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)))) ! )) !=20 ! (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))) ! =20 ! `(begin ! ,@defs ! (let ,lets ! (match ,code (,arg (begin ,@sets))) ! ,@sets2)))) !=20 !=20 ! ;;;Reading the rest from upstream !=20 ! ;;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))))) !=20 ! (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)))))))) !=20 ! (syntax-case x () ! ((_ reject-list file) ! (with-syntax (((exp ...) (datum->syntax ! x=20 ! (read-filtered ! (syntax->datum #'reject-list) ! (syntax->datum #'file))))) ! #'(begin exp ...)))))) !=20 ! (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 --Boundary-00=_Eou+Legj22R2p3x--