mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 01:30:27 +02:00
Code Activity

more define-syntax-rule usage

Browse source 
* module/ice-9/boot-9.scm:
* module/ice-9/control.scm:
* module/ice-9/futures.scm:
* module/ice-9/optargs.scm:
* module/ice-9/poll.scm:
* module/ice-9/receive.scm:
* module/ice-9/threads.scm:
* module/ice-9/vlist.scm:
* module/language/assembly/compile-bytecode.scm:
* module/language/ecmascript/compile-tree-il.scm:
* module/language/tree-il.scm:
* module/oop/goops.scm:
* module/oop/goops/simple.scm:
* module/oop/goops/stklos.scm:
* module/srfi/srfi-1.scm:
* module/srfi/srfi-35.scm:
* module/srfi/srfi-39.scm:
* module/srfi/srfi-45.scm:
* module/srfi/srfi-67/compare.scm:
* module/sxml/match.scm:
* module/system/repl/error-handling.scm:
* module/system/repl/repl.scm:
* module/system/vm/inspect.scm:
* module/texinfo.scm:
* module/web/server.scm: Use define-syntax-rule, where it makes sense.
This commit is contained in:
Andy Wingo 2011-09-02 11:36:14 +02:00
parent 1bbe0a631c
commit 0c65f52c6d
25 changed files with 373 additions and 513 deletions
Download patch file Download diff file Expand all files Collapse all files

8
module/srfi/srfi-1.scm
View file

@ -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

30
module/srfi/srfi-35.scm
View file

@ -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-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 compound-condition
(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.

12
module/srfi/srfi-39.scm
View file

@ -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)

13
module/srfi/srfi-45.scm
View file

@ -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)))

189
module/srfi/srfi-67/compare.scm
View file

@ -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)