From 232b230e652b90e5f024d333f431d2c29a3c6740 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 26 Nov 2019 06:31:48 -0700 Subject: [PATCH] add enable-error-source-expression original commit: 02f383510653bb16c65fc812eb0c619bcb0347b5 --- csug/system.stex | 11 ++++++++++ makefiles/Mf-install.in | 2 +- s/cmacros.ss | 2 +- s/compile.ss | 1 + s/cpcheck.ss | 48 ++++++++++++++++++++++++----------------- s/front.ss | 2 ++ s/primdata.ss | 1 + 7 files changed, 45 insertions(+), 22 deletions(-) diff --git a/csug/system.stex b/csug/system.stex index 807b99b52d..dd320f657b 100644 --- a/csug/system.stex +++ b/csug/system.stex @@ -1131,6 +1131,7 @@ compile-profile generate-interrupt-trap enable-cross-library-optimization enable-arithmetic-left-associative +enable-error-source-expression \endschemedisplay It restores the values after the file has been compiled. @@ -2599,6 +2600,16 @@ implement \scheme{+}, \scheme{fx+}, \scheme{fl+}, \scheme{cfl+}, left-associative operations when given more than two arguments. The default is \scheme{#f}. +%---------------------------------------------------------------------------- +\entryheader +\formdef{enable-error-source-expression}{\categorythreadparameter}{enable-error-source-expression} +\listlibraries +\endentryheader + +This parameter controls whether the compiler can convert erroneous +expressions into a call to an error function that shows the expression +as an S-expression. The default is \scheme{#t}. + %---------------------------------------------------------------------------- \entryheader \formdef{generate-wpo-files}{\categorythreadparameter}{generate-wpo-files} diff --git a/makefiles/Mf-install.in b/makefiles/Mf-install.in index ebb2019732..fd34da7a7f 100644 --- a/makefiles/Mf-install.in +++ b/makefiles/Mf-install.in @@ -62,7 +62,7 @@ InstallLZ4Target= # no changes should be needed below this point # ############################################################################### -Version=csv9.5.3.4 +Version=csv9.5.3.5 Include=boot/$m PetiteBoot=boot/$m/petite.boot SchemeBoot=boot/$m/scheme.boot diff --git a/s/cmacros.ss b/s/cmacros.ss index bf5f6b0d8c..cf11bdba86 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -328,7 +328,7 @@ [(_ foo e1 e2) e1] ... [(_ bar e1 e2) e2]))))]))) -(define-constant scheme-version #x09050304) +(define-constant scheme-version #x09050305) (define-syntax define-machine-types (lambda (x) diff --git a/s/compile.ss b/s/compile.ss index 5684d6ae36..cc0a13ab59 100644 --- a/s/compile.ss +++ b/s/compile.ss @@ -577,6 +577,7 @@ [$optimize-closures ($optimize-closures)] [enable-cross-library-optimization (enable-cross-library-optimization)] [enable-arithmetic-left-associative (enable-arithmetic-left-associative)] + [enable-error-source-expression (enable-error-source-expression)] [enable-type-recovery (enable-type-recovery)]) (emit-header op (constant machine-type)) (when hostop (emit-header hostop (host-machine-type))) diff --git a/s/cpcheck.ss b/s/cpcheck.ss index 5c8341a867..130e920086 100644 --- a/s/cpcheck.ss +++ b/s/cpcheck.ss @@ -95,29 +95,37 @@ (define argcnt-error (lambda (preinfo f args) - (let ([call (parameterize ([print-gensym #f] [print-level 3] [print-length 6]) - (format "~s" (preinfo-sexpr preinfo)))]) - `(seq ,f - ,(build-sequence args - (cond - [(preinfo-src preinfo) => - (lambda (src) - ($source-warning 'compile src #t - "possible incorrect argument count in call ~a" - call) + (let* ([call (parameterize ([print-gensym #f] [print-level 3] [print-length 6]) + (format "~s" (preinfo-sexpr preinfo)))] + [warn (lambda (src) + ($source-warning 'compile src #t + "possible incorrect argument count in call ~a" + call))]) + (cond + [(enable-error-source-expression) + `(seq ,f + ,(build-sequence args + (cond + [(preinfo-src preinfo) => + (lambda (src) + (warn src) + `(call ,preinfo + ,(lookup-primref 2 '$source-violation) + (quote #f) + (quote ,src) + (quote #t) + (quote "incorrect argument count in call ~a") + (quote ,call)))] + [else `(call ,preinfo - ,(lookup-primref 2 '$source-violation) + ,(lookup-primref 2 '$oops) (quote #f) - (quote ,src) - (quote #t) (quote "incorrect argument count in call ~a") - (quote ,call)))] - [else - `(call ,preinfo - ,(lookup-primref 2 '$oops) - (quote #f) - (quote "incorrect argument count in call ~a") - (quote ,call))])))))))) + (quote ,call))])))] + [else + ;; Just report warning, if source, and keep original call + (cond [(preinfo-src preinfo) => warn]) + `(call ,preinfo ,f ,args ...)])))))) (Expr : Expr (ir [ctxt #f]) -> Expr () [(quote ,d) ir] [(ref ,maybe-src ,x) diff --git a/s/front.ss b/s/front.ss index 6feebe8ef5..6680b47bed 100644 --- a/s/front.ss +++ b/s/front.ss @@ -117,6 +117,8 @@ (define enable-type-recovery ($make-thread-parameter #t (lambda (x) (and x #t)))) +(define enable-error-source-expression ($make-thread-parameter #t (lambda (x) (and x #t)))) + (define machine-type (lambda () (constant machine-type-name))) diff --git a/s/primdata.ss b/s/primdata.ss index d622b29346..974e59ce0f 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -957,6 +957,7 @@ (enable-object-backreferences [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) (enable-object-counts [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) (enable-type-recovery [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) + (enable-error-source-expression [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) (eval-syntax-expanders-when [sig [() -> (list)] [(sub-list) -> (void)]] [flags]) (expand-omit-library-invocations [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) (expand-output [sig [() -> (maybe-textual-output-port)] [(maybe-textual-output-port) -> (void)]] [flags])