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

Rewrite SRFI-31 in terms of `syntax-rules'.

Browse source 
* module/srfi/srfi-31.scm: Use `#:export' instead of `#:export-syntax'.
  (rec): Rewrite using `syntax-rules'.

* test-suite/tests/srfi-31.test ("rec special form"): Change exception
  type to EXCEPTION:SYNTAX-PATTERN-UNMATCHED.
This commit is contained in:
Ludovic Courtès 2012-09-11 23:39:32 +02:00
parent 9855388378
commit e7350baf1e
2 changed files with 16 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,6 +1,6 @@
;;; srfi-31.scm --- special form for recursive evaluation ;;; srfi-31.scm --- special form for recursive evaluation
;; Copyright (C) 2004, 2006 Free Software Foundation, Inc. ;; Copyright (C) 2004, 2006, 2012 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
@ -19,17 +19,15 @@
;;; Original author: Rob Browning <rlb@defaultvalue.org> ;;; Original author: Rob Browning <rlb@defaultvalue.org>
(define-module (srfi srfi-31) (define-module (srfi srfi-31)
:export-syntax (rec)) #:export (rec))
(define-macro (rec arg-form . body) (define-syntax rec
(cond (syntax-rules ()
((and (symbol? arg-form) (= 1 (length body))) "Return the given object, defined in a lexical environment where
;; (rec S (cons 1 (delay S))) NAME is bound to itself."
`(letrec ((,arg-form ,(car body))) ((_ (name . formals) body ...) ; procedure
,arg-form)) (letrec ((name (lambda formals body ...)))
;; (rec (f x) (+ x 1)) name))
((list? arg-form) ((_ name expr) ; arbitrary object
`(letrec ((,(car arg-form) (lambda ,(cdr arg-form) ,@body))) (letrec ((name expr))
,(car arg-form))) name))))
(else
(error "syntax error in rec form" `(rec ,arg-form ,@body)))))

7
test-suite/tests/srfi-31.test
View file

@ -1,6 +1,6 @@
;;;; srfi-31.test --- Test suite for Guile's SRFI-31 functions. -*- scheme -*- ;;;; srfi-31.test --- Test suite for Guile's SRFI-31 functions. -*- scheme -*-
;;;; ;;;;
;;;; Copyright (C) 2004, 2006, 2010 Free Software Foundation, Inc. ;;;; Copyright (C) 2004, 2006, 2010, 2012 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
@ -22,9 +22,10 @@
(with-test-prefix "rec special form" (with-test-prefix "rec special form"
(pass-if-exception "bogus variable" '(misc-error . ".*") (pass-if-exception "bogus variable"
exception:syntax-pattern-unmatched
(eval '(rec #:foo) (current-module))) (eval '(rec #:foo) (current-module)))
(pass-if "rec expressions" (pass-if "rec expressions"
(let ((ones-list (rec ones (cons 1 (delay ones))))) (let ((ones-list (rec ones (cons 1 (delay ones)))))
(and (= 1 (car ones-list)) (and (= 1 (car ones-list))