diff options
author | Andy Wingo <wingo@pobox.com> | 2017-11-05 13:05:19 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2017-11-05 15:00:16 +0100 |
commit | cf486700b78a72f1bcab5b450394a63cf3ec7bff (patch) | |
tree | a67270c542f31646515145c0b84d2ae4045d6128 | |
parent | 17bd5a893835b44acbfc5ee4254813e9a6ceea25 (diff) | |
download | guile-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.scm | 3 | ||||
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 2 | ||||
-rw-r--r-- | module/language/tree-il/peval.scm | 2 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 37 | ||||
-rw-r--r-- | 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 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) |