asdf.scm

(define-syntax ck
  (syntax-rules (quote)
    ((ck () 'v) v)                      ; yield the value on empty stack

    ((ck (((op ...) ea ...) . s) 'v)    ; re-focus on the other argument, ea
     (ck-arg s (op ... 'v) ea ...))

    ((ck s (op ea ...))                 ; Focus: handling an application;
     (ck-arg s (op) ea ...))))          ; check if args are values

(define-syntax ck-arg
  (syntax-rules (quote)
    ((ck-arg s (op va ...))             ; all arguments are evaluated,
     (op s va ...))                     ; do the redex

    ((ck-arg s (op ...) 'v ea1 ...)     ; optimization when the first ea
     (ck-arg s (op ... 'v) ea1 ...))    ; was already a value

    ((ck-arg s (op ...) ea ea1 ...)     ; focus on ea, to evaluate it
     (ck (((op ...) ea1 ...) . s) ea))))


(define-syntax ck-partition 
  (syntax-rules (quote)
    ((_ s '(a ... b) 'l)    
     (ck-partition s '(a ...) '(((a ...) b) . l)))
    ((_ s '() 'l)
     (ck s 'l))))

(define-syntax compile-curried
  (syntax-rules (quote)
    ((_ s 'name '(a ...) 'body '(((b ...) c) ...))
      (ck ()
      '(define-syntax name
         (syntax-rules ()
           ((_ a ...) (begin . body))
           ((_ b ...) (lambda (c) (name b ... c)))
           ...))))))

(define-syntax-rule (define-curried (name a ...) . body)
  (ck () (compile-curried 'name '(a ...) 'body 
  (ck-partition '(a ...) '()))))


(use-modules (al) (ice-9 match))
;; (use-modules (srfi srfi-1) (srfi srfi-2))

(define-curried (string-matches pattern string)
  ;;CAUTION: buggy version
  (and-let* ((match-struct (string-match pattern string))
                (count (match:count match-struct)))
     (map (lambda(n)(match:substring match-struct n))
          (iota (1- count) 1))))

;; scheme@(guile-user)> ,exp ((string-matches "([a-z])") "a")
;; $2 = (let* ((string-1 "a")
;;        (match-struct (string-match "([a-z])" string)))
;;   (and match-struct
;;        (let ((count (match:count match-struct)))
;;          (and count
;;               (map (lambda (n) (match:substring match-struct n))
;;                    (iota (#{1-}# count) 1))))))

define-macro.scm

(define-module (define-macro)
  #:export (define-macro))

(define-syntax define-macro
  (lambda (x)
    "Define a defmacro."
    (syntax-case x ()
      ((_ (macro . args) doc body1 body ...)
       (string? (syntax->datum #'doc))
       #'(define-macro macro doc (lambda args body1 body ...)))
      ((_ (macro . args) body ...)
       #'(define-macro macro #f (lambda args body ...)))
      ((_ macro transformer)
       #'(define-macro macro #f transformer))
      ((_ macro doc transformer)
       (or (string? (syntax->datum #'doc))
           (not (syntax->datum #'doc)))
       #'(define-syntax macro
           (lambda (y)
             (define (recontextualize form context default)
               (define (walk x)
                 ;; is there any possibility of a circular syntax object?
                 (cond ((hashv-ref context x) => (lambda (x) x))
                       ((pair? x)
                        (cons (walk (car x))
                              (walk (cdr x))))
                       ((vector? x)
                        (vector-map walk x))
                       ((symbol? x)
                        (datum->syntax default x))
                       (else x)))
               (walk form)
               ;;(datum->syntax default form)
               )
             (define (build-context form stx-form)
               (define ctx (make-hash-table))
               (define (walk x y)
                 (hashv-set! ctx x y)
                 ;; is there any possibility of a circular syntax object?
                 (cond ((pair? x)
                        (walk (car x) (car (syntax-e y)))
                        (walk (cdr x) (cdr (syntax-e y))))
                       ((vector? x)
                        (vector-for-each walk x (syntax-e y)))))
               (walk form stx-form)
               ctx)
             (define (vector-for-each f v1 v2)
               (define len (vector-length v1))
               (define v* (make-vector len))
               (let loop ((i 0))
                 (unless (= i len)
                   (vector-set! v* i (f (vector-ref v1 i) (vector-ref v2 i)))
                   (loop (+ i 1))))
               v*)
             (define (vector-map f v)
               (define len (vector-length v))
               (define v* (make-vector len))
               (let loop ((i 0))
                 (unless (= i len)
                   (vector-set! v* i (f (vector-ref v i)))
                   (loop (+ i 1))))
               v*)
             (define (syntax-e obj)
               (syntax-case obj ()
                 [(first . rest)
                  (cons #'first #'rest)]
                 [#(value (... ...))
                  (apply vector #'(value (... ...)))]
                 [a (syntax->datum #'a)]))
             doc ;; FIXME: may not be a docstring, and so would fail above
             #((macro-type . defmacro)
               (defmacro-args args))
             (syntax-case y ()
               ((_ . args)
                (let* ((v (syntax->datum #'args))
                       (ctx (build-context v #'args)))
                  (recontextualize (apply transformer v) ctx y))))))))))

gistfile1.txt

(define-module (al)
  #:use-module (define-macro)
  :export-syntax (and-let*))
;;;; and-let-star.scm --- and-let* syntactic form (draft SRFI-2) for Guile
;;;; written by Michael Livshin <mike@olan.com>
;;;;
;;;; 	Copyright (C) 1999, 2001, 2004, 2006 Free Software Foundation, Inc.
;;;; 
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;; (define-module (ice-9 and-let-star)
;;   :export-syntax (and-let*))

(defmacro and-let* (vars . body)

  (define (expand vars body)
    (cond
     ((null? vars)
      (if (null? body)
	  #t
	  `(begin ,@body)))
     ((pair? vars)
      (let ((exp (car vars)))
        (cond
         ((pair? exp)
          (cond
           ((null? (cdr exp))
            `(and ,(car exp) ,(expand (cdr vars) body)))
           (else
            (let ((var (car exp)))
              `(let (,exp)
                 (and ,var ,(expand (cdr vars) body)))))))
         (else
          `(and ,exp ,(expand (cdr vars) body))))))
     (else
      (error "not a proper list" vars))))

  (expand vars body))

(cond-expand-provide (current-module) '(srfi-2))