Re: and-let* is not composable?

[Ian Price]

Ian Price <address@hidden> writes:

> This version of define-macro still fails on the original macros as
> posted by Panicz Maciej Godek, but gives the "right" result using stis's
> ck macro version.
>
> At 2:30am, I'm not liable to get to the bottom of why till tomorrow, but
> I think doing something like this is a positive step.

Turns out it was PEBKAC

/tmp $ guile -q
GNU Guile 2.0.9.95-c9e3-dirty
Copyright (C) 1995-2013 Free Software Foundation, Inc.

Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
This program is free software, and you are welcome to redistribute it
under certain conditions; type `,show c' for details.

Enter `,help' for help.
scheme@(guile-user)> (include "/tmp/defmacrofix.scm")
scheme@(guile-user)> ,expand ((string-matches "([a-z])") "a")
$1 = (let* ((string "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))))))

-- 
Ian Price -- shift-reset.com

"Programming is like pinball. The reward for doing it well is
the opportunity to do it again" - from "The Wizardy Compiled"

(use-modules (ice-9 match)
             (srfi srfi-1))

(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)
             #,@(if (string? (syntax->datum #'doc))
                    (list #'doc)
                    '())
             (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))
             (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-each2 walk x (syntax-e y)))))
               (walk form stx-form)
               ctx)
             (define (vector-for-each2 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)]))
             #((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))))))))))

(define-macro (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))

(define-macro (define-curried signature . body)
  (match signature
    ((name args ...)
     `(define-syntax ,name
        (syntax-rules ()
          ((_ ,@args)
           (begin ,@body))
          ,@(let loop ((args* args))
              (match args*
                (() '())
                ((first ... last)
                 (cons `((_ ,@first #;...)
                         (lambda(,last)(,name ,@args*)))
                       (loop first #;...))))))))))


(define-curried (matches? pattern x)
  (match x
    (pattern #t)
    (else #f)))

(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))))