diff --git a/scheme/ikarus.boot.4.prebuilt b/scheme/ikarus.boot.4.prebuilt index 19d015b..1617e50 100644 Binary files a/scheme/ikarus.boot.4.prebuilt and b/scheme/ikarus.boot.4.prebuilt differ diff --git a/scheme/ikarus.boot.8.prebuilt b/scheme/ikarus.boot.8.prebuilt index f415e1c..a203a85 100644 Binary files a/scheme/ikarus.boot.8.prebuilt and b/scheme/ikarus.boot.8.prebuilt differ diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss index 5ad8595..d2da20c 100644 --- a/scheme/ikarus.compiler.ss +++ b/scheme/ikarus.compiler.ss @@ -18,8 +18,8 @@ (export compile-core-expr-to-port assembler-output optimize-cp current-primitive-locations eval-core - current-core-eval - compile-core-expr expand/optimize optimizer-output + current-core-eval compile-core-expr + expand expand/optimize optimizer-output cp0-effort-limit cp0-size-limit optimize-level perform-tag-analysis tag-analysis-output strip-source-info generate-debug-calls) @@ -36,7 +36,7 @@ compile-core-expr-to-port assembler-output current-primitive-locations eval-core cp0-size-limit cp0-effort-limit - expand/optimize optimizer-output + expand/optimize expand optimizer-output tag-analysis-output perform-tag-analysis current-core-eval) (ikarus.fasl.write) @@ -2481,19 +2481,30 @@ (refresh-cached-labels!)) (error 'current-primitive-locations "not a procedure" p))]))) +(define (expand/pretty x env who . passes) + (unless (environment? env) + (die who "not an environment" env)) + (let-values ([(x libs) (core-expand x env)]) + (let f ([x (recordize x)] [passes passes]) + (if (null? passes) + (unparse-pretty x) + (f ((car passes) x) (cdr passes)))))) + (define expand/optimize (case-lambda - [(p) (expand/optimize p (interaction-environment))] - [(p env) - (unless (environment? env) - (env 'expand/optimize "not an environment" env)) - (let-values ([(p lib*) (expand p env)]) - (let* ([p (recordize p)] - [p (parameterize ([open-mvcalls #f]) - (optimize-direct-calls p))] - [p (optimize-letrec/scc p)] - [p (source-optimize p)]) - (unparse-pretty p)))])) + [(x) (expand/optimize x (interaction-environment))] + [(x env) + (expand/pretty x env 'expand/optimize + (lambda (x) + (parameterize ([open-mvcalls #f]) + (optimize-direct-calls x))) + optimize-letrec/scc + source-optimize)])) + +(define expand + (case-lambda + [(x) (expand x (interaction-environment))] + [(x env) (expand/pretty x env 'expand)])) ) diff --git a/scheme/last-revision b/scheme/last-revision index 88dd643..93752ca 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1797 +1798 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index c5525f5..a5ad372 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -19,7 +19,7 @@ (import (except (ikarus) current-core-eval assembler-output optimize-cp optimize-level - cp0-size-limit cp0-effort-limit expand/optimize + cp0-size-limit cp0-effort-limit expand/optimize expand optimizer-output tag-analysis-output perform-tag-analysis)) (import (ikarus.compiler)) (import (except (psyntax system $bootstrap) @@ -390,6 +390,7 @@ [optimizer-output i] [new-cafe i] [expand i] + [core-expand i] [expand/optimize i] [environment? i] [environment-symbols i] diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index 4a6ada4..40dfc28 100644 --- a/scheme/psyntax.expander.ss +++ b/scheme/psyntax.expander.ss @@ -20,7 +20,8 @@ (library (psyntax expander) (export identifier? syntax-dispatch - eval expand generate-temporaries free-identifier=? + eval core-expand + generate-temporaries free-identifier=? bound-identifier=? datum->syntax syntax-error syntax-violation syntax->datum @@ -3752,7 +3753,7 @@ ;;; expander (chi-expr). It takes an expression and an environment. ;;; It returns two values: The resulting core-expression and a list of ;;; libraries that must be invoked before evaluating the core expr. - (define expand + (define core-expand (lambda (x env) (cond ((env? env) @@ -3785,6 +3786,7 @@ (else (assertion-violation 'expand "not an environment" env))))) + ;;; This is R6RS's eval. It takes an expression and an environment, ;;; expands the expression, invokes its invoke-required libraries and ;;; evaluates its expanded core form. @@ -3792,7 +3794,7 @@ (lambda (x env) (unless (environment? env) (error 'eval "not an environment" env)) - (let-values (((x invoke-req*) (expand x env))) + (let-values (((x invoke-req*) (core-expand x env))) (for-each invoke-library invoke-req*) (eval-core (expanded->core x)))))