mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

error, scm-error primcalls expand to `throw'

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2017-11-05 13:05:19 +01:00
parent 17bd5a8938
commit cf486700b7
5 changed files with 42 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

3
module/language/cps/prune-bailouts.scm
View file

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

2
module/language/tree-il/compile-cps.scm
View file

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

2
module/language/tree-il/peval.scm
View file

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

37
module/language/tree-il/primitives.scm
View file

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

4
test-suite/tests/peval.test
View file

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