X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/0bf0d9601754efe3e0988b4471dbf7e376a09bd8..761338f60c3b61d210c1e2a85a00668843012681:/module/srfi/srfi-35.scm diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm index 203546625..8f86bce57 100644 --- a/module/srfi/srfi-35.scm +++ b/module/srfi/srfi-35.scm @@ -1,11 +1,11 @@ -;;; srfi-35.scm --- Conditions +;;; srfi-35.scm --- Conditions -*- coding: utf-8 -*- -;; Copyright (C) 2007, 2008 Free Software Foundation, Inc. +;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. +;; version 3 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -16,7 +16,7 @@ ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -;;; Author: Ludovic Courtès +;;; Author: Ludovic Courtès ;;; Commentary: @@ -48,14 +48,27 @@ ;; The vtable of all condition types. ;; vtable fields: vtable, self, printer ;; user fields: id, parent, all-field-names - (make-vtable-vtable "prprpr" 0 - (lambda (ct port) - (if (eq? ct %condition-type-vtable) - (display "#") - (format port "#" - (condition-type-id ct) - (number->string (object-address ct) - 16)))))) + (let ((s (make-vtable (string-append standard-vtable-fields "prprpr") + (lambda (ct port) + (format port "#" + (condition-type-id ct) + (number->string (object-address ct) + 16)))))) + (set-struct-vtable-name! s 'condition-type) + s)) + +(define (%make-condition-type layout id parent all-fields) + (let ((struct (make-struct %condition-type-vtable 0 + (make-struct-layout layout) ;; layout + print-condition ;; printer + id parent all-fields))) + + ;; Hack to associate STRUCT with a name, providing a better name for + ;; GOOPS classes as returned by `class-of' et al. + (set-struct-vtable-name! struct (cond ((symbol? id) id) + ((string? id) (string->symbol id)) + (else (string->symbol "")))) + struct)) (define (condition-type? obj) "Return true if OBJ is a condition type." @@ -65,15 +78,15 @@ (define (condition-type-id ct) (and (condition-type? ct) - (struct-ref ct 3))) + (struct-ref ct (+ vtable-offset-user 0)))) (define (condition-type-parent ct) (and (condition-type? ct) - (struct-ref ct 4))) + (struct-ref ct (+ vtable-offset-user 1)))) (define (condition-type-all-fields ct) (and (condition-type? ct) - (struct-ref ct 5))) + (struct-ref ct (+ vtable-offset-user 2)))) (define (struct-layout-for-condition field-names) @@ -87,9 +100,22 @@ (cons "pr" layout))))) (define (print-condition c port) - (format port "#" - (condition-type-id (condition-type c)) - (number->string (object-address c) 16))) + ;; Print condition C to PORT in a way similar to how records print: + ;; #. + (define (field-values) + (let* ((type (struct-vtable c)) + (strings (fold (lambda (field result) + (cons (format #f "~A: ~S" field + (condition-ref c field)) + result)) + '() + (condition-type-all-fields type)))) + (string-join (reverse strings) " "))) + + (format port "#" + (condition-type-id (condition-type c)) + (field-values) + (number->string (object-address c) 16))) (define (make-condition-type id parent field-names) "Return a new condition type named ID, inheriting from PARENT, and with the @@ -104,10 +130,8 @@ supertypes." field-names parent-fields))) (let* ((all-fields (append parent-fields field-names)) (layout (struct-layout-for-condition all-fields))) - (make-struct %condition-type-vtable 0 - (make-struct-layout layout) ;; layout - print-condition ;; printer - id parent all-fields)) + (%make-condition-type layout + id parent all-fields)) (error "invalid condition type field names" field-names))) (error "parent is not a condition type" parent)) @@ -126,13 +150,10 @@ supertypes." (let* ((all-fields (append-map condition-type-all-fields parents)) (layout (struct-layout-for-condition all-fields))) - (make-struct %condition-type-vtable 0 - (make-struct-layout layout) ;; layout - print-condition ;; printer - id - parents ;; list of parents! - all-fields - all-fields))))) + (%make-condition-type layout + id + parents ;; list of parents! + all-fields))))) ;;; @@ -274,37 +295,35 @@ by C." ;;; Syntax. ;;; -(define-macro (define-condition-type name parent pred . field-specs) - `(begin - (define ,name - (make-condition-type ',name ,parent - ',(map car field-specs))) - (define (,pred c) - (condition-has-type? c ,name)) - ,@(map (lambda (field-spec) - (let ((field-name (car field-spec)) - (accessor (cadr field-spec))) - `(define (,accessor c) - (condition-ref c ',field-name)))) - field-specs))) - -(define-macro (condition . type-field-bindings) - (cond ((null? type-field-bindings) - (error "`condition' syntax error" type-field-bindings)) - (else - ;; the poor man's hygienic macro - (let ((mc (gensym "mc")) - (mcct (gensym "mcct"))) - `(let ((,mc (@ (srfi srfi-35) make-condition)) - (,mcct (@@ (srfi srfi-35) make-compound-condition-type))) - (,mc (,mcct 'compound (list ,@(map car type-field-bindings))) - ,@(append-map (lambda (type-field-binding) - (append-map (lambda (field+value) - (let ((f (car field+value)) - (v (cadr field+value))) - `(',f ,v))) - (cdr type-field-binding))) - type-field-bindings))))))) +(define-syntax-rule (define-condition-type name parent pred (field-name field-accessor) ...) + (begin + (define name + (make-condition-type 'name parent '(field-name ...))) + (define (pred c) + (condition-has-type? c name)) + (define (field-accessor c) + (condition-ref c 'field-name)) + ...)) + +(define-syntax-rule (compound-condition (type ...) (field ...)) + ;; Create a compound condition using `make-compound-condition-type'. + (condition ((make-compound-condition-type '%compound `(,type ...)) + field ...))) + +(define-syntax condition-instantiation + ;; Build the `(make-condition type ...)' call. + (syntax-rules () + ((_ type (out ...)) + (make-condition type out ...)) + ((_ type (out ...) (field-name field-value) rest ...) + (condition-instantiation type (out ... 'field-name field-value) rest ...)))) + +(define-syntax condition + (syntax-rules () + ((_ (type field ...)) + (condition-instantiation type () field ...)) + ((_ (type field ...) ...) + (compound-condition (type ...) (field ... ...))))) ;;; @@ -329,9 +348,4 @@ by C." (define-condition-type &error &serious error?) - -;;; Local Variables: -;;; coding: latin-1 -;;; End: - ;;; srfi-35.scm ends here