Changeset 32912 in project


Ignore:
Timestamp:
11/17/15 16:13:06 (5 years ago)
Author:
juergen
Message:

bindings version 4.0

Location:
release/4/bindings/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/bindings/trunk/bindings.meta

    r32485 r32912  
    11;;;; bindings.meta -*- Scheme -*-
    22
    3 ((synopsis "Binding pattern variables to subexpressions of nested sequences with application to macro-constructors")
     3((synopsis "Procedural-macros and destructuring bindings made easy")
    44 (category lang-exts)
    55 (license "BSD")
    6  (test-depends tuples simple-tests)
    7  (author "[[Juergen Lorenz]]")
    8  (files "bindings.setup" "bindings.release-info" "bindings.meta" "bindings.scm" "macro-helpers.scm" "tests/run.scm"))
     6 (test-depends simple-tests arrays)
     7 (author "Juergen Lorenz")
     8 (files "bindings.release-info" "bindings.scm" "bindings.setup"
     9        "bindings.meta" "tests/run.scm"))
  • release/4/bindings/trunk/bindings.scm

    r32481 r32912  
    1 #|[
    2 Author: Juergen Lorenz
    3 ju (at) jugilo (dot) de
    4 
    5 Copyright (c) 2011-2014, Juergen Lorenz
    6 All rights reserved.
    7 
    8 Redistribution and use in source and binary forms, with or without
    9 modification, are permitted provided that the following conditions are
    10 met:
    11 
    12 Redistributions of source code must retain the above copyright
    13 notice, this list of conditions and the following disclaimer.
    14 
    15 Redistributions in binary form must reproduce the above copyright
    16 notice, this list of conditions and the following disclaimer in the
    17 documentation and/or other materials provided with the distribution.
    18 
    19 Neither the name of the author nor the names of its contributors may be
    20 used to endorse or promote products derived from this software without
    21 specific prior written permission.
    22 
    23 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
    24 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
    25 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
    26 PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
    27 HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
    28 SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
    29 TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
    30 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
    31 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
    32 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
    33 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    34 ]|#
    35 
    36 
    37 #|[
    38 This package defines two libraries, macro-helpers and bindings. The former
    39 exports a lot of procedures, most of which are needed in the latter,
    40 some of them at compile-time.  The latter exports a series of macros,
    41 most of them binding constructs, which gives the library its name. The
    42 others are helpful in writing low-level macros. In particular,
    43 macro-rules is as easy to use as syntax-rules, but much more powerful,
    44 since it's a procedural macro and hence can do much of its work in local
    45 procedures at compile-time.
    46 
    47 The fundamental binding-construct, bind, is patterned after Paul
    48 Graham's dbind, cf. "On Lisp", p. 232.
    49 In Chicken, dbind for lists could look like as follows
     1; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
     2;
     3; Copyright (c) 2013-2015, Juergen Lorenz
     4; All rights reserved.
     5;
     6; Redistribution and use in source and binary forms, with or without
     7; modification, are permitted provided that the following conditions are
     8; met:
     9;
     10; Redistributions of source code must retain the above copyright
     11; notice, this list of conditions and the following dispasser.
     12;
     13; Redistributions in binary form must reproduce the above copyright
     14; notice, this list of conditions and the following dispasser in the
     15; documentation and/or other materials provided with the distribution.
     16;
     17; Neither the name of the author nor the names of its contributors may be
     18; used to endorse or promote products derived from this software without
     19; specific prior written permission.
     20;
     21; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
     22; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
     23; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
     24; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
     25; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
     26; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
     27; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
     28; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
     29; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
     30; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
     31; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
     32
     33#|[
     34The fundamental binding-construct, bind, is patterned after Paul Graham's
     35dbind, cf. "On Lisp", p. 232.
     36In Chicken, dbind for lists could look as follows
    5037
    5138  (define-syntax dbind
     
    6754                                    (loop p g 0))
    6855                              recu))))
    69                   (let ((tail `(list-tail ,seq ,n)))
    70                     (if (null? pat)
    71                       '()
    72                       `((,pat ,tail))))))))
     56                  (if (null? pat)
     57                    '()
     58                    `((,pat (list-tail ,seq ,n))))))))
    7359          (dbind-ex
    7460            (lambda (binds body)
     
    8975               ,(dbind-ex (destruc pat gseq) body)))))))
    9076
     77This code works as follows: First, destruc traverses the pattern and
     78groups each symbol with some list accessing code, using gensyms to step
     79down the pattern while grouping the gensym bound object with all pairs
     80depending on this gensym. So, for example,
     81
     82  (destruc '(a (b . c) . d) 'seq)
     83
     84will result in
     85
     86  ((a (list-ref seq 0))
     87   ((#:g (list-ref seq 1)) (b (list-ref #:g 0)) (c (list-tail #:g 1)))
     88   (d (list-tail seq 2)))
     89
     90This tree is then transformed via dbind-ex into a nested let
     91
     92  (let ((a (list-ref seq 0))
     93        (#:g (list-ref seq 1))
     94        (d (list-tail seq 2)))
     95    (let ((b (list-ref #:g 0))
     96          (c (list-tail #:g 1)))
     97      body))
     98 
    9199Note, that the destructuring procedures are local to this macro. This is
    92100necessary in Chicken for the macro to work, in particular in compiled
    93 code. We circumvent this problem by packaging the helpers in an extra
    94 library, which can be required within a begin-for-syntax.
     101code, unless you import them for-syntax. But since they are of no
     102interest outside of the macro, local procedrues are preferable.
     103
    95104Note further, that ir-macro-transformer does all the necessary renaming
    96 transparently behind the scene, even if the helpers are defined in
     105transparently behind the scene, even if the helpers where defined in
    97106another module. In particular, gseq needn't be a gensym.
     107
    98108And note, that Graham's code didn't check for seq's length, i.e.
    99109(dbind (a b) '(1 2 3) (list a b) would happily return '(1 2).
    100 This problem is tackled with dbind-len below.
    101 And last, but not least, some macros should accept non-symbol literals,
    102 in particular bind-case and macro-rules; dbind-lit will help here.
    103 Another feature, which we would like to have, is a wild-card, represented
    104 by the symbol underscore. It matches everything, but binds nothing. So
    105 it can appear multiple times in the same macro.
    106 
    107 We'll provide two versions of destruc, one for lists - or, to be more
    108 precise, for nested pseudolists - and one for generic sequences.
    109 ]|#
    110 
    111 #|[
    112 The bindings module below should demonstrate the power of destructuring.
    113 It exports a lot of binding constructs, the most important of it being
    114 bind, which is a version of Common Lisp's destructuring-bind, but
    115 destructures generic sequences, can check the bound variables in an
    116 optional where clause and accepts non-symbol listerals, which
    117 match only if they are equal. The latter is important for bind-case, a
    118 version of matchable's match, and macro-rules, a low-level version of
    119 syntax-rules.
    120 Note, that the internal documentation uses special repeated dots besides
    121 ellipses:
    122 Two or four dots means: Repeat the expression on the left at most once
    123 or at least once respectively.
    124 ]|#
    125 (module bindings
    126   (bindings
    127    bindable?  bind-case bind-let bind-let* bind-letrec
    128    bindrec bind-lambda bind-lambda* bind* bind-set!
    129    bind bind-define bind-case-lambda bind-case-lambda*
    130    bind/cc macro-rules define-macro let-macro letrec-macro
    131    define-er-macro let-er-macro letrec-er-macro)
    132 
     110
     111Graham's original code works on the sequence datatype, so vectors and
     112strings are destructured as well. Sequences don't exist in Scheme,
     113unless you import-for-syntax Felix' sequences egg. To make this module
     114self-contained, I prefer to supply access-routines closed over a table,
     115which provides sequence versions of list-ref and list-tail, the only
     116sequence routines used by destruc above, as well as a sequence version
     117of length, which is needed to do the length checks.
     118
     119There are some features, which I would like to have and which are
     120implemented as well. First wildcards, represented by the underscore
     121symbol. It matches everything, but binds nothing. So it can appear
     122multiple times in the same macro. Wildcard symbols are simply not
     123collected in the destruc routine.
     124
     125Second, non-symbol literals, which don't bind anything, of course, but
     126match only themselves. This and the length checks are treated simply by
     127pairing them as well with check-routines in destruc but separating the
     128pairs with leading symbol from those with leading nil or literal in
     129dbind-ex. The former are bound with lets as in Graham's code, the
     130latter's cadrs being evaluated before the recursive call to dbind-ex.
     131
     132The last feature missing is fenders, which is important in particular
     133for bind-case and can easily be implemented with a where clause: A
     134pattern matches successfully if only each pattern variable can be bound
     135and the where clause is satisfied. If the where clause doesn't pass, the
     136next pattern is tried in bind-case or a bind-exception is signalled in
     137bind.
     138
     139bind-case is the macro, which is heavily used in macro-rules. It does
     140all the destructuring there while implicit renaming cares for variable
     141captures.
     142
     143bind and bind-case are implemented in the first module, on which the
     144others rely.
     145
     146Note, that the implementation of define-macro and macro-rules in the
     147macro-bindings module is surprisingly easy having implicit-renaming
     148macros and binding routines at ones disposal.
     149]|#
     150
     151(module basic-bindings
     152  (bind bind-case
     153   bind-seq-length bind-seq-ref bind-seq-tail bind-table-show bind-table-add!
     154   bind-exception bind-exception-handler signal-bind-exception
     155   list-of vector-of symbol-dispatcher basic-bindings)
    133156  (import scheme
    134 ;          (only macro-helpers
    135 ;                define-syntax-rule
    136 ;                replace*
    137 ;                seq-length seq-ref seq-tail
    138 ;                bind-exception
    139 ;                symbol-dispatcher)
    140           (only chicken
    141                 use
    142                 condition-case
    143                 print gensym
    144                 current-exception-handler
    145                 make-property-condition
    146                 condition-predicate
    147                 get-condition-property
    148                 signal abort))
    149   (reexport (only macro-helpers
    150                   rename-prefix
    151                   bind-exception
    152                   seq-length-ref-tail!))
    153   (import-for-syntax (only macro-helpers
    154                            once-only
    155                            rename-prefix
    156                            remove-wildcards
    157                            extract
    158                            collect*
    159                            flatten-map*
    160                            map*
    161                            mappend
    162                            replace*
    163                            plength
    164                            plist-ref
    165                            plist-tail
    166                            seq-length
    167                            seq-ref
    168                            seq-tail
    169                            found?
    170                            collect*
    171                            prefixed-with?
    172                            strip-prefix
    173                            list-destruc
    174                            seq-destruc
    175                            dbind-ex
    176                            dbind-lit
    177                            dbind-len
    178                            dbind-def)
    179                      (only chicken
    180                            receive
    181                            condition-case))
    182   (begin-for-syntax (require-library macro-helpers)) ;;;
    183   (use (only macro-helpers
    184              define-syntax-rule
    185              replace*
    186              seq-length seq-ref seq-tail
    187              bind-exception
    188              symbol-dispatcher)) ;;;
    189  
    190 
    191 #|[
    192 Documentation dispatcher
    193 ]|#
    194 (define bindings
    195   (symbol-dispatcher '(
    196     (bind-set!
    197       macro:
    198       (bind-set! pat seq)
    199       "sets multiple variables by destructuring its sequence argument")
    200     (bind-define
    201       macro:
    202       (bind-define pat seq)
    203       "defines multiple variables by destructuring its sequence argument")
    204     (bind
    205       macro:
    206       (bind pat seq (where . fenders) .. xpr ....)
    207       "a variant of Common Lisp's destructuring-bind")
    208     (bindable?
    209       macro:
    210       (bindable? pat . fenders)
    211       "returns a unary predicate, which checks"
    212       "if its argument matches pat and passes all fenders")
    213     (bind-lambda
    214       macro:
    215       (bind-lambda pat (where . fenders) .. xpr ....)
    216       "combination of lambda and bind, one pattern argument")
    217     (bind-lambda*
    218       macro:
    219       (bind-lambda* pat (where . fenders) .. xpr ....)
    220       "combination of lambda and bind, multiple pattern arguments")
    221     (bindrec
    222       macro:
    223       (bindrec pat seq (where . fenders) .. xpr ....)
    224       "recursive version of bind")
    225     (bind*
    226       macro:
    227       (bind* loop pat seq (where . fenders) .. xpr ....)
    228       "named version of bind")
    229     (bind-let
    230       macro:
    231       (bind-let loop .. ((pat seq) ...) xpr ....)
    232       "nested version of let, named and unnamed")
    233     (bind-let*
    234       macro:
    235       (bind-let* ((pat seq) ...) xpr ....)
    236       "nested version of let*")
    237     (bind-letrec
    238       macro:
    239       (bind-letrec ((pat seq) ...) xpr ....)
    240       "recursive version of bind-let")
    241     (bind-case
    242       macro:
    243       (bind-case seq (pat (where . fenders) .. xpr ....) ....)
    244       "matches seq against pat with optional fenders in a case regime")
    245     (bind-case-lambda
    246       macro:
    247       (bind-case-lambda (pat (where . fenders) .. xpr ....) ....)
    248       "combination of lambda and bind-case with one pattern argument")
    249     (bind-case-lambda*
    250       macro:
    251       (bind-case-lambda* (pat (where . fenders) .. xpr ....) ....)
    252       "combination of lambda and bind-case with multiple pattern arguments")
    253     (bind/cc
    254       macro:
    255       (bind/cc cc xpr ....)
    256       "binds cc to the current contiunation"
    257       "and execute xpr ... in this context")
    258     (macro-rules
    259       macro:
    260       (macro-rules literal ... (keyword ...) (pat tpl) ....)
    261       "low-level version of syntax-rules"
    262       "with optional injected literals"
    263       "and quasiquoted templates")
    264     (define-macro
    265       macro:
    266       one-of
    267       (define-macro name macro-rules-expression)
    268       (define-macro (name . args) xpr ....)
    269       (define-macro (name . args) (keywords x ...) xpr ....)
    270       (define-macro (name . args) (inject y ...) xpr ....)
    271       (define-macro (name . args) (inject y ...) (keywords x ...) xpr ....)
    272       (define-macro (name . args) (keywords x ...) (inject y ...) xpr ....)
    273       "a version of macro-rules with only one rule")
    274     (define-er-macro
    275       macro:
    276       (define-er-macro (name . args) (keywords key ...) .. xpr ....)
    277       "explicit-renaming macro where prefixed symbols are renamed"
    278       "The prefix is taken from the parameter rename-prefix")
    279     (let-er-macro
    280       macro:
    281       (let-er-macro ((code tpl) ...) xpr ....)
    282       "local parallel version of define-er-macro")
    283     (letrec-er-macro
    284       macro:
    285       (letrec-er-macro ((code tpl) ...) xpr ....)
    286       "local recursive version of define-er-macro")
    287     (rename-prefix
    288       parameter:
    289       (rename-prefix sym ..)
    290       "sets rename-prefix to sym or returns it, default: '%")
    291     (bind-exception
    292       (procedure: (location message . arguments) -> condition))
    293     (seq-length-ref-tail!
    294       (procedure: (type? type-length type-ref type-tail)
    295                   updates (seq-length seq-ref seq-tail)))
    296     )))
    297 
    298 #|[
    299 Let's start with a new exception-handler, which is able to cope with
    300 bind exceptions
    301 ]|#
    302 
    303 (current-exception-handler
     157          (only chicken case-lambda condition-case define-values
     158                error subvector
     159                current-exception-handler condition-predicate
     160                get-condition-property make-property-condition
     161                make-composite-condition signal abort print)
     162          (only data-structures conjoin list-of?))
     163  (import-for-syntax
     164    (only data-structures compress))
     165
     166#|[
     167Let's start with defining bind-exceptions, a corresponding exception-handler,
     168and registering this handler
     169]|#
     170
     171;;; (bind-exception loc msg arg ...)
     172;;; --------------------------------
     173;;; composite condition, to allow for (exn bind) in condition-case
     174(define (bind-exception loc msg . args)
     175  (make-composite-condition
     176    (make-property-condition 'exn
     177      'location `(,loc)
     178      'message msg
     179      'arguments (apply list args))
     180    (make-property-condition 'bind
     181      'location `(,loc)
     182      'message msg
     183      'arguments (apply list args))))
     184
     185;;; (signal-bind-exception loc msg arg ...)
     186;;; ---------------------------------------
     187;;; signals a bind-exception, can be used instead of error
     188(define (signal-bind-exception loc msg . args)
     189  (signal
     190    (apply bind-exception loc msg args)))
     191
     192;;; (bind-exception-handler var)
     193;;; ----------------------------
     194;;; exception-handler to be passed to the parameter
     195;;; current-exception-handler
     196(define bind-exception-handler
    304197  (let ((old-handler (current-exception-handler)))
    305198    (lambda (var)
    306199      (if ((condition-predicate 'bind) var)
    307200        (begin
    308           (display "Error: ")
     201          (display "Bind error: ")
    309202          (print (get-condition-property var 'bind 'location))
    310203          (print (get-condition-property var 'bind 'message))
     
    314207        (old-handler var)))))
    315208
     209;;; set current-exception-handler
     210(current-exception-handler bind-exception-handler)
    316211
    317212#|[
    318 The first two macros are nested versions of set! and define. They allow
    319 the simultaneous definition of procedures which have access to common
    320 state. In fact, it suffices to implement bind-set! since Chicken
    321 reduces define to set! anyway: try (expand '(define a 1)) to convince
    322 yourself.  So we could implement bind-define as an alias to bind-set!
    323 But according to the standard, set! changes existing variables, while
    324 define defines new ones. So our definition will reflect this.
    325 
    326 bind-set! replaces the values of symbols in a nested lambda-list in one
    327 go with the corresponding subeseqessions of its second argument. So,
    328 after (bind-set! (a (b (c . d))) '(1 (2 (3 4 5)))) d should have the
    329 value (4 5), b the value 2 etc.
    330 bind-define does the same, but defines the pattern variables before
    331 setting them. The real advantage of this is, that we can define several
    332 functions which rely on the same encapsulated state. Consider
     213The following three routines maintain the lookup table for the needed
     214sequence primitives. Instead of bind-table-lookup the three sequence
     215primitives below are exported.
     216If you prefer, you can use the sequence primitives size, elt and sub of
     217the sequences egg, provided you rename them bind-seq-length,
     218bind-seq-ref and bind-seq-tail respectively.
     219]|#
     220
     221;;; (bind-table-lookup obj)
     222;;; -----------------------
     223;;; returns an association list of predicates and associated vectors
     224;;; with length, ref and tail primitives
     225;;;
     226;;; (bind-table-show)
     227;;; -----------------
     228;;; prints the contents of the table
     229;;;
     230;;; (bind-table-add! type? len ref tail)
     231;;; ------------------------------------
     232;;; adds a new list to the top of the table
     233(define-values (bind-table-lookup bind-table-show bind-table-add!)
     234  (let (
     235    (tbl
     236      (list (cons pair?
     237                  (vector
     238                    (lambda (obj)
     239                      (let loop ((obj obj) (len 0))
     240                        (if (pair? obj)
     241                          (loop (cdr obj) (+ len 1))
     242                          len)))
     243                    list-ref
     244                    list-tail))
     245            (cons vector?
     246                  (vector vector-length vector-ref subvector))
     247            (cons string?
     248                  (vector string-length string-ref substring))
     249            ;; atoms catch all
     250            (cons (lambda (obj) (not (pair? obj)))
     251                  (vector
     252                    (lambda (obj) 0)
     253                    (lambda (obj pos)
     254                      (signal-bind-exception 'bind-table-lookup
     255                                             "out of range"
     256                                             obj
     257                                             pos))
     258                    (lambda (obj pos)
     259                      (if (zero? pos)
     260                        obj
     261                        (signal-bind-exception 'bind-table-lookup
     262                                               "out of range"
     263                                               obj)))))
     264            ))
     265    )
     266    (values
     267      (lambda (obj)
     268        (let loop ((tbl tbl))
     269          ;; note, that we have a catch-all predicate in the table
     270          (if ((caar tbl) obj)
     271            (cdar tbl)
     272            (loop (cdr tbl)))))
     273      (lambda () (print tbl))
     274      (lambda (type? len ref tail)
     275        (set! tbl (cons (cons type?
     276                              (vector len ref tail))
     277                        tbl))))
     278      ))
     279
     280;;; (bind-seq-length seq)
     281;;; ---------------------
     282;;; returns the length of the sequence argument
     283(define (bind-seq-length obj)
     284  ((vector-ref (bind-table-lookup obj) 0) obj))
     285
     286;;; (bind-seq-ref seq pos)
     287;;; ----------------------
     288;;; returns the item of the sequence argument at index pos
     289(define (bind-seq-ref obj pos)
     290  ((vector-ref (bind-table-lookup obj) 1) obj pos))
     291
     292;;; (bind-seq-tail seq pos)
     293;;; -----------------------
     294;;; returns the tail of the sequence argument starting at index pos
     295(define (bind-seq-tail obj pos)
     296  ((vector-ref (bind-table-lookup obj) 2) obj pos))
     297
     298#|[
     299The following is Graham's dbind extended with fenders, wildcards,
     300non-symbol literals and length-checks. For example
     301
     302  (bind (x (y z)) '(1 #(2 3)) (where (integer? x)) (list x y z))
     303
     304will result in '(1 2 3) while
     305
     306  (bind (_ ("y" z)) '(1 #("y" z)) z)
     307
     308will produce 3
     309
     310]|#
     311
     312;;; (bind pat seq (where . fenders) .. xpr ....)
     313;;; ---------------------------------------------
     314;;; binds pattern variables of pat to corresponding subexpressions of
     315;;; seq and executes body xpr .... in this context, provided all
     316;;; fenders pass
     317(define-syntax bind
     318  (ir-macro-transformer
     319    (lambda (form inject compare?)
     320      (letrec (
     321        (len 'bind-seq-length)
     322        (ref 'bind-seq-ref)
     323        (tail 'bind-seq-tail)
     324        (filter2
     325          (lambda (ok? lst)
     326            (let loop ((lst lst) (yes '()) (no '()))
     327              (if (null? lst)
     328                (list (reverse yes) (reverse no))
     329                (let ((first (car lst)) (rest (cdr lst)))
     330                  (if (ok? first)
     331                    (loop rest (cons first yes) no)
     332                    (loop rest yes (cons first no))))))))
     333        (mappend
     334          (lambda (fn lists)
     335            (apply append (map fn lists))))
     336        (destruc
     337          (lambda (pat seq)
     338            (let loop ((pat pat) (seq seq) (n 0))
     339              (cond
     340                ((pair? pat)
     341                 (let ((p (car pat)) (recu (loop (cdr pat) seq (+ n 1))))
     342                   (cond
     343                     ((symbol? p)
     344                      (if (compare? p '_)
     345                        ;; skip
     346                        recu
     347                        (cons `(,p (,ref ,seq ,n)) recu)))
     348                     ((pair? p)
     349                      (let ((g (gensym)))
     350                        (cons (cons `(,g (,ref ,seq ,n))
     351                                    (loop p g 0))
     352                              recu)))
     353                     (else
     354                       (cons `(,p (equal? ',p (,ref ,seq ,n)))
     355                             recu))
     356                     )))
     357                ((symbol? pat)
     358                 `((,pat (,tail ,seq ,n))))
     359                ((null? pat)
     360                 `((,pat (zero? (,len (,tail ,seq ,n))))))
     361                ))))
     362        (dbind-ex
     363          (lambda (binds body)
     364            (if (null? binds)
     365              `(begin ,@body)
     366              (apply (lambda (defs checks)
     367                       `(let ,defs
     368                          (if (and ,@(map cadr checks))
     369                            ,(dbind-ex
     370                               (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
     371                                        binds)
     372                               body)
     373                            (signal-bind-exception
     374                              'bind
     375                              "match error"
     376                              ',(cons 'and (map cadr checks))))
     377                          ))
     378                     (filter2 (lambda (pair) (symbol? (car pair)))
     379                              (map (lambda (b) (if (pair? (car b)) (car b) b))
     380                                   binds)))
     381              )))
     382        )         
     383        (let ((pat (cadr form))
     384              (seq (caddr form))
     385              (xpr (cadddr form))
     386              (xprs (cddddr form))
     387              (gseq 'seq))
     388          (let ((fender? (and (pair? xpr)
     389                              (compare? 'where (car xpr))))
     390                (destruc-pat-gseq (destruc pat gseq)))
     391            (if fender?
     392              `(let ((,gseq ,seq))
     393                 (if ,(dbind-ex destruc-pat-gseq
     394                                (list (cons 'and (cdr xpr))))
     395                   ,(dbind-ex destruc-pat-gseq xprs)
     396                   (signal-bind-exception 'bind
     397                                          "match error"
     398                                          ,gseq
     399                                          ',pat
     400                                          ',xpr)))
     401              `(let ((,gseq ,seq))
     402                 ,(dbind-ex destruc-pat-gseq (cons xpr xprs))))
     403            ))))))
     404
     405#|[
     406The following macro does more or less the same what the match macro from
     407the matchable package does, for example
     408
     409  (bind-case '(1 (2 3))
     410    ((x y) (where (list? y)) (list x y))
     411    ((x (y . z)) (list x y z))
     412    ((x (y z)) (list x y z))) ;-> '(1 2 (3))
     413
     414or, to give a more realistic example, mapping:
     415
     416  (define (my-map fn lst)
     417    (bind-case lst
     418      (() '())
     419      ((x . xs) (cons (fn x) (my-map fn xs)))))
     420
     421To improve error messages, we wrap it around an inner version,
     422bind-case-inner, which does all of the work.
     423]|#
     424
     425;;; inner version, not exported
     426(define-syntax bind-case-inner
     427  (ir-macro-transformer
     428    (lambda (form inject compare?)
     429      (let ((seq (cadr form)) (clauses (cddr form)))
     430        (if (null? clauses)
     431          `(signal-bind-exception 'bind-case-inner
     432                                  "no match for"
     433                                  ,seq
     434                                  )
     435
     436          `(condition-case (bind ,(caar clauses) ,seq ,@(cdar clauses))
     437             ((exn type)
     438              (bind-case ,seq ,@(cdr clauses)))
     439             ((exn bind)
     440              (bind-case ,seq ,@(cdr clauses)))))))))
     441
     442;;; (bind-case seq (pat (where fender ...) .. xpr ....) ....)
     443;;; ---------------------------------------------------------
     444;;; Checks if seq matches pattern pat [satisfying fender ...] ....
     445;;; in sequence, binds the pattern variables of the first matching
     446;;; pattern to corresponding subexpressions of seq and executes
     447;;; corresponding body xpr ....
     448(define-syntax bind-case
     449  (ir-macro-transformer
     450    (lambda (form inject compare?)
     451      (let ((seq (cadr form)) (clauses (cddr form)))
     452        `(condition-case (bind-case-inner ,seq ,@clauses)
     453           ((exn bind)
     454            (signal-bind-exception 'bind-case
     455                                   "no match for"
     456                                   ,seq
     457                                   ',(cons 'in
     458                                           (map (lambda (clause)
     459                                                  (list (car clause)
     460                                                        (if (and (pair? (cadr clause))
     461                                                                 (compare? (caadr clause) 'where))
     462                                                          (cadr clause)
     463                                                          (list 'where #t))))
     464                                          clauses)))))))))
     465
     466#|[
     467At last some helper functions, which sometimes make life easier
     468]|#
     469
     470;;; (list-of ok? ....)
     471;;; ------------------
     472;;; returns a list predicate which checks all ok? arguments
     473(define (list-of . oks?) (list-of? (apply conjoin oks?)))
     474
     475;;; (vector-of ok? ....)
     476;;; --------------------
     477;;; returns a list predicate which checks all ok? arguments
     478(define (vector-of . oks?)
     479  (let (
     480    (vector-of?
     481      (lambda (ok?)
     482        (lambda (vec)
     483          (and (vector? vec)
     484               (let loop ((n 0))
     485                 (cond
     486                   ((= n (vector-length vec))
     487                    #t)
     488                   ((ok? (vector-ref vec n))
     489                    (loop (+ n 1)))
     490                   (else #f)))))))
     491    )
     492    (vector-of? (apply conjoin oks?))))
     493
     494;;; (symbol-dispatcher alist)
     495;;; -------------------------
     496;;; returns a procedure of zero or one argument, which shows all cars
     497;;; or the cdr of the alist item with car symbol
     498(define (symbol-dispatcher alist)
     499  (case-lambda
     500    (()
     501     (map car alist))
     502    ((sym)
     503     (let ((pair (assq sym alist)))
     504       (if pair
     505         (for-each print (cdr pair))
     506         (error "Not in list"
     507                sym
     508                (map car alist)))))))
     509
     510;;; (basic-bindings sym ..)
     511;;; -----------------------
     512;;; documentation procedure of this module
     513(define basic-bindings
     514  (symbol-dispatcher '(
     515    (bind
     516      macro:
     517      (bind pat seq (where . fenders) .. xpr ....)
     518      "a variant of Common Lisp's destructuring-bind")
     519    (bind-case
     520      macro:
     521      (bind-case seq (pat (where . fenders) .. xpr ....) ....)
     522      "matches seq against pat with optional fenders in a case regime")
     523    (bind-exception
     524      procedure:
     525      (bind-exception loc msg arg ...)
     526      "generates a composite condition with location symbol, string message"
     527      "and passible additional arguments arg ...")
     528    (signal-bind-exception
     529      procedure:
     530      (bind-exception loc msg arg ...)
     531      "signals a composite condition with location symbol, string message"
     532      "and passible additional arguments arg ...")
     533    (bind-exception-handler
     534      procedure:
     535      (bind-exception-handler var)
     536      "to be passed to the parameter current-exception-handler")
     537    (bind-seq-length
     538      procedure:
     539      (bind-seq-length seq)
     540      "redurns the length of a sequence")
     541    (bind-seq-ref
     542      procedure:
     543      (bind-seq-ref seq pos)
     544      "returns the item at position pos of a sequence")
     545    (bind-seq-tail
     546      procedure:
     547      (bind-seq-ref seq pos)
     548      "returns the tail starting at position pos of a sequence")
     549    (bind-table-show
     550      procedure:
     551      (bind-table-show)
     552      "pretty prints the sequence table")
     553    (bind-table-add!
     554      procedure:
     555      (bind-table-add! type? len ref tail)
     556      "adds a new table item to the front of the sequence table")
     557    (list-of
     558      procedure:
     559      (list-of ok? ...)
     560      "generates a list predicate which checks all of its arguments")
     561    (vector-of
     562      procedure:
     563      (vector-of ok? ...)
     564      "generates a list predicate which checks all of its arguments")
     565    (symbol-dispatcher
     566      procedure:
     567      (symbol-dispatcher alist)
     568      "generates a procedure of zero or one argument showing all"
     569      "cars or the cdr or the alist item with symbol as car")
     570    )))
     571
     572) ; basic-bindings
     573
     574
     575#|[
     576Now we'll use bind-case to create procedural macros.  The first,
     577macro-rules, is a procedural version of syntax-rules. It is as
     578convenient as the latter, but much more powerfull. For example, it can
     579use injected symbols and once pattern variables, do some of its work at
     580compile-time, use local functions at compile-time and what have you.
     581Contrary to syntax-rules the templates usually evaluate to quasiquoted
     582expressions.
     583Other procedural macro-building routines are provided as well, in
     584particular, a hygienic define-macro, based on bind as well as local
     585versions of it, macro-let and macro-letrec.
     586]|#
     587
     588(module macro-bindings
     589  (define-macro macro-rules macro-let macro-letrec once-only
     590    ;mac-rules
     591   with-gensyms macro-bindings)
     592  (import scheme basic-bindings)
     593  (import-for-syntax
     594    (only basic-bindings bind bind-case)
     595    (only data-structures compress))
     596
     597
     598;;; (macro-rules sym ... (key ...) (pat (where fender ...) .. tpl) ....)
     599;;; --------------------------------------------------------------------
     600;;; where sym ... are injected non-hygienig symbols, key ... are
     601;;; additional keywords, pat ....  are nested lambda-lists without
     602;;; spezial meaning of ellipses and tpl .... usually evaluate to
     603;;; quasiquoted templates. The optional fenders belong to the pattern
     604;;; matching process.
     605(define-syntax macro-rules
     606  (ir-macro-transformer
     607    (lambda (f i c?)
     608      (let ((f* (let loop ((tail (cdr f)) (head '()))
     609                  (if (symbol? (car tail))
     610                    (loop (cdr tail) (cons (car tail) head))
     611                    (cons head tail)))))
     612        (let ((syms (car f*))
     613              (keys (cadr f*))
     614              (rules (cddr f*))
     615              (flatten*
     616                ; imported flatten doesn't work with pseudo-lists
     617                (lambda (tree)
     618                  (let loop ((tree tree) (result '()))
     619                    (cond
     620                      ((pair? tree)
     621                       (loop (car tree) (loop (cdr tree) result)))
     622                      ((null? tree) result)
     623                      (else
     624                        (cons tree result)))))))
     625          `(ir-macro-transformer
     626             (lambda (form inject compare?)
     627               (let ,(map (lambda (s)
     628                            `(,s (inject ',s)))
     629                          syms)
     630                 (bind-case form
     631                   ,@(map (lambda (rule)
     632                            (let* ((pat (car rule))
     633                                   (fpat (flatten* pat))
     634                                   (kpat (compress
     635                                           (map (lambda (x)
     636                                                  (memq x keys))
     637                                                fpat)
     638                                           fpat))
     639                                   ;; compare? keywords with its names
     640                                   (key-checks
     641                                     (map (lambda (p s)
     642                                            `(compare? ,p ,s))
     643                                          kpat
     644                                          (map (lambda (x) `',x)
     645                                               kpat))))
     646                              (let ((tpl (cdr rule)))
     647                                ;; add key-checks to where clause of tpl
     648                                (if (and (pair? (car tpl))
     649                                         (c? (caar tpl) 'where))
     650                                  `(,pat (where ,@key-checks ,@(cdar tpl))
     651                                         ,@(cdr tpl))
     652                                  `(,pat (where ,@key-checks) ,@tpl)))))
     653                          rules))))))))))
     654
     655;;; (define-macro (name . args) (where fender ...) .. xpr ....)
     656;;; -----------------------------------------------------------
     657;;; simple hygienic macro without injections and keywords, but with
     658;;; fenders and once arguments.
     659(define-syntax define-macro
     660  (ir-macro-transformer
     661    (lambda (f i c?)
     662      (let ((code (cadr f))
     663            (xpr (caddr f))
     664            (xprs (cdddr f)))
     665        `(define-syntax ,(car code)
     666           (ir-macro-transformer
     667             (lambda (form inject compare?)
     668               (bind ,(cdr code) (cdr form) ,xpr ,@xprs))))))))
     669
     670#|[
     671Now follow the local versions of define-macro, macro-let and
     672macro-letrec. Since the syntax of both is identical, they are
     673implemented by means of a helper macro.
     674]|#
     675
     676;; helper for macro-let and macro-letrec
     677(define-syntax macro
     678  (ir-macro-transformer
     679    (lambda (form inject compare?)
     680      (let ((op (cadr form))
     681            (pat-tpl-pairs (caddr form))
     682            (xpr (cadddr form))
     683            (xprs (cddddr form)))
     684        (let ((pats (map car pat-tpl-pairs))
     685              (tpls (map cdr pat-tpl-pairs)))
     686          `(,op ,(map (lambda (pat tpl)
     687                               `(,(car pat)
     688                                  (macro-rules ()
     689                                     ((_ ,@(cdr pat)) ,@tpl))))
     690                              pats tpls)
     691                       ,xpr ,@xprs))))))
     692
     693;;; (macro-let (((name . args) (where fender ...) .. xpr ...) ...) body ....)
     694;;; -------------------------------------------------------------------------
     695;;; evaluates body ... in the context of parallel macros name ....
     696(define-syntax macro-let
     697  (ir-macro-transformer
     698    (lambda (form inject compare?)
     699      (let ((pat-tpl-pairs (cadr form))
     700            (xpr (caddr form))
     701            (xprs (cdddr form)))
     702        `(macro let-syntax ,pat-tpl-pairs ,xpr ,@xprs)))))
     703
     704;;; (macro-letrec (((name . args) (where fender ...) .. xpr ...) ...) body ....)
     705;;; ----------------------------------------------------------------------------
     706;;; evaluates body ... in the context of recursive macros name ....
     707(define-syntax macro-letrec
     708  (ir-macro-transformer
     709    (lambda (form inject compare?)
     710      (let ((pat-tpl-pairs (cadr form))
     711            (xpr (caddr form))
     712            (xprs (cdddr form)))
     713        `(macro letrec-syntax ,pat-tpl-pairs ,xpr ,@xprs)))))
     714
     715;;; (with-gensyms (name ....) xpr ....)
     716;;; -----------------------------------
     717;;; binds name ... to (gensym 'name) ... in body xpr ...
     718(define-syntax with-gensyms
     719  (ir-macro-transformer
     720    (lambda (form inject compare?)
     721      `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form))
     722         ,@(cddr form)))))
     723
     724;;; (once-only (x ....) xpr ....)
     725;;; -----------------------------
     726;;; macro-arguments x .... are only evaluated once and from left to
     727;;; right in the body xpr ....
     728;;; The code is more or less due to
     729;;; P. Seibel, Practical Common Lisp, p. 102
     730(define-syntax once-only
     731  (ir-macro-transformer
     732    (lambda (form inject compare?)
     733      (let ((names (cadr form))
     734            (body (cddr form)))
     735        (let ((gensyms (map (lambda (x) (gensym)) names)))
     736          `(let ,(map (lambda (g) `(,g (gensym))) gensyms)
     737             `(let ,(list ,@(map (lambda (g n) ``(,,g ,,n))
     738                                 gensyms names))
     739                ,(let ,(map (lambda (n g) `(,n ,g))
     740                            names gensyms)
     741                   ,@body))))))))
     742
     743;;; (macro-bindings sym ..)
     744;;; -----------------------
     745;;; documentation procedure.
     746(define macro-bindings
     747  (symbol-dispatcher '(
     748    (macro-rules
     749      macro:
     750      (macro-rules literal ... (keyword ...) (pat tpl) ....)
     751      "procedural version of syntax-rules"
     752      "with optional injected literals"
     753      "and quasiquoted templates")
     754    (define-macro
     755      macro:
     756      (define-macro (name . args) xpr ....)
     757      "a version of macro-rules with only one rule"
     758      "no injected symbols and no keywords")
     759    (macro-let
     760      macro:
     761      (macro-let (((name . args) (where fender ...) .. xpr ...) ...) body ....)
     762      "evaluates body ... in the context of parallel macros name ....")
     763    (macro-letrec
     764      macro:
     765      (macro-letrec (((name . args) (where fender ...) .. xpr ...) ...) body ....)
     766      "evaluates body ... in the context of recursive macros name ....")
     767    (once-only
     768      macro:
     769      (once-only (x ....) xpr ....)
     770      "arguments x ... are evaluated only once and"
     771      "from left to right in the body xpr ....")
     772    (with-gensyms
     773      macro:
     774      (with-gensyms (x ....) xpr ....)
     775      "generates a series of gensyms x .... to be used in body xpr ...")
     776    )))
     777) ; macro-bindings
     778
     779#|[
     780The binding macros to follow are all implemented either with
     781define-macro or with macro-rules, hence the latter must be
     782imported for-syntax. Had we chosen the direct implementation of
     783define-macro with bind instead of macro-rules, we had to import
     784for-syntax bind as well. This is the reason, why separate modules are
     785needed. Note, that the fundamental macros, bind and bind-case, know how
     786to handle where clauses. Hence the derived macros do as well.
     787]|#
     788
     789(module more-bindings *
     790  (import scheme
     791          basic-bindings
     792          (except macro-bindings macro-rules)
     793          )
     794  (import-for-syntax (only basic-bindings bind)
     795                     (only macro-bindings macro-rules))
     796
     797#|[
     798The next macro, bindable?, can be used to check, if a
     799sequence-expression matches a pattern and passes all fenders.
     800]|#
     801
     802;;; (bindable? pat (where fender ...) ..)
     803;;; -------------------------------------
     804;;; returns a unary predicate which checks, if its argument matches pat
     805;;; and fulfills the predicates in the list fender ...
     806;;; Mostly used in fenders of macro-rules and define-macro, but must
     807;;; then be imported for-syntax.
     808(define-syntax bindable?
     809  (macro-rules (where)
     810    ((_ pat (where . fenders))
     811     `(lambda (seq)
     812        (condition-case (bind ,pat seq (and ,@fenders))
     813          ((exn bind) #f))))
     814    ((_ pat)
     815     `(bindable? ,pat (where)))))
     816
     817#|[
     818The following two macros, bind-define and bind-set!, destructure their
     819sequence arguments with respect to their pattern argument and define or
     820set! the pattern variables correspondingly.  For example, one can define
     821multiple procedures operating on a common state
    333822
    334823  (bind-define (push top pop)
    335824    (let ((state '()))
    336825      (list
    337         (lambda (arg) (set! lst (cons arg state)))
     826        (lambda (arg) (set! state (cons arg state)))
    338827        (lambda () (car state))
    339         (lambda () (set! lst (cdr state))))))
    340 
    341 Now we have three procedures, which all operate on the encapsulated
    342 list.
    343 
    344 The implementation uses the fourth procedure, dbind-def, which operates
    345 on the return values of seq-destruc.
    346 ]|#
     828        (lambda () (set! state (cdr state))))))
     829
     830]|#
     831
     832;; helper macro for bind-define and bind-set!
     833(define-macro (bind-def-set! pat seq def?)
     834  (let ((sym? (lambda (p)
     835                (and (symbol? p)
     836                     (not (compare? p '_))))))
     837    (let ((aux (let copy ((pat pat))
     838                 (cond
     839                   ((sym? pat) (gensym))
     840                   ((pair? pat)
     841                    (cons (copy (car pat)) (copy (cdr pat))))
     842                   (else pat))))
     843          (flatten*
     844            ; imported flatten doesn't work with pseudo-lists
     845            (lambda (tree)
     846              (let loop ((tree tree) (result '()))
     847                (cond
     848                  ((pair? tree)
     849                   (loop (car tree) (loop (cdr tree) result)))
     850                  ((null? tree) result)
     851                  (else
     852                    (cons tree result))))))
     853          (filter
     854            (lambda (ok? lst)
     855              (compress (map ok? lst) lst))))
     856      (if def?
     857        `(begin
     858           ,@(map (lambda (p) `(define ,p ',p))
     859                  (filter sym? (flatten* pat)))
     860           (bind ,aux ,seq
     861             ,@(map (lambda (p a) `(set! ,p ,a))
     862                    (filter sym? (flatten* pat))
     863                    (filter sym? (flatten* aux)))))
     864        `(begin
     865           (bind ,aux ,seq
     866             ,@(map (lambda (p a) `(set! ,p ,a))
     867                    (filter sym? (flatten* pat))
     868                    (filter sym? (flatten* aux))))))
     869      )))
     870
    347871
    348872;;; (bind-define pat seq)
     
    350874;;; destructures the sequence seq according to the pattern pat and sets
    351875;;; pattern variables with values corresponding to subexpressions of seq
    352 (define-syntax bind-define
    353   (ir-macro-transformer
    354     (lambda (form inject compare?)
    355       (let ((pat (cadr form)) (seq (caddr form)) (gseq 'seq))
    356         `(begin (define ,gseq ,seq)
    357                 ,(dbind-def 'define (seq-destruc pat gseq)))))))
     876(define-macro (bind-define pat seq)
     877  `(bind-def-set! ,pat ,seq #t))
    358878
    359879;;; (bind-set! pat seq)
    360880;;; -------------------
    361 ;;; destructures the sequence seq according to the pattern pat and
    362 ;;; defines pattern variables with values corresponding to
    363 ;;; subexpressions of seq
    364 (define-syntax bind-set!
    365   (ir-macro-transformer
    366     (lambda (form inject compare?)
    367       (let ((pat (cadr form)) (seq (caddr form)) (gseq 'seq))
    368         `(begin (set! ,gseq ,seq)
    369                 ,(dbind-def 'set! (seq-destruc pat gseq)))))))
    370 
    371 
    372 #|[
    373 Now we'll extend Graham's dbind, allowing non-symbols in the patterns,
    374 which must be equal to the corresponding values in the template for a
    375 match.
    376 ]|#
    377 
    378 (define-syntax dbind
    379   (ir-macro-transformer
    380     (lambda (form inject compare?)
    381       (let ((pat (cadr form))
    382             (seq (caddr form))
    383             (body (cdddr form))
    384             (gseq 'seq))
    385         `(let ((,gseq ,seq))
    386            ,(receive (symbols literals checks)
    387               (seq-destruc pat seq)
    388               `(if ,(dbind-len checks)
    389                  (if ,(dbind-lit literals)
    390                    ;,(dbind-ex symbols body)
    391                    ,(dbind-ex (remove-wildcards compare? symbols)
    392                               body)
    393                    (signal
    394                      (bind-exception 'dbind
    395                                      "literals don't match"
    396                                      ',literals)))
    397                  (signal (bind-exception 'dbind
    398                                          "not matchable"
    399                                          ',pat ,gseq)))))))))
    400      
    401 ;;; (bind pat seq (where . fenders) .. xpr . xprs)
    402 ;;; ----------------------------------------------
    403 ;;; binds pattern variables of pat to corresponding subexpressions of
    404 ;;; seq and executes tthe body xpr . xprs in this context. If a where
    405 ;;; expression is supplied, all fenders must return #t for seq to be
    406 ;;; successfully bound.
    407 (define-syntax bind
    408   (syntax-rules (where)
    409     ((_ pat seq (where . fenders) xpr . xprs)
    410      (dbind pat seq (and . fenders) xpr . xprs))
    411     ((_ pat seq xpr . xprs)
    412      (dbind pat seq #t xpr . xprs))))
    413 
    414 #|[
    415 The next macro, bindable?, can be used to check, if a
    416 sequence-expression matches a pattern and passes all fenders. It's used
    417 in bind-case below.
    418 The implementation relies on bind, which must be protected against exceptions.
    419 ]|#
    420 
    421 ;;; (bindable? pat . fenders)
    422 ;;; -------------------------
    423 ;;; returns a unary predicate which checks, if its argument matches pat
    424 ;;; and fulfills the predicates in the list fenders
    425 (define-syntax-rule (bindable? pat . fenders)
    426   (lambda (seq)
    427     (condition-case
    428       (bind pat seq (and . fenders))
    429       ((exn bind) #f))))
     881;;; sets pattern variables of pat to corresponding sub-expressins of seq
     882(define-macro (bind-set! pat seq)
     883  `(bind-def-set! ,pat ,seq #f))
    430884
    431885#|[
     
    444898]|#
    445899
    446 ;;; (bind-lambda pat xpr . xprs)
    447 ;;; --------------------------------
     900;;; (bind-lambda pat (where fender ...) .. xpr ....)
     901;;; ------------------------------------------------
    448902;;; combination of lambda and bind, one pattern argument
    449 (define-syntax bind-lambda
    450   (syntax-rules (where)
    451     ((_ pat (where . fenders) xpr . xprs)
    452      (lambda (x) (bind pat x (where . fenders) xpr . xprs)))
    453     ((_ pat xpr . xprs)
    454      (lambda (x) (bind pat x xpr . xprs)))))
    455 
    456 ;;; (bind-lambda* pat xpr . xprs)
    457 ;;; ---------------------------------
     903(define-macro (bind-lambda pat xpr . xprs)
     904  `(lambda (x) (bind ,pat x ,xpr ,@xprs)))
     905
     906;;; (bind-lambda* pat (where fender ...) .. xpr ....)
     907;;; -------------------------------------------------
    458908;;; combination of lambda and bind, multiple pattern arguments
    459 (define-syntax bind-lambda*
    460   (syntax-rules (where)
    461     ((_ pat (where . fenders) xpr . xprs)
    462      (lambda x (bind pat x (where . fenders) xpr . xprs)))
    463     ((_ pat xpr . xprs)
    464      (lambda x (bind pat x xpr . xprs)))))
     909(define-macro (bind-lambda* pat xpr . xprs)
     910  `(lambda x (bind ,pat x ,xpr ,@xprs)))
    465911
    466912#|[
     
    478924]|#
    479925
    480 ;;; (bind* name pat seq (where . fenders) .. xpr . xprs)
    481 ;;; ---------------------------------------------------------
     926;;; (bind* name pat seq (where . fenders) .. xpr ....)
     927;;; ---------------------------------------------------
    482928;;; named version of bind
    483 (define-syntax bind*
    484   (syntax-rules (where)
    485     ((_ loop pat seq (where . fenders) xpr . xprs)
    486      ((letrec ((loop
    487                  (bind-lambda pat (where . fenders) xpr . xprs)))
    488                  ;(lambda (x)
    489                  ;  (bind pat x (where . fenders) xpr . xprs))))
    490         loop)
    491       seq))
    492     ((_ loop pat seq xpr . xprs)
    493      (bind* loop pat seq (where) xpr . xprs))))
    494 
    495 #|[
    496 And here is the recursive version of bind.
    497 
    498   (bindrec ((o?) e?)
    499     (list (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
    500           (lambda (n) (if (zero? n) #t (o? (- n 1)))))
    501     (list (o? 95) (e? 95)))
    502   -> '(#t #f)
    503 
    504 It's definition is patterned after a procedural definition of letrec:
    505 
    506   (define-macro (my-letrec pairs . body)
    507     (let ((vars (map car pairs))
    508           (vals (map cadr pairs))
    509           (aux (map (lambda (x) (gensym)) pairs)))
    510       `(let ,(map (lambda (var) `(,var #f)) vars)
    511          (let ,(map (lambda (a v) `(,a ,v)) aux vals)
    512            ,@(map (lambda (v e) `(set! ,v ,e)) vars vals)
    513            ,@body))))
    514 
    515 Note, how simple this is, compared with the syntax-rules definition in
    516 R5RS
    517 ]|#
    518 
    519 ;;; (bindrec pat seq (where . fenders) .. xpr ....)
    520 ;;; ----------------------------------------------------
    521 ;;; recursive version of bind
    522 (define-syntax bindrec
    523   (ir-macro-transformer
    524     (lambda (form inject compare?)
    525       (let ((pat (cadr form))
    526             (seq (caddr form))
    527             (xpr (cadddr form))
    528             (xprs (cddddr form)))
    529         (let ((aux (map* gensym pat)))
    530           `(let ,(flatten-map* (lambda (v) `(,v #f)) pat)
    531              (dbind ,aux ,seq
    532                ,@(flatten-map* (lambda (x y) `(set! ,x ,y))
    533                                pat aux)
    534                (if ,(and (pair? xpr) (compare? (car xpr) 'where))
    535                  (if (and ,@(cdr xpr))
    536                    (begin ,@xprs)
    537                    (signal (bind-exception 'bindrec
    538                                            "fenders not passed"
    539                                            ',(cdr xpr))))
    540                  (begin ,xpr ,@xprs)))))))))
     929(define-macro (bind* name pat seq xpr . xprs)
     930  `((letrec ((,name
     931               (bind-lambda ,pat ,xpr ,@xprs)))
     932      ,name)
     933    ,seq))
    541934
    542935#|[
     
    559952]|#
    560953
    561 ;;; (bind-let loop .. ((pat seq) ...) xpr . xprs)
    562 ;;; ---------------------------------------------
     954;;; (bind-let loop .. ((pat seq) ...) xpr ....)
     955;;; --------------------------------------------
    563956;;; nested version of let, named and unnamed
    564957(define-syntax bind-let
    565   (syntax-rules ()
     958  (macro-rules ()
     959    ((_ loop () xpr . xprs)
     960     `(let ,loop () ,xpr ,@xprs))
     961    ((_ loop ((pat0 seq0) . pat-seq-pairs) xpr . xprs)
     962     `(bind* ,loop
     963        ,(cons pat0 (map car pat-seq-pairs))
     964        (list ,seq0 ,@(map cadr pat-seq-pairs))
     965        ,xpr ,@xprs))
    566966    ((_ () xpr . xprs)
    567      (begin xpr . xprs))
    568     ((_ ((pat0 seq0) (pat1 seq1) ...) xpr . xprs)
    569      (bind (pat0 pat1 ...) (list seq0 seq1 ...) xpr . xprs))
    570     ((_ loop () xpr . xprs)
    571      (let loop () xpr . xprs))
    572     ((_ loop ((pat0 seq0) ...) xpr . xprs)
    573      (bind* loop (pat0 ...) (list seq0 ...) xpr . xprs))))
     967     `(begin ,xpr ,@xprs))
     968    ((_ ((pat0 seq0) . pat-seq-pairs) xpr . xprs)
     969     `(bind
     970        ,(cons pat0 (map car pat-seq-pairs))
     971        (list ,seq0 ,@(map cadr pat-seq-pairs))
     972        ,xpr ,@xprs))
     973    ))
    574974
    575975#|[
     
    585985]|#
    586986
    587 ;;; (bind-let* ((pat seq) ...) xpr . xprs)
    588 ;;; --------------------------------------
     987;;; (bind-let* ((pat seq) ...) xpr ....)
     988;;; -------------------------------------
    589989;;; sequential version of bind-let
    590990(define-syntax bind-let*
    591   (syntax-rules ()
     991  (macro-rules ()
    592992    ((_ () xpr . xprs)
    593      (let () xpr . xprs))
    594     ((_ ((pat seq) . pairs) xpr . xprs)
    595      (bind pat seq (bind-let* pairs xpr . xprs)))))
     993     `(let () ,xpr ,@xprs))
     994    ((_ ((pat seq) . pat-seq-pairs) xpr . xprs)
     995     `(bind ,pat ,seq (bind-let* ,pat-seq-pairs ,xpr ,@xprs)))))
     996
     997#|[
     998And here is the recursive version of bind.
     999
     1000  (bindrec ((o?) e?)
     1001    (list (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
     1002          (lambda (n) (if (zero? n) #t (o? (- n 1)))))
     1003    (list (o? 95) (e? 95)))
     1004  -> '(#t #f)
     1005]|#
     1006
     1007;;; (bindrec pat seq (where . fenders) .. xpr ....)
     1008;;; -----------------------------------------------
     1009;;; recursive version of bind
     1010(define-macro (bindrec pat seq xpr . xprs)
     1011  `(bind ,pat ',pat
     1012     ; bind pattern variables to auxiliary values
     1013     ; so that they are in scope
     1014     (bind-set! ,pat ,seq)
     1015     ; set! the real values
     1016     ,xpr ,@xprs))
    5961017
    5971018#|[
     
    6071028]|#
    6081029
    609 ;;; (bind-letrec ((pat seq) ...) xpr . xprs)
    610 ;;; ----------------------------------------
     1030;;; (bind-letrec ((pat seq) ...) xpr ....)
     1031;;; ---------------------------------------
    6111032;;; recursive version of bind-let
    612 (define-syntax-rule (bind-letrec ((pat seq) ...) xpr . xprs)
    613   (bindrec (pat ...) (list seq ...) xpr . xprs))
    614 
    615 #|[
    616 The following macro does more or less the same what the match macro from
    617 the matchable package does, for example
    618 
    619   (bind-case '(1 (2 3))
    620     ((x y) (where (list? y)) (list x y))
    621     ((x (y . z)) (list x y z))
    622     ((x (y z)) (list x y z))) ;-> '(1 2 (3))
    623 
    624 or, to give a more realistic example, mapping:
    625 
    626   (define (my-map fn lst)
    627     (bind-case lst
    628       (() '())
    629       ((x . xs) (cons (fn x) (my-map fn xs)))))
    630 ]|#
    631 
    632 ;;; (bind-case seq (pat (where . fenders) .. xpr . xprs) ....)
    633 ;;; ----------------------------------------------------------
    634 ;;; Checks if seq matches pattern pat [satisfying fenders] ....
    635 ;;; in sequence, binds the pattern variables of the first matching
    636 ;;; pattern to corresponding subexpressions of seq and executes
    637 ;;; corresponding body xpr . xprs
    638 (define-syntax bind-case
    639   (syntax-rules (where)
    640     ((_ seq (pat (where . fenders) xpr . xprs) . clauses)
    641      (condition-case
    642        (bind pat seq (where . fenders) xpr . xprs)
    643        ((exn bind) (bind-case seq . clauses))))
    644     ((_ seq (pat xpr . xprs) . clauses)
    645      (condition-case
    646        (bind pat seq xpr . xprs)
    647        ((exn bind) (bind-case seq . clauses))))
    648     ((_ seq)
    649      (signal (bind-exception 'bind-case
    650                              "no rule matches"
    651                              seq)))
    652     ))
     1033(define-macro (bind-letrec pat-seq-pairs xpr . xprs)
     1034  `(bindrec ,(map car pat-seq-pairs)
     1035     (list ,@(map cadr pat-seq-pairs))
     1036     ,xpr ,@xprs))
    6531037
    6541038#|[
     
    6721056]|#
    6731057
    674 ;;; (bind-case-lambda (pat (where . fenders) .. xpr . xprs) ....)
    675 ;;; -------------------------------------------------------------
     1058;;; (bind-case-lambda (pat (where . fenders) .. xpr ....) ....)
     1059;;; ------------------------------------------------------------
    6761060;;; combination of lambda and bind-case, one pattern argument
    6771061(define-syntax bind-case-lambda
    678   (syntax-rules (where)
    679     ((_ (pat (where . fenders) xpr . xprs))
    680      (lambda (x) (bind pat x (where . fenders) xpr . xprs)))
     1062  (macro-rules ()
    6811063    ((_ (pat xpr . xprs))
    682      (lambda (x) (bind pat x xpr . xprs)))
     1064     `(lambda (x) (bind ,pat x ,xpr ,@xprs)))
    6831065    ((_ clause . clauses)
    684      (lambda (x)
    685        (bind-case x clause . clauses)))))
    686 
    687 ;;; (bind-case-lambda* (pat (where . fenders) .. xpr . xprs) ....)
    688 ;;; --------------------------------------------------------------
     1066     `(lambda (x)
     1067       (bind-case x ,clause ,@clauses)))))
     1068
     1069;;; (bind-case-lambda* (pat (where . fenders) .. xpr ....) ....)
     1070;;; -------------------------------------------------------------
    6891071;;; combination of lambda and bind-case, multiple pattern arguments
    6901072(define-syntax bind-case-lambda*
    691   (syntax-rules (where)
    692     ((_ (pat (where . fenders) xpr . xprs))
    693      (lambda x (bind pat x (where . fenders) xpr . xprs)))
     1073  (macro-rules ()
    6941074    ((_ (pat xpr . xprs))
    695      (lambda x (bind pat x xpr . xprs)))
     1075     `(lambda x (bind ,pat x ,xpr ,@xprs)))
    6961076    ((_ clause . clauses)
    697      (lambda x
    698        (bind-case x clause . clauses)))))
     1077     `(lambda x
     1078       (bind-case x ,clause ,@clauses)))))
     1079
     1080#|[
     1081The following macro is sometimes named let/cc or let-cc
     1082]|#
    6991083
    7001084;;; (bind/cc cc xpr ....)
     
    7021086;;; captures the current continuation, binds it to cc and executes
    7031087;;; xpr .... in this context
    704 (define-syntax-rule (bind/cc cc xpr . xprs)
    705   (call-with-current-continuation
    706     (lambda (cc) xpr . xprs)))
    707 
    708 #|[
    709 Now we'll use macro-helpers and binding-macros to implement macros,
    710 which implement macros. The first, macro-rules, is a low-level version
    711 of syntax-rules. It is as convenient as the latter, but much more
    712 powerfull. For example, it can use injected symbols, do some of its work
    713 at compile-time, use local functions at compile-time and what have you.
    714 Contrary to syntax-rules the templates usually evaluate to quasiquoted
    715 expressions.
    716 ]|#
    717 
    718 ;;; (macro-rules sym ... (key ...)
    719 ;;;   (pat tpl) ....)
    720 ;;; ------------------------------
    721 ;;; where sym ... are injected non-hygienig symbols, key ... are
    722 ;;; additional keywords, pat ....  are nested lambda-lists without
    723 ;;; spezial meaning of ellipses and tpl .... evaluate to
    724 ;;; quasiquoted templates.
    725 (define-syntax macro-rules
    726   (ir-macro-transformer
    727     (lambda (f i c?)
    728       ;; injections is list of injected syms, tail starts with keyword-list
    729       (receive (tail injections)
    730         (let loop ((tail (cdr f)) (injections '()))
    731           (if (list? (car tail)) ; keyword list
    732             (values tail injections)
    733             (loop (cdr tail) (cons (car tail) injections))))
    734           (let ((keywords (car tail))
    735                 (rules (cdr tail))
    736                 (inject-sym (lambda (h) `(,h (inject ',h)))))
    737             (if (null? rules)
    738               `(signal (bind-exception 'macro-rules "no rule matches"))
    739               (let (
    740                 (once? (lambda (x) (and (pair? x) (c? (car x) 'once))))
    741                 (extract-keywords
    742                   (lambda (r) (extract (lambda (y) (memq y keywords)) r)))
    743                 (process-injections
    744                   (lambda (binds)
    745                     (if (null? injections)
    746                       binds
    747                       `(let ,(map inject-sym injections)
    748                          ,binds))))
    749                 )
    750                 (let (
    751                   (process-keywords
    752                     (lambda (r)
    753                       ;; doesn't work whith where clauses
    754                       ;`(,(car r)
    755                       ;   (where ,@(map (lambda (p s) `(compare? ,p ,s))
    756                       ;                 (extract-keywords (cddar r))
    757                       ;                 (map (lambda (x) `',x)
    758                       ;                      (extract-keywords (cddar r)))))
    759                       ;   ,@(cdr r))))
    760                       (let* ((kws (extract-keywords (cddar r)))
    761                              ;; compare? keywords with its names
    762                              (keys (map (lambda (p s) `(compare? ,p ,s))
    763                                           kws (map (lambda (x) `',x) kws)))
    764                              ;; add keyword-clauses to where-clauses
    765                              (wheres (if (c? (caadr r) 'where)
    766                                        (append keys (cdadr r))
    767                                        keys)))
    768                         ;; replace first item in template
    769                         `(,(car r)
    770                              (where ,@wheres)
    771                            ,@(if (null? (cddr r)) (cdr r) (cddr r))))))
    772                   (process-onces
    773                     (lambda (r)
    774                       (let ((args (cdar r)))
    775                         (if (found? once? args)
    776                           (let (
    777                             (osyms (map cadr (collect* once? args)))
    778                             (vars (replace* once? cadr args))
    779                             )
    780                             `((_ ,@vars) (once-only ,osyms ,@(cdr r))))
    781                           `((_ ,@args) ,@(cdr r))))))
    782                   (process-wrapper
    783                     (lambda (binds)
    784                       `(ir-macro-transformer
    785                          (lambda (form inject compare?)
    786                            ,(process-injections binds)))))
    787                   )
    788                   (if (null? keywords)
    789                     (process-wrapper
    790                       `(bind-case form ,@(map process-onces rules)))
    791                     (process-wrapper
    792                       `(bind-case form
    793                          ,@(map process-keywords
    794                                 (map process-onces rules)))))))))))))
    795 
    796 ;;; (define-macro (name . args)
    797 ;;;   (inject sym ...) ..
    798 ;;;   (keywords key ...) ..
    799 ;;;   xpr ....)
    800 ;;; ---------------------------
    801 (define-syntax define-macro
    802   (syntax-rules (inject keywords macro-rules)
    803     ;; without injections
    804     ((_ name (macro-rules (key ...) xpr . xprs))
    805      (define-syntax name
    806        (macro-rules (key ...) xpr .  xprs)))
    807     ;; with injections
    808     ((_ name (macro-rules syms keys xpr . xprs))
    809      (define-syntax name
    810        (macro-rules syms keys xpr .  xprs)))
    811     ((_ (name . args) (inject sym ...) (keywords key ...) xpr . xprs)
    812      (define-syntax name
    813        (macro-rules sym ... (key ...) ((_ . args) xpr . xprs))))
    814     ((_ (name . args) (keywords key ...) (inject sym ...) xpr . xprs)
    815      (define-syntax name
    816        (macro-rules sym ... (key ...) ((_ . args) xpr . xprs))))
    817     ((_ (name . args) (inject sym ...) xpr . xprs)
    818      (define-syntax name
    819        (macro-rules sym ... () ((_ . args) xpr . xprs))))
    820     ((_ (name . args) (keywords key ...) xpr . xprs)
    821      (define-syntax name
    822        (macro-rules (key ...) ((_ . args) xpr . xprs))))
    823     ((_ (name . args) xpr . xprs)
    824      (define-syntax name
    825        (macro-rules () ((_ . args) xpr . xprs))))))
    826 
    827 ;;; (let-macro ((name macro-rules-xpr) ....) xpr ....)
    828 ;;; --------------------------------------------------
    829 ;;; binds macro-rules-xpr .... locally and in parallel to name ....
    830 ;;; and executes xpr .... in this context
    831 (define-syntax let-macro
    832   (ir-macro-transformer
    833     (lambda (f i c?)
    834       (let ((bindings (cadr f))
    835             (body (cddr f)))
    836         (let ((names (map car bindings))
    837               (rules (map cadr bindings)))
    838         (let ((names (map car bindings))
    839               (rules (map cadr bindings)))
    840           (let loop ((lst (map car rules)))
    841             (cond
    842               ((null? lst)
    843                `(let-syntax ,(map (lambda (n r) `(,n ,r))
    844                                   names rules)
    845                             ,@body))
    846               ((c? (car lst) 'macro-rules)
    847                (loop (cdr lst)))
    848               (else
    849                 `(signal (bind-exception 'letrec-macro "no rule matches")))))))))))
    850 
    851 ;;; (letrec-macro ((name macro-rules-xpr) ....) xpr ....)
    852 ;;; -----------------------------------------------------
    853 ;;; binds macro-rules-xpr .... locally and recursively to name ....
    854 ;;; and executes xpr .... in this context
    855 (define-syntax letrec-macro
    856   (ir-macro-transformer
    857     (lambda (f i c?)
    858       (let ((bindings (cadr f))
    859             (body (cddr f)))
    860         (let ((names (map car bindings))
    861               (rules (map cadr bindings)))
    862           (let loop ((lst (map car rules)))
    863             (cond
    864               ((null? lst)
    865                `(letrec-syntax ,(map (lambda (n r) `(,n ,r))
    866                                      names rules)
    867                                ,@body))
    868               ((c? (car lst) 'macro-rules)
    869                (loop (cdr lst)))
    870               (else
    871                 `(signal (bind-exception 'letrec-macro "no rule matches"))))))))))
    872 
    873 ;;; (define-er-macro (name . args)
    874 ;;;   (rename-prefix pre)   ;;;
    875 ;;;   (keywords key ...) ..
    876 ;;;   xpr ....)
    877 ;;; ------------------------------
    878 (define-syntax define-er-macro
    879   (ir-macro-transformer
    880     (lambda (f i c?)
    881       (let ((code (cadr f))
    882             (body (cddr f))
    883             (once? (lambda (x)
    884                      (and (pair? x) (c? (car x) 'once))))
    885             (pre (rename-prefix)))
    886         (let (
    887           (name (car code))
    888           (args (cdr code))
    889           (keywords? (c? (caar body) 'keywords))
    890           )
    891           (let (
    892             (process-renames
    893               (lambda (b)
    894                 (map (lambda (s)
    895                         `(,s (rename
    896                                ',(strip-prefix pre
    897                                                (i s)))))
    898                       (extract (prefixed-with? pre) b))))
    899             (process-keywords
    900               (lambda (vs ks)
    901                 (if keywords?
    902                   `(and ,@(map (lambda (x y) `(compare? ,x ,y))
    903                                (extract (lambda (a) (memq a ks))
    904                                         (cdr vs))
    905                                (map (lambda (b) `',b)
    906                                     (extract (lambda (a) (memq a ks))
    907                                              (cdr vs)))))
    908                    #t)))
    909             (process-wrapper
    910               (lambda (binds)
    911                 `(define-syntax ,name
    912                    (er-macro-transformer
    913                      (lambda (form rename compare?)
    914                        (condition-case
    915                          ,binds
    916                          ((exn bind)
    917                           (signal (bind-exception 'define-er-macro
    918                                                   "no match")))))))))
    919             )
    920             (let ((keys (if keywords? (cdar body) '()))
    921                   (body (if keywords? (cdr body) body)))
    922               (if (found? once? args)
    923                 (let ((osyms (map cadr (collect* once? args)))
    924                       (vars (replace* once? cadr args)))
    925                   (process-wrapper
    926                     `(dbind ,vars
    927                             (cdr form)
    928                             ,(process-keywords vars keys)
    929                             (let ,(process-renames body)
    930                               (once-only ,osyms ,@body)))))
    931                 (process-wrapper
    932                   `(dbind ,args
    933                           (cdr form)
    934                           ,(process-keywords args keys)
    935                           (let ,(process-renames body)
    936                             ,@body)))))))))))
    937 
    938 ;;; (letrec-er-macro ((macro-code tpl) ...) . body)
    939 ;;; -----------------------------------------------
    940 ;;; defines local macros by binding recursively macro-codes to templates
    941 ;;; and evaluating body in this context.
    942 (define-syntax letrec-er-macro
    943   (er-macro-transformer
    944     (lambda (f r c?)
    945       (let ((binds (cadr f))
    946             (body (cddr f))
    947             (%letrec-syntax (r 'letrec-syntax)))
    948         `(,%letrec-syntax
    949            ,(map (lambda (m)
    950                    `(,(cadr m) ,(caddr m)))
    951                  (map (lambda (b)
    952                         (expand `(define-er-macro ,@b)))
    953                       binds))
    954            ,@body)))))
    955 
    956 ;;; (let-er-macro ((macro-code tpl) ...) . body)
    957 ;;; -----------------------------------------
    958 ;;; defines local macros by binding in parallel macro-codes to templates
    959 ;;; and evaluating body in this context.
    960 (define-syntax let-er-macro
    961   (er-macro-transformer
    962     (lambda (f r c?)
    963       (let ((binds (cadr f))
    964             (body (cddr f))
    965             (%let-syntax (r 'let-syntax)))
    966         `(,%let-syntax
    967            ,(map (lambda (m)
    968                    `(,(cadr m) ,(caddr m)))
    969                  (map (lambda (b)
    970                         (expand `(define-er-macro ,@b)))
    971                       binds))
    972            ,@body)))))
    973 
    974 ) ; module bindings
    975 
     1088(define-macro (bind/cc cc xpr . xprs)
     1089  `(call-with-current-continuation
     1090     (lambda (,cc) ,xpr ,@xprs)))
     1091
     1092;;; (more-bindings sym ..)
     1093;;; ----------------------
     1094;;; documentation procedure
     1095(define more-bindings
     1096  (symbol-dispatcher '(
     1097    (bindable?
     1098      macro:
     1099      (bindable? pat (where . fenders) ..)
     1100      "returns a unary predicate, which checks"
     1101      "if its argument matches pat and passes all fenders")
     1102    (bind-set!
     1103      macro:
     1104      (bind-set! pat seq)
     1105      "sets multiple variables by destructuring its sequence argument")
     1106    (bind-define
     1107      macro:
     1108      (bind-define pat seq)
     1109      "defines multiple variables by destructuring its sequence argument")
     1110    (bind-lambda
     1111      macro:
     1112      (bind-lambda pat (where . fenders) .. xpr ....)
     1113      "combination of lambda and bind, one pattern argument")
     1114    (bind-lambda*
     1115      macro:
     1116      (bind-lambda* pat (where . fenders) .. xpr ....)
     1117      "combination of lambda and bind, multiple pattern arguments")
     1118    (bind*
     1119      macro:
     1120      (bind* loop pat seq (where . fenders) .. xpr ....)
     1121      "named version of bind")
     1122    (bind-let
     1123      macro:
     1124      (bind-let loop .. ((pat seq) ...) xpr ....)
     1125      "nested version of let, named and unnamed")
     1126    (bind-let*
     1127      macro:
     1128      (bind-let* ((pat seq) ...) xpr ....)
     1129      "nested version of let*")
     1130    (bindrec
     1131      macro:
     1132      (bindrec pat seq (where . fenders) .. xpr ....)
     1133      "recursive version of bind")
     1134    (bind-letrec
     1135      macro:
     1136      (bind-letrec ((pat seq) ...) xpr ....)
     1137      "recursive version of bind-let")
     1138    (bind-case-lambda
     1139      macro:
     1140      (bind-case-lambda (pat (where . fenders) .. xpr ....) ....)
     1141      "combination of lambda and bind-case with one pattern argument")
     1142    (bind-case-lambda*
     1143      macro:
     1144      (bind-case-lambda* (pat (where . fenders) .. xpr ....) ....)
     1145      "combination of lambda and bind-case with multiple pattern arguments")
     1146    (bind/cc
     1147      macro:
     1148      (bind/cc cc xpr ....)
     1149      "binds cc to the current contiunation"
     1150      "and execute xpr ... in this context")
     1151    )))
     1152
     1153) ; more-bindings
     1154
     1155#|[
     1156And now we put all three modules into one for convenience
     1157]|#
     1158
     1159(module bindings *
     1160  (import scheme
     1161          (only chicken case-lambda error)
     1162          basic-bindings macro-bindings more-bindings)
     1163  (reexport basic-bindings macro-bindings more-bindings)
     1164
     1165;;; (bindings sym ..)
     1166;;; -----------------
     1167;;; documentation procedure.
     1168(define bindings
     1169  (let ((lst (append (basic-bindings)
     1170                     (macro-bindings)
     1171                     (more-bindings))))
     1172    (case-lambda
     1173      (() lst)
     1174      ((sym)
     1175       (cond
     1176         ((memq sym (basic-bindings))
     1177          (basic-bindings sym))
     1178         ((memq sym (macro-bindings))
     1179          (macro-bindings sym))
     1180         ((memq sym (more-bindings))
     1181          (more-bindings sym))
     1182         (else
     1183           (error "Not in list" sym lst)))))))
     1184) ; bindings
     1185
  • release/4/bindings/trunk/bindings.setup

    r32486 r32912  
    11;;;; bindings.setup -*- Scheme -*-
    22
    3 (compile -O3 -s -d1 macro-helpers.scm -J)
    4 (compile -O3 -d0 -s macro-helpers.import.scm)
    53(compile -O3 -s -d1 bindings.scm -J)
     4(compile -O3 -d0 -s basic-bindings.import.scm)
     5(compile -O3 -d0 -s macro-bindings.import.scm)
     6(compile -O3 -d0 -s more-bindings.import.scm)
    67(compile -O3 -d0 -s bindings.import.scm)
    78
    89(install-extension
    910 'bindings
    10  '("bindings.so" "bindings.import.so" "macro-helpers.so" "macro-helpers.import.so")
    11  '((version "3.5.2.2")))
    12 
     11 '("bindings.so" "basic-bindings.import.so" "macro-bindings.import.so"
     12   "more-bindings.import.so" "bindings.import.so")
     13 '((version "4.0")))
  • release/4/bindings/trunk/tests/run.scm

    r32481 r32912  
    33;;;; ju (at) jugilo (dot) de
    44
    5 (require-library tuples simple-tests)
    6 
    7 (import bindings (except macro-helpers atom? flatten)
    8         (only tuples tuple tuple? tuple-length tuple-ref tuple-from-upto)
    9         (only chicken error)
    10         simple-tests)
    11 (import-for-syntax
    12   (only bindings macro-rules)
    13   (only macro-helpers once-only with-gensyms))
     5(require-library bindings arrays simple-tests)
     6
     7(import simple-tests
     8        (only arrays array array? array-length array-item array-drop
     9              array->list)
     10        (except bindings macro-rules once-only with-gensyms)
     11        )
     12(import-for-syntax (only bindings macro-rules once-only with-gensyms))
    1413
    1514
    1615(compound-test (bindings)
    17 
    18   (define-test (helpers?)
    19     (check
    20       (equal? (flatten '(a (b c (d))))
    21               '(a b c d))
    22       (equal? (memp odd? '(2 4 3 1))
    23               '(3 1))
    24       (not (assp odd? '((0 1) (0 2) (0 3))))
    25       (equal? (assp odd? '((0 1) (1 2) (2 3)))
    26               '(1 2))
    27       (equal? (filter odd? '(2 4 3 6 1 0))
    28               '(3 1))
    29       (equal? (filter* odd? '(1 (2 (3 . 4) . 5) . 6))
    30               '(1 ((3) . 5)))
    31       (equal? (collect* (lambda (x) (and (number? x) (odd? x)))
    32                         '(1 (2 (3 . 4) . 5) . 6))
    33               '(1 3 5))
    34       (equal? (adjoin 'x '(a b c))
    35               '(x a b c))
    36       (equal? (adjoin 'x '(a b x c))
    37               '(a b x c))
    38       (equal? (remove-duplicates '(a b c b a d))
    39               '(a b c d))
    40       (eq? (strip-prefix 'x 'xabc) 'abc)
    41       (eq? (strip-suffix 'x 'abcx) 'abc)
    42       (eq? (add-prefix 'x 'abc) 'xabc)
    43       ((prefixed-with? 'x) 'xabc)
    44       (not ((prefixed-with? 'x) 'abc))
    45       (equal? (extract odd? '(1 2 (3 4 (5 6))))
    46               '(1 3 5))
    47       (equal? (extract (prefixed-with? 'x)
    48                        '(abc (xab yd (ya xb))))
    49               '(xab xb))
    50       (equal? (map* + '(1 (2 . 3) . 4) '(10 (20 . 30) . 40))
    51               '(11 (22 . 33) . 44))
    52       (equal? (flatten-map* + '(1 (2 . 3) . 4) '(10 (20 . 30) . 40))
    53               '(11 22 33 44))
    54       (equal?
    55         (replace* (lambda (x) (and (atom? x) (not (null?  x)) (odd? x)))
    56                   (lambda (x) (* 10 x))
    57                   '(0 (1 (2 . 3))))
    58         '(0 (10 (2 . 30))))
    59       (= (plist-tail '(0 1 2 . 3) 3) 3)
    60       (= (ptail '(0 1 2 . 3)) 3)
    61       (equal? (phead '(0 1 2 . 3)) '(0 1 2))
    62       (equal? (plist-head '(0 1 2 . 3) 3) '(0 1 2))
    63       (equal? (vector-tail '#(0 1 2 3) 4) '#())
    64       (equal? (vector-tail '#(0 1 2 3) 0) '#(0 1 2 3))
    65       (equal? (vector-head '#(0 1 2 3) 0) '#())
    66       (equal? (vector-head '#(0 1 2 3) 4) '#(0 1 2 3))
    67       (atom? '#(1))
    68       ((list-of atom?) '(#() #(1) #(0 1)))
    69       ((list-of number? positive?) '(1 2 3))
    70       ((list-of) '(1 2 3))
    71       (not ((list-of number? positive?) '(1 -2 3)))
    72       ))
    73   (helpers?)
    74 
    75   (define-test (sequences?)
    76     (check
    77       "ADD TUPLES TO GENERIC SEQUENCES"
    78       (seq-length-ref-tail! tuple?
    79                             tuple-length
    80                             tuple-ref
    81                             tuple-from-upto)
    82       (equal? (bind (x y z) (tuple 1 2 3) (list x y z)) '(1 2 3))
    83       (equal? (bind (x (y z)) (vector 0 (tuple 1 2)) (list x y z)) '(0 1 2))
    84       (equal? (bind (x (y (z))) (vector 0 (tuple 1 "2")) (list x y z))
    85               '(0 1 #\2))
    86       ))
    87   (sequences?)
    8816
    8917  (define-test (bind?)
     
    14270            (loop (vector (- x 1) (+ y 1)))))
    14371        '#(0 5))
     72      "ADD ARRAYS TO GENERIC SEQUENCES"
     73      (bind-table-add!  array?
     74                        array-length
     75                        (lambda (seq k)
     76                          (array-item k seq))
     77                        (lambda (seq k)
     78                          (array-drop k seq)))
     79
     80      (equal?
     81        (bind (x y z) (array 1 2 3) (list x y z))
     82        '(1 2 3))
     83
     84      (equal?
     85        (bind (x (y z)) (vector 0 (array 1 2)) (list x y z))
     86        '(0 1 2))
     87
     88      (equal?
     89        (bind (x (y . z)) (vector 0 (array 1 2 3 4))
     90          (list x y (array->list z)))
     91        '(0 1 (2 3 4)))
     92
    14493      ))
    14594  (bind?)
     
    14897    (check
    14998      (not ((bindable? (x)) '(name 1)))
    150       (not ((bindable? (x y) (number? x)) '(name 1)))
     99      (not ((bindable? (x y) (where (number? x))) '(name 1)))
    151100      ((bindable? (_ x)) '(name 1))
    152101      (not ((bindable? (_ x)) '(name 1 2)))
    153       (not ((bindable? (_ x y) (symbol? x)) '(name 1 2)))
    154       ((bindable? (a b) (odd? a)) '#(1 2))
    155       (not ((bindable? (x (y z)) (char-alphabetic? y)) '(1 "23")))
     102      (not ((bindable? (_ x y) (where (symbol? x))) '(name 1 2)))
     103      ((bindable? (a b) (where (odd? a))) '#(1 2))
     104      (not ((bindable? (x (y z)) (where (char-alphabetic? y))) '(1 "23")))
    156105      ((bindable? (x (y . z))) '(1 "23"))
    157106      ((bindable? (x y)) '(1 "23"))
     
    240189                          (my-map fn xs)))))
    241190      (equal? (my-map add1 '#(1 2 3)) '(2 3 4))
     191
    242192      "NON-SYMBOL LITERALS"
    243193      (bind-case '#("a") ((#f) #f) (("a") #t))
     
    277227         '#(0 2 3 4 5))
    278228        '#(2 3 4 5))
     229;      (equal? ; wrong string after dot
     230;        ((bind-case-lambda
     231;           ((e . f) (where (zero? e)) e)
     232;           ((a (b . "c") . d) (list a b d))
     233;           ((e . f) (list e f)))
     234;         '(1 (2 . "c") 4 5))
     235;        '(1 2 (4 5)))
    279236      (equal?
    280237        ((bind-case-lambda
    281238           ((e . f) (where (zero? e)) e)
    282            ((a (b . "c") . d) (list a b d))
     239           ((a (b "c") . d) (list a b d))
    283240           ((e . f) (list e f)))
    284          '(1 (2 . "c") 4 5))
     241         '(1 (2 "c") 4 5))
    285242        '(1 2 (4 5)))
    286243      (equal?
     
    304261      ))
    305262  (lambdas?)
    306 
     263;
    307264  (define-test (lets?)
    308265    (check
     
    411368  (define-test (macros?)
    412369    (check
    413       (define-er-macro (efreeze . body)
    414         `(,%lambda () ,@body))
    415       (= ((efreeze 1 2 3)) 3)
    416 
    417       (define-er-macro (osquare (once x)) `(,%* ,x ,x))
    418       (= (let ((x 5)) (osquare ((lambda () (set! x (* x 10)) x))))
    419          2500)
    420       (define-er-macro (square x) `(,%* ,x ,x))
    421       (= (let ((x 5)) (square ((lambda () (set! x (* x 10)) x))))
    422          25000)
    423       (define-macro (foo (qux))
    424         (keywords bar baz)
    425         `(case ',qux
    426            ((bar baz) ',qux)
    427            (else 'no)))
    428       (eq? (foo (bar)) 'bar)
    429       (eq? (foo (baz)) 'baz)
    430       (eq? (foo (qux)) 'no)
    431       (define-macro (nif (once xpr) pos zer neg)
    432         `(cond
    433            ((positive? ,xpr) ,pos)
    434            ((negative? ,xpr) ,neg)
    435            (else ,zer)))
     370      (define-macro (nif xpr pos zer neg)
     371        (once-only (xpr)
     372      ;(define-macro (nif (once xpr) pos zer neg)
     373          `(cond
     374             ((positive? ,xpr) ,pos)
     375             ((negative? ,xpr) ,neg)
     376             (else ,zer))))
    436377      (eq? (nif 2 'positive 'zero 'negative) 'positive)
    437378      (define-macro (freeze xpr)
     
    442383      (equal? (let ((x 'x) (y 'y)) (swap! x y) (list x y))
    443384              '(y x))
    444       (= (let-er-macro (((freeze xpr) `(,%lambda () ,xpr)))
    445            ((freeze 3)))
    446          3)
    447       (= (letrec-er-macro (((second lst) `(,%car (,%rest ,lst)))
    448                            ((rest lst) `(,%cdr ,lst)))
    449           (second '(1 2 3)))
    450         2)
    451       (= (letrec-macro ((second (macro-rules ()
    452                                   ((_ lst) `(,car (rest ,lst)))))
    453                         (rest (macro-rules ()
    454                                 ((_ lst) `(,cdr ,lst)))))
    455            (second '(1 2 3)))
     385      (= (letrec-syntax (
     386           (sec (macro-rules ()
     387                     ((_ lst) `(car (res ,lst)))))
     388           (res (macro-rules ()
     389                   ((_ lst) `(cdr ,lst))))
     390           )
     391           (sec '(1 2 3)))
    456392         2)
    457       (letrec-macro ((odd? (macro-rules ()
    458                              ((_ n) `(if ,(negative? n) #f ,(even?
    459                                                               (- n 1))))))
    460                      (even? (macro-rules ()
    461                               ((_ n) `(if ,(zero? n) #t ,(odd? (- n 1)))))))
    462                     (even?  286))
     393      (= (macro-letrec (
     394           ((sec lst) `(car (res ,lst)))
     395           ((res lst) `(cdr ,lst))
     396           )
     397           (sec '(1 2 3))))
     398      (= (macro-let (
     399           ((fir lst) (where (list? lst)) `(car ,lst))
     400           ((res lst) (where (list? lst)) `(cdr ,lst))
     401           )
     402           (fir (res '(1 2 3))))
     403         2)
    463404
    464405      "LITERALS"
    465       (define-macro foo
     406      (define-syntax foo
    466407        (macro-rules ()
    467408          ((_ "foo" x) x)
     
    487428
    488429      "VERBOSE IFS"
    489       (define-er-macro (verbose-if test (then . xprs) (else . yprs))
    490         (keywords then else)
    491         `(,%if ,test
    492            (,%begin ,@xprs)
    493            (,%begin ,@yprs)))
    494       (define (quux x)
    495         (verbose-if (odd? x) (then "odd") (else "even")))
    496       (equal? (quux 3) "odd")
    497       (equal? (quux 4) "even")
    498       (define-syntax-rule (sr-vif test (then . xprs) (else . yprs))
    499         (keywords then else)
    500         (if test
    501           (begin . xprs)
    502           (begin . yprs)))
    503       (eq? (sr-vif (odd? 5) (then 1 'odd) (else 2 'even)) 'odd)
    504       (eq? (sr-vif (odd? 6) (then 1 'odd) (else 2 'even)) 'even)
    505       (define-macro vif
     430      (define-syntax vif
     431        (macro-rules (then else)
     432          ((_ test (then xpr . xprs))
     433           `(if ,test
     434              (begin ,xpr ,@xprs)))
     435          ((_ test (else xpr . xprs))
     436           `(if ,(not test)
     437              (begin ,xpr ,@xprs)))
     438          ((_ test (then xpr . xprs) (else ypr . yprs))
     439           `(if ,test
     440              (begin ,xpr ,@xprs)
     441              (begin ,ypr ,@yprs)))))
     442      (pe '
    506443        (macro-rules (then else)
    507444          ((_ test (then xpr . xprs))
     
    522459      (eq? (pux) 'false)
    523460     
    524       "LOW-LEVEL COND"
    525       (define-macro my-cond
     461      "PROCEDURAL COND"
     462      (define-syntax my-cond
    526463        (macro-rules (else =>)
    527464          ((_ (else xpr . xprs))
     
    578515
    579516      "ANAPHORIC MACROS"
    580       (define-macro (alambda args xpr . xprs)
    581         (inject self)
    582         `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
    583            ,self))
     517      (define-syntax alambda
     518        (macro-rules self ()
     519          ((_ args xpr . xprs)
     520           `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
     521              ,self))))
    584522      (define ! (alambda (n) (if (zero? n) 1 (* n (self (- n 1))))))
    585523      (= (! 5) 120)
    586       (define-macro aif
     524      (define-syntax aif
    587525        (macro-rules it ()
    588526          ((_ test consequent)
     
    599537  (define-test (etc?)
    600538    (check
    601       (define-syntax-rule (freeze x) (lambda () x))
    602       (= ((freeze 25)) 25)
     539      "ONCE-ONLY"
    603540      (define-macro (square x)
    604541        (once-only (x)
     542      ;(define-macro (square (once x))
    605543          `(* ,x ,x)))
    606544      (let ((n 4))
    607545        (= (square (begin (set! n (+ n 1)) n)) 25))
     546      (define counter ; used for side-effects
     547        (let ((state 0))
     548          (lambda ()
     549            (set! state (+ state 1))
     550            state)))
     551      (= (square (counter)) 1)
     552      (= (square (counter)) 4)
     553      (= (square (counter)) 9)
    608554
    609555      (define-macro (for (var start end) . body)
     
    612558                 ((= ,var ,end))
    613559                 ,@body)))
    614       (define counter
    615         (let ((state 0))
    616           (lambda ()
    617             (set! state (+ state 1))
    618             state)))
    619       (let ((lst '()))
    620         (for (x 0 (counter)) (set! lst (cons x lst)))
    621         (equal? lst '(0)))
    622560      (define-macro (times a b)
    623561        (with-gensyms (x y)
Note: See TracChangeset for help on using the changeset viewer.