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

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

132
module/ice-9/boot-9.scm
View file

@ -504,9 +504,8 @@ If there is no handler at all, Guile prints an error and then exits."
((do "step" x y) ((do "step" x y)
y))) y)))
(define-syntax delay (define-syntax-rule (delay exp)
(syntax-rules () (make-promise (lambda () exp)))
((_ exp) (make-promise (lambda () exp)))))
(include-from-path "ice-9/quasisyntax") (include-from-path "ice-9/quasisyntax")
@ -517,11 +516,9 @@ If there is no handler at all, Guile prints an error and then exits."
(with-syntax ((s (datum->syntax x (syntax-source x)))) (with-syntax ((s (datum->syntax x (syntax-source x))))
#''s))))) #''s)))))
(define-syntax define-once (define-syntax-rule (define-once sym val)
(syntax-rules () (define sym
((_ sym val) (if (module-locally-bound? (current-module) 'sym) sym val)))
(define sym
(if (module-locally-bound? (current-module) 'sym) sym val)))))
;;; The real versions of `map' and `for-each', with cycle detection, and ;;; The real versions of `map' and `for-each', with cycle detection, and
;;; that use reverse! instead of recursion in the case of `map'. ;;; that use reverse! instead of recursion in the case of `map'.
@ -853,12 +850,10 @@ VALUE."
(define (and=> value procedure) (and value (procedure value))) (define (and=> value procedure) (and value (procedure value)))
(define call/cc call-with-current-continuation) (define call/cc call-with-current-continuation)
(define-syntax false-if-exception (define-syntax-rule (false-if-exception expr)
(syntax-rules () (catch #t
((_ expr) (lambda () expr)
(catch #t (lambda (k . args) #f)))
(lambda () expr)
(lambda (k . args) #f)))))
@ -877,12 +872,10 @@ VALUE."
;; properties within the object itself. ;; properties within the object itself.
(define (make-object-property) (define (make-object-property)
(define-syntax with-mutex (define-syntax-rule (with-mutex lock exp)
(syntax-rules () (dynamic-wind (lambda () (lock-mutex lock))
((_ lock exp) (lambda () exp)
(dynamic-wind (lambda () (lock-mutex lock)) (lambda () (unlock-mutex lock))))
(lambda () exp)
(lambda () (unlock-mutex lock))))))
(let ((prop (make-weak-key-hash-table)) (let ((prop (make-weak-key-hash-table))
(lock (make-mutex))) (lock (make-mutex)))
(make-procedure-with-setter (make-procedure-with-setter
@ -1380,10 +1373,9 @@ VALUE."
(thunk))) (thunk)))
(lambda (k . args) (lambda (k . args)
(%start-stack tag (lambda () (apply k args))))))) (%start-stack tag (lambda () (apply k args)))))))
(define-syntax start-stack
(syntax-rules () (define-syntax-rule (start-stack tag exp)
((_ tag exp) (%start-stack tag (lambda () exp)))
(%start-stack tag (lambda () exp)))))
@ -2846,11 +2838,9 @@ module '(ice-9 q) '(make-q q-length))}."
flags) flags)
(interface options) (interface options)
(interface))) (interface)))
(define-syntax option-set! (define-syntax-rule (option-set! opt val)
(syntax-rules () (eval-when (eval load compile expand)
((_ opt val) (options (append (options) (list 'opt val)))))))))
(eval-when (eval load compile expand)
(options (append (options) (list 'opt val)))))))))))
(define-option-interface (define-option-interface
(debug-options-interface (debug-options-interface
@ -3175,21 +3165,17 @@ module '(ice-9 q) '(make-q q-length))}."
(process-use-modules (list quoted-args ...)) (process-use-modules (list quoted-args ...))
*unspecified*)))))) *unspecified*))))))
(define-syntax use-syntax (define-syntax-rule (use-syntax spec ...)
(syntax-rules () (begin
((_ spec ...) (eval-when (eval load compile expand)
(begin (issue-deprecation-warning
(eval-when (eval load compile expand) "`use-syntax' is deprecated. Please contact guile-devel for more info."))
(issue-deprecation-warning (use-modules spec ...)))
"`use-syntax' is deprecated. Please contact guile-devel for more info."))
(use-modules spec ...)))))
(include-from-path "ice-9/r6rs-libraries") (include-from-path "ice-9/r6rs-libraries")
(define-syntax define-private (define-syntax-rule (define-private foo bar)
(syntax-rules () (define foo bar))
((_ foo bar)
(define foo bar))))
(define-syntax define-public (define-syntax define-public
(syntax-rules () (syntax-rules ()
@ -3200,18 +3186,14 @@ module '(ice-9 q) '(make-q q-length))}."
(define name val) (define name val)
(export name))))) (export name)))))
(define-syntax defmacro-public (define-syntax-rule (defmacro-public name args body ...)
(syntax-rules () (begin
((_ name args . body) (defmacro name args body ...)
(begin (export-syntax name)))
(defmacro name args . body)
(export-syntax name)))))
;; And now for the most important macro. ;; And now for the most important macro.
(define-syntax λ (define-syntax-rule (λ formals body ...)
(syntax-rules () (lambda formals body ...))
((_ formals body ...)
(lambda formals body ...))))
;; Export a local variable ;; Export a local variable
@ -3270,39 +3252,29 @@ module '(ice-9 q) '(make-q q-length))}."
(module-add! public-i external-name var))))) (module-add! public-i external-name var)))))
names))) names)))
(define-syntax export (define-syntax-rule (export name ...)
(syntax-rules () (eval-when (eval load compile expand)
((_ name ...) (call-with-deferred-observers
(eval-when (eval load compile expand) (lambda ()
(call-with-deferred-observers (module-export! (current-module) '(name ...))))))
(lambda ()
(module-export! (current-module) '(name ...))))))))
(define-syntax re-export (define-syntax-rule (re-export name ...)
(syntax-rules () (eval-when (eval load compile expand)
((_ name ...) (call-with-deferred-observers
(eval-when (eval load compile expand) (lambda ()
(call-with-deferred-observers (module-re-export! (current-module) '(name ...))))))
(lambda ()
(module-re-export! (current-module) '(name ...))))))))
(define-syntax export! (define-syntax-rule (export! name ...)
(syntax-rules () (eval-when (eval load compile expand)
((_ name ...) (call-with-deferred-observers
(eval-when (eval load compile expand) (lambda ()
(call-with-deferred-observers (module-replace! (current-module) '(name ...))))))
(lambda ()
(module-replace! (current-module) '(name ...))))))))
(define-syntax export-syntax (define-syntax-rule (export-syntax name ...)
(syntax-rules () (export name ...))
((_ name ...)
(export name ...))))
(define-syntax re-export-syntax (define-syntax-rule (re-export-syntax name ...)
(syntax-rules () (re-export name ...))
((_ name ...)
(re-export name ...))))

22
module/ice-9/control.scm
View file

@ -60,20 +60,16 @@
;; http://okmij.org/ftp/Scheme/delim-control-n.scm, which are in the ;; http://okmij.org/ftp/Scheme/delim-control-n.scm, which are in the
;; public domain, as noted at the top of http://okmij.org/ftp/. ;; public domain, as noted at the top of http://okmij.org/ftp/.
;; ;;
(define-syntax reset (define-syntax-rule (reset . body)
(syntax-rules () (call-with-prompt (default-prompt-tag)
((_ . body) (lambda () . body)
(call-with-prompt (default-prompt-tag) (lambda (cont f) (f cont))))
(lambda () . body)
(lambda (cont f) (f cont))))))
(define-syntax shift (define-syntax-rule (shift var . body)
(syntax-rules () (abort-to-prompt (default-prompt-tag)
((_ var . body) (lambda (cont)
(abort-to-prompt (default-prompt-tag) ((lambda (var) (reset . body))
(lambda (cont) (lambda vals (reset (apply cont vals)))))))
((lambda (var) (reset . body))
(lambda vals (reset (apply cont vals)))))))))
(define (reset* thunk) (define (reset* thunk)
(reset (thunk))) (reset (thunk)))

8
module/ice-9/futures.scm
View file

@ -173,8 +173,6 @@ touched."
;;; Syntax. ;;; Syntax.
;;; ;;;
(define-syntax future (define-syntax-rule (future body)
(syntax-rules () "Return a new future for BODY."
"Return a new future for BODY." (make-future (lambda () body)))
((_ body)
(make-future (lambda () body)))))

12
module/ice-9/optargs.scm
View file

@ -1,6 +1,6 @@
;;;; optargs.scm -- support for optional arguments ;;;; optargs.scm -- support for optional arguments
;;;; ;;;;
;;;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006, 2009, 2010 Free Software Foundation, Inc. ;;;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006, 2009, 2010, 2011 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
@ -278,12 +278,10 @@
#'(define-macro id doc (lambda* args b0 b1 ...))) #'(define-macro id doc (lambda* args b0 b1 ...)))
((_ id args b0 b1 ...) ((_ id args b0 b1 ...)
#'(define-macro id #f (lambda* args b0 b1 ...)))))) #'(define-macro id #f (lambda* args b0 b1 ...))))))
(define-syntax defmacro*-public (define-syntax-rule (defmacro*-public id args b0 b1 ...)
(syntax-rules () (begin
((_ id args b0 b1 ...) (defmacro* id args b0 b1 ...)
(begin (export-syntax id)))
(defmacro* id args b0 b1 ...)
(export-syntax id)))))
;;; Support for optional & keyword args with the interpreter. ;;; Support for optional & keyword args with the interpreter.
(define *uninitialized* (list 'uninitialized)) (define *uninitialized* (list 'uninitialized))

7
module/ice-9/poll.scm
View file

@ -1,6 +1,6 @@
;; poll ;; poll
;;;; Copyright (C) 2010 Free Software Foundation, Inc. ;;;; Copyright (C) 2010, 2011 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
@ -68,9 +68,8 @@
(ports pset-ports set-pset-ports!) (ports pset-ports set-pset-ports!)
) )
(define-syntax pollfd-offset (define-syntax-rule (pollfd-offset n)
(syntax-rules () (* n 8))
((_ n) (* n 8))))
(define* (make-empty-poll-set #:optional (pre-allocated 4)) (define* (make-empty-poll-set #:optional (pre-allocated 4))
(make-poll-set (make-bytevector (pollfd-offset pre-allocated) 0) (make-poll-set (make-bytevector (pollfd-offset pre-allocated) 0)

14
module/ice-9/receive.scm
View file

@ -1,6 +1,6 @@
;;;; SRFI-8 ;;;; SRFI-8
;;; Copyright (C) 2000, 2001, 2004, 2006, 2010 Free Software Foundation, Inc. ;;; Copyright (C) 2000, 2001, 2004, 2006, 2010, 2011 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
@ -17,14 +17,10 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 receive) (define-module (ice-9 receive)
:export (receive) #:export (receive))
:no-backtrace
)
(define-syntax receive (define-syntax-rule (receive vars vals . body)
(syntax-rules () (call-with-values (lambda () vals)
((receive vars vals . body) (lambda vars . body)))
(call-with-values (lambda () vals)
(lambda vars . body)))))
(cond-expand-provide (current-module) '(srfi-8)) (cond-expand-provide (current-module) '(srfi-8))

56
module/ice-9/threads.scm
View file

@ -1,4 +1,4 @@
;;;; Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 2010 Free Software Foundation, Inc. ;;;; Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 2010, 2011 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
@ -51,12 +51,10 @@
;;; Macros first, so that the procedures expand correctly. ;;; Macros first, so that the procedures expand correctly.
(define-syntax begin-thread (define-syntax-rule (begin-thread e0 e1 ...)
(syntax-rules () (call-with-new-thread
((_ e0 e1 ...) (lambda () e0 e1 ...)
(call-with-new-thread %thread-handler))
(lambda () e0 e1 ...)
%thread-handler))))
(define-syntax parallel (define-syntax parallel
(lambda (x) (lambda (x)
@ -67,35 +65,27 @@
...) ...)
(values (touch tmp0) ...))))))) (values (touch tmp0) ...)))))))
(define-syntax letpar (define-syntax-rule (letpar ((v e) ...) b0 b1 ...)
(syntax-rules () (call-with-values
((_ ((v e) ...) b0 b1 ...) (lambda () (parallel e ...))
(call-with-values (lambda (v ...)
(lambda () (parallel e ...)) b0 b1 ...)))
(lambda (v ...)
b0 b1 ...)))))
(define-syntax make-thread (define-syntax-rule (make-thread proc arg ...)
(syntax-rules () (call-with-new-thread
((_ proc arg ...) (lambda () (proc arg ...))
(call-with-new-thread %thread-handler))
(lambda () (proc arg ...))
%thread-handler))))
(define-syntax with-mutex (define-syntax-rule (with-mutex m e0 e1 ...)
(syntax-rules () (let ((x m))
((_ m e0 e1 ...) (dynamic-wind
(let ((x m)) (lambda () (lock-mutex x))
(dynamic-wind (lambda () (begin e0 e1 ...))
(lambda () (lock-mutex x)) (lambda () (unlock-mutex x)))))
(lambda () (begin e0 e1 ...))
(lambda () (unlock-mutex x)))))))
(define-syntax monitor (define-syntax-rule (monitor first rest ...)
(syntax-rules () (with-mutex (make-mutex)
((_ first rest ...) first rest ...))
(with-mutex (make-mutex)
first rest ...))))
(define (par-mapper mapper) (define (par-mapper mapper)
(lambda (proc . arglists) (lambda (proc . arglists)

20
module/ice-9/vlist.scm
View file

@ -70,14 +70,12 @@
(fluid-set! f 2) (fluid-set! f 2)
f)) f))
(define-syntax define-inline (define-syntax-rule (define-inline (name formals ...) body ...)
;; Work around the lack of an inliner. ;; Work around the lack of an inliner.
(syntax-rules () (define-syntax name
((_ (name formals ...) body ...) (syntax-rules ()
(define-syntax name ((_ formals ...)
(syntax-rules () (begin body ...)))))
((_ formals ...)
(begin body ...)))))))
(define-inline (make-block base offset size hash-tab?) (define-inline (make-block base offset size hash-tab?)
;; Return a block (and block descriptor) of SIZE elements pointing to BASE ;; Return a block (and block descriptor) of SIZE elements pointing to BASE
@ -90,11 +88,9 @@
base offset size 0 base offset size 0
(and hash-tab? (make-vector size #f)))) (and hash-tab? (make-vector size #f))))
(define-syntax define-block-accessor (define-syntax-rule (define-block-accessor name index)
(syntax-rules () (define-inline (name block)
((_ name index) (vector-ref block index)))
(define-inline (name block)
(vector-ref block index)))))
(define-block-accessor block-content 0) (define-block-accessor block-content 0)
(define-block-accessor block-base 1) (define-block-accessor block-base 1)

18
module/language/assembly/compile-bytecode.scm
View file

@ -28,16 +28,14 @@
#:export (compile-bytecode)) #:export (compile-bytecode))
(define (compile-bytecode assembly env . opts) (define (compile-bytecode assembly env . opts)
(define-syntax define-inline1 (define-syntax-rule (define-inline1 (proc arg) body body* ...)
(syntax-rules () (define-syntax proc
((_ (proc arg) body body* ...) (syntax-rules ()
(define-syntax proc ((_ (arg-expr (... ...)))
(syntax-rules () (let ((x (arg-expr (... ...))))
((_ (arg-expr (... ...))) (proc x)))
(let ((x (arg-expr (... ...)))) ((_ arg)
(proc x))) (begin body body* ...)))))
((_ arg)
(begin body body* ...)))))))
(define (fill-bytecode bv target-endianness) (define (fill-bytecode bv target-endianness)
(let ((pos 0)) (let ((pos 0))

36
module/language/ecmascript/compile-tree-il.scm
View file

@ -25,20 +25,14 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:export (compile-tree-il)) #:export (compile-tree-il))
(define-syntax -> (define-syntax-rule (-> (type arg ...))
(syntax-rules () `(type ,arg ...))
((_ (type arg ...))
`(type ,arg ...))))
(define-syntax @implv (define-syntax-rule (@implv sym)
(syntax-rules () (-> (@ '(language ecmascript impl) 'sym)))
((_ sym)
(-> (@ '(language ecmascript impl) 'sym)))))
(define-syntax @impl (define-syntax-rule (@impl sym arg ...)
(syntax-rules () (-> (apply (@implv sym) arg ...)))
((_ sym arg ...)
(-> (apply (@implv sym) arg ...)))))
(define (empty-lexical-environment) (define (empty-lexical-environment)
'()) '())
@ -67,16 +61,14 @@
;; for emacs: ;; for emacs:
;; (put 'pmatch/source 'scheme-indent-function 1) ;; (put 'pmatch/source 'scheme-indent-function 1)
(define-syntax pmatch/source (define-syntax-rule (pmatch/source x clause ...)
(syntax-rules () (let ((x x))
((_ x clause ...) (let ((res (pmatch x
(let ((x x)) clause ...)))
(let ((res (pmatch x (let ((loc (location x)))
clause ...))) (if loc
(let ((loc (location x))) (set-source-properties! res (location x))))
(if loc res)))
(set-source-properties! res (location x))))
res)))))
(define (comp x e) (define (comp x e)
(let ((l (location x))) (let ((l (location x)))

148
module/language/tree-il.scm
View file

@ -554,81 +554,79 @@ This is an implementation of `foldts' as described by Andy Wingo in
(leaf tree result)))))) (leaf tree result))))))
(define-syntax make-tree-il-folder (define-syntax-rule (make-tree-il-folder seed ...)
(syntax-rules () (lambda (tree down up seed ...)
((_ seed ...) (define (fold-values proc exps seed ...)
(lambda (tree down up seed ...) (if (null? exps)
(define (fold-values proc exps seed ...) (values seed ...)
(if (null? exps) (let-values (((seed ...) (proc (car exps) seed ...)))
(values seed ...) (fold-values proc (cdr exps) seed ...))))
(let-values (((seed ...) (proc (car exps) seed ...))) (let foldts ((tree tree) (seed seed) ...)
(fold-values proc (cdr exps) seed ...)))) (let*-values
(let foldts ((tree tree) (seed seed) ...) (((seed ...) (down tree seed ...))
(let*-values ((seed ...)
(((seed ...) (down tree seed ...)) (record-case tree
((seed ...) ((<lexical-set> exp)
(record-case tree (foldts exp seed ...))
((<lexical-set> exp) ((<module-set> exp)
(foldts exp seed ...)) (foldts exp seed ...))
((<module-set> exp) ((<toplevel-set> exp)
(foldts exp seed ...)) (foldts exp seed ...))
((<toplevel-set> exp) ((<toplevel-define> exp)
(foldts exp seed ...)) (foldts exp seed ...))
((<toplevel-define> exp) ((<conditional> test consequent alternate)
(foldts exp seed ...)) (let*-values (((seed ...) (foldts test seed ...))
((<conditional> test consequent alternate) ((seed ...) (foldts consequent seed ...)))
(let*-values (((seed ...) (foldts test seed ...)) (foldts alternate seed ...)))
((seed ...) (foldts consequent seed ...))) ((<application> proc args)
(foldts alternate seed ...))) (let-values (((seed ...) (foldts proc seed ...)))
((<application> proc args) (fold-values foldts args seed ...)))
(let-values (((seed ...) (foldts proc seed ...))) ((<sequence> exps)
(fold-values foldts args seed ...))) (fold-values foldts exps seed ...))
((<sequence> exps) ((<lambda> body)
(fold-values foldts exps seed ...)) (foldts body seed ...))
((<lambda> body) ((<lambda-case> inits body alternate)
(foldts body seed ...)) (let-values (((seed ...) (fold-values foldts inits seed ...)))
((<lambda-case> inits body alternate) (if alternate
(let-values (((seed ...) (fold-values foldts inits seed ...))) (let-values (((seed ...) (foldts body seed ...)))
(if alternate (foldts alternate seed ...))
(let-values (((seed ...) (foldts body seed ...))) (foldts body seed ...))))
(foldts alternate seed ...)) ((<let> vals body)
(foldts body seed ...)))) (let*-values (((seed ...) (fold-values foldts vals seed ...)))
((<let> vals body) (foldts body seed ...)))
(let*-values (((seed ...) (fold-values foldts vals seed ...))) ((<letrec> vals body)
(foldts body seed ...))) (let*-values (((seed ...) (fold-values foldts vals seed ...)))
((<letrec> vals body) (foldts body seed ...)))
(let*-values (((seed ...) (fold-values foldts vals seed ...))) ((<fix> vals body)
(foldts body seed ...))) (let*-values (((seed ...) (fold-values foldts vals seed ...)))
((<fix> vals body) (foldts body seed ...)))
(let*-values (((seed ...) (fold-values foldts vals seed ...))) ((<let-values> exp body)
(foldts body seed ...))) (let*-values (((seed ...) (foldts exp seed ...)))
((<let-values> exp body) (foldts body seed ...)))
(let*-values (((seed ...) (foldts exp seed ...))) ((<dynwind> body winder unwinder)
(foldts body seed ...))) (let*-values (((seed ...) (foldts body seed ...))
((<dynwind> body winder unwinder) ((seed ...) (foldts winder seed ...)))
(let*-values (((seed ...) (foldts body seed ...)) (foldts unwinder seed ...)))
((seed ...) (foldts winder seed ...))) ((<dynlet> fluids vals body)
(foldts unwinder seed ...))) (let*-values (((seed ...) (fold-values foldts fluids seed ...))
((<dynlet> fluids vals body) ((seed ...) (fold-values foldts vals seed ...)))
(let*-values (((seed ...) (fold-values foldts fluids seed ...)) (foldts body seed ...)))
((seed ...) (fold-values foldts vals seed ...))) ((<dynref> fluid)
(foldts body seed ...))) (foldts fluid seed ...))
((<dynref> fluid) ((<dynset> fluid exp)
(foldts fluid seed ...)) (let*-values (((seed ...) (foldts fluid seed ...)))
((<dynset> fluid exp) (foldts exp seed ...)))
(let*-values (((seed ...) (foldts fluid seed ...))) ((<prompt> tag body handler)
(foldts exp seed ...))) (let*-values (((seed ...) (foldts tag seed ...))
((<prompt> tag body handler) ((seed ...) (foldts body seed ...)))
(let*-values (((seed ...) (foldts tag seed ...)) (foldts handler seed ...)))
((seed ...) (foldts body seed ...))) ((<abort> tag args tail)
(foldts handler seed ...))) (let*-values (((seed ...) (foldts tag seed ...))
((<abort> tag args tail) ((seed ...) (fold-values foldts args seed ...)))
(let*-values (((seed ...) (foldts tag seed ...)) (foldts tail seed ...)))
((seed ...) (fold-values foldts args seed ...))) (else
(foldts tail seed ...))) (values seed ...)))))
(else (up tree seed ...)))))
(values seed ...)))))
(up tree seed ...)))))))
(define (post-order! f x) (define (post-order! f x)
(let lp ((x x)) (let lp ((x x))

37
module/oop/goops.scm
View file

@ -288,21 +288,18 @@
#'(define-class-pre-definitions (rest ...) #'(define-class-pre-definitions (rest ...)
out ... (define-class-pre-definition (slotopt ...))))))) out ... (define-class-pre-definition (slotopt ...)))))))
(define-syntax define-class (define-syntax-rule (define-class name supers slot ...)
(syntax-rules () (begin
((_ name supers slot ...) (define-class-pre-definitions (slot ...))
(begin (if (and (defined? 'name)
(define-class-pre-definitions (slot ...)) (is-a? name <class>)
(if (and (defined? 'name) (memq <object> (class-precedence-list name)))
(is-a? name <class>) (class-redefinition name
(memq <object> (class-precedence-list name))) (class supers slot ... #:name 'name))
(class-redefinition name (toplevel-define! 'name (class supers slot ... #:name 'name)))))
(class supers slot ... #:name 'name))
(toplevel-define! 'name (class supers slot ... #:name 'name)))))))
(define-syntax standard-define-class (define-syntax-rule (standard-define-class arg ...)
(syntax-rules () (define-class arg ...))
((_ arg ...) (define-class arg ...))))
;;; ;;;
;;; {Generic functions and accessors} ;;; {Generic functions and accessors}
@ -390,13 +387,11 @@
(else (make <generic> #:name name)))) (else (make <generic> #:name name))))
;; same semantics as <generic> ;; same semantics as <generic>
(define-syntax define-accessor (define-syntax-rule (define-accessor name)
(syntax-rules () (define name
((_ name) (cond ((not (defined? 'name)) (ensure-accessor #f 'name))
(define name ((is-a? name <accessor>) (make <accessor> #:name 'name))
(cond ((not (defined? 'name)) (ensure-accessor #f 'name)) (else (ensure-accessor name 'name)))))
((is-a? name <accessor>) (make <accessor> #:name 'name))
(else (ensure-accessor name 'name)))))))
(define (make-setter-name name) (define (make-setter-name name)
(string->symbol (string-append "setter:" (symbol->string name)))) (string->symbol (string-append "setter:" (symbol->string name))))

8
module/oop/goops/simple.scm
View file

@ -1,6 +1,6 @@
;;; installed-scm-file ;;; installed-scm-file
;;;; Copyright (C) 2005, 2006, 2010 Free Software Foundation, Inc. ;;;; Copyright (C) 2005, 2006, 2010, 2011 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
@ -23,10 +23,8 @@
:export (define-class) :export (define-class)
:no-backtrace) :no-backtrace)
(define-syntax define-class (define-syntax-rule (define-class arg ...)
(syntax-rules () (define-class-with-accessors-keywords arg ...))
((_ arg ...)
(define-class-with-accessors-keywords arg ...))))
(module-use! (module-public-interface (current-module)) (module-use! (module-public-interface (current-module))
(resolve-interface '(oop goops))) (resolve-interface '(oop goops)))

8
module/oop/goops/stklos.scm
View file

@ -1,4 +1,4 @@
;;;; Copyright (C) 1999,2002, 2006, 2010 Free Software Foundation, Inc. ;;;; Copyright (C) 1999,2002, 2006, 2010, 2011 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
@ -47,10 +47,8 @@
;;; Enable keyword support (*fixme*---currently this has global effect) ;;; Enable keyword support (*fixme*---currently this has global effect)
(read-set! keywords 'prefix) (read-set! keywords 'prefix)
(define-syntax define-class (define-syntax-rule (define-class name supers (slot ...) rest ...)
(syntax-rules () (standard-define-class name supers slot ... rest ...))
((_ name supers (slot ...) rest ...)
(standard-define-class name supers slot ... rest ...))))
(define (toplevel-define! name val) (define (toplevel-define! name val)
(module-define! (current-module) name val)) (module-define! (current-module) name val))

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

@ -240,11 +240,9 @@ higher-order procedures."
(scm-error 'wrong-type-arg (symbol->string caller) (scm-error 'wrong-type-arg (symbol->string caller)
"Wrong type argument: ~S" (list arg) '())) "Wrong type argument: ~S" (list arg) '()))
(define-syntax check-arg (define-syntax-rule (check-arg pred arg caller)
(syntax-rules () (if (not (pred arg))
((_ pred arg caller) (wrong-type-arg 'caller arg)))
(if (not (pred arg))
(wrong-type-arg 'caller arg)))))
(define (out-of-range proc arg) (define (out-of-range proc arg)
(scm-error 'out-of-range proc (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 -*- ;;; 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 ;; 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
@ -295,24 +295,20 @@ by C."
;;; Syntax. ;;; Syntax.
;;; ;;;
(define-syntax define-condition-type (define-syntax-rule (define-condition-type name parent pred (field-name field-accessor) ...)
(syntax-rules () (begin
((_ name parent pred (field-name field-accessor) ...) (define name
(begin (make-condition-type 'name parent '(field-name ...)))
(define name (define (pred c)
(make-condition-type 'name parent '(field-name ...))) (condition-has-type? c name))
(define (pred c) (define (field-accessor c)
(condition-has-type? c name)) (condition-ref c 'field-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'. ;; Create a compound condition using `make-compound-condition-type'.
(syntax-rules () (condition ((make-compound-condition-type '%compound `(,type ...))
((_ (type ...) (field ...)) field ...)))
(condition ((make-compound-condition-type '%compound `(,type ...))
field ...)))))
(define-syntax condition-instantiation (define-syntax condition-instantiation
;; Build the `(make-condition type ...)' call. ;; Build the `(make-condition type ...)' call.

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

@ -1,6 +1,6 @@
;;; srfi-39.scm --- Parameter objects ;;; 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 ;; 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
@ -69,12 +69,10 @@
((null? (cdr new-value)) (fluid-set! value (conv (car new-value)))) ((null? (cdr new-value)) (fluid-set! value (conv (car new-value))))
(else (error "make-parameter expects 0 or 1 arguments" new-value))))))) (else (error "make-parameter expects 0 or 1 arguments" new-value)))))))
(define-syntax parameterize (define-syntax-rule (parameterize ((?param ?value) ...) ?body ...)
(syntax-rules () (with-parameters* (list ?param ...)
((_ ((?param ?value) ...) ?body ...) (list ?value ...)
(with-parameters* (list ?param ...) (lambda () ?body ...)))
(list ?value ...)
(lambda () ?body ...)))))
(define (current-input-port . new-value) (define (current-input-port . new-value)
(if (null? 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 ;;; 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. ;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
;; Permission is hereby granted, free of charge, to any person ;; Permission is hereby granted, free of charge, to any person
@ -47,17 +47,14 @@
(tag value-tag value-tag-set!) (tag value-tag value-tag-set!)
(proc value-proc value-proc-set!)) (proc value-proc value-proc-set!))
(define-syntax lazy (define-syntax-rule (lazy exp)
(syntax-rules () (make-promise (make-value 'lazy (lambda () exp))))
((lazy exp)
(make-promise (make-value 'lazy (lambda () exp))))))
(define (eager x) (define (eager x)
(make-promise (make-value 'eager x))) (make-promise (make-value 'eager x)))
(define-syntax delay (define-syntax-rule (delay exp)
(syntax-rules () (lazy (eager exp)))
((delay exp) (lazy (eager exp)))))
(define (force promise) (define (force promise)
(let ((content (promise-val 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. ; Copyright (c) 2005 Sebastian Egner and Jens Axel S{\o}gaard.
; ;
; Permission is hereby granted, free of charge, to any person obtaining ; Permission is hereby granted, free of charge, to any person obtaining
@ -88,14 +89,12 @@
; 3-sided conditional ; 3-sided conditional
(define-syntax if3 (define-syntax-rule (if3 c less equal greater)
(syntax-rules () (case c
((if3 c less equal greater) ((-1) less)
(case c (( 0) equal)
((-1) less) (( 1) greater)
(( 0) equal) (else (error "comparison value not in {-1,0,1}"))))
(( 1) greater)
(else (error "comparison value not in {-1,0,1}"))))))
; 2-sided conditionals for comparisons ; 2-sided conditionals for comparisons
@ -110,51 +109,37 @@
(a-cases alternate) (a-cases alternate)
(else (error "comparison value not in {-1,0,1}")))))) (else (error "comparison value not in {-1,0,1}"))))))
(define-syntax if=? (define-syntax-rule (if=? arg ...)
(syntax-rules () (compare:if-rel? (0) (-1 1) arg ...))
((if=? arg ...)
(compare:if-rel? (0) (-1 1) arg ...))))
(define-syntax if<? (define-syntax-rule (if<? arg ...)
(syntax-rules () (compare:if-rel? (-1) (0 1) arg ...))
((if<? arg ...)
(compare:if-rel? (-1) (0 1) arg ...))))
(define-syntax if>? (define-syntax-rule (if>? arg ...)
(syntax-rules () (compare:if-rel? (1) (-1 0) arg ...))
((if>? arg ...)
(compare:if-rel? (1) (-1 0) arg ...))))
(define-syntax if<=? (define-syntax-rule (if<=? arg ...)
(syntax-rules () (compare:if-rel? (-1 0) (1) arg ...))
((if<=? arg ...)
(compare:if-rel? (-1 0) (1) arg ...))))
(define-syntax if>=? (define-syntax-rule (if>=? arg ...)
(syntax-rules () (compare:if-rel? (0 1) (-1) arg ...))
((if>=? arg ...)
(compare:if-rel? (0 1) (-1) arg ...))))
(define-syntax if-not=? (define-syntax-rule if- (not=? arg ...)
(syntax-rules () (compare:if-rel? (-1 1) (0) arg ...))
((if-not=? arg ...)
(compare:if-rel? (-1 1) (0) arg ...))))
; predicates from compare procedures ; predicates from compare procedures
(define-syntax compare:define-rel? (define-syntax-rule compare:define- (rel? rel? if-rel?)
(syntax-rules () (define rel?
((compare:define-rel? rel? if-rel?) (case-lambda
(define rel? (() (lambda (x y) (if-rel? (default-compare x y) #t #f)))
(case-lambda ((compare) (lambda (x y) (if-rel? (compare x y) #t #f)))
(() (lambda (x y) (if-rel? (default-compare x y) #t #f))) ((x y) (if-rel? (default-compare x y) #t #f))
((compare) (lambda (x y) (if-rel? (compare x y) #t #f))) ((compare x y)
((x y) (if-rel? (default-compare x y) #t #f)) (if (procedure? compare)
((compare x y) (if-rel? (compare x y) #t #f)
(if (procedure? compare) (error "not a procedure (Did you mean rel/rel??): " 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=?)
(compare:define-rel? <? if<?) (compare:define-rel? <? if<?)
@ -166,29 +151,27 @@
; chains of length 3 ; chains of length 3
(define-syntax compare:define-rel1/rel2? (define-syntax-rule compare:define-rel1/ (rel2? rel1/rel2? if-rel1? if-rel2?)
(syntax-rules () (define rel1/rel2?
((compare:define-rel1/rel2? rel1/rel2? if-rel1? if-rel2?) (case-lambda
(define rel1/rel2? (()
(case-lambda (lambda (x y z)
(() (if-rel1? (default-compare x y)
(lambda (x y z) (if-rel2? (default-compare y z) #t #f)
(if-rel1? (default-compare x y) (compare:checked #f default-compare z))))
(if-rel2? (default-compare y z) #t #f) ((compare)
(compare:checked #f default-compare z)))) (lambda (x y z)
((compare) (if-rel1? (compare x y)
(lambda (x y z) (if-rel2? (compare y z) #t #f)
(if-rel1? (compare x y) (compare:checked #f compare z))))
(if-rel2? (compare y z) #t #f) ((x y z)
(compare:checked #f compare z)))) (if-rel1? (default-compare x y)
((x y z) (if-rel2? (default-compare y z) #t #f)
(if-rel1? (default-compare x y) (compare:checked #f default-compare z)))
(if-rel2? (default-compare y z) #t #f) ((compare x y z)
(compare:checked #f default-compare z))) (if-rel1? (compare x y)
((compare x y z) (if-rel2? (compare y z) #t #f)
(if-rel1? (compare x y) (compare:checked #f compare z))))))
(if-rel2? (compare y z) #t #f)
(compare:checked #f compare z))))))))
(compare:define-rel1/rel2? </<? if<? if<?) (compare:define-rel1/rel2? </<? if<? if<?)
(compare:define-rel1/rel2? </<=? if<? if<=?) (compare:define-rel1/rel2? </<=? if<? if<=?)
@ -202,31 +185,29 @@
; chains of arbitrary length ; chains of arbitrary length
(define-syntax compare:define-chain-rel? (define-syntax-rule compare:define-chain- (rel? chain-rel? if-rel?)
(syntax-rules () (define chain-rel?
((compare:define-chain-rel? chain-rel? if-rel?) (case-lambda
(define chain-rel? ((compare)
(case-lambda #t)
((compare) ((compare x1)
#t) (compare:checked #t compare x1))
((compare x1) ((compare x1 x2)
(compare:checked #t compare x1)) (if-rel? (compare x1 x2) #t #f))
((compare x1 x2) ((compare x1 x2 x3)
(if-rel? (compare x1 x2) #t #f)) (if-rel? (compare x1 x2)
((compare x1 x2 x3) (if-rel? (compare x2 x3) #t #f)
(if-rel? (compare x1 x2) (compare:checked #f compare x3)))
(if-rel? (compare x2 x3) #t #f) ((compare x1 x2 . x3+)
(compare:checked #f compare x3))) (if-rel? (compare x1 x2)
((compare x1 x2 . x3+) (let chain? ((head x2) (tail x3+))
(if-rel? (compare x1 x2) (if (null? tail)
(let chain? ((head x2) (tail x3+)) #t
(if (null? tail) (if-rel? (compare head (car tail))
#t (chain? (car tail) (cdr tail))
(if-rel? (compare head (car tail)) (apply compare:checked #f
(chain? (car tail) (cdr tail)) compare (cdr tail)))))
(apply compare:checked #f (apply compare:checked #f compare x3+))))))
compare (cdr tail)))))
(apply compare:checked #f compare x3+))))))))
(compare:define-chain-rel? chain=? if=?) (compare:define-chain-rel? chain=? if=?)
(compare:define-chain-rel? chain<? if<?) (compare:define-chain-rel? chain<? if<?)
@ -468,19 +449,17 @@
(begin (compare:type-check type? type-name x) (begin (compare:type-check type? type-name x)
(compare:type-check type? type-name y))))) (compare:type-check type? type-name y)))))
(define-syntax compare:define-by=/< (define-syntax-rule compare:define- (by=/< compare = < type? type-name)
(syntax-rules () (define compare
((compare:define-by=/< compare = < type? type-name) (let ((= =) (< <))
(define compare (lambda (x y)
(let ((= =) (< <)) (if (type? x)
(lambda (x y) (if (eq? x y)
(if (type? x) 0
(if (eq? x y) (if (type? y)
0 (if (= x y) 0 (if (< x y) -1 1))
(if (type? y) (error (string-append "not " type-name ":") y)))
(if (= x y) 0 (if (< x y) -1 1)) (error (string-append "not " type-name ":") x))))))
(error (string-append "not " type-name ":") y)))
(error (string-append "not " type-name ":") x))))))))
(define (boolean-compare x y) (define (boolean-compare x y)
(compare:type-check boolean? "boolean" x y) (compare:type-check boolean? "boolean" x y)

37
module/sxml/match.scm
View file

@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*- ;;; -*- mode: scheme; coding: utf-8; -*-
;;; ;;;
;;; Copyright (C) 2010 Free Software Foundation, Inc. ;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;;; ;;;
;;; This library is free software; you can redistribute it and/or modify it ;;; This library is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU Lesser General Public License as published by ;;; under the terms of the GNU Lesser General Public License as published by
@ -40,34 +40,27 @@
;;; PLT compatibility layer. ;;; PLT compatibility layer.
;;; ;;;
(define-syntax syntax-object->datum (define-syntax-rule (syntax-object->datum stx)
(syntax-rules () (syntax->datum stx))
((_ stx)
(syntax->datum stx))))
(define-syntax void (define-syntax-rule (void)
(syntax-rules () *unspecified*)
((_) *unspecified*)))
(define %call/ec-prompt (define %call/ec-prompt
(make-prompt-tag)) (make-prompt-tag))
(define-syntax call/ec (define-syntax-rule (call/ec proc)
;; aka. `call-with-escape-continuation' ;; aka. `call-with-escape-continuation'
(syntax-rules () (call-with-prompt %call/ec-prompt
((_ proc) (lambda ()
(call-with-prompt %call/ec-prompt (proc (lambda args
(lambda () (apply abort-to-prompt
(proc (lambda args %call/ec-prompt args))))
(apply abort-to-prompt (lambda (_ . args)
%call/ec-prompt args)))) (apply values args))))
(lambda (_ . args)
(apply values args))))))
(define-syntax let/ec (define-syntax-rule (let/ec cont body ...)
(syntax-rules () (call/ec (lambda (cont) body ...)))
((_ cont body ...)
(call/ec (lambda (cont) body ...)))))
(define (raise-syntax-error x msg obj sub) (define (raise-syntax-error x msg obj sub)
(throw 'sxml-match-error x msg obj sub)) (throw 'sxml-match-error x msg obj sub))

6
module/system/repl/error-handling.scm
View file

@ -182,7 +182,5 @@
(apply (if (memq k pass-keys) throw on-error) k args)) (apply (if (memq k pass-keys) throw on-error) k args))
(error "Unknown on-error strategy" on-error))))))) (error "Unknown on-error strategy" on-error)))))))
(define-syntax with-error-handling (define-syntax-rule (with-error-handling form)
(syntax-rules () (call-with-error-handling (lambda () form)))
((_ form)
(call-with-error-handling (lambda () form)))))

16
module/system/repl/repl.scm
View file

@ -135,15 +135,13 @@
(run-repl (make-repl lang debug))) (run-repl (make-repl lang debug)))
;; (put 'abort-on-error 'scheme-indent-function 1) ;; (put 'abort-on-error 'scheme-indent-function 1)
(define-syntax abort-on-error (define-syntax-rule (abort-on-error string exp)
(syntax-rules () (catch #t
((_ string exp) (lambda () exp)
(catch #t (lambda (key . args)
(lambda () exp) (format #t "While ~A:~%" string)
(lambda (key . args) (print-exception (current-output-port) #f key args)
(format #t "While ~A:~%" string) (abort))))
(print-exception (current-output-port) #f key args)
(abort))))))
(define (run-repl repl) (define (run-repl repl)
(define (with-stack-and-prompt thunk) (define (with-stack-and-prompt thunk)

21
module/system/vm/inspect.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM debugging facilities ;;; Guile VM debugging facilities
;;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc. ;;; Copyright (C) 2001, 2009, 2010, 2011 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
@ -81,16 +81,15 @@
;;; ;;;
(define (inspect x) (define (inspect x)
(define-syntax define-command (define-syntax-rule (define-command ((mod cname alias ...) . args)
(syntax-rules () body ...)
((_ ((mod cname alias ...) . args) body ...) (define cname
(define cname (let ((c (lambda* args body ...)))
(let ((c (lambda* args body ...))) (set-procedure-property! c 'name 'cname)
(set-procedure-property! c 'name 'cname) (module-define! mod 'cname c)
(module-define! mod 'cname c) (module-add! mod 'alias (module-local-variable mod 'cname))
(module-add! mod 'alias (module-local-variable mod 'cname)) ...
... c)))
c)))))
(let ((commands (make-module))) (let ((commands (make-module)))
(define (prompt) (define (prompt)

20
module/texinfo.scm
View file

@ -77,6 +77,7 @@
#:use-module (sxml transform) #:use-module (sxml transform)
#:use-module (sxml ssax input-parse) #:use-module (sxml ssax input-parse)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-13) #:use-module (srfi srfi-13)
#:export (call-with-file-and-dir #:export (call-with-file-and-dir
texi-command-specs texi-command-specs
@ -103,25 +104,6 @@ files by relative path name."
(call-with-input-file (basename filename) proc)) (call-with-input-file (basename filename) proc))
(lambda () (chdir current-dir))))) (lambda () (chdir current-dir)))))
;; Define this version here, because (srfi srfi-11)'s definition uses
;; syntax-rules, which is really damn slow
(define-macro (let*-values bindings . body)
(if (null? bindings) (cons 'begin body)
(apply
(lambda (vars initializer)
(let ((cont
(cons 'let*-values
(cons (cdr bindings) body))))
(cond
((not (pair? vars)) ; regular let case, a single var
`(let ((,vars ,initializer)) ,cont))
((null? (cdr vars)) ; single var, see the prev case
`(let ((,(car vars) ,initializer)) ,cont))
(else ; the most generic case
`(call-with-values (lambda () ,initializer)
(lambda ,vars ,cont))))))
(car bindings))))
;;======================================================================== ;;========================================================================
;; Reflection on the XML vocabulary ;; Reflection on the XML vocabulary

8
module/web/server.scm
View file

@ -118,11 +118,9 @@
(write server-impl-write) (write server-impl-write)
(close server-impl-close)) (close server-impl-close))
(define-syntax define-server-impl (define-syntax-rule (define-server-impl name open read write close)
(syntax-rules () (define name
((_ name open read write close) (make-server-impl 'name open read write close)))
(define name
(make-server-impl 'name open read write close)))))
(define (lookup-server-impl impl) (define (lookup-server-impl impl)
"Look up a server implementation. If @var{impl} is a server "Look up a server implementation. If @var{impl} is a server