Hi all, The core-library-reorganization page has "(chicken condition)" under "undecided", but I think it's fine the way it is. The attached patches add this module.
The first patch is a straightforward change to wrap the relevant procedure definitions in a module definition. I decided to also add the call chain accessing stuff to this module, as I think this is a better place than (chicken base). This time around, I minimised the number of ##sys# prefix removals, to avoid complicating things too much. It's better to do that in another pass; this changeset is complicated enough as it is. Because of the way the bootstrapping process works, the first patch also defines "#%with-exception-handler" as an alias for the with-exception-handler from chicken.condition. That's because we use the handle-exceptions macro in a few places in the compiler itself. When we're building with an old compiler, it will use the macro definitions from that compiler, which will expand to the *old* procedure names. The unprefixed "with-exception-handler" is assigned a #% prefix as always, so it can be accessed from any module, regardless of renames that have been done. Thus, we need to ensure that a procedure by the name of "#%with-exception-handler" can be found. I added that to the code of library.scm just after importing chicken.condition. The second patch is a bit of a mindfuck, but it paves the way to adding other modules that include syntax exports. Because we also have the syntax definitions "handle-exceptions" and "condition-case", I think those belong in this module too. But can't put macro definitions in library.scm or at least, I haven't been able to figure out how to do so: when I tried, I got into nasty dependency issues with the eval, expand and/or module units being required, and they depend on library itself. So instead, I wrote a custom import library, much like we do for the "chicken" module. This import library contains all the usual procedure mappings, but it also contains a syntax environment, which it takes from a global "##sys#chicken.condition-macro-environment" definition, analogous to ##sys#chicken-macro-environment. This is defined in expand.scm and assigned by chicken-syntax.scm, again much like ##sys#chicken-macro-environment and ##sys#chicken-ffi- macro-environment. When compiling with an old CHICKEN version, it will load the new chicken.condition import library into the compiler and choke on the non-existent "##sys#chicken.condition-macro-environment", so I added a temporary workaround to make it use the chicken macro environment as a fallback when the new definition doesn't exist. I hope all of this makes sense. If this works out, we can do a similar thing for all the other core modules that need to export syntax definitions. It's all copy and paste from here on out :) Cheers Peter
From 3d3338c678425f96c45f0994f01a562a5b6d6afe Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Sun, 7 May 2017 16:45:16 +0200
Subject: [PATCH 1/2] Add chicken.condition module
---
README | 1 +
chicken-install.scm | 1 +
chicken-syntax.scm | 7 +-
chicken.import.scm | 26 +++---
core.scm | 1 +
csi.scm | 1 +
data-structures.scm | 5 +-
defaults.make | 8 +-
distribution/manifest | 2 +
eval.scm | 2 +-
expand.scm | 3 +-
library.scm | 252 +++++++++++++++++++++++++++-----------------------
modules.scm | 12 ++-
posixunix.scm | 1 +
posixwin.scm | 1 +
rules.make | 10 ++
scheduler.scm | 2 +-
support.scm | 1 +
types.db | 42 ++++-----
19 files changed, 211 insertions(+), 167 deletions(-)
diff --git a/README b/README
index 27db7bb..2047a8d 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 05f2600..0e56b0e 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 65367b8..a69721f 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 b19e72b..3ebc9c9 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 8f68e3f..4d05fd8 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 72defb8..d03c169 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 0a6ea24..bf9821b 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 bc66d78..bf3258f 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 7e9c3ad..69b8178 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 9fb27da..859cfba 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 4397d22..937e899 100644
--- a/expand.scm
+++ b/expand.scm
@@ -52,6 +52,7 @@
expansion-result-hook)
(import scheme chicken
+ chicken.condition
chicken.internal
chicken.keyword
chicken.platform)
@@ -225,7 +226,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 2b98ae9..e13916e 100644
--- a/library.scm
+++ b/library.scm
@@ -4383,72 +4383,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)
@@ -4460,46 +4394,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 ()
@@ -4553,15 +4447,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)
@@ -4585,12 +4554,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
@@ -4611,12 +4580,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)
@@ -4627,8 +4596,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
@@ -4670,7 +4678,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)
@@ -4683,6 +4691,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
@@ -4692,6 +4701,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)
@@ -4828,6 +4839,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 2bf32c6..034d317 100644
--- a/modules.scm
+++ b/modules.scm
@@ -1001,9 +1001,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 40b5b75..60f547b 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 02fc62f..4243562 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 c1bdda3..56abb53 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 c77c786..1cc6753 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 3d2f413..596dab9 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 13b911b..b510c97 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,28 @@
(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 +1000,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 +1197,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 +1256,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 +1316,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 +1357,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)
--
2.1.4
From d15ab6fb6e1e18d5340ce98557643a00c05746ce Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Sun, 7 May 2017 21:20:32 +0200
Subject: [PATCH 2/2] Add syntax exports to chicken.condition
The macros condition-case and handle-exceptions really belong to
chicken.condition, but adding macros to library.scm is problematic
because the module and eval units rely on library, whereas to add
macros you'll need to use those two, causing a cyclic dependency.
This dependency cycle is why we have a separate chicken-syntax unit.
So, we keep the definitions there, but we add them to a separate
syntax environment which we use in a hand-rolled import library, which
we use in lieu of an emitted import library based on the module
definition (which does not contain said macros).
Because we no longer emit the import library, the compiler would
generate a call to eval to register the module at least in the current
compilation unit. To suppress this, we add -no-module-registration
when compiling library.scm.
Finally, to allow compilation with an older version CHICKEN, we use
the original syntax environment from chicken if the new
chicken.condition-macro-environment environment is undefined. This is
strictly incorrect because too many macros will be exported by the
chicken.condition module, but that's not a problem in practice, and
once we have a bootstrap CHICKEN we can get rid of this hack.
---
chicken-syntax.scm | 129 ++++++++++++++++++++++---------------------
chicken.condition.import.scm | 45 +++++++++++++++
defaults.make | 4 +-
eval.scm | 4 ++
expand.scm | 3 +
library.scm | 4 ++
modules.scm | 4 +-
rules.make | 3 +-
tests/compiler-tests.scm | 2 +-
tests/syntax-tests.scm | 4 +-
10 files changed, 131 insertions(+), 71 deletions(-)
create mode 100644 chicken.condition.import.scm
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index a69721f..38ba115 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -46,7 +46,69 @@
(provide* chicken-syntax) ; TODO remove after snapshot release
-;;; Non-standard macros:
+;;; Exceptions:
+(define ##sys#chicken.condition-macro-environment
+ (let ((me0 (##sys#macro-environment)))
+
+(##sys#extend-macro-environment
+ 'handle-exceptions
+ `((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 _ . _))
+ (let ((k (r 'k))
+ (args (r 'args)))
+ `((,(r 'call-with-current-continuation)
+ (##core#lambda
+ (,k)
+ (chicken.condition#with-exception-handler
+ (##core#lambda (,(cadr form)) (,k (##core#lambda () ,(caddr form))))
+ (##core#lambda
+ ()
+ (##sys#call-with-values
+ (##core#lambda () ,@(cdddr form))
+ (##core#lambda
+ ,args
+ (,k (##core#lambda () (##sys#apply ##sys#values ,args)))) ) ) ) ) ) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'condition-case
+ `((else . ,(##sys#primitive-alias 'else))
+ (memv . ,(##sys#primitive-alias 'memv)))
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'condition-case form '(_ _ . _))
+ (let ((exvar (r 'exvar))
+ (kvar (r 'kvar))
+ (%and (r 'and))
+ (%memv (r 'memv))
+ (%else (r 'else)))
+ (define (parse-clause c)
+ (let* ((var (and (symbol? (car c)) (car c)))
+ (kinds (if var (cadr c) (car c)))
+ (body (if var
+ `(##core#let ((,var ,exvar)) ,@(cddr c))
+ `(##core#let () ,@(cdr c)))))
+ (if (null? kinds)
+ `(,%else ,body)
+ `((,%and ,kvar ,@(map (lambda (k)
+ `(,%memv (##core#quote ,k) ,kvar)) kinds))
+ ,body ) ) ) )
+ `(,(r 'handle-exceptions) ,exvar
+ (##core#let ((,kvar (,%and (##sys#structure? ,exvar
+ (##core#quote condition))
+ (##sys#slot ,exvar 1))))
+ ,(let ((clauses (map parse-clause (cddr form))))
+ `(,(r 'cond)
+ ,@clauses
+ ,@(if (assq %else clauses)
+ `() ; Don't generate two else clauses
+ `((,%else (chicken.condition#signal ,exvar)))) )) )
+ ,(cadr form))))))
+
+(##sys#macro-subset me0 ##sys#default-macro-environment)))
+
+;;; Other non-standard macros:
(define ##sys#chicken-macro-environment
(let ((me0 (##sys#macro-environment)))
@@ -868,66 +930,6 @@
(##sys#check-syntax 'define-record-printer (cons head body) '(symbol _))
`(##sys#register-record-printer ',head ,@body) ] ) ))))
-
-;;; Exceptions:
-
-(##sys#extend-macro-environment
- 'handle-exceptions
- `((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 _ . _))
- (let ((k (r 'k))
- (args (r 'args)))
- `((,(r 'call-with-current-continuation)
- (##core#lambda
- (,k)
- (chicken.condition#with-exception-handler
- (##core#lambda (,(cadr form)) (,k (##core#lambda () ,(caddr form))))
- (##core#lambda
- ()
- (##sys#call-with-values
- (##core#lambda () ,@(cdddr form))
- (##core#lambda
- ,args
- (,k (##core#lambda () (##sys#apply ##sys#values ,args)))) ) ) ) ) ) ) ) ) ) )
-
-(##sys#extend-macro-environment
- 'condition-case
- `((else . ,(##sys#primitive-alias 'else))
- (memv . ,(##sys#primitive-alias 'memv)))
- (##sys#er-transformer
- (lambda (form r c)
- (##sys#check-syntax 'condition-case form '(_ _ . _))
- (let ((exvar (r 'exvar))
- (kvar (r 'kvar))
- (%and (r 'and))
- (%memv (r 'memv))
- (%else (r 'else)))
- (define (parse-clause c)
- (let* ((var (and (symbol? (car c)) (car c)))
- (kinds (if var (cadr c) (car c)))
- (body (if var
- `(##core#let ((,var ,exvar)) ,@(cddr c))
- `(##core#let () ,@(cdr c)))))
- (if (null? kinds)
- `(,%else ,body)
- `((,%and ,kvar ,@(map (lambda (k)
- `(,%memv (##core#quote ,k) ,kvar)) kinds))
- ,body ) ) ) )
- `(,(r 'handle-exceptions) ,exvar
- (##core#let ((,kvar (,%and (##sys#structure? ,exvar
- (##core#quote condition))
- (##sys#slot ,exvar 1))))
- ,(let ((clauses (map parse-clause (cddr form))))
- `(,(r 'cond)
- ,@clauses
- ,@(if (assq %else clauses)
- `() ; Don't generate two else clauses
- `((,%else (chicken.condition#signal ,exvar)))) )) )
- ,(cadr form))))))
-
-
;;; SRFI-9:
(##sys#extend-macro-environment
@@ -1350,9 +1352,10 @@
t0 'define-type name))))))))))
-;; capture current macro env
+;; capture current macro env and add all the preceding ones as well
-(##sys#macro-subset me0 ##sys#default-macro-environment)))
+(append ##sys#chicken.condition-macro-environment
+ (##sys#macro-subset me0 ##sys#default-macro-environment))))
;; register features
diff --git a/chicken.condition.import.scm b/chicken.condition.import.scm
new file mode 100644
index 0000000..00fc0c9
--- /dev/null
+++ b/chicken.condition.import.scm
@@ -0,0 +1,45 @@
+;;;; chicken.condition.import.scm - import library for "chicken.condition" module
+;
+; Copyright (c) 2017, The CHICKEN Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
+; disclaimer in the documentation and/or other materials provided with the distribution.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+(##sys#register-core-module
+ 'chicken.condition
+ 'library
+ '((abort . chicken.condition#abort)
+ (signal . chicken.condition#signal)
+ (current-exception-handler . chicken.condition#current-exception-handler)
+ (get-call-chain . chicken.condition#get-call-chain)
+ (print-call-chain . chicken.condition#print-call-chain)
+ (with-exception-handler . chicken.condition#with-exception-handler)
+ (make-property-condition . chicken.condition#make-property-condition)
+ (make-composite-condition . chicken.condition#make-composite-condition)
+ (condition? . chicken.condition#condition?)
+ (condition->list . chicken.condition#condition->list)
+ (condition-predicate . chicken.condition#condition-predicate)
+ (condition-property-accessor . chicken.condition#condition-property-accessor)
+ (get-condition-property . chicken.condition#get-condition-property))
+ ;; OBSOLETE: This can be removed after bootstrapping
+ (if (##sys#symbol-has-toplevel-binding? '##sys#chicken.condition-macro-environment)
+ ##sys#chicken.condition-macro-environment
+ ##sys#chicken-macro-environment))
diff --git a/defaults.make b/defaults.make
index bf3258f..d56f252 100644
--- a/defaults.make
+++ b/defaults.make
@@ -263,9 +263,9 @@ CHICKEN_PROGRAM_OPTIONS += $(if $(PROFILE_OBJECTS),-profile)
# import libraries
-PRIMITIVE_IMPORT_LIBRARIES = chicken chicken.csi chicken.foreign
+PRIMITIVE_IMPORT_LIBRARIES = chicken chicken.condition chicken.csi chicken.foreign
DYNAMIC_IMPORT_LIBRARIES = srfi-4
-DYNAMIC_CHICKEN_IMPORT_LIBRARIES = bitwise condition errno file.posix \
+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
diff --git a/eval.scm b/eval.scm
index 859cfba..40be3b7 100644
--- a/eval.scm
+++ b/eval.scm
@@ -894,6 +894,10 @@
. (##core#require library))
(chicken.foreign
. (##core#require-for-syntax chicken-ffi-syntax))
+ (chicken.condition
+ . (##core#begin
+ (##core#require-for-syntax chicken-syntax)
+ (##core#require library)))
(chicken
. (##core#begin
(##core#require-for-syntax chicken-syntax)
diff --git a/expand.scm b/expand.scm
index 937e899..f6862e1 100644
--- a/expand.scm
+++ b/expand.scm
@@ -177,8 +177,11 @@
;;; Macro handling
(define ##sys#macro-environment (make-parameter '()))
+
+;; These are all re-assigned by chicken-syntax.scm:
(define ##sys#chicken-macro-environment '()) ; used later in chicken.import.scm
(define ##sys#chicken-ffi-macro-environment '()) ; used later in foreign.import.scm
+(define ##sys#chicken.condition-macro-environment '()) ; used later in chicken.condition.import.scm
(define (##sys#ensure-transformer t #!optional loc)
(cond ((procedure? t) (##sys#slot (##sys#er-transformer t) 1)) ; DEPRECATED
diff --git a/library.scm b/library.scm
index e13916e..176d6d2 100644
--- a/library.scm
+++ b/library.scm
@@ -4448,9 +4448,13 @@ EOF
;;; Condition handling:
(module chicken.condition
+ ;; NOTE: We don't emit the import lib. Due to syntax exports, it
+ ;; has to be a hardcoded primitive module.
(abort signal current-exception-handler get-call-chain
print-call-chain with-exception-handler
+ ;; [syntax] condition-case handle-exceptions
+
;; Condition object manipulation
make-property-condition make-composite-condition condition?
condition->list condition-predicate condition-property-accessor
diff --git a/modules.scm b/modules.scm
index 034d317..c1deed7 100644
--- a/modules.scm
+++ b/modules.scm
@@ -420,7 +420,7 @@
(set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
mod))
-;; same as register-builtin, but uses module's name as its library
+;; same as register-core-module, but uses module's name as its library
(define (##sys#register-primitive-module name vexports #!optional (sexports '()))
(##sys#register-core-module name name vexports sexports))
@@ -1010,7 +1010,7 @@
(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))
+ (se-subset '(handle-exceptions) ##sys#chicken.condition-macro-environment))
(##sys#register-primitive-module
'srfi-15 '() (se-subset '(fluid-let) ##sys#chicken-macro-environment))
diff --git a/rules.make b/rules.make
index 56abb53..be110e6 100644
--- a/rules.make
+++ b/rules.make
@@ -506,7 +506,6 @@ $(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))
@@ -768,8 +767,8 @@ bootstrap-lib = $(CHICKEN) $(call profile-flags, $@) $< $(CHICKEN_LIBRARY_OPTION
library.c: $(SRCDIR)library.scm $(SRCDIR)banner.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib) \
+ -no-module-registration \
-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/tests/compiler-tests.scm b/tests/compiler-tests.scm
index 769b338..b353565 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -2,7 +2,7 @@
(import (chicken bitwise) (chicken flonum) (chicken foreign)
- (srfi 4))
+ (srfi 4) (chicken condition))
(import-for-syntax data-structures expand)
;; test dropping of previous toplevel assignments
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index 1c4941a..0abda56 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -532,7 +532,7 @@
(c:define-values (a b c) (values 1 2 3)) )
(module prefixed-self-reference2 ()
- (import scheme (prefix chicken c:))
+ (import scheme (prefix chicken c:) (prefix (chicken condition) c:))
(c:define-values (a b c) (values 1 2 3))
(c:print "ok")
(c:condition-case
@@ -540,6 +540,8 @@
(ex () (c:print "caught"))))
(module prefixed-self-reference3 (a)
+ ;; TODO: Switch this around when plain "chicken" has been removed
+ ;(import (prefix scheme s.) (prefix (chicken condition) c.))
(import (prefix scheme s.) (prefix chicken c.))
(s.define (a x y)
(c.condition-case (s.+ x y) ((exn) "not numbers")))
--
2.1.4
signature.asc
Description: Digital signature
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
