diff options
Diffstat (limited to 'module/language')
-rw-r--r-- | module/language/assembly/compile-bytecode.scm | 18 | ||||
-rw-r--r-- | module/language/ecmascript/compile-tree-il.scm | 36 | ||||
-rw-r--r-- | module/language/tree-il.scm | 148 |
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)) |