mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-20 02:30:23 +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

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

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

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

@ -25,20 +25,14 @@
#:use-module (srfi srfi-1)
#:export (compile-tree-il))
(define-syntax ->
(syntax-rules ()
((_ (type arg ...))
`(type ,arg ...))))
(define-syntax-rule (-> (type arg ...))
`(type ,arg ...))
(define-syntax @implv
(syntax-rules ()
((_ sym)
(-> (@ '(language ecmascript impl) 'sym)))))
(define-syntax-rule (@implv sym)
(-> (@ '(language ecmascript impl) 'sym)))
(define-syntax @impl
(syntax-rules ()
((_ sym arg ...)
(-> (apply (@implv sym) arg ...)))))
(define-syntax-rule (@impl sym arg ...)
(-> (apply (@implv sym) arg ...)))
(define (empty-lexical-environment)
'())
@ -67,16 +61,14 @@
;; for emacs:
;; (put 'pmatch/source 'scheme-indent-function 1)
(define-syntax pmatch/source
(syntax-rules ()
((_ x clause ...)
(let ((x x))
(let ((res (pmatch x
clause ...)))
(let ((loc (location x)))
(if loc
(set-source-properties! res (location x))))
res)))))
(define-syntax-rule (pmatch/source x clause ...)
(let ((x x))
(let ((res (pmatch x
clause ...)))
(let ((loc (location x)))
(if loc
(set-source-properties! res (location x))))
res)))
(define (comp x e)
(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))))))
(define-syntax make-tree-il-folder
(syntax-rules ()
((_ seed ...)
(lambda (tree down up seed ...)
(define (fold-values proc exps seed ...)
(if (null? exps)
(values seed ...)
(let-values (((seed ...) (proc (car exps) seed ...)))
(fold-values proc (cdr exps) seed ...))))
(let foldts ((tree tree) (seed seed) ...)
(let*-values
(((seed ...) (down tree seed ...))
((seed ...)
(record-case tree
((<lexical-set> exp)
(foldts exp seed ...))
((<module-set> exp)
(foldts exp seed ...))
((<toplevel-set> exp)
(foldts exp seed ...))
((<toplevel-define> exp)
(foldts exp seed ...))
((<conditional> test consequent alternate)
(let*-values (((seed ...) (foldts test seed ...))
((seed ...) (foldts consequent seed ...)))
(foldts alternate seed ...)))
((<application> proc args)
(let-values (((seed ...) (foldts proc seed ...)))
(fold-values foldts args seed ...)))
((<sequence> exps)
(fold-values foldts exps seed ...))
((<lambda> body)
(foldts body seed ...))
((<lambda-case> inits body alternate)
(let-values (((seed ...) (fold-values foldts inits seed ...)))
(if alternate
(let-values (((seed ...) (foldts body seed ...)))
(foldts alternate seed ...))
(foldts body seed ...))))
((<let> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<letrec> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<fix> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<let-values> exp body)
(let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...)))
((<dynwind> body winder unwinder)
(let*-values (((seed ...) (foldts body seed ...))
((seed ...) (foldts winder seed ...)))
(foldts unwinder seed ...)))
((<dynlet> fluids vals body)
(let*-values (((seed ...) (fold-values foldts fluids seed ...))
((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<dynref> fluid)
(foldts fluid seed ...))
((<dynset> fluid exp)
(let*-values (((seed ...) (foldts fluid seed ...)))
(foldts exp seed ...)))
((<prompt> tag body handler)
(let*-values (((seed ...) (foldts tag seed ...))
((seed ...) (foldts body seed ...)))
(foldts handler seed ...)))
((<abort> tag args tail)
(let*-values (((seed ...) (foldts tag seed ...))
((seed ...) (fold-values foldts args seed ...)))
(foldts tail seed ...)))
(else
(values seed ...)))))
(up tree seed ...)))))))
(define-syntax-rule (make-tree-il-folder seed ...)
(lambda (tree down up seed ...)
(define (fold-values proc exps seed ...)
(if (null? exps)
(values seed ...)
(let-values (((seed ...) (proc (car exps) seed ...)))
(fold-values proc (cdr exps) seed ...))))
(let foldts ((tree tree) (seed seed) ...)
(let*-values
(((seed ...) (down tree seed ...))
((seed ...)
(record-case tree
((<lexical-set> exp)
(foldts exp seed ...))
((<module-set> exp)
(foldts exp seed ...))
((<toplevel-set> exp)
(foldts exp seed ...))
((<toplevel-define> exp)
(foldts exp seed ...))
((<conditional> test consequent alternate)
(let*-values (((seed ...) (foldts test seed ...))
((seed ...) (foldts consequent seed ...)))
(foldts alternate seed ...)))
((<application> proc args)
(let-values (((seed ...) (foldts proc seed ...)))
(fold-values foldts args seed ...)))
((<sequence> exps)
(fold-values foldts exps seed ...))
((<lambda> body)
(foldts body seed ...))
((<lambda-case> inits body alternate)
(let-values (((seed ...) (fold-values foldts inits seed ...)))
(if alternate
(let-values (((seed ...) (foldts body seed ...)))
(foldts alternate seed ...))
(foldts body seed ...))))
((<let> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<letrec> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<fix> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<let-values> exp body)
(let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...)))
((<dynwind> body winder unwinder)
(let*-values (((seed ...) (foldts body seed ...))
((seed ...) (foldts winder seed ...)))
(foldts unwinder seed ...)))
((<dynlet> fluids vals body)
(let*-values (((seed ...) (fold-values foldts fluids seed ...))
((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<dynref> fluid)
(foldts fluid seed ...))
((<dynset> fluid exp)
(let*-values (((seed ...) (foldts fluid seed ...)))
(foldts exp seed ...)))
((<prompt> tag body handler)
(let*-values (((seed ...) (foldts tag seed ...))
((seed ...) (foldts body seed ...)))
(foldts handler seed ...)))
((<abort> tag args tail)
(let*-values (((seed ...) (foldts tag seed ...))
((seed ...) (fold-values foldts args seed ...)))
(foldts tail seed ...)))
(else
(values seed ...)))))
(up tree seed ...)))))
(define (post-order! f x)
(let lp ((x x))