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: Tue, 25 May 2010 23:10:14 +0200 Message-ID: <201005252310.14425.stefan.tampe@spray.se> References: <201005062239.32992.stefan.tampe@spray.se> <201005242305.08448.stefan.tampe@spray.se> <87632bswt6.fsf@gnu.org> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: Multipart/Mixed; boundary="Boundary-00=_2yD/L4kUS9SdKUQ" X-Trace: dough.gmane.org 1274844543 27877 80.91.229.12 (26 May 2010 03:29:03 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Wed, 26 May 2010 03:29:03 +0000 (UTC) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Wed May 26 05:29:00 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 1OH7HU-0000uY-L2 for guile-devel@m.gmane.org; Wed, 26 May 2010 05:28:57 +0200 Original-Received: from localhost ([127.0.0.1]:60260 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1OH7HR-0006P6-7j for guile-devel@m.gmane.org; Tue, 25 May 2010 23:27:41 -0400 Original-Received: from [140.186.70.92] (port=38387 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1OH6yx-0000Qy-6V for guile-devel@gnu.org; Tue, 25 May 2010 23:08:47 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.69) (envelope-from ) id 1OH20A-0001xs-V9 for guile-devel@gnu.org; Tue, 25 May 2010 17:49:36 -0400 Original-Received: from spsmtp02oc.mail2world.com ([74.202.142.198]:4071) by eggs.gnu.org with esmtp (Exim 4.69) (envelope-from ) id 1OH20A-0001ti-8b for guile-devel@gnu.org; Tue, 25 May 2010 17:49:30 -0400 Original-Received: from mail pickup service by spsmtp02oc.mail2world.com with Microsoft SMTPSVC; Tue, 25 May 2010 14:49:04 -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; Tue, 25 May 2010 14:48:58 -0700 User-Agent: KMail/1.12.4 (Linux/2.6.31.12-0.2-desktop; KDE/4.3.5; x86_64; ; ) In-Reply-To: <87632bswt6.fsf@gnu.org> X-OriginalArrivalTime: 25 May 2010 21:49:04.0921 (UTC) FILETIME=[1855D090:01CAFC54] 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:10368 Archived-At: --Boundary-00=_2yD/L4kUS9SdKUQ Content-Type: Text/Plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable On Tuesday 25 May 2010 07:41:57 pm Ludovic Court=C3=A8s wrote: > Hello, >=20 > This patch lacks match.upstream.scm and is not in unidiff format, which > makes it hard for me to read. >=20 > Can you generate the patch, e.g., with git, using =E2=80=9Cgit diff maste= r=E2=80=9D or > some such? >=20 > Thanks, > Ludo=E2=80=99. Yes I've never done this before :-). Anyway git diff --cached gives the attached patch file. Also I made the code less hacky by using define-syntax in stead of a defmacro and macroexpand for the defin-syntax sugar (oh hacker).=20 It was a litle more work then I expected. /Stefan --Boundary-00=_2yD/L4kUS9SdKUQ Content-Type: text/x-patch; charset="UTF-8"; name="ice-9-match.patch" Content-Transfer-Encoding: quoted-printable Content-Disposition: attachment; filename="ice-9-match.patch" diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm index d758923..1a2a61e 100644 =2D-- a/module/ice-9/match.scm +++ b/module/ice-9/match.scm @@ -1,199 +1,245 @@ =2D;;; installed-scm-file =2D =2D;;;; Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc. =2D;;;; =2D;;;; This library is free software; you can redistribute it and/or =2D;;;; modify it under the terms of the GNU Lesser General Public =2D;;;; License as published by the Free Software Foundation; either =2D;;;; version 3 of the License, or (at your option) any later version. =2D;;;;=20 =2D;;;; This library is distributed in the hope that it will be useful, =2D;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of =2D;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU =2D;;;; Lesser General Public License for more details. =2D;;;;=20 =2D;;;; You should have received a copy of the GNU Lesser General Public =2D;;;; License along with this library; if not, write to the Free Software =2D;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110= =2D1301 USA =2D;;;; +;; 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) =2D :use-module (ice-9 pretty-print) =2D :export (match match-lambda match-lambda* match-define =2D match-let match-let* match-letrec =2D define-structure define-const-structure =2D match:andmap =2D match:error match:set-error =2D match:error-control match:set-error-control =2D match:structure-control match:set-structure-control =2D match:runtime-structures match:set-runtime-structures)) =2D =2D;; The original code can be found at the Scheme Repository =2D;; =2D;; http://www.cs.indiana.edu/scheme-repository/code.match.html =2D;; =2D;; or Andrew K. Wright's web page: =2D;; =2D;; http://www.star-lab.com/wright/code.html =2D =2D=0C =2D;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; =2D;; Pattern Matching Syntactic Extensions for Scheme =2D;; =2D(define match:version "Version 1.19, Sep 15, 1995") =2D;; =2D;; Written by Andrew K. Wright, 1993 (wright@research.nj.nec.com). =2D;; Adapted from code originally written by Bruce F. Duba, 1991. =2D;; This package also includes a modified version of Kent Dybvig's =2D;; define-structure (see Dybvig, R.K., The Scheme Programming Language, =2D;; Prentice-Hall, NJ, 1987). =2D;; =2D;; This macro package extends Scheme with several new expression forms. =2D;; Following is a brief summary of the new forms. See the associated =2D;; LaTeX documentation for a full description of their functionality. =2D;; =2D;; =2D;; match expressions: =2D;; =2D;; exp ::=3D ... =2D;; | (match exp clause ...) =2D;; | (match-lambda clause ...) =2D;; | (match-lambda* clause ...) =2D;; | (match-let ((pat exp) ...) body) =2D;; | (match-let* ((pat exp) ...) body) =2D;; | (match-letrec ((pat exp) ...) body) =2D;; | (match-define pat exp) =2D;; =2D;; clause ::=3D (pat body) | (pat =3D> exp) =2D;; =2D;; patterns: matches: =2D;; =2D;; pat ::=3D identifier anything, and binds identif= ier =2D;; | _ anything =2D;; | () the empty list =2D;; | #t #t =2D;; | #f #f =2D;; | string a string =2D;; | number a number =2D;; | character a character =2D;; | 'sexp an s-expression =2D;; | 'symbol a symbol (special case of s-e= xpr) =2D;; | (pat_1 ... pat_n) list of n elements =2D;; | (pat_1 ... pat_n . pat_{n+1}) list of n or more =2D;; | (pat_1 ... pat_n pat_n+1 ooo) list of n or more, each eleme= nt =2D;; of remainder must match pat= _n+1 =2D;; | #(pat_1 ... pat_n) vector of n elements =2D;; | #(pat_1 ... pat_n pat_n+1 ooo) vector of n or more, each ele= ment =2D;; of remainder must match pat= _n+1 =2D;; | #&pat box =2D;; | ($ struct-name pat_1 ... pat_n) a structure =2D;; | (=3D field pat) a field of a structure =2D;; | (and pat_1 ... pat_n) if all of pat_1 thru pat_n ma= tch =2D;; | (or pat_1 ... pat_n) if any of pat_1 thru pat_n ma= tch =2D;; | (not pat_1 ... pat_n) if all pat_1 thru pat_n don't= match =2D;; | (? predicate pat_1 ... pat_n) if predicate true and all of =2D;; pat_1 thru pat_n match =2D;; | (set! identifier) anything, and binds setter =2D;; | (get! identifier) anything, and binds getter =2D;; | `qp a quasi-pattern =2D;; =2D;; ooo ::=3D ... zero or more =2D;; | ___ zero or more =2D;; | ..k k or more =2D;; | __k k or more =2D;; =2D;; quasi-patterns: matches: =2D;; =2D;; qp ::=3D () the empty list =2D;; | #t #t =2D;; | #f #f =2D;; | string a string =2D;; | number a number =2D;; | character a character =2D;; | identifier a symbol =2D;; | (qp_1 ... qp_n) list of n elements =2D;; | (qp_1 ... qp_n . qp_{n+1}) list of n or more =2D;; | (qp_1 ... qp_n qp_n+1 ooo) list of n or more, each eleme= nt =2D;; of remainder must match qp_= n+1 =2D;; | #(qp_1 ... qp_n) vector of n elements =2D;; | #(qp_1 ... qp_n qp_n+1 ooo) vector of n or more, each ele= ment =2D;; of remainder must match qp_= n+1 =2D;; | #&qp box =2D;; | ,pat a pattern =2D;; | ,@pat a pattern =2D;; =2D;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $, =2D;; and, or, not, set!, get!, ..., ___) cannot be used as pattern variabl= es. =2D;; =2D;; =2D;; structure expressions: =2D;; =2D;; exp ::=3D ... =2D;; | (define-structure (id_0 id_1 ... id_n)) =2D;; | (define-structure (id_0 id_1 ... id_n) =2D;; ((id_{n+1} exp_1) ... (id_{n+m} exp_m))) =2D;; | (define-const-structure (id_0 arg_1 ... arg_n)) =2D;; | (define-const-structure (id_0 arg_1 ... arg_n) =2D;; ((arg_{n+1} exp_1) ... (arg_{n+m} exp= _m))) =2D;; =2D;; arg ::=3D id | (! id) | (@ id) =2D;; =2D;; =2D;; match:error-control controls what code is generated for failed matche= s. =2D;; Possible values: =2D;; 'unspecified - do nothing, ie., evaluate (cond [#f #f]) =2D;; 'fail - call match:error, or die at car or cdr =2D;; 'error - call match:error with the unmatched value =2D;; 'match - call match:error with the unmatched value _and_ =2D;; the quoted match expression =2D;; match:error-control is set by calling match:set-error-control with =2D;; the new value. =2D;; =2D;; match:error is called for a failed match. =2D;; match:error is set by calling match:set-error with the new value. =2D;; =2D;; match:structure-control controls the uniqueness of structures =2D;; (does not exist for Scheme 48 version). =2D;; Possible values: =2D;; 'vector - (default) structures are vectors with a symbol in position= 0 =2D;; 'disjoint - structures are fully disjoint from all other values =2D;; match:structure-control is set by calling match:set-structure-control =2D;; with the new value. =2D;; =2D;; match:runtime-structures controls whether local structure declarations =2D;; generate new structures each time they are reached =2D;; (does not exist for Scheme 48 version). =2D;; Possible values: =2D;; #t - (default) each runtime occurrence generates a new structure =2D;; #f - each lexical occurrence generates a new structure =2D;; =2D;; End of user visible/modifiable stuff. =2D;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; =2D =2D(define match:error (lambda (val . args) (for-each pretty-print args) (e= rror "no matching clause for " val))) =2D(define match:andmap (lambda (f l) (if (null? l) (and) (and (f (car l)) = (match:andmap f (cdr l)))))) =2D(define match:syntax-err (lambda (obj msg) (error msg obj))) =2D(define match:disjoint-structure-tags (quote ())) =2D(define match:make-structure-tag (lambda (name) (if (or (eq? match:struc= ture-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) ">")))= )) =2D(define match:structure? (lambda (tag) (memq tag match:disjoint-structur= e-tags))) =2D(define match:structure-control (quote vector)) =2D(define match:set-structure-control (lambda (v) (set! match:structure-co= ntrol v))) =2D(define match:set-error (lambda (v) (set! match:error v))) =2D(define match:error-control (quote error)) =2D(define match:set-error-control (lambda (v) (set! match:error-control v)= )) =2D(define match:disjoint-predicates (cons (quote null) (quote (pair? symbo= l? boolean? number? string? char? procedure? vector?)))) =2D(define match:vector-structures (quote ())) =2D(define match:expanders (letrec ((genmatch (lambda (x clauses match-expr= ) (let* ((length>=3D (gensym)) (eb-errf (error-maker match-expr)) (blist (c= ar eb-errf)) (plist (map (lambda (c) (let* ((x (bound (validate-pattern (ca= r c)))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (fai= l (and (pair? (cdr c)) (pair? (cadr c)) (eq? (caadr c) (quote =3D>)) (symbo= l? (cadadr c)) (pair? (cdadr c)) (null? (cddadr c)) (pair? (cddr c)) (cadad= r c))) (bv2 (if fail (cons fail bv) bv)) (body (if fail (cddr c) (cdr c))))= (set! blist (cons (quasiquote ((unquote code) (lambda (unquote bv2) (unquo= te-splicing body)))) (append bindings blist))) (list p code bv (and fail (g= ensym)) #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?))) =2D(defmacro match args (cond ((and (list? args) (<=3D 1 (length args)) (ma= tch:andmap (lambda (y) (and (list? y) (<=3D 2 (length y)))) (cdr args))) (l= et* ((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-splici= ng args)))))))))) (else (match:syntax-err (quasiquote (match (unquote-splic= ing args))) "syntax error in")))) =2D(defmacro match-lambda args (if (and (list? args) (match:andmap (lambda = (g195) (if (and (pair? g195) (list? (cdr g195))) (pair? (cdr g195)) #f)) ar= gs)) ((lambda () (let ((e (gensym))) (quasiquote (lambda ((unquote e)) (mat= ch (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err = (quasiquote (match-lambda (unquote-splicing args))) "syntax error in"))))) =2D(defmacro match-lambda* args (if (and (list? args) (match:andmap (lambda= (g203) (if (and (pair? g203) (list? (cdr g203))) (pair? (cdr g203)) #f)) a= rgs)) ((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"))))) =2D(defmacro match-let args (let ((g227 (lambda (pat exp body) (quasiquote = (match (unquote exp) ((unquote pat) (unquote-splicing body)))))) (g223 (lam= bda (pat exp body) (let ((g (map (lambda (x) (gensym)) pat)) (vpattern (lis= t->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 (ge= nsym)) (g2 (gensym))) (quasiquote (let (((unquote g1) (unquote e1)) ((unquo= te 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)) (l= ist? (cadr args))) (let g230 ((g231 (cadr args)) (g229 (quote ())) (g228 (q= uote ()))) (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 (((unqu= ote name) (match-lambda* ((unquote pat) (unquote-splicing body))))) ((unquo= te name) (unquote-splicing exp)))))) (car args) (reverse g228) (reverse g22= 9) (cddr args)) (g215)) (if (and (pair? (car g231)) (pair? (cdar g231)) (nu= ll? (cddar g231))) (g230 (cdr g231) (cons (cadar g231) g229) (cons (caar g2= 31) g228)) (g215)))) (g215)) (if (list? (car args)) (if (match:andmap (lamb= da (g236) (if (and (pair? g236) (g205 (car g236)) (pair? (cdr g236))) (null= ? (cddr g236)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr arg= s))) ((lambda () (quasiquote (let (unquote-splicing args))))) (let g218 ((g= 219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215= ) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g2= 18 (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)) (pa= ir? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdada= r args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (= quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cda= r g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (c= ons (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 (cd= r 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)))))) (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 (qu= ote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar = g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (con= s (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) (cad= aar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (c= ar args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if = (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cd= r g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g= 218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219= ) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (rev= erse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g21= 9)) (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? (c= dr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and= (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g2= 19) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (g215)))) = (g215)))) =2D(defmacro match-let* args (let ((g245 (lambda () (match:syntax-err (quas= iquote (match-let* (unquote-splicing args))) "syntax error in")))) (if (pai= r? args) (if (null? (car args)) (if (and (list? (cdr args)) (pair? (cdr arg= s))) ((lambda (body) (quasiquote (let* (unquote-splicing args)))) (cdr args= )) (g245)) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar ar= gs)) (null? (cddaar args)) (list? (cdar args)) (list? (cdr args)) (pair? (c= dr 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) (cad= aar args) (cdar args) (cdr args)) (g245))) (g245)))) =2D(defmacro match-letrec args (let ((g269 (cadddr match:expanders)) (g268 = (lambda (p1 e1 p2 e2 body) (quasiquote (match-letrec ((((unquote p1) unquot= e p2) (cons (unquote e1) (unquote e2)))) (unquote-splicing body))))) (g264 = (lambda () (match:syntax-err (quasiquote (match-letrec (unquote-splicing ar= gs))) "syntax error in"))) (g263 (lambda (pat exp body) (quasiquote (match-= letrec (((unquote (list->vector pat)) (vector (unquote-splicing exp)))) (un= quote-splicing body))))) (g255 (lambda (pat exp body) ((cadr match:expander= s) pat exp body (quasiquote (match-letrec (((unquote pat) (unquote exp))) (= unquote-splicing body))))))) (if (pair? args) (if (list? (car args)) (if (m= atch: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 arg= s))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (i= f (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 arg= s)) (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) g= 256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (= cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (l= ist? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caad= ar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257= (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (ca= r 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 (lis= t? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr= args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cdd= ar 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))) (g26= 3 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g2= 59)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cada= r 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 (ca= dar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar a= rgs)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))= ) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g2= 68 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args))= (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (nul= l? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cdd= ar 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)))))) (let g258 ((g259 (car arg= s)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (= cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr arg= s)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g= 259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (= g264))))) (g264))) (g264)))) =2D(defmacro match-define args (let ((g279 (cadddr match:expanders)) (g278 = (lambda () (match:syntax-err (quasiquote (match-define (unquote-splicing ar= gs))) "syntax error in")))) (if (pair? args) (if (g279 (car args)) (if (and= (pair? (cdr args)) (null? (cddr args))) ((lambda () (quasiquote (begin (de= fine (unquote-splicing args)))))) (g278)) (if (and (pair? (cdr args)) (null= ? (cddr args))) ((lambda (pat exp) ((caddr match:expanders) pat exp (quasiq= uote (match-define (unquote-splicing args))))) (car args) (cadr args)) (g27= 8))) (g278)))) =2D(define match:runtime-structures #f) =2D(define match:set-runtime-structures (lambda (v) (set! match:runtime-str= uctures v))) =2D(define match:primitive-vector? vector?) =2D(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lam= bda () #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)) (matc= h:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (= if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((la= mbda (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 (quasiq= uote (defstruct (unquote-splicing args))) "syntax error in")))) (if (and (p= air? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (p= air? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((= g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name const= ructor predicate fields) (let* ((selectors (map selector-name fields)) (mut= ators (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:primitiv= e-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?)))= )) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? m= atch:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vec= tor? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not= (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:d= isjoint-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 value= s are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures= (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquo= te name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote s= electors) (vector (unquote tag) (unquote-splicing selectors)))) (define (un= quote predicate) (lambda (obj) (and ((unquote vectorP) obj) (=3D (vector-le= ngth obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unqu= ote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiq= uote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) sel= ectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (qua= siquote (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)) (g= 296)))) (g296))))) =2D(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 n= ame) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair?= (cdr args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quot= e ())) (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) (rever= se g307)) (g311)) (if (and (pair? (car g309)) (pair? (cdar g309)) (null? (c= ddar g309))) (g308 (cdr g309) (cons (cadar g309) g307) (cons (caar g309) g3= 06)) (g311)))) (g311))) (g311)))) =2D(defmacro define-const-structure args (let ((field? (lambda (id) (if (sy= mbol? 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)))) (h= as-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)) ((nu= mber? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (mat= ch:syntax-err (quasiquote (define-const-structure (unquote-splicing args)))= "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cda= r args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-co= nst-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cd= ar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (qu= ote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args)))= (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (nu= ll? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id= 2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)= ) (constructor (symbol-append (quote make-) name)) (predicate (symbol-appen= d name (quote ?)))) (quasiquote (begin (defstruct (unquote name) (unquote r= aw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-inde= x (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-appe= nd name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i= (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (n= ull? id2) (quasiquote (define (unquote constructor) (unquote raw-constructo= r))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (na= mes1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map fi= eld-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-splicin= g (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quo= te _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field= =2Dname field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (u= nquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (fiel= d-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define= (unquote (symbol-append (quote set-) name (quote -) (field-name field) (qu= ote !))) (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 (ca= ar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) = (cons (car g329) g327)) (g335)))) (g335))) (g335))))) + #:use-module (srfi srfi-9) + #:export (match-define match-let* match-let match-letrec match-lambd= a* + 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 ? $ =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))) + + ((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))) + + ((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)))) + )) + +(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)))))) + +;;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)))) + )) + + + +(define-syntax match-define + (syntax-rules () + ((q arg code) + (match-extract-vars arg (sieve (match-define-helper0 arg code) ()) ()= ())))) + +(define-syntax sieve + (syntax-rules () + ((_ cc (w ...) ((v q) v2 ...)) + (sieve cc (v w ...) (v2 ...))) + ((_ cc (w ...) (v v2 ...)) + (sieve cc (v w ...) (v2 ...))) + ((_ (cc ...) w ()) + (cc ... w)))) + =20 +(define-syntax match-define-helper0 + (lambda (x) + (syntax-case x () + ((q arg code v) + (with-syntax ((vtemp (map (lambda (x) + (datum->syntax + (syntax q) (gensym "temp"))) + (syntax->datum (syntax v))))) + (syntax (match-define-helper v vtemp arg code))))))) + +(define-syntax match-define-helper + (syntax-rules () + ((_ (v ...) (vt ...) arg code)=20 + (begin=20 + (begin (define v 0)=20 + ...) + (let ((vt 0) ...) + (match code=20 + (arg (begin (set! vt v)=20 + ...))) + (begin (set! v vt)=20 + ...)))))) + + +;;;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=20 + (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 diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.= scm new file mode 100644 index 0000000..963b89f =2D-- /dev/null +++ b/module/ice-9/match.upstream.scm @@ -0,0 +1,670 @@ +;;;; match.scm -- portable hygienic pattern matcher +;; +;; This code is written by Alex Shinn and placed in the +;; Public Domain. All warranties are disclaimed. + +;; This is a full superset of the popular MATCH package by Andrew +;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks +;; in R6RS SYNTAX-RULES), and thus preserving hygiene. + +;; This is a simple generative pattern matcher - each pattern is +;; expanded into the required tests, calling a failure continuation if +;; the tests fail. This makes the logic easy to follow and extend, +;; but produces sub-optimal code in cases where you have many similar +;; clauses due to repeating the same tests. Nonetheless a smart +;; compiler should be able to remove the redundant tests. For +;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance +;; hit. + +;; The original version was written on 2006/11/29 and described in the +;; following Usenet post: +;; http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd +;; and is still available at +;; http://synthcode.com/scheme/match-simple.scm +;; It's just 80 lines for the core MATCH, and an extra 40 lines for +;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar. +;; +;; A variant of this file which uses COND-EXPAND in a few places for +;; performance can be found at +;; http://synthcode.com/scheme/match-cond-expand.scm +;; +;; 2009/11/25 - adding `***' tree search patterns +;; 2008/03/20 - fixing bug where (a ...) matched non-lists +;; 2008/03/15 - removing redundant check in vector patterns +;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell) +;; 2007/09/04 - fixing quasiquote patterns +;; 2007/07/21 - allowing ellipse patterns in non-final list positions +;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse +;; (thanks to Taylor Campbell) +;; 2007/04/08 - clean up, commenting +;; 2006/12/24 - bugfixes +;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set! + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; force compile-time syntax errors with useful messages + +(define-syntax match-syntax-error + (syntax-rules () + ((_) (match-syntax-error "invalid match-syntax-error usage")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; The basic interface. MATCH just performs some basic syntax +;; validation, binds the match expression to a temporary variable `v', +;; and passes it on to MATCH-NEXT. It's a constant throughout the +;; code below that the binding `v' is a direct variable reference, not +;; an expression. + +(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) ...) + (match-next atom (atom (set! atom)) (pat . body) ...)) + )) + +;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure +;; thunk, which is expanded by recursing MATCH-NEXT on the remaining +;; clauses. `g+s' is a list of two elements, the get! and set! +;; expressions respectively. + +(define-syntax match-next + (syntax-rules (=3D>) + ;; no more clauses, the match failed + ((match-next v g+s) + (error 'match "no matching pattern")) + ;; named failure continuation + ((match-next v g+s (pat (=3D> failure) . body) . rest) + (let ((failure (lambda () (match-next v g+s . rest)))) + ;; match-one analyzes the pattern for us + (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ()))) + ;; anonymous failure continuation, give it a dummy name + ((match-next v g+s (pat . body) . rest) + (match-next v g+s (pat (=3D> failure) . body) . rest)))) + +;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to +;; MATCH-TWO. + +(define-syntax match-one + (syntax-rules () + ;; If it's a list of two or more values, check to see if the + ;; second one is an ellipse and handle accordingly, otherwise go + ;; to MATCH-TWO. + ((match-one v (p q . r) g+s sk fk i) + (match-check-ellipse + q + (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()) + (match-two v (p q . r) g+s sk fk i))) + ;; Go directly to MATCH-TWO. + ((match-one . x) + (match-two . x)))) + +;; This is the guts of the pattern matcher. We are passed a lot of +;; information in the form: +;; +;; (match-two var pattern getter setter success-k fail-k (ids ...)) +;; +;; usually abbreviated +;; +;; (match-two v p g+s sk fk i) +;; +;; where VAR is the symbol name of the current variable we are +;; matching, PATTERN is the current pattern, getter and setter are the +;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding +;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure +;; continuation (which is just a thunk call and is thus safe to expand +;; multiple times) and IDS are the list of identifiers bound in the +;; pattern so far. + +(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)) + ((match-two v (=3D proc p) . 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)))) + )) + +;; QUASIQUOTE patterns + +(define-syntax match-quasiquote + (syntax-rules (unquote unquote-splicing quasiquote) + ((_ v (unquote p) g+s sk fk i) + (match-one v p g+s sk fk i)) + ((_ v ((unquote-splicing p) . rest) g+s sk fk i) + (if (pair? v) + (match-one v + (p . tmp) + (match-quasiquote tmp rest g+s sk fk) + fk + i) + fk)) + ((_ v (quasiquote p) g+s sk fk i . depth) + (match-quasiquote v p g+s sk fk i #f . depth)) + ((_ v (unquote p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (unquote-splicing p) g+s sk fk i x . depth) + (match-quasiquote v p g+s sk fk i . depth)) + ((_ v (p . q) g+s sk fk i . depth) + (if (pair? v) + (let ((w (car v)) (x (cdr v))) + (match-quasiquote + w p g+s + (match-quasiquote-step x q g+s sk fk depth) + fk i . depth)) + fk)) + ((_ v #(elt ...) g+s sk fk i . depth) + (if (vector? v) + (let ((ls (vector->list v))) + (match-quasiquote ls (elt ...) g+s sk fk i . depth)) + fk)) + ((_ v x g+s sk fk i . depth) + (match-one v 'x g+s sk fk i)))) + +(define-syntax match-quasiquote-step + (syntax-rules () + ((match-quasiquote-step x q g+s sk fk depth i) + (match-quasiquote x q g+s sk fk i . depth)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utilities + +;; Takes two values and just expands into the first. +(define-syntax match-drop-ids + (syntax-rules () + ((_ expr ids ...) expr))) + +(define-syntax match-drop-first-arg + (syntax-rules () + ((_ arg expr) expr))) + +;; To expand an OR group we try each clause in succession, passing the +;; first that succeeds to the success continuation. On failure for +;; any clause, we just try the next clause, finally resorting to the +;; failure continuation fk if all clauses fail. The only trick is +;; that we want to unify the identifiers, so that the success +;; continuation can refer to a variable from any of the OR clauses. + +(define-syntax match-gen-or + (syntax-rules () + ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...)) + (let ((sk2 (lambda (id ...) (sk ... (i ... id ...))))) + (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...)= ))))) + +(define-syntax match-gen-or-step + (syntax-rules () + ((_ v () g+s sk fk . x) + ;; no OR clauses, call the failure continuation + fk) + ((_ v (p) . x) + ;; last (or only) OR clause, just expand normally + (match-one v p . x)) + ((_ v (p . q) g+s sk fk i) + ;; match one and try the remaining on failure + (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i)) + )) + +;; We match a pattern (p ...) by matching the pattern p in a loop on +;; each element of the variable, accumulating the bound ids into lists. + +;; Look at the body of the simple case - it's just a named let loop, +;; matching each element in turn to the same pattern. The only trick +;; is that we want to keep track of the lists of each extracted id, so +;; when the loop recurses we cons the ids onto their respective list +;; variables, and on success we bind the ids (what the user input and +;; expects to see in the success body) to the reversed accumulated +;; list IDs. + +(define-syntax match-gen-ellipses + (syntax-rules () + ((_ v p () g+s (sk ...) fk i ((id id-ls) ...)) + (match-check-identifier p + ;; simplest case equivalent to (p ...), just bind the list + (let ((p v)) + (if (list? p) + (sk ... i) + fk)) + ;; simple case, match all elements of the list + (let loop ((ls v) (id-ls '()) ...) + (cond + ((null? ls) + (let ((id (reverse id-ls)) ...) (sk ... i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids (loop (cdr ls) (cons id id-ls) ..= =2E)) + fk i))) + (else + fk))))) + ((_ v p r g+s (sk ...) fk i ((id id-ls) ...)) + ;; general case, trailing patterns to match, keep track of the + ;; remaining list length so we don't need any backtracking + (match-verify-no-ellipses + r + (let* ((tail-len (length 'r)) + (ls v) + (len (length ls))) + (if (< len tail-len) + fk + (let loop ((ls ls) (n len) (id-ls '()) ...) + (cond + ((=3D n tail-len) + (let ((id (reverse id-ls)) ...) + (match-one ls r (#f #f) (sk ... i) fk i))) + ((pair? ls) + (let ((w (car ls))) + (match-one w p ((car ls) (set-car! ls)) + (match-drop-ids + (loop (cdr ls) (- n 1) (cons id id-ls) ...)) + fk + i))) + (else + fk))))))))) + +;; This is just a safety check. Although unlike syntax-rules we allow +;; trailing patterns after an ellipses, we explicitly disable multiple +;; ellipses at the same level. This is because in the general case +;; such patterns are exponential in the number of ellipses, and we +;; don't want to make it easy to construct very expensive operations +;; with simple looking patterns. For example, it would be O(n^2) for +;; patterns like (a ... b ...) because we must consider every trailing +;; element for every possible break for the leading "a ...". + +(define-syntax match-verify-no-ellipses + (syntax-rules () + ((_ (x . y) sk) + (match-check-ellipse + x + (match-syntax-error + "multiple ellipse patterns not allowed at same level") + (match-verify-no-ellipses y sk))) + ((_ () sk) + sk) + ((_ x sk) + (match-syntax-error "dotted tail not allowed after ellipse" x)))) + +;; Matching a tree search pattern is only slightly more complicated. +;; Here we allow patterns of the form +;; +;; (x *** y) +;; +;; to represent the pattern y located somewhere in a tree where the +;; path from the current object to y can be seen as a list of the form +;; (X ...). Y can immediately match the current object in which case +;; the path is the empty list. In a sense it's a 2-dimensional +;; version of the ... pattern. +;; +;; As a common case the pattern (_ *** y) can be used to search for Y +;; anywhere in a tree, regardless of the path used. +;; +;; To implement the search, we use two recursive procedures. TRY +;; attempts to match Y once, and on success it calls the normal SK on +;; the accumulated list ids as in MATCH-GEN-ELLIPSES. On failure, we +;; call NEXT which first checks if the current value is a list +;; beginning with X, then calls TRY on each remaining element of the +;; list. Since TRY will recursively call NEXT again on failure, this +;; effects a full depth-first search. +;; +;; The failure continuation throughout is a jump to the next step in +;; the tree search, initialized with the original failure continuation +;; FK. + +(define-syntax match-gen-search + (syntax-rules () + ((match-gen-search v p q g+s sk fk i ((id id-ls) ...)) + (letrec ((try (lambda (w fail id-ls ...) + (match-one w q g+s + (match-drop-ids + (let ((id (reverse id-ls)) ...) + sk)) + (next w fail id-ls ...) i))) + (next (lambda (w fail id-ls ...) + (if (not (pair? w)) + (fail) + (let ((u (car w))) + (match-one + u p ((car w) (set-car! w)) + (match-drop-ids + ;; accumulate the head variables from + ;; the p pattern, and loop over the tail + (let ((id-ls (cons id id-ls)) ...) + (let lp ((ls (cdr w))) + (if (pair? ls) + (try (car ls) + (lambda () (lp (cdr ls))) + id-ls ...) + (fail))))) + (fail) i)))))) + ;; the initial id-ls binding here is a dummy to get the right + ;; number of '()s + (let ((id-ls '()) ...) + (try v (lambda () fk) id-ls ...)))))) + +;; Vector patterns are just more of the same, with the slight +;; exception that we pass around the current vector index being +;; matched. + +(define-syntax match-vector + (syntax-rules (___) + ((_ v n pats (p q) . x) + (match-check-ellipse q + (match-gen-vector-ellipses v n pats p . x) + (match-vector-two v n pats (p q) . x))) + ((_ v n pats (p ___) sk fk i) + (match-gen-vector-ellipses v n pats p sk fk i)) + ((_ . x) + (match-vector-two . x)))) + +;; Check the exact vector length, then check each element in turn. + +(define-syntax match-vector-two + (syntax-rules () + ((_ v n ((pat index) ...) () sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (=3D len n) + (match-vector-step v ((pat index) ...) sk fk i) + fk)) + fk)) + ((_ v n (pats ...) (p . q) . x) + (match-vector v (+ n 1) (pats ... (p n)) q . x)))) + +(define-syntax match-vector-step + (syntax-rules () + ((_ v () (sk ...) fk i) (sk ... i)) + ((_ v ((pat index) . rest) sk fk i) + (let ((w (vector-ref v index))) + (match-one w pat ((vector-ref v index) (vector-set! v index)) + (match-vector-step v rest sk fk) + fk i))))) + +;; With a vector ellipse pattern we first check to see if the vector +;; length is at least the required length. + +(define-syntax match-gen-vector-ellipses + (syntax-rules () + ((_ v n ((pat index) ...) p sk fk i) + (if (vector? v) + (let ((len (vector-length v))) + (if (>=3D len n) + (match-vector-step v ((pat index) ...) + (match-vector-tail v p n len sk fk) + fk i) + fk)) + fk)))) + +(define-syntax match-vector-tail + (syntax-rules () + ((_ v p n len sk fk i) + (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ())= ))) + +(define-syntax match-vector-tail-two + (syntax-rules () + ((_ v p n len (sk ...) fk i ((id id-ls) ...)) + (let loop ((j n) (id-ls '()) ...) + (if (>=3D j len) + (let ((id (reverse id-ls)) ...) (sk ... i)) + (let ((w (vector-ref v j))) + (match-one w p ((vector-ref v j) (vetor-set! v j)) + (match-drop-ids (loop (+ j 1) (cons id id-ls) ...)) + fk i))))))) + +;; Extract all identifiers in a pattern. A little more complicated +;; than just looking for symbols, we need to ignore special keywords +;; and non-pattern forms (such as the predicate expression in ? +;; patterns), and also ignore previously bound identifiers. +;; +;; Calls the continuation with all new vars as a list of the form +;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely +;; pair with the original variable (e.g. it's used in the ellipse +;; generation for list variables). +;; +;; (match-extract-vars pattern continuation (ids ...) (new-vars ...)) + +(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 (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)))) + )) + +;; Stepper used in the above so it can expand the CAR and CDR +;; separately. + +(define-syntax match-extract-vars-step + (syntax-rules () + ((_ p k i v ((v2 v2-ls) ...)) + (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v))) + )) + +(define-syntax match-extract-quasiquote-vars + (syntax-rules (quasiquote unquote unquote-splicing) + ((match-extract-quasiquote-vars (quasiquote x) k i v d) + (match-extract-quasiquote-vars x k i v (#t . d))) + ((match-extract-quasiquote-vars (unquote-splicing x) k i v d) + (match-extract-quasiquote-vars (unquote x) k i v d)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t)) + (match-extract-vars x k i v)) + ((match-extract-quasiquote-vars (unquote x) k i v (#t . d)) + (match-extract-quasiquote-vars x k i v d)) + ((match-extract-quasiquote-vars (x . y) k i v (#t . d)) + (match-extract-quasiquote-vars + x + (match-extract-quasiquote-vars-step y k i v d) i ())) + ((match-extract-quasiquote-vars #(x ...) k i v (#t . d)) + (match-extract-quasiquote-vars (x ...) k i v d)) + ((match-extract-quasiquote-vars x (k ...) i v (#t . d)) + (k ... v)) + )) + +(define-syntax match-extract-quasiquote-vars-step + (syntax-rules () + ((_ x k i v d ((v2 v2-ls) ...)) + (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) = d)) + )) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Gimme some sugar baby. + +(define-syntax match-lambda + (syntax-rules () + ((_ clause ...) (lambda (expr) (match expr clause ...))))) + +(define-syntax match-lambda* + (syntax-rules () + ((_ clause ...) (lambda expr (match expr clause ...))))) + +(define-syntax match-let + (syntax-rules () + ((_ (vars ...) . body) + (match-let/helper let () () (vars ...) . body)) + ((_ loop . rest) + (match-named-let loop () . rest)))) + +(define-syntax match-letrec + (syntax-rules () + ((_ vars . body) (match-let/helper letrec () () vars . body)))) + +(define-syntax match-let/helper + (syntax-rules () + ((_ let ((var expr) ...) () () . body) + (let ((var expr) ...) . body)) + ((_ let ((var expr) ...) ((pat tmp) ...) () . body) + (let ((var expr) ...) + (match-let* ((pat tmp) ...) + . body))) + ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body) + (match-let/helper + let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body)) + ((_ let (v ...) (p ...) ((a expr) . rest) . body) + (match-let/helper let (v ... (a expr)) (p ...) rest . body)))) + +(define-syntax match-named-let + (syntax-rules () + ((_ loop ((pat expr var) ...) () . body) + (let loop ((var expr) ...) + (match-let ((pat var) ...) + . body))) + ((_ loop (v ...) ((pat expr) . rest) . body) + (match-named-let loop (v ... (pat expr tmp)) rest . body)))) + +(define-syntax match-let* + (syntax-rules () + ((_ () . body) + (begin . body)) + ((_ ((pat expr) . rest) . body) + (match expr (pat (match-let* rest . body)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Otherwise COND-EXPANDed bits. + +;; This *should* work, but doesn't :( +;; (define-syntax match-check-ellipse +;; (syntax-rules (...) +;; ((_ ... sk fk) sk) +;; ((_ x sk fk) fk))) + +;; This is a little more complicated, and introduces a new let-syntax, +;; but should work portably in any R[56]RS Scheme. Taylor Campbell +;; originally came up with the idea. +(define-syntax match-check-ellipse + (syntax-rules () + ;; these two aren't necessary but provide fast-case failures + ((match-check-ellipse (a . b) success-k failure-k) failure-k) + ((match-check-ellipse #(a ...) success-k failure-k) failure-k) + ;; matching an atom + ((match-check-ellipse id success-k failure-k) + (let-syntax ((ellipse? (syntax-rules () + ;; iff `id' is `...' here then this will + ;; match a list of any length + ((ellipse? (foo id) sk fk) sk) + ((ellipse? other sk fk) fk)))) + ;; this list of three elements will only many the (foo id) list + ;; above if `id' is `...' + (ellipse? (a b c) success-k failure-k))))) + + +;; This is portable but can be more efficient with non-portable +;; extensions. This trick was originally discovered by Oleg Kiselyov. + +(define-syntax match-check-identifier + (syntax-rules () + ;; fast-case failures, lists and vectors are not identifiers + ((_ (x . y) success-k failure-k) failure-k) + ((_ #(x ...) success-k failure-k) failure-k) + ;; x is an atom + ((_ x success-k failure-k) + (let-syntax + ((sym? + (syntax-rules () + ;; if the symbol `abracadabra' matches x, then x is a + ;; symbol + ((sym? x sk fk) sk) + ;; otherwise x is a non-symbol datum + ((sym? y sk fk) fk)))) + (sym? abracadabra success-k failure-k))))) --Boundary-00=_2yD/L4kUS9SdKUQ--