Ian Price <ianpric...@googlemail.com> 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))))
