summaryrefslogtreecommitdiff
path: root/module/srfi
diff options
context:
space:
mode:
Diffstat (limited to 'module/srfi')
-rw-r--r--module/srfi/srfi-1.scm8
-rw-r--r--module/srfi/srfi-35.scm32
-rw-r--r--module/srfi/srfi-39.scm12
-rw-r--r--module/srfi/srfi-45.scm13
-rw-r--r--module/srfi/srfi-67/compare.scm189
5 files changed, 111 insertions, 143 deletions
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 765bd50e9..d2347b0d1 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -240,11 +240,9 @@ higher-order procedures."
(scm-error 'wrong-type-arg (symbol->string caller)
"Wrong type argument: ~S" (list arg) '()))
-(define-syntax check-arg
- (syntax-rules ()
- ((_ pred arg caller)
- (if (not (pred arg))
- (wrong-type-arg 'caller arg)))))
+(define-syntax-rule (check-arg pred arg caller)
+ (if (not (pred arg))
+ (wrong-type-arg 'caller arg)))
(define (out-of-range proc arg)
(scm-error 'out-of-range proc
diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index 7f1ff7fc9..d2b9c9420 100644
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@@ -1,6 +1,6 @@
;;; srfi-35.scm --- Conditions -*- coding: utf-8 -*-
-;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2007, 2008, 2009, 2010, 2011 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
@@ -295,24 +295,20 @@ by C."
;;; Syntax.
;;;
-(define-syntax define-condition-type
- (syntax-rules ()
- ((_ name parent pred (field-name field-accessor) ...)
- (begin
- (define name
- (make-condition-type 'name parent '(field-name ...)))
- (define (pred c)
- (condition-has-type? c name))
- (define (field-accessor c)
- (condition-ref c 'field-name))
- ...))))
-
-(define-syntax compound-condition
+(define-syntax-rule (define-condition-type name parent pred (field-name field-accessor) ...)
+ (begin
+ (define name
+ (make-condition-type 'name parent '(field-name ...)))
+ (define (pred c)
+ (condition-has-type? c name))
+ (define (field-accessor c)
+ (condition-ref c 'field-name))
+ ...))
+
+(define-syntax-rule (compound-condition (type ...) (field ...))
;; Create a compound condition using `make-compound-condition-type'.
- (syntax-rules ()
- ((_ (type ...) (field ...))
- (condition ((make-compound-condition-type '%compound `(,type ...))
- field ...)))))
+ (condition ((make-compound-condition-type '%compound `(,type ...))
+ field ...)))
(define-syntax condition-instantiation
;; Build the `(make-condition type ...)' call.
diff --git a/module/srfi/srfi-39.scm b/module/srfi/srfi-39.scm
index 61e67b820..dba86fdbb 100644
--- a/module/srfi/srfi-39.scm
+++ b/module/srfi/srfi-39.scm
@@ -1,6 +1,6 @@
;;; srfi-39.scm --- Parameter objects
-;; Copyright (C) 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 2004, 2005, 2006, 2008, 2011 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
@@ -69,12 +69,10 @@
((null? (cdr new-value)) (fluid-set! value (conv (car new-value))))
(else (error "make-parameter expects 0 or 1 arguments" new-value)))))))
-(define-syntax parameterize
- (syntax-rules ()
- ((_ ((?param ?value) ...) ?body ...)
- (with-parameters* (list ?param ...)
- (list ?value ...)
- (lambda () ?body ...)))))
+(define-syntax-rule (parameterize ((?param ?value) ...) ?body ...)
+ (with-parameters* (list ?param ...)
+ (list ?value ...)
+ (lambda () ?body ...)))
(define (current-input-port . new-value)
(if (null? new-value)
diff --git a/module/srfi/srfi-45.scm b/module/srfi/srfi-45.scm
index 1b912befc..29b0393ff 100644
--- a/module/srfi/srfi-45.scm
+++ b/module/srfi/srfi-45.scm
@@ -1,6 +1,6 @@
;;; srfi-45.scm -- Primitives for Expressing Iterative Lazy Algorithms
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
;; Permission is hereby granted, free of charge, to any person
@@ -47,17 +47,14 @@
(tag value-tag value-tag-set!)
(proc value-proc value-proc-set!))
-(define-syntax lazy
- (syntax-rules ()
- ((lazy exp)
- (make-promise (make-value 'lazy (lambda () exp))))))
+(define-syntax-rule (lazy exp)
+ (make-promise (make-value 'lazy (lambda () exp))))
(define (eager x)
(make-promise (make-value 'eager x)))
-(define-syntax delay
- (syntax-rules ()
- ((delay exp) (lazy (eager exp)))))
+(define-syntax-rule (delay exp)
+ (lazy (eager exp)))
(define (force promise)
(let ((content (promise-val promise)))
diff --git a/module/srfi/srfi-67/compare.scm b/module/srfi/srfi-67/compare.scm
index 21b0e94c4..2ab947ece 100644
--- a/module/srfi/srfi-67/compare.scm
+++ b/module/srfi/srfi-67/compare.scm
@@ -1,3 +1,4 @@
+; Copyright (c) 2011 Free Software Foundation, Inc.
; Copyright (c) 2005 Sebastian Egner and Jens Axel S{\o}gaard.
;
; Permission is hereby granted, free of charge, to any person obtaining
@@ -88,14 +89,12 @@
; 3-sided conditional
-(define-syntax if3
- (syntax-rules ()
- ((if3 c less equal greater)
- (case c
- ((-1) less)
- (( 0) equal)
- (( 1) greater)
- (else (error "comparison value not in {-1,0,1}"))))))
+(define-syntax-rule (if3 c less equal greater)
+ (case c
+ ((-1) less)
+ (( 0) equal)
+ (( 1) greater)
+ (else (error "comparison value not in {-1,0,1}"))))
; 2-sided conditionals for comparisons
@@ -110,51 +109,37 @@
(a-cases alternate)
(else (error "comparison value not in {-1,0,1}"))))))
-(define-syntax if=?
- (syntax-rules ()
- ((if=? arg ...)
- (compare:if-rel? (0) (-1 1) arg ...))))
+(define-syntax-rule (if=? arg ...)
+ (compare:if-rel? (0) (-1 1) arg ...))
-(define-syntax if<?
- (syntax-rules ()
- ((if<? arg ...)
- (compare:if-rel? (-1) (0 1) arg ...))))
+(define-syntax-rule (if<? arg ...)
+ (compare:if-rel? (-1) (0 1) arg ...))
-(define-syntax if>?
- (syntax-rules ()
- ((if>? arg ...)
- (compare:if-rel? (1) (-1 0) arg ...))))
+(define-syntax-rule (if>? arg ...)
+ (compare:if-rel? (1) (-1 0) arg ...))
-(define-syntax if<=?
- (syntax-rules ()
- ((if<=? arg ...)
- (compare:if-rel? (-1 0) (1) arg ...))))
+(define-syntax-rule (if<=? arg ...)
+ (compare:if-rel? (-1 0) (1) arg ...))
-(define-syntax if>=?
- (syntax-rules ()
- ((if>=? arg ...)
- (compare:if-rel? (0 1) (-1) arg ...))))
+(define-syntax-rule (if>=? arg ...)
+ (compare:if-rel? (0 1) (-1) arg ...))
-(define-syntax if-not=?
- (syntax-rules ()
- ((if-not=? arg ...)
- (compare:if-rel? (-1 1) (0) arg ...))))
+(define-syntax-rule if- (not=? arg ...)
+ (compare:if-rel? (-1 1) (0) arg ...))
; predicates from compare procedures
-(define-syntax compare:define-rel?
- (syntax-rules ()
- ((compare:define-rel? rel? if-rel?)
- (define rel?
- (case-lambda
- (() (lambda (x y) (if-rel? (default-compare x y) #t #f)))
- ((compare) (lambda (x y) (if-rel? (compare x y) #t #f)))
- ((x y) (if-rel? (default-compare x y) #t #f))
- ((compare x y)
- (if (procedure? compare)
- (if-rel? (compare x y) #t #f)
- (error "not a procedure (Did you mean rel/rel??): " compare))))))))
+(define-syntax-rule compare:define- (rel? rel? if-rel?)
+ (define rel?
+ (case-lambda
+ (() (lambda (x y) (if-rel? (default-compare x y) #t #f)))
+ ((compare) (lambda (x y) (if-rel? (compare x y) #t #f)))
+ ((x y) (if-rel? (default-compare x y) #t #f))
+ ((compare x y)
+ (if (procedure? compare)
+ (if-rel? (compare x y) #t #f)
+ (error "not a procedure (Did you mean rel/rel??): " compare))))))
(compare:define-rel? =? if=?)
(compare:define-rel? <? if<?)
@@ -166,29 +151,27 @@
; chains of length 3
-(define-syntax compare:define-rel1/rel2?
- (syntax-rules ()
- ((compare:define-rel1/rel2? rel1/rel2? if-rel1? if-rel2?)
- (define rel1/rel2?
- (case-lambda
- (()
- (lambda (x y z)
- (if-rel1? (default-compare x y)
- (if-rel2? (default-compare y z) #t #f)
- (compare:checked #f default-compare z))))
- ((compare)
- (lambda (x y z)
- (if-rel1? (compare x y)
- (if-rel2? (compare y z) #t #f)
- (compare:checked #f compare z))))
- ((x y z)
- (if-rel1? (default-compare x y)
- (if-rel2? (default-compare y z) #t #f)
- (compare:checked #f default-compare z)))
- ((compare x y z)
- (if-rel1? (compare x y)
- (if-rel2? (compare y z) #t #f)
- (compare:checked #f compare z))))))))
+(define-syntax-rule compare:define-rel1/ (rel2? rel1/rel2? if-rel1? if-rel2?)
+ (define rel1/rel2?
+ (case-lambda
+ (()
+ (lambda (x y z)
+ (if-rel1? (default-compare x y)
+ (if-rel2? (default-compare y z) #t #f)
+ (compare:checked #f default-compare z))))
+ ((compare)
+ (lambda (x y z)
+ (if-rel1? (compare x y)
+ (if-rel2? (compare y z) #t #f)
+ (compare:checked #f compare z))))
+ ((x y z)
+ (if-rel1? (default-compare x y)
+ (if-rel2? (default-compare y z) #t #f)
+ (compare:checked #f default-compare z)))
+ ((compare x y z)
+ (if-rel1? (compare x y)
+ (if-rel2? (compare y z) #t #f)
+ (compare:checked #f compare z))))))
(compare:define-rel1/rel2? </<? if<? if<?)
(compare:define-rel1/rel2? </<=? if<? if<=?)
@@ -202,31 +185,29 @@
; chains of arbitrary length
-(define-syntax compare:define-chain-rel?
- (syntax-rules ()
- ((compare:define-chain-rel? chain-rel? if-rel?)
- (define chain-rel?
- (case-lambda
- ((compare)
- #t)
- ((compare x1)
- (compare:checked #t compare x1))
- ((compare x1 x2)
- (if-rel? (compare x1 x2) #t #f))
- ((compare x1 x2 x3)
- (if-rel? (compare x1 x2)
- (if-rel? (compare x2 x3) #t #f)
- (compare:checked #f compare x3)))
- ((compare x1 x2 . x3+)
- (if-rel? (compare x1 x2)
- (let chain? ((head x2) (tail x3+))
- (if (null? tail)
- #t
- (if-rel? (compare head (car tail))
- (chain? (car tail) (cdr tail))
- (apply compare:checked #f
- compare (cdr tail)))))
- (apply compare:checked #f compare x3+))))))))
+(define-syntax-rule compare:define-chain- (rel? chain-rel? if-rel?)
+ (define chain-rel?
+ (case-lambda
+ ((compare)
+ #t)
+ ((compare x1)
+ (compare:checked #t compare x1))
+ ((compare x1 x2)
+ (if-rel? (compare x1 x2) #t #f))
+ ((compare x1 x2 x3)
+ (if-rel? (compare x1 x2)
+ (if-rel? (compare x2 x3) #t #f)
+ (compare:checked #f compare x3)))
+ ((compare x1 x2 . x3+)
+ (if-rel? (compare x1 x2)
+ (let chain? ((head x2) (tail x3+))
+ (if (null? tail)
+ #t
+ (if-rel? (compare head (car tail))
+ (chain? (car tail) (cdr tail))
+ (apply compare:checked #f
+ compare (cdr tail)))))
+ (apply compare:checked #f compare x3+))))))
(compare:define-chain-rel? chain=? if=?)
(compare:define-chain-rel? chain<? if<?)
@@ -468,19 +449,17 @@
(begin (compare:type-check type? type-name x)
(compare:type-check type? type-name y)))))
-(define-syntax compare:define-by=/<
- (syntax-rules ()
- ((compare:define-by=/< compare = < type? type-name)
- (define compare
- (let ((= =) (< <))
- (lambda (x y)
- (if (type? x)
- (if (eq? x y)
- 0
- (if (type? y)
- (if (= x y) 0 (if (< x y) -1 1))
- (error (string-append "not " type-name ":") y)))
- (error (string-append "not " type-name ":") x))))))))
+(define-syntax-rule compare:define- (by=/< compare = < type? type-name)
+ (define compare
+ (let ((= =) (< <))
+ (lambda (x y)
+ (if (type? x)
+ (if (eq? x y)
+ 0
+ (if (type? y)
+ (if (= x y) 0 (if (< x y) -1 1))
+ (error (string-append "not " type-name ":") y)))
+ (error (string-append "not " type-name ":") x))))))
(define (boolean-compare x y)
(compare:type-check boolean? "boolean" x y)