mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Get rid of `define-macro' in the SRFI 26 implementation

Browse source 
* module/srfi/srfi-26.scm (cut, cute): Implement using `syntax-case'.
  The new implementation is mostly just a transcription of the old code;
  the reference implementation which relies only on `syntax-rules' may
  (or may not) be considered more elegant :-).

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Andreas Rottmann 2010-12-07 23:13:55 +01:00 • committed by Ludovic Courtès
parent 51fc066ae2
commit 3df539b1a5
1 changed files with 43 additions and 26 deletions
Download patch file Download diff file Expand all files Collapse all files

69
module/srfi/srfi-26.scm
View file

@ -1,6 +1,6 @@
;;; srfi-26.scm --- specializing parameters without currying. ;;; srfi-26.scm --- specializing parameters without currying.
;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. ;; Copyright (C) 2002, 2006, 2010 Free Software Foundation, Inc.
;; ;;
;; This library is free software; you can redistribute it and/or ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -21,29 +21,46 @@
(cond-expand-provide (current-module) '(srfi-26)) (cond-expand-provide (current-module) '(srfi-26))
(define-macro (cut slot . slots) (define-syntax cut
(let loop ((slots (cons slot slots)) (lambda (stx)
(params '()) (syntax-case stx ()
(args '())) ((cut slot0 slot1+ ...)
(if (null? slots) (let loop ((slots #'(slot0 slot1+ ...))
`(lambda ,(reverse! params) ,(reverse! args)) (params '())
(let ((s (car slots)) (args '()))
(rest (cdr slots))) (if (null? slots)
(case s #`(lambda #,(reverse params) #,(reverse args))
((<>) (let ((s (car slots))
(let ((var (gensym))) (rest (cdr slots)))
(loop rest (cons var params) (cons var args)))) (with-syntax (((var) (generate-temporaries '(var))))
((<...>) (syntax-case s (<> <...>)
(if (pair? rest) (<>
(error "<...> not on the end of cut expression")) (loop rest (cons #'var params) (cons #'var args)))
(let ((var (gensym))) (<...>
`(lambda ,(append! (reverse! params) var) (if (pair? rest)
(apply ,@(reverse! (cons var args)))))) (error "<...> not on the end of cut expression"))
(else #`(lambda #,(append (reverse params) #'var)
(loop rest params (cons s args)))))))) (apply #,@(reverse (cons #'var args)))))
(else
(loop rest params (cons s args))))))))))))
(define-macro (cute . slots) (define-syntax cute
(let ((temp (map (lambda (s) (and (not (memq s '(<> <...>))) (gensym))) (lambda (stx)
slots))) (syntax-case stx ()
`(let ,(delq! #f (map (lambda (t s) (and t (list t s))) temp slots)) ((cute slots ...)
(cut ,@(map (lambda (t s) (or t s)) temp slots))))) (let loop ((slots #'(slots ...))
(bindings '())
(arguments '()))
(define (process-hole)
(loop (cdr slots) bindings (cons (car slots) arguments)))
(if (null? slots)
#`(let #,bindings
(cut #,@(reverse arguments)))
(syntax-case (car slots) (<> <...>)
(<> (process-hole))
(<...> (process-hole))
(expr
(with-syntax (((t) (generate-temporaries '(t))))
(loop (cdr slots)
(cons #'(t expr) bindings)
(cons #'t arguments)))))))))))