Skip to content

Commit

Permalink
Merge branch 'jpellegrini-declare-new-error'
Browse files Browse the repository at this point in the history
  • Loading branch information
@egallesio
egallesio committed Oct 26, 2024
2 parents 06ae31f + 98f407e commit e14ce28
Show file tree
Hide file tree
Showing 5 changed files with 3,662 additions and 3,712 deletions.
66 changes: 66 additions & 0 deletions doc/HTML/stklos-ref.html
View file
Original file line number Diff line number Diff line change
Expand Up @@ -28291,6 +28291,72 @@ <h4 id="doc_srfi_35conditions">srfi-35&#8201;&#8212;&#8201;Conditions</h4>
See <em><a href="#doc_predefined_conditions">Section 7.3</a></em> for the predefined conditions
and when it is required to load this file.</p>
</div>
<div class="paragraph">
<p>Furthermore, this SRFI exports also the helper syntax <code>define-new-error</code>:
<a id='P_define-new-error'></a>
</p>
</div>
<div class="paragraph rmargin text-right">
<p><span class="rmargin small silver"><em>STklos</em> syntax</span></p>
</div>
<div class="sidebarblock">
<div class="content">
<div class="paragraph small">
<p><code><strong>(define-new-error name) </strong></code><br></p>
</div>
</div>
</div>
<div class="paragraph">
<p>Declares a new error with name <code>&amp;name</code>. This will expand to
<code>define-condition-type</code> (described in SRFI-35),
and the effect will be that:</p>
</div>
<div class="ulist">
<ul>
<li>
<p>a new condition of type <code>&amp;error-message</code> is created, with a <code>&amp;</code>
sign prepended to <code>name</code></p>
</li>
<li>
<p>a new predicate is created, with a <code>&amp;</code> sign prepended and a
question mark (<code>?</code>) appended to <code>name</code></p>
</li>
<li>
<p>a new procedure called <code>name</code> is created. This procedure will
signal errors of this new type.</p>
</li>
</ul>
</div>
<div class="listingblock">
<div class="content">
<pre class="rouge highlight"><code data-lang="scheme"><span class="p">(</span><span class="nf">import</span> <span class="p">(</span><span class="nf">srfi</span> <span class="mi">35</span><span class="p">))</span>

<span class="p">(</span><span class="nf">define-new-error</span> <span class="nv">big-error</span><span class="p">)</span>
<span class="p">(</span><span class="nf">apropos</span> <span class="ss">'big-error</span><span class="p">)</span> <span class="nv">=&gt;</span> <span class="p">(</span><span class="nf">&amp;big-error</span> <span class="nv">&amp;big-error?</span> <span class="nv">big-error</span><span class="p">)</span>

<span class="p">(</span><span class="nf">describe</span> <span class="nv">&amp;big-error</span><span class="p">)</span>
<span class="o">#</span><span class="p">[</span><span class="nf">condition-type</span> <span class="nv">&amp;big-error</span> <span class="mi">139844680604416</span><span class="p">]</span> <span class="nv">is</span> <span class="nv">a</span> <span class="nv">condition</span> <span class="nv">type</span>
<span class="nv">whose</span> <span class="nv">name</span> <span class="nv">is</span> <span class="nv">&amp;big-error</span><span class="o">.</span>
<span class="nv">Parent</span> <span class="nv">of</span> <span class="nv">condition</span> <span class="nv">type:</span> <span class="nv">&amp;error-message</span>
<span class="nv">Fields</span> <span class="nv">of</span> <span class="nv">condition</span> <span class="nv">type:</span>
<span class="nv">location</span>
<span class="nv">backtrace</span>
<span class="nv">message</span>
<span class="nv">r7rs-msg</span>
<span class="nv">r7rs-irritants</span>

<span class="nv">&amp;big-error?</span> <span class="nv">=&gt;</span> <span class="o">#</span><span class="p">[</span><span class="nf">closure</span> <span class="nv">&amp;big-error?</span><span class="p">]</span>
<span class="nv">big-error</span> <span class="nv">=&gt;</span> <span class="o">#</span><span class="p">[</span><span class="nf">closure</span> <span class="nv">big-error</span><span class="p">]</span>

<span class="p">(</span><span class="nf">big-error</span> <span class="s">"Huge mistake: ~S"</span> <span class="mi">14</span><span class="p">)</span>
<span class="nv">****</span> <span class="nv">Error:</span>
<span class="nv">big-error:</span> <span class="nv">Huge</span> <span class="nv">mistake:</span> <span class="mi">14</span>

<span class="p">(</span><span class="nf">big-error</span> <span class="ss">'callee</span> <span class="s">"Huge mistake: ~S"</span> <span class="mi">14</span><span class="p">)</span>
<span class="nv">****</span> <span class="nv">Error:</span>
<span class="nv">callee:</span> <span class="nv">Huge</span> <span class="nv">mistake:</span> <span class="mi">14</span></code></pre>
</div>
</div>
</div>
<div class="sect3">
<h4 id="doc_srfi_36io_conditions">srfi-36&#8201;&#8212;&#8201;I/O Conditions</h4>
Expand Down
4 changes: 4 additions & 0 deletions doc/refman/srfi.adoc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -294,6 +294,10 @@ is more general than the one defined this SRFI.
See _<<doc_predefined_conditions>>_ for the predefined conditions
and when it is required to load this file.

Furthermore, this SRFI exports also the helper syntax `define-new-error`:
{{insertdoc 'define-new-error}}



// **** SRFI-36
{{srfi-subsection 36}}
Expand Down
24 changes: 1 addition & 23 deletions lib/bonus.stk
View file
Original file line number Diff line number Diff line change
Expand Up @@ -49,7 +49,6 @@
ansi-color ansi-color-protect do-color
port->string port->sexp-list port->string-list
print printerr eprintf printf fprintf
declare-new-error
exec exec-list die
decompose-file-name dirname basename file-separator
make-path file-suffix file-prefix
Expand Down Expand Up @@ -465,7 +464,7 @@ doc>
(expr (read-ci p)))
(close-port p)
expr))


#|
<doc EXT eval-from-string-ci eval-from-string
Expand Down Expand Up @@ -1698,27 +1697,6 @@ doc>
(define (fprintf port fmt . args)
(display (apply format fmt args) port))


#|
<doc EXT-SYNTAX declare-new-error
* (declare-new-error name)
*
* TODO
*
doc>
|#
(define-macro (declare-new-error name)
(let ((cond-name (string->symbol (format "&~a" name)))
(predicate (string->symbol (format "&~a?" name)))
(args (gensym)))
`(begin
(define-condition-type ,cond-name &error-message ,predicate)
(define (,name . ,args)
(if (and (not (null? ,args))
(symbol? (car ,args)))
(apply signal-error ,cond-name ,args)
(apply signal-error ,cond-name ',name ,args))))))

#|
<doc EXT exec exec-list
* (exec str)
Expand Down
63 changes: 62 additions & 1 deletion lib/srfi/35.stk
View file
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
;;;;
;;;; 35.stk -- Implementation of SRFI-35 (Conditions)
;;;;
;;;; Copyright © 2004-2022 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;; Copyright © 2004-2024 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
Expand Down Expand Up @@ -40,6 +40,9 @@

;; Standard conditions
&condition &message &serious &error

;; STklos bonus
define-new-error
)

(define-macro (%define-condition-type-accessors name supertype predicate . slots)
Expand Down Expand Up @@ -82,6 +85,64 @@
slots)
,new)))

#|
<doc EXT-SYNTAX define-new-error
* (define-new-error name)
*
* Declares a new error with name |&name|. This will expand to
* |define-condition-type| (described in SRFI-35),
* and the effect will be that:
*
* - a new condition of type |&error-message| is created, with a |&|
* sign prepended to |name|
*
* - a new predicate is created, with a |&| sign prepended and a
* question mark (|?|) appended to |name|
*
* - a new procedure called |name| is created. This procedure will
* signal errors of this new type.
*
* @lisp
* (import (srfi 35))
*
* (define-new-error big-error)
* (apropos 'big-error) => (&big-error &big-error? big-error)
*
* (describe &big-error)
* #[condition-type &big-error 139844680604416] is a condition type
* whose name is &big-error.
* Parent of condition type: &error-message
* Fields of condition type:
* location
* backtrace
* message
* r7rs-msg
* r7rs-irritants
*
* &big-error? => #[closure &big-error?]
* big-error => #[closure big-error]
*
* (big-error "Huge mistake: ~S" 14)
* **** Error:
* big-error: Huge mistake: 14
*
* (big-error 'callee "Huge mistake: ~S" 14)
* **** Error:
* callee: Huge mistake: 14
* @end lisp
doc>
|#
(define-macro (define-new-error name)
(let ((cond-name (string->symbol (format "&~a" name)))
(predicate (string->symbol (format "&~a?" name)))
(args (gensym)))
`(begin
(define-condition-type ,cond-name &error-message ,predicate)
(define (,name . ,args)
(if (and (not (null? ,args))
(symbol? (car ,args)))
(apply signal-error ,cond-name ,args)
(apply signal-error ,cond-name ',name ,args))))))
) ;; End of module

(provide "srfi/35")
Expand Down
Loading

0 comments on commit e14ce28

Please sign in to comment.