From d15ab6fb6e1e18d5340ce98557643a00c05746ce Mon Sep 17 00:00:00 2001 From: Peter Bex 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