Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Move REPL condition printing into the SRFI 35 implementation

Browse source
This commit is contained in:
Daphne Preston-Kendal 2024-11-02 01:03:27 +01:00
parent 76f35bc733
commit 2781739291
4 changed files with 48 additions and 52 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

45
lib/chibi/repl.scm
View file

@ -370,49 +370,6 @@
(display ".\nNote module files must end in \".sld\".\n" out)))))))
)))
(define (repl-print-condition exn out)
(define components (simple-conditions exn))
(define n-components (length components))
(display "CONDITION: " out)
(display n-components out)
(display " component" out)
(if (not (= n-components 1)) (display "s" out))
(display "\n" out)
(for-each
(lambda (component idx)
(define component-type (type-of component))
(display " " out)
(display idx out)
(display ". " out)
(display (type-name component-type) out)
(display "\n" out)
(let loop ((as (reverse
(condition-type-ancestors component-type)))
(idx 0))
(if (not (null? as))
(let ((a (car as)))
(let a-loop ((fields (type-slots a))
(idx idx))
(if (null? fields)
(loop (cdr as) idx)
(begin
(display " " out)
(display (if (pair? (car fields))
(car (cdar fields))
(car fields))
out)
(if (not (eqv? a component-type))
(begin
(display " (" out)
(display (type-name a) out)
(display ")" out)))
(display ": " out)
(write (slot-ref component-type component idx) out)
(display "\n" out)
(a-loop (cdr fields) (+ idx 1)))))))))
components
(iota n-components 1)))
(define undefined-value (if #f #f))
(define $0 undefined-value)
@ -463,8 +420,6 @@
(lambda (n) (thread-interrupt! thread))
(lambda ()
(protect (exn
((condition? exn)
(repl-print-condition exn out))
(else
(repl-print-exception exn out)
(repl-advise-exception exn (current-error-port))))

1
lib/chibi/repl.sld
View file

@ -9,7 +9,6 @@
(srfi 1)
(srfi 9)
(only (srfi 18) current-thread)
(srfi 35 internal)
(srfi 38)
(srfi 95)
(srfi 98))

43
lib/srfi/35/internal.scm
View file

@ -204,3 +204,46 @@
(define-condition-type/constructor &error &serious
make-error error?)
;; (chibi repl) support
(define-method (repl-print-exception (exn condition?) (out output-port?))
(define components (simple-conditions exn))
(define n-components (length components))
(display "CONDITION: " out)
(display n-components out)
(display " component" out)
(if (not (= n-components 1)) (display "s" out))
(display "\n" out)
(for-each
(lambda (component idx)
(define component-type (record-rtd component))
(display " " out)
(display idx out)
(display ". " out)
(display (rtd-name component-type) out)
(display "\n" out)
(let loop ((as (reverse
(condition-type-ancestors component-type)))
(idx 0))
(if (not (null? as))
(let ((a (car as)))
(let a-loop ((fields (vector->list (rtd-field-names a)))
(idx idx))
(if (null? fields)
(loop (cdr as) idx)
(begin
(display " " out)
(display (if (pair? (car fields))
(car (cdar fields))
(car fields))
out)
(if (not (eqv? a component-type))
(begin
(display " (" out)
(display (rtd-name a) out)
(display ")" out)))
(display ": " out)
(write (slot-ref component-type component idx) out)
(display "\n" out)
(a-loop (cdr fields) (+ idx 1)))))))))
components
(iota n-components 1)))

11
lib/srfi/35/internal.sld
View file

@ -3,28 +3,27 @@
define-record-type
;; exclude (srfi 1 immutable) duplicate imports:
map cons list append reverse)
(scheme write)
(only (chibi)
er-macro-transformer
slot-ref
is-a?)
(only (chibi repl) repl-print-exception)
(only (chibi generic) define-method)
;; don’t let people go messing with a compound condition
;; components list:
(srfi 1 immutable)
(srfi 99)
(srfi 133))
(export simple-condition?
compound-condition?
make-condition-type
(export make-condition-type
condition?
condition-type?
condition-subtype?
condition-type-ancestors
make-condition
make-compound-condition
condition-has-type?
condition-ref
simple-conditions
extract-condition
compound-condition-components
condition-predicate
condition-accessor
define-condition-type/constructor