[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 04/10: Use more `match' in (system base compile)
From: |
Andy Wingo |
Subject: |
[Guile-commits] 04/10: Use more `match' in (system base compile) |
Date: |
Fri, 8 May 2020 11:13:42 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 6bb996ec6679666f6a1c17f8c1c48cbe56b32c19
Author: Andy Wingo <address@hidden>
AuthorDate: Fri May 8 10:12:33 2020 +0200
Use more `match' in (system base compile)
* module/system/base/compile.scm (validate-options): New helper.
(compile-file, compile-and-load, compile): Call the new helper.
(compile-passes, compile-fold, find-language-joint):
(default-language-joiner, decompile-passes, decompile-fold): Use more
"match".
---
module/system/base/compile.scm | 95 ++++++++++++++++++++++++++----------------
1 file changed, 59 insertions(+), 36 deletions(-)
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index ea73cc5..0502ad4 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -21,6 +21,7 @@
#:use-module (system base language)
#:use-module (system base message)
#:use-module (ice-9 receive)
+ #:use-module (ice-9 match)
#:export (compiled-file-name
compile-file
compile-and-load
@@ -127,6 +128,28 @@
(and (false-if-exception (ensure-directory (dirname f)))
f))))
+(define (validate-options opts)
+ (define (validate-warnings warnings)
+ (match warnings
+ (() (values))
+ ((w . warnings)
+ (unless (lookup-warning-type w)
+ (warning 'unsupported-warning #f w))
+ (validate-warnings warnings))))
+ (match opts
+ (() (values))
+ ((kw arg . opts)
+ (match kw
+ (#:warnings (validate-warnings arg))
+ ((? keyword?) (values))
+ (_
+ ;; Programming error.
+ (warn "malformed options list: not a keyword" kw)))
+ (validate-options opts))
+ (_
+ ;; Programming error.
+ (warn "malformed options list: expected keyword and arg pair" opts))))
+
(define* (compile-file file #:key
(output-file #f)
(from (current-language))
@@ -134,6 +157,7 @@
(env (default-environment from))
(opts '())
(canonicalization 'relative))
+ (validate-options opts)
(with-fluids ((%file-port-name-canonicalization canonicalization))
(let* ((comp (or output-file (compiled-file-name file)
(error "failed to create path for auto-compiled file"
@@ -156,6 +180,7 @@
(define* (compile-and-load file #:key (from (current-language)) (to 'value)
(env (current-module)) (opts '())
(canonicalization 'relative))
+ (validate-options opts)
(with-fluids ((%file-port-name-canonicalization canonicalization))
(read-and-compile (open-input-file file)
#:from from #:to to #:opts opts
@@ -167,33 +192,39 @@
;;;
(define (compile-passes from to opts)
- (map cdr
- (or (lookup-compilation-order from to)
- (error "no way to compile" from "to" to))))
+ (match (lookup-compilation-order from to)
+ (((langs . passes) ...) passes)
+ (_ (error "no way to compile" from "to" to))))
(define (compile-fold passes exp env opts)
(let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
- (if (null? passes)
- (values x e cenv)
- (receive (x e new-cenv) ((car passes) x e opts)
- (lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
+ (match passes
+ (() (values x e cenv))
+ ((pass . passes)
+ (receive (x e new-cenv) (pass x e opts)
+ (lp passes x e (if first? new-cenv cenv) #f))))))
(define (find-language-joint from to)
- (let lp ((in (reverse (or (lookup-compilation-order from to)
- (error "no way to compile" from "to" to))))
- (lang to))
- (cond ((null? in) to)
- ((language-joiner lang) lang)
- (else
- (lp (cdr in) (caar in))))))
+ (match (lookup-compilation-order from to)
+ (((langs . passes) ...)
+ (or (let lp ((langs langs))
+ (match langs
+ (() #f)
+ ((lang . langs)
+ (or (lp langs)
+ (and (language-joiner lang)
+ lang)))))
+ to))
+ (_ (error "no way to compile" from "to" to))))
(define (default-language-joiner lang)
(lambda (exps env)
- (if (and (pair? exps) (null? (cdr exps)))
- (car exps)
- (error
- "Multiple expressions read and compiled, but language has no joiner"
- lang))))
+ (match exps
+ ((exp) exp)
+ (_
+ (error
+ "Multiple expressions read and compiled, but language has no joiner"
+ lang)))))
(define (read-and-parse lang port cenv)
(let ((exp ((language-reader lang) port cenv)))
@@ -236,16 +267,7 @@
(to 'value)
(env (default-environment from))
(opts '()))
-
- (let ((warnings (memq #:warnings opts)))
- (if (pair? warnings)
- (let ((warnings (cadr warnings)))
- ;; Sanity-check the requested warnings.
- (for-each (lambda (w)
- (or (lookup-warning-type w)
- (warning 'unsupported-warning #f w)))
- warnings))))
-
+ (validate-options opts)
(receive (exp env cenv)
(compile-fold (compile-passes from to opts) x env opts)
exp))
@@ -256,15 +278,16 @@
;;;
(define (decompile-passes from to opts)
- (map cdr
- (or (lookup-decompilation-order from to)
- (error "no way to decompile" from "to" to))))
+ (match (lookup-decompilation-order from to)
+ (((langs . passes) ...) passes)
+ (_ (error "no way to decompile" from "to" to))))
(define (decompile-fold passes exp env opts)
- (if (null? passes)
- (values exp env)
- (receive (exp env) ((car passes) exp env opts)
- (decompile-fold (cdr passes) exp env opts))))
+ (match passes
+ (() (values exp env))
+ ((pass . passes)
+ (receive (exp env) (pass exp env opts)
+ (decompile-fold passes exp env opts)))))
(define* (decompile x #:key
(env #f)
- [Guile-commits] branch master updated (728de16 -> 4311dc9), Andy Wingo, 2020/05/08
- [Guile-commits] 06/10: Add #:optimization-level, #:warning-level compile keyword args, Andy Wingo, 2020/05/08
- [Guile-commits] 09/10: Warning and optimization levels always small integers, Andy Wingo, 2020/05/08
- [Guile-commits] 08/10: Wire up simplified warning levels in "guild compile", Andy Wingo, 2020/05/08
- [Guile-commits] 02/10: Remove compilation order cache, Andy Wingo, 2020/05/08
- [Guile-commits] 01/10: Update (system base compile) header, Andy Wingo, 2020/05/08
- [Guile-commits] 04/10: Use more `match' in (system base compile),
Andy Wingo <=
- [Guile-commits] 05/10: Rework compile-fold, Andy Wingo, 2020/05/08
- [Guile-commits] 10/10: Define new "lowering" phase in compiler, Andy Wingo, 2020/05/08
- [Guile-commits] 07/10: Add language-specific analysis pass to compiler infrastructure, Andy Wingo, 2020/05/08
- [Guile-commits] 03/10: Slight (system base compile) refactor, Andy Wingo, 2020/05/08