[Guile-commits] 15/16: error, scm-error primcalls expand to `throw'

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit cf486700b78a72f1bcab5b450394a63cf3ec7bff
Author: Andy Wingo <address@hidden>
Date:   Sun Nov 5 13:05:19 2017 +0100

    error, scm-error primcalls expand to `throw'
    
    * module/language/tree-il/primitives.scm (scm-error, error): Expand
      into `throw'.
    * module/language/tree-il/peval.scm (peval): Reify "throw" for dynwind
      error.
    * module/language/tree-il/compile-cps.scm (canonicalize): Reify "throw"
      for call-with-prompt error.
    * module/language/cps/prune-bailouts.scm (prune-bailouts): Don't expect
      "error" or "scm-error" here.
---
 module/language/cps/prune-bailouts.scm  |  3 +--
 module/language/tree-il/compile-cps.scm |  2 +-
 module/language/tree-il/peval.scm       |  2 +-
 module/language/tree-il/primitives.scm  | 37 +++++++++++++++++++++++++++++++++
 test-suite/tests/peval.test             |  4 ++--
 5 files changed, 42 insertions(+), 6 deletions(-)

diff --git a/module/language/cps/prune-bailouts.scm 
b/module/language/cps/prune-bailouts.scm
index 6a46798..4120872 100644
--- a/module/language/cps/prune-bailouts.scm
+++ b/module/language/cps/prune-bailouts.scm
@@ -73,8 +73,7 @@ unreferenced terms.  In that case TAIL-LABEL is either absent 
or #f."
         (lambda (label cont out)
           (match cont
             (($ $kargs names vars
-                ($ $continue k src
-                   (and exp ($ $primcall (or 'error 'scm-error 'throw)))))
+                ($ $continue k src (and exp ($ $primcall 'throw))))
              (call-with-values (lambda () (prune-bailout out tails k src exp))
                (lambda (out term)
                  (if term
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index a242da9..8d906ff 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1149,7 +1149,7 @@ integer."
              (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
              (make-void src)
              (make-primcall
-              src 'scm-error
+              src 'throw
               (list
                (make-const #f 'wrong-type-arg)
                (make-const #f "call-with-prompt")
diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index 0c23f7b..c3df1a7 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1193,7 +1193,7 @@ top-level bindings from ENV and return the resulting 
expression."
               (make-primcall src 'thunk? (list u))
               (make-call src w '())
               (make-primcall
-               src 'scm-error
+               src 'throw
                (list
                 (make-const #f 'wrong-type-arg)
                 (make-const #f "dynamic-wind")
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index e716714..646eea0 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -378,6 +378,43 @@
                                     ,(consequent (cadr in)))
                                   out)))))))
 
+;; Oddly, scm-error is just an explicitly 5-argument `throw'.  Weird.
+(define-primitive-expander scm-error (key who message args data)
+  (throw key who message args data))
+
+(define (escape-format-directives str)
+  (string-join (string-split str #\~) "~~"))
+
+(hashq-set!
+ *primitive-expand-table*
+ 'error
+ (match-lambda*
+  ((src)
+   (make-primcall src 'throw
+                  (list (make-const src 'misc-error)
+                        (make-const src #f)
+                        (make-const src "?")
+                        (make-const src #f)
+                        (make-const src #f))))
+  ((src ($ <const> src2 (? string? message)) . args)
+   (let ((msg (string-join (cons (escape-format-directives message)
+                                 (make-list (length args) "~S")))))
+     (make-primcall src 'throw
+                    (list (make-const src 'misc-error)
+                          (make-const src #f)
+                          (make-const src2 msg)
+                          (make-primcall src 'list args)
+                          (make-const src #f)))))
+  ((src message . args)
+   (let ((msg (string-join (cons "~A" (make-list (length args) "~S")))))
+     (make-primcall src 'throw
+                    (list (make-const src 'misc-error)
+                          (make-const src #f)
+                          (make-const src msg)
+                          (make-const src "?")
+                          (make-primcall src 'list (cons message args))
+                          (make-const src #f)))))))
+
 (define-primitive-expander zero? (x)
   (= x 0))
 
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 4e2ccf9..1b1eff9 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1,7 +1,7 @@
 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
 ;;;; Andy Wingo <address@hidden> --- May 2009
 ;;;;
-;;;;   Copyright (C) 2009-2014 Free Software Foundation, Inc.
+;;;;   Copyright (C) 2009-2014, 2017 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -1145,7 +1145,7 @@
    (let (tmp tmp) (_ _) ((toplevel foo) (toplevel baz))
         (seq (seq (if (primcall thunk? (lexical tmp _))
                       (call (lexical tmp _))
-                      (primcall scm-error . _))
+                      (primcall throw . _))
                   (primcall wind (lexical tmp _) (lexical tmp _)))
              (let (tmp) (_) ((toplevel bar))
                   (seq (seq (primcall unwind)