summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
Diffstat (limited to 'module/language')
-rw-r--r--module/language/assembly/compile-bytecode.scm18
-rw-r--r--module/language/ecmascript/compile-tree-il.scm36
-rw-r--r--module/language/tree-il.scm148
3 files changed, 95 insertions, 107 deletions
diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm
index 163ffccdc..85805a523 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -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))
diff --git a/module/language/ecmascript/compile-tree-il.scm b/module/language/ecmascript/compile-tree-il.scm
index c46fd621d..a2401f442 100644
--- a/module/language/ecmascript/compile-tree-il.scm
+++ b/module/language/ecmascript/compile-tree-il.scm
@@ -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)))
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index decd3637c..580ebdace 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -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))