add enable-error-source-expression

original commit: 02f383510653bb16c65fc812eb0c619bcb0347b5

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}

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

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)

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)))

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)

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)))

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])