diff options
Diffstat (limited to 'module/srfi')
-rw-r--r-- | module/srfi/srfi-1.scm | 8 | ||||
-rw-r--r-- | module/srfi/srfi-35.scm | 32 | ||||
-rw-r--r-- | module/srfi/srfi-39.scm | 12 | ||||
-rw-r--r-- | module/srfi/srfi-45.scm | 13 | ||||
-rw-r--r-- | module/srfi/srfi-67/compare.scm | 189 |
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) |