~ chicken-core (chicken-5) d3c44a5f74ea8c8461ab0bdb74c4ece07eae32b7
commit d3c44a5f74ea8c8461ab0bdb74c4ece07eae32b7
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sun May 7 21:20:32 2017 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Fri May 19 11:22:28 2017 +1200
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.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index e67051b3..de328d86 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,11 @@
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)))
+(let ((me* (##sys#macro-subset me0 ##sys#default-macro-environment)))
+ ;; TODO: omit `chicken.condition-m-e' when plain "chicken" module goes away
+ (append ##sys#chicken.condition-macro-environment me*))))
;; register features
diff --git a/chicken.condition.import.scm b/chicken.condition.import.scm
new file mode 100644
index 00000000..00fc0c95
--- /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 bf3258f4..a7fa5e91 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 859cfba0..40be3b71 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 e5d8bb50..0395be4a 100644
--- a/expand.scm
+++ b/expand.scm
@@ -175,8 +175,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 27a0b258..4d144d13 100644
--- a/library.scm
+++ b/library.scm
@@ -4450,9 +4450,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 85e7a059..4f90cb11 100644
--- a/modules.scm
+++ b/modules.scm
@@ -421,7 +421,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))
@@ -1012,7 +1012,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 b82e98a8..3a1e3425 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 769b338c..a744449c 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -2,7 +2,7 @@
(import (chicken bitwise) (chicken flonum) (chicken foreign)
- (srfi 4))
+ (chicken condition) (srfi 4))
(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 3f061fbf..f1ec80fa 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")))
Trap