summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2017-11-05 13:05:19 +0100
committerAndy Wingo <wingo@pobox.com>2017-11-05 15:00:16 +0100
commitcf486700b78a72f1bcab5b450394a63cf3ec7bff (patch)
treea67270c542f31646515145c0b84d2ae4045d6128
parent17bd5a893835b44acbfc5ee4254813e9a6ceea25 (diff)
downloadguile-cf486700b78a72f1bcab5b450394a63cf3ec7bff.tar.gz
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.
-rw-r--r--module/language/cps/prune-bailouts.scm3
-rw-r--r--module/language/tree-il/compile-cps.scm2
-rw-r--r--module/language/tree-il/peval.scm2
-rw-r--r--module/language/tree-il/primitives.scm37
-rw-r--r--test-suite/tests/peval.test4
5 files changed, 42 insertions, 6 deletions
diff --git a/module/language/cps/prune-bailouts.scm b/module/language/cps/prune-bailouts.scm
index 6a46798ad..412087231 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 a242da99d..8d906ffc2 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 0c23f7b41..c3df1a700 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 e716714fb..646eea0c1 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 4e2ccf9c6..1b1eff9da 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 <wingo@pobox.com> --- 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)