~ chicken-core (chicken-5) c8608b99cd9c5c0319cacbeddbd9627f6b37c763
commit c8608b99cd9c5c0319cacbeddbd9627f6b37c763
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sun May 7 16:45:16 2017 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Fri May 19 10:32:26 2017 +1200
Add chicken.condition module
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/README b/README
index 27db7bb6..2047a8de 100644
--- a/README
+++ b/README
@@ -286,6 +286,7 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
| | |-- chicken.import.so
| | |-- chicken.bitwise.import.so
| | |-- chicken.compiler.user-pass.import.so
+ | | |-- chicken.condition.import.so
| | |-- chicken.continuation.import.so
| | |-- chicken.csi.import.so
| | |-- chicken.data-structures.import.so
diff --git a/chicken-install.scm b/chicken-install.scm
index 05f26003..0e56b0e2 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -28,6 +28,7 @@
(import (scheme))
(import (chicken))
+(import (chicken condition))
(import (chicken foreign))
(import (chicken data-structures))
(import (chicken keyword))
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 65367b83..e67051b3 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -873,8 +873,7 @@
(##sys#extend-macro-environment
'handle-exceptions
- `((call-with-current-continuation . ,(##sys#primitive-alias 'call-with-current-continuation))
- (with-exception-handler . ,(##sys#primitive-alias 'with-exception-handler)))
+ `((call-with-current-continuation . ,(##sys#primitive-alias 'call-with-current-continuation)))
(##sys#er-transformer
(lambda (form r c)
(##sys#check-syntax 'handle-exceptions form '(_ variable _ . _))
@@ -883,7 +882,7 @@
`((,(r 'call-with-current-continuation)
(##core#lambda
(,k)
- (,(r 'with-exception-handler)
+ (chicken.condition#with-exception-handler
(##core#lambda (,(cadr form)) (,k (##core#lambda () ,(caddr form))))
(##core#lambda
()
@@ -925,7 +924,7 @@
,@clauses
,@(if (assq %else clauses)
`() ; Don't generate two else clauses
- `((,%else (##sys#signal ,exvar)))) )) )
+ `((,%else (chicken.condition#signal ,exvar)))))))
,(cadr form))))))
diff --git a/chicken.import.scm b/chicken.import.scm
index b19e72b5..3ebc9c9d 100644
--- a/chicken.import.scm
+++ b/chicken.import.scm
@@ -26,7 +26,7 @@
(##sys#register-primitive-module
'chicken
- '(abort
+ '((abort . chicken.condition#abort)
add1
argc+argv
argv
@@ -42,13 +42,13 @@
(chicken-home . chicken.platform#chicken-home)
(chicken-version . chicken.platform#chicken-version)
command-line-arguments
- condition-predicate
- condition-property-accessor
- condition?
- condition->list
+ (condition-predicate . chicken.condition#condition-predicate)
+ (condition-property-accessor . chicken.condition#condition-property-accessor)
+ (condition? . chicken.condition#condition?)
+ (condition->list . chicken.condition#condition->list)
cplxnum?
current-error-port
- current-exception-handler
+ (current-exception-handler . chicken.condition#current-exception-handler)
current-read-table
delete-file
directory-exists?
@@ -105,8 +105,8 @@
(fxlen . chicken.fixnum#fxlen)
gensym
get
- get-call-chain
- get-condition-property
+ (get-call-chain . chicken.condition#get-call-chain)
+ (get-condition-property . chicken.condition#get-condition-property)
get-environment-variable
(get-line-number . chicken.expand#get-line-number)
get-output-string
@@ -126,10 +126,10 @@
(machine-byte-order . chicken.platform#machine-byte-order)
(machine-type . chicken.platform#machine-type)
make-blob
- make-composite-condition
+ (make-composite-condition . chicken.condition#make-composite-condition)
make-parameter
make-promise
- make-property-condition
+ (make-property-condition . chicken.condition#make-property-condition)
module-environment
(most-negative-fixnum . chicken.fixnum#most-negative-fixnum)
(most-positive-fixnum . chicken.fixnum#most-positive-fixnum)
@@ -147,7 +147,7 @@
(provide . chicken.load#provide)
(provided? . chicken.load#provided?)
print
- print-call-chain
+ (print-call-chain . chicken.condition#print-call-chain)
print-error-message
print*
procedure-information
@@ -169,7 +169,7 @@
reverse-list->string
set-port-name!
setter
- signal
+ (signal . chicken.condition#signal)
signum
singlestep
sleep
@@ -190,5 +190,5 @@
vector-copy!
void
warning
- with-exception-handler)
+ (with-exception-handler . chicken.condition#with-exception-handler))
##sys#chicken-macro-environment) ;XXX incorrect - won't work in compiled executable that does expansion
diff --git a/core.scm b/core.scm
index 8f68e3fa..4d05fd8e 100644
--- a/core.scm
+++ b/core.scm
@@ -322,6 +322,7 @@
line-number-database-size)
(import chicken scheme
+ chicken.condition
chicken.compiler.scrutinizer
chicken.compiler.support
chicken.data-structures
diff --git a/csi.scm b/csi.scm
index 72defb80..d03c1690 100644
--- a/csi.scm
+++ b/csi.scm
@@ -45,6 +45,7 @@ EOF
(editor-command toplevel-command set-describer!)
(import chicken scheme
+ chicken.condition
chicken.data-structures
chicken.foreign
chicken.format
diff --git a/data-structures.scm b/data-structures.scm
index 0a6ea241..bf9821b1 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -44,6 +44,7 @@
(import scheme chicken)
(import chicken.foreign)
+(import chicken.condition)
(include "common-declarations.scm")
@@ -748,13 +749,13 @@
(define (visit dag node edges path state)
(case (alist-ref node (car state) pred)
((grey)
- (##sys#abort
+ (abort
(##sys#make-structure
'condition
'(exn runtime cycle)
`((exn . message) "cycle detected"
(exn . arguments) ,(list (cons node (reverse path)))
- (exn . call-chain) ,(##sys#get-call-chain)
+ (exn . call-chain) ,(get-call-chain)
(exn . location) topological-sort))))
((black)
state)
diff --git a/defaults.make b/defaults.make
index bc66d78c..bf3258f4 100644
--- a/defaults.make
+++ b/defaults.make
@@ -265,10 +265,10 @@ CHICKEN_PROGRAM_OPTIONS += $(if $(PROFILE_OBJECTS),-profile)
PRIMITIVE_IMPORT_LIBRARIES = chicken chicken.csi chicken.foreign
DYNAMIC_IMPORT_LIBRARIES = srfi-4
-DYNAMIC_CHICKEN_IMPORT_LIBRARIES = bitwise errno file.posix fixnum flonum \
- format gc io keyword load locative memory platform posix \
- pretty-print process process.signal process-context random \
- time time.posix
+DYNAMIC_CHICKEN_IMPORT_LIBRARIES = bitwise condition errno file.posix \
+ fixnum flonum format gc io keyword load locative memory \
+ platform posix pretty-print process process.signal \
+ process-context random time time.posix
DYNAMIC_CHICKEN_COMPILER_IMPORT_LIBRARIES = user-pass
DYNAMIC_CHICKEN_UNIT_IMPORT_LIBRARIES = continuation data-structures \
eval expand file files internal irregex lolevel pathname port \
diff --git a/distribution/manifest b/distribution/manifest
index 7e9c3adb..69b81782 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -267,6 +267,8 @@ chicken.bitwise.import.scm
chicken.bitwise.import.c
chicken.compiler.user-pass.import.scm
chicken.compiler.user-pass.import.c
+chicken.condition.import.scm
+chicken.condition.import.c
chicken.continuation.import.scm
chicken.continuation.import.c
chicken.csi.import.scm
diff --git a/eval.scm b/eval.scm
index 9fb27da7..859cfba0 100644
--- a/eval.scm
+++ b/eval.scm
@@ -1374,7 +1374,7 @@
;;; Simple invocation API:
-(import chicken chicken.eval chicken.load)
+(import chicken chicken.eval chicken.load chicken.condition)
(declare
(hide last-error run-safe store-result store-string
diff --git a/expand.scm b/expand.scm
index c471d351..e5d8bb50 100644
--- a/expand.scm
+++ b/expand.scm
@@ -51,6 +51,7 @@
expansion-result-hook)
(import scheme chicken
+ chicken.condition
chicken.internal
chicken.keyword
chicken.platform)
@@ -223,7 +224,7 @@
(handle-exceptions ex
;; modify error message in condition object to include
;; currently expanded macro-name
- (##sys#abort
+ (abort
(if (and (##sys#structure? ex 'condition)
(memv 'exn (##sys#slot ex 1)) )
(##sys#make-structure
diff --git a/library.scm b/library.scm
index 6826107a..27a0b258 100644
--- a/library.scm
+++ b/library.scm
@@ -4385,72 +4385,6 @@ EOF
(string-append "#<pointer 0x" (##sys#number->string (##sys#pointer->address x) 16) ">") ) ) ) )
-;;; Access backtrace:
-
-(define-constant +trace-buffer-entry-slot-count+ 4)
-
-(define get-call-chain
- (let ((extract
- (foreign-lambda* nonnull-c-string ((scheme-object x)) "C_return((C_char *)x);")))
- (lambda (#!optional (start 0) (thread ##sys#current-thread))
- (let* ((tbl (foreign-value "C_trace_buffer_size" int))
- ;; 4 slots: "raw" string, cooked1, cooked2, thread
- (c +trace-buffer-entry-slot-count+)
- (vec (##sys#make-vector (fx* c tbl) #f))
- (r (##core#inline "C_fetch_trace" start vec))
- (n (if (fixnum? r) r (fx* c tbl))) )
- (let loop ((i 0))
- (if (fx>= i n)
- '()
- (let ((t (##sys#slot vec (fx+ i 3)))) ; thread
- (if (or (not t) (not thread) (eq? thread t))
- (cons (vector
- (extract (##sys#slot vec i)) ; raw
- (##sys#slot vec (fx+ i 1)) ; cooked1
- (##sys#slot vec (fx+ i 2)) ) ; cooked2
- (loop (fx+ i c)) )
- (loop (fx+ i c))) ) ) ) ) ) ) )
-
-(define (##sys#really-print-call-chain port chain header)
- (when (pair? chain)
- (##sys#print header #f port)
- (for-each
- (lambda (info)
- (let* ((more1 (##sys#slot info 1)) ; cooked1 (expr/form)
- (more2 (##sys#slot info 2)) ; cooked2 (cntr/frameinfo)
- (fi (##sys#structure? more2 'frameinfo)))
- (##sys#print "\n\t" #f port)
- (##sys#print (##sys#slot info 0) #f port) ; raw (mode)
- (##sys#print "\t " #f port)
- (when (and more2 (if fi (##sys#slot more2 1)))
- (##sys#write-char-0 #\[ port)
- (##sys#print
- (if fi
- (##sys#slot more2 1) ; cntr
- more2)
- #f port)
- (##sys#print "] " #f port) )
- (when more1
- (##sys#with-print-length-limit
- 100
- (lambda ()
- (##sys#print more1 #t port) ) ) ) ) )
- chain)
- (##sys#print "\t<--\n" #f port) ) )
-
-(define (print-call-chain #!optional (port ##sys#standard-output) (start 0)
- (thread ##sys#current-thread)
- (header "\n\tCall history:\n") )
- (##sys#check-output-port port #t 'print-call-chain)
- (##sys#check-fixnum start 'print-call-chain)
- (##sys#check-string header 'print-call-chain)
- (let ((ct (##sys#get-call-chain start thread)))
- (##sys#really-print-call-chain port ct header)
- ct))
-
-(define ##sys#get-call-chain get-call-chain)
-
-
;;; Interrupt handling:
(define (##sys#user-interrupt-hook)
@@ -4462,46 +4396,6 @@ EOF
;;; Default handlers
-(define ##sys#break-on-error (foreign-value "C_enable_repl" bool))
-
-(define-foreign-variable _ex_software int "EX_SOFTWARE")
-
-(define ##sys#error-handler
- (make-parameter
- (let ([string-append string-append])
- (lambda (msg . args)
- (##sys#error-handler (lambda args (##core#inline "C_halt" "error in error")))
- (cond ((not (foreign-value "C_gui_mode" bool))
- (##sys#print "\nError" #f ##sys#standard-error)
- (when msg
- (##sys#print ": " #f ##sys#standard-error)
- (##sys#print msg #f ##sys#standard-error) )
- (##sys#with-print-length-limit
- 400
- (lambda ()
- (cond [(fx= 1 (length args))
- (##sys#print ": " #f ##sys#standard-error)
- (##sys#print (##sys#slot args 0) #t ##sys#standard-error)]
- [else
- (##sys#for-each
- (lambda (x)
- (##sys#print #\newline #f ##sys#standard-error)
- (##sys#print x #t ##sys#standard-error))
- args)])))
- (##sys#print #\newline #f ##sys#standard-error)
- (print-call-chain ##sys#standard-error)
- (when (and ##sys#break-on-error (##sys#symbol-has-toplevel-binding? 'chicken.repl#repl))
- (chicken.repl#repl)
- (##sys#print #\newline #f ##sys#standard-error)
- (##core#inline "C_exit_runtime" _ex_software) )
- (##core#inline "C_halt" #f) )
- (else
- (let ((out (open-output-string)))
- (when msg (##sys#print msg #f out))
- (##sys#print #\newline #f out)
- (##sys#for-each (lambda (x) (##sys#print x #t out) (##sys#print #\newline #f out)) args)
- (##core#inline "C_halt" (get-output-string out)) ) ) ) ) ) ) )
-
(define reset-handler
(make-parameter
(lambda ()
@@ -4555,15 +4449,90 @@ EOF
;;; Condition handling:
-(define (##sys#debugger msg . args)
- (##core#inline "signal_debug_event" #:debugger-invocation msg args) )
+(module chicken.condition
+ (abort signal current-exception-handler get-call-chain
+ print-call-chain with-exception-handler
+
+ ;; Condition object manipulation
+ make-property-condition make-composite-condition condition?
+ condition->list condition-predicate condition-property-accessor
+ get-condition-property)
+
+(import scheme)
+(import chicken.fixnum)
+(import chicken.foreign)
+(import (only chicken get-output-string open-output-string
+ define-constant when fixnum? let-optionals make-parameter))
+
+;;; Access backtrace:
+
+(define-constant +trace-buffer-entry-slot-count+ 4)
+
+(define get-call-chain
+ (let ((extract
+ (foreign-lambda* nonnull-c-string ((scheme-object x)) "C_return((C_char *)x);")))
+ (lambda (#!optional (start 0) (thread ##sys#current-thread))
+ (let* ((tbl (foreign-value "C_trace_buffer_size" int))
+ ;; 4 slots: "raw" string, cooked1, cooked2, thread
+ (c +trace-buffer-entry-slot-count+)
+ (vec (##sys#make-vector (fx* c tbl) #f))
+ (r (##core#inline "C_fetch_trace" start vec))
+ (n (if (fixnum? r) r (fx* c tbl))))
+ (let loop ((i 0))
+ (if (fx>= i n)
+ '()
+ (let ((t (##sys#slot vec (fx+ i 3)))) ; thread
+ (if (or (not t) (not thread) (eq? thread t))
+ (cons (vector
+ (extract (##sys#slot vec i)) ; raw
+ (##sys#slot vec (fx+ i 1)) ; cooked1
+ (##sys#slot vec (fx+ i 2))) ; cooked2
+ (loop (fx+ i c)))
+ (loop (fx+ i c))))))))))
+
+(define (##sys#really-print-call-chain port chain header)
+ (when (pair? chain)
+ (##sys#print header #f port)
+ (for-each
+ (lambda (info)
+ (let* ((more1 (##sys#slot info 1)) ; cooked1 (expr/form)
+ (more2 (##sys#slot info 2)) ; cooked2 (cntr/frameinfo)
+ (fi (##sys#structure? more2 'frameinfo)))
+ (##sys#print "\n\t" #f port)
+ (##sys#print (##sys#slot info 0) #f port) ; raw (mode)
+ (##sys#print "\t " #f port)
+ (when (and more2 (if fi (##sys#slot more2 1)))
+ (##sys#write-char-0 #\[ port)
+ (##sys#print
+ (if fi
+ (##sys#slot more2 1) ; cntr
+ more2)
+ #f port)
+ (##sys#print "] " #f port))
+ (when more1
+ (##sys#with-print-length-limit
+ 100
+ (lambda ()
+ (##sys#print more1 #t port))))))
+ chain)
+ (##sys#print "\t<--\n" #f port)))
+
+(define (print-call-chain #!optional (port ##sys#standard-output) (start 0)
+ (thread ##sys#current-thread)
+ (header "\n\tCall history:\n"))
+ (##sys#check-output-port port #t 'print-call-chain)
+ (##sys#check-fixnum start 'print-call-chain)
+ (##sys#check-string header 'print-call-chain)
+ (let ((ct (get-call-chain start thread)))
+ (##sys#really-print-call-chain port ct header)
+ ct))
(define (##sys#signal-hook mode msg . args)
(##core#inline "C_dbg_hook" #f)
(##core#inline "signal_debug_event" mode msg args)
(case mode
[(#:user-interrupt)
- (##sys#abort
+ (abort
(##sys#make-structure
'condition
'(user-interrupt)
@@ -4587,12 +4556,12 @@ EOF
(##sys#flush-output ##sys#standard-error)]
[else
(when (and (symbol? msg) (null? args))
- (set! msg (##sys#symbol->string msg)) )
+ (set! msg (symbol->string msg)))
(let* ([hasloc (and (or (not msg) (symbol? msg)) (pair? args))]
[loc (and hasloc msg)]
[msg (if hasloc (##sys#slot args 0) msg)]
[args (if hasloc (##sys#slot args 1) args)] )
- (##sys#abort
+ (abort
(##sys#make-structure
'condition
(case mode
@@ -4613,12 +4582,12 @@ EOF
[else '(exn)] )
(list '(exn . message) msg
'(exn . arguments) args
- '(exn . call-chain) (##sys#get-call-chain)
+ '(exn . call-chain) (get-call-chain)
'(exn . location) loc) ) ) ) ] ) )
(define (abort x)
(##sys#current-exception-handler x)
- (##sys#abort
+ (abort
(##sys#make-structure
'condition
'(exn)
@@ -4629,8 +4598,47 @@ EOF
(define (signal x)
(##sys#current-exception-handler x) )
-(define ##sys#abort abort)
-(define ##sys#signal signal)
+(define ##sys#break-on-error (foreign-value "C_enable_repl" bool))
+
+(define-foreign-variable _ex_software int "EX_SOFTWARE")
+
+(define ##sys#error-handler
+ (make-parameter
+ (let ([string-append string-append])
+ (lambda (msg . args)
+ (##sys#error-handler (lambda args (##core#inline "C_halt" "error in error")))
+ (cond ((not (foreign-value "C_gui_mode" bool))
+ (##sys#print "\nError" #f ##sys#standard-error)
+ (when msg
+ (##sys#print ": " #f ##sys#standard-error)
+ (##sys#print msg #f ##sys#standard-error))
+ (##sys#with-print-length-limit
+ 400
+ (lambda ()
+ (cond [(fx= 1 (length args))
+ (##sys#print ": " #f ##sys#standard-error)
+ (##sys#print (##sys#slot args 0) #t ##sys#standard-error)]
+ [else
+ (##sys#for-each
+ (lambda (x)
+ (##sys#print #\newline #f ##sys#standard-error)
+ (##sys#print x #t ##sys#standard-error))
+ args)])))
+ (##sys#print #\newline #f ##sys#standard-error)
+ (print-call-chain ##sys#standard-error)
+ (when (and ##sys#break-on-error (##sys#symbol-has-toplevel-binding? 'chicken.repl#repl))
+ ;; Hack to avoid hard / cyclic dependency
+ ((##sys#slot 'chicken.repl#repl 0))
+ (##sys#print #\newline #f ##sys#standard-error)
+ (##core#inline "C_exit_runtime" _ex_software))
+ (##core#inline "C_halt" #f))
+ (else
+ (let ((out (open-output-string)))
+ (when msg (##sys#print msg #f out))
+ (##sys#print #\newline #f out)
+ (##sys#for-each (lambda (x) (##sys#print x #t out) (##sys#print #\newline #f out)) args)
+ (##core#inline "C_halt" (get-output-string out)))))))))
+
(define ##sys#last-exception #f) ; used in csi for ,exn command
@@ -4672,7 +4680,7 @@ EOF
"uncaught exception"
(cadr (member '(uncaught-exception . reason) (##sys#slot c 2))) )
((##sys#reset-handler)) ) ) ) )
- (##sys#abort
+ (abort
(##sys#make-structure
'condition
'(uncaught-exception)
@@ -4685,6 +4693,7 @@ EOF
thunk
(lambda () (set! ##sys#current-exception-handler oldh)) ) ) )
+;; TODO: Make this a proper parameter
(define (current-exception-handler . args)
(if (null? args)
##sys#current-exception-handler
@@ -4694,6 +4703,8 @@ EOF
(when set? (set! ##sys#current-exception-handler proc)))
proc)))
+;;; Condition object manipulation
+
(define (make-property-condition kind . props)
(##sys#make-structure
'condition (list kind)
@@ -4830,6 +4841,15 @@ EOF
((55) (apply ##sys#signal-hook #:type-error loc "cannot compute absolute value of complex number" args))
(else (apply ##sys#signal-hook #:runtime-error loc "unknown internal error" args)) ) ) ) )
+) ; chicken.condition
+
+(import chicken.condition)
+
+;; OBSOLETE: This can be removed after bootstrapping, when the
+;; handle-exceptions macro won't be rewritten to a primitive alias.
+;; This is necessary because the compiler uses this macro itself.
+(define #%with-exception-handler with-exception-handler)
+
;;; Miscellaneous low-level routines:
diff --git a/modules.scm b/modules.scm
index 15635ca7..85e7a059 100644
--- a/modules.scm
+++ b/modules.scm
@@ -1003,9 +1003,15 @@
(##sys#register-core-module
'srfi-12 'library
- '(abort condition? condition-predicate condition-property-accessor
- current-exception-handler make-composite-condition make-property-condition
- signal with-exception-handler)
+ '((abort . chicken.condition#abort)
+ (condition? . chicken.condition#condition?)
+ (condition-predicate . chicken.condition#condition-predicate)
+ (condition-property-accessor . chicken.condition#condition-property-accessor)
+ (current-exception-handler . chicken.condition#current-exception-handler)
+ (make-composite-condition . chicken.condition#make-composite-condition)
+ (make-property-condition . chicken.condition#make-property-condition)
+ (signal . chicken.condition#signal)
+ (with-exception-handler . chicken.condition#with-exception-handler))
(se-subset '(handle-exceptions) ##sys#chicken-macro-environment))
(##sys#register-primitive-module
diff --git a/posixunix.scm b/posixunix.scm
index 40b5b757..60f547b2 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -76,6 +76,7 @@
(import scheme chicken)
(import chicken.bitwise
+ chicken.condition
chicken.foreign
chicken.irregex
chicken.memory
diff --git a/posixwin.scm b/posixwin.scm
index 02fc62f2..42435620 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -672,6 +672,7 @@ EOF
(import scheme chicken)
(import chicken.bitwise
+ chicken.condition
chicken.data-structures
chicken.foreign
chicken.irregex
diff --git a/rules.make b/rules.make
index 49435e5c..b82e98a8 100644
--- a/rules.make
+++ b/rules.make
@@ -506,6 +506,7 @@ $(eval $(call declare-emitted-import-lib-dependency,chicken.time.posix,$(POSIXFI
$(eval $(call declare-emitted-import-lib-dependency,chicken.process,$(POSIXFILE)))
$(eval $(call declare-emitted-import-lib-dependency,chicken.process.signal,$(POSIXFILE)))
$(eval $(call declare-emitted-import-lib-dependency,chicken.bitwise,library))
+$(eval $(call declare-emitted-import-lib-dependency,chicken.condition,library))
$(eval $(call declare-emitted-import-lib-dependency,chicken.fixnum,library))
$(eval $(call declare-emitted-import-lib-dependency,chicken.flonum,library))
$(eval $(call declare-emitted-import-lib-dependency,chicken.gc,library))
@@ -602,6 +603,7 @@ chicken-ffi-syntax.c: chicken-ffi-syntax.scm \
chicken.format.import.scm
support.c: support.scm mini-srfi-1.scm \
chicken.bitwise.import.scm \
+ chicken.condition.import.scm \
chicken.data-structures.import.scm \
chicken.expand.import.scm \
chicken.files.import.scm \
@@ -628,6 +630,7 @@ csc.c: csc.scm \
chicken.pathname.import.scm \
chicken.posix.import.scm
csi.c: csi.scm \
+ chicken.condition.import.scm \
chicken.data-structures.import.scm \
chicken.foreign.import.scm \
chicken.format.import.scm \
@@ -664,6 +667,7 @@ chicken-status.c: chicken-status.scm \
chicken.posix.import.scm \
chicken.pretty-print.import.scm
chicken-install.c: chicken-install.scm \
+ chicken.condition.import.scm \
chicken.data-structures.import.scm \
chicken.files.import.scm \
chicken.foreign.import.scm \
@@ -693,6 +697,7 @@ srfi-4.c: srfi-4.scm \
chicken.platform.import.scm
posixunix.c: posixunix.scm \
chicken.bitwise.import.scm \
+ chicken.condition.import.scm \
chicken.foreign.import.scm \
chicken.irregex.import.scm \
chicken.memory.import.scm \
@@ -701,6 +706,7 @@ posixunix.c: posixunix.scm \
chicken.port.import.scm \
chicken.time.import.scm
posixwin.c: posixwin.scm \
+ chicken.condition.import.scm \
chicken.bitwise.import.scm \
chicken.foreign.import.scm \
chicken.irregex.import.scm \
@@ -710,8 +716,10 @@ posixwin.c: posixwin.scm \
chicken.port.import.scm \
chicken.time.import.scm
data-structures.c: data-structures.scm \
+ chicken.condition.import.scm \
chicken.foreign.import.scm
expand.c: expand.scm \
+ chicken.condition.import.scm \
chicken.keyword.import.scm \
chicken.platform.import.scm \
chicken.internal.import.scm
@@ -719,6 +727,7 @@ extras.c: extras.scm \
chicken.data-structures.import.scm \
chicken.time.import.scm
eval.c: eval.scm \
+ chicken.condition.import.scm \
chicken.expand.import.scm \
chicken.foreign.import.scm \
chicken.internal.import.scm \
@@ -760,6 +769,7 @@ bootstrap-lib = $(CHICKEN) $(call profile-flags, $@) $< $(CHICKEN_LIBRARY_OPTION
library.c: $(SRCDIR)library.scm $(SRCDIR)banner.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib) \
-emit-import-library chicken.bitwise \
+ -emit-import-library chicken.condition \
-emit-import-library chicken.fixnum \
-emit-import-library chicken.flonum \
-emit-import-library chicken.gc \
diff --git a/scheduler.scm b/scheduler.scm
index c77c786b..1cc67536 100644
--- a/scheduler.scm
+++ b/scheduler.scm
@@ -379,7 +379,7 @@ EOF
(##sys#setslot
pt 1
(lambda ()
- (##sys#signal arg)
+ (signal arg)
(ptx) ) )
(##sys#thread-unblock! pt) ) )
(else
diff --git a/support.scm b/support.scm
index e0402d2a..0048836d 100644
--- a/support.scm
+++ b/support.scm
@@ -77,6 +77,7 @@
(import chicken scheme
chicken.bitwise
+ chicken.condition
chicken.data-structures
chicken.expand
chicken.files
diff --git a/types.db b/types.db
index 13b911bd..7e304660 100644
--- a/types.db
+++ b/types.db
@@ -865,9 +865,6 @@
;; chicken
-(abort (procedure abort (*) noreturn))
-(##sys#abort (procedure abort (*) noreturn))
-
(add1 (#(procedure #:clean #:enforce #:foldable) add1 (number) number)
((fixnum) (integer)
(##core#inline_allocate ("C_a_i_fixnum_plus" 5) #(1) '1))
@@ -947,12 +944,27 @@
(case-sensitive (#(procedure #:clean) case-sensitive (#!optional *) *))
(char-name (#(procedure #:clean #:enforce) char-name ((or char symbol) #!optional char) *)) ;XXX -> (or char symbol) ?
(command-line-arguments (#(procedure #:clean) command-line-arguments (#!optional (list-of string)) (list-of string)))
-(condition-predicate (#(procedure #:clean #:enforce) condition-predicate (symbol) (procedure ((struct condition)) boolean)))
-(condition-property-accessor (#(procedure #:clean #:enforce) condition-property-accessor (symbol symbol #!optional *) (procedure ((struct condition)) *)))
-(condition? (#(procedure #:pure #:predicate (struct condition)) condition? (*) boolean))
+;; condition
+
+(chicken.condition#abort (procedure chicken.condition#abort (*) noreturn))
+(chicken.condition#condition? (#(procedure #:pure #:predicate (struct condition)) chicken.condition#condition? (*) boolean))
+(chicken.condition#condition->list (#(procedure #:clean #:enforce) chicken.condition#condition->list ((struct condition)) (list-of (pair symbol *))))
+(chicken.condition#condition-predicate (#(procedure #:clean #:enforce) chicken.condition#condition-predicate (symbol) (procedure ((struct condition)) boolean)))
+(chicken.condition#condition-property-accessor (#(procedure #:clean #:enforce) chicken.condition#condition-property-accessor (symbol symbol #!optional *) (procedure ((struct condition)) *)))
-(condition->list (#(procedure #:clean #:enforce) condition->list ((struct condition)) (list-of (pair symbol *))))
+(chicken.condition#current-exception-handler
+ (#(procedure #:clean #:enforce) chicken.condition#current-exception-handler (#!optional (procedure (*) noreturn) boolean boolean) procedure)
+ ((procedure) (let ((#(tmp1) #(1)))
+ (let ((#(tmp2) (set! ##sys#current-exception-handler #(tmp1))))
+ #(tmp1))))
+ (() ##sys#current-exception-handler))
+(chicken.condition#get-call-chain (#(procedure #:clean #:enforce) chicken.condition#get-call-chain (#!optional fixnum (struct thread)) (list-of vector)))
+(chicken.condition#get-condition-property (#(procedure #:clean #:enforce) chicken.condition#get-condition-property ((struct condition) symbol symbol #!optional *) *))
+(chicken.condition#make-composite-condition (#(procedure #:clean #:enforce) chicken.condition#make-composite-condition (#!rest (struct condition)) (struct condition)))
+(chicken.condition#make-property-condition (#(procedure #:clean #:enforce) chicken.condition#make-property-condition (symbol #!rest *) (struct condition)))
+(chicken.condition#with-exception-handler (#(procedure #:enforce) chicken.condition#with-exception-handler ((procedure (*) . *) (procedure () . *)) . *))
+(chicken.condition#signal (procedure chicken.condition#signal (*) . *))
;; continuation
@@ -987,13 +999,6 @@
#(tmp1))))
(() ##sys#standard-error))
-(current-exception-handler
- (#(procedure #:clean #:enforce) current-exception-handler (#!optional (procedure (*) noreturn) boolean boolean) procedure)
- ((procedure) (let ((#(tmp1) #(1)))
- (let ((#(tmp2) (set! ##sys#current-exception-handler #(tmp1))))
- #(tmp1))))
- (() ##sys#current-exception-handler))
-
;; time
(chicken.time#cpu-time (#(procedure #:clean) chicken.time#cpu-time () fixnum fixnum))
@@ -1191,8 +1196,6 @@
(get (#(procedure #:clean #:enforce) get (symbol symbol #!optional *) *)
((symbol symbol *) (##core#inline "C_i_getprop" #(1) #(2) #(3))))
-(get-call-chain (#(procedure #:clean #:enforce) get-call-chain (#!optional fixnum (struct thread)) (list-of vector)))
-(get-condition-property (#(procedure #:clean #:enforce) get-condition-property ((struct condition) symbol symbol #!optional *) *))
(get-environment-variable (#(procedure #:clean #:enforce) get-environment-variable (string) *))
(get-output-string (#(procedure #:clean #:enforce) get-output-string (output-port) string))
(get-properties (#(procedure #:clean #:enforce) get-properties (symbol list) symbol * list))
@@ -1252,9 +1255,7 @@
(make-blob (#(procedure #:clean #:enforce) make-blob (fixnum) blob)
((fixnum) (##sys#make-blob #(1))))
-(make-composite-condition (#(procedure #:clean #:enforce) make-composite-condition (#!rest (struct condition)) (struct condition)))
(make-parameter (#(procedure #:clean #:enforce) make-parameter (* #!optional procedure) procedure))
-(make-property-condition (#(procedure #:clean #:enforce) make-property-condition (symbol #!rest *) (struct condition)))
(chicken.flonum#maximum-flonum float)
(chicken.flonum#minimum-flonum float)
(chicken.fixnum#most-negative-fixnum fixnum)
@@ -1314,7 +1315,6 @@
((port string) (##sys#setslot #(1) '3 #(2))))
(setter (#(procedure #:clean #:enforce) setter (procedure) procedure))
-(signal (procedure signal (*) . *))
(signum (#(procedure #:clean #:enforce) signum (number) (or fixnum float cplxnum))
((fixnum) (fixnum) (##core#inline "C_i_fixnum_signum" #(1)))
@@ -1356,9 +1356,6 @@
(##sys#void (#(procedure #:pure) void (#!rest) undefined))
(warning (procedure warning (* #!rest) undefined))
-(with-exception-handler
- (#(procedure #:enforce) with-exception-handler ((procedure (*) . *) (procedure () . *)) . *))
-
;; chicken (internal)
(##sys#foreign-char-argument (#(procedure #:clean #:enforce) ##sys#foreign-char-argument (char) char)
Trap