1: ;;
    2: ;; SRFI-26
    3: ;;  $Id: srfi-26.scm,v 1.1 2002/06/27 03:17:08 shirok Exp $
    4: 
    5: ;; This implementation is taken from http://srfi.schemers.org/srfi-26/
    6: ;; As shown below, originally written by Al Petrofsky and modified by
    7: ;; Sebastian Egner.  Shiro Kawai adapted it for Gauche module system.
    8: 
    9: (define-module srfi-26
   10:   (export cut cute))
   11: (select-module srfi-26)
   12: 
   13: ; REFERENCE IMPLEMENTATION FOR SRFI-26 "CUT"
   14: ; ==========================================
   15: ;
   16: ; Sebastian.Egner@philips.com, 5-Jun-2002.
   17: ; adapted from the posting by Al Petrofsky <al@petrofsky.org>
   18: ;
   19: ; The code to handle the variable argument case was originally
   20: ; proposed by Michael Sperber and has been adapted to the new
   21: ; syntax of the macro using an explicit rest-slot symbol. The
   22: ; code to evaluate the non-slots for cute has been proposed by
   23: ; Dale Jordan. The code to allow a slot for the procedure position
   24: ; and to process the macro using an internal macro is based on 
   25: ; a suggestion by Al Petrofsky. The code found below is, with
   26: ; exception of this header and some changes in variable names,
   27: ; entirely written by Al Petrofsky.
   28: ;
   29: ; compliance:
   30: ;   Scheme R5RS (including macros).
   31: ;
   32: ; loading this file into Scheme 48 0.57:
   33: ;   ,load cut.scm
   34: ;
   35: ; history of this file:
   36: ;   SE,  6-Feb-2002: initial version as 'curry' with ". <>" notation
   37: ;   SE, 14-Feb-2002: revised for <...>
   38: ;   SE, 27-Feb-2002: revised for 'cut'
   39: ;   SE, 03-Jun-2002: revised for proc-slot, cute
   40: ;   SE, 04-Jun-2002: rewritten with internal transformer (no "loop" pattern)
   41: ;   SE, 05-Jun-2002: replace my code by Al's; substituted "constant" etc.
   42: ;     to match the convention in the SRFI-document
   43: 
   44: ; (srfi-26-internal-cut slot-names combination . se)
   45: ;   transformer used internally
   46: ;     slot-names  : the internal names of the slots
   47: ;     combination : procedure being specialized, followed by its arguments
   48: ;     se          : slots-or-exprs, the qualifiers of the macro
   49: 
   50: (define-syntax srfi-26-internal-cut
   51:   (syntax-rules (<> <...>)
   52: 
   53:     ;; construct fixed- or variable-arity procedure:
   54:     ;;   (begin proc) throws an error if proc is not an <expression>
   55:     ((srfi-26-internal-cut (slot-name ...) (proc arg ...))
   56:      (lambda (slot-name ...) ((begin proc) arg ...)))
   57:     ((srfi-26-internal-cut (slot-name ...) (proc arg ...) <...>)
   58:      (lambda (slot-name ... . rest-slot) (apply proc arg ... rest-slot)))
   59: 
   60:     ;; process one slot-or-expr
   61:     ((srfi-26-internal-cut (slot-name ...)   (position ...)      <>  . se)
   62:      (srfi-26-internal-cut (slot-name ... x) (position ... x)        . se))
   63:     ((srfi-26-internal-cut (slot-name ...)   (position ...)      nse . se)
   64:      (srfi-26-internal-cut (slot-name ...)   (position ... nse)      . se))))
   65: 
   66: ; (srfi-26-internal-cute slot-names nse-bindings combination . se)
   67: ;   transformer used internally
   68: ;     slot-names     : the internal names of the slots
   69: ;     nse-bindings   : let-style bindings for the non-slot expressions.
   70: ;     combination    : procedure being specialized, followed by its arguments
   71: ;     se             : slots-or-exprs, the qualifiers of the macro
   72: 
   73: (define-syntax srfi-26-internal-cute
   74:   (syntax-rules (<> <...>)
   75: 
   76:     ;; If there are no slot-or-exprs to process, then:
   77:     ;; construct a fixed-arity procedure,
   78:     ((srfi-26-internal-cute
   79:       (slot-name ...) nse-bindings (proc arg ...))
   80:      (let nse-bindings (lambda (slot-name ...) (proc arg ...))))
   81:     ;; or a variable-arity procedure
   82:     ((srfi-26-internal-cute
   83:       (slot-name ...) nse-bindings (proc arg ...) <...>)
   84:      (let nse-bindings (lambda (slot-name ... . x) (apply proc arg ... x))))
   85: 
   86:     ;; otherwise, process one slot:
   87:     ((srfi-26-internal-cute
   88:       (slot-name ...)         nse-bindings  (position ...)   <>  . se)
   89:      (srfi-26-internal-cute
   90:       (slot-name ... x)       nse-bindings  (position ... x)     . se))
   91:     ;; or one non-slot expression
   92:     ((srfi-26-internal-cute
   93:       slot-names              nse-bindings  (position ...)   nse . se)
   94:      (srfi-26-internal-cute
   95:       slot-names ((x nse) . nse-bindings) (position ... x)       . se))))
   96: 
   97: ; exported syntax
   98: 
   99: (define-syntax cut
  100:   (syntax-rules ()
  101:     ((cut . slots-or-exprs)
  102:      (srfi-26-internal-cut () () . slots-or-exprs))))
  103: 
  104: (define-syntax cute
  105:   (syntax-rules ()
  106:     ((cute . slots-or-exprs)
  107:      (srfi-26-internal-cute () () () . slots-or-exprs))))
  108: 
  109: (provide "srfi-26")