mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +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
;; 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
;; modify it under the terms of the GNU Lesser General Public
@ -19,17 +19,15 @@
;;; Original author: Rob Browning <rlb@defaultvalue.org>
(define-module (srfi srfi-31)
:export-syntax (rec))
#:export (rec))
(define-macro (rec arg-form . body)
(cond
((and (symbol? arg-form) (= 1 (length body)))
;; (rec S (cons 1 (delay S)))
`(letrec ((,arg-form ,(car body)))
,arg-form))
;; (rec (f x) (+ x 1))
((list? arg-form)
`(letrec ((,(car arg-form) (lambda ,(cdr arg-form) ,@body)))
,(car arg-form)))
(else
(error "syntax error in rec form" `(rec ,arg-form ,@body)))))
(define-syntax rec
(syntax-rules ()
"Return the given object, defined in a lexical environment where
NAME is bound to itself."
((_ (name . formals) body ...) ; procedure
(letrec ((name (lambda formals body ...)))
name))
((_ name expr) ; arbitrary object
(letrec ((name expr))
name))))

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 -*-
;;;;
;;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
@ -22,9 +22,10 @@
(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)))
(pass-if "rec expressions"
(let ((ones-list (rec ones (cons 1 (delay ones)))))
(and (= 1 (car ones-list))