PageRenderTime 16ms CodeModel.GetById 2ms app.highlight 6ms RepoModel.GetById 1ms app.codeStats 0ms

/scheme/ikarus.conditions.sls

http://github.com/marcomaggi/vicare
Unknown | 1706 lines | 1463 code | 243 blank | 0 comment | 0 complexity | c75a209a44bdcc6423a81a8adbf06a27 MD5 | raw file

Large files files are truncated, but you can click here to view the full file

   1;;;Ikarus Scheme -- A compiler for R6RS Scheme.
   2;;;Copyright (C) 2006,2007,2008  Abdulaziz Ghuloum
   3;;;Modified by Marco Maggi <marco.maggi-ipsu@poste.it>
   4;;;
   5;;;This program is free software: you can  redistribute it and/or modify it under the
   6;;;terms  of the  GNU General  Public  License version  3  as published  by the  Free
   7;;;Software Foundation.
   8;;;
   9;;;This program is  distributed in the hope  that it will be useful,  but WITHOUT ANY
  10;;;WARRANTY; without  even the implied warranty  of MERCHANTABILITY or FITNESS  FOR A
  11;;;PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  12;;;
  13;;;You should have received a copy of  the GNU General Public License along with this
  14;;;program.  If not, see <http://www.gnu.org/licenses/>.
  15
  16
  17#!vicare
  18(library (ikarus conditions)
  19  (export
  20    define-core-condition-type
  21
  22    condition? compound-condition? condition-and-rtd?
  23    simple-condition?
  24    list-of-conditions?
  25    list-of-simple-conditions?
  26    simple-conditions condition-predicate
  27    condition condition-accessor print-condition
  28
  29    raise-non-continuable-standard-condition
  30
  31    make-message-condition message-condition?
  32    condition-message make-warning warning?
  33    make-serious-condition serious-condition? make-error
  34    error? make-violation violation? make-assertion-violation
  35    assertion-violation? make-irritants-condition
  36    irritants-condition? condition-irritants
  37    make-who-condition who-condition? condition-who
  38    make-non-continuable-violation non-continuable-violation?
  39    make-implementation-restriction-violation
  40    implementation-restriction-violation?
  41    make-lexical-violation lexical-violation?
  42    make-syntax-violation syntax-violation?
  43    syntax-violation-form syntax-violation-subform
  44    make-undefined-violation undefined-violation?
  45    make-i/o-error i/o-error? make-i/o-read-error
  46    i/o-read-error? make-i/o-write-error i/o-write-error?
  47    make-i/o-invalid-position-error
  48    i/o-invalid-position-error? i/o-error-position
  49    make-i/o-filename-error i/o-filename-error?
  50    i/o-error-filename make-i/o-file-protection-error
  51    i/o-file-protection-error? make-i/o-file-is-read-only-error
  52    i/o-file-is-read-only-error?
  53    make-i/o-file-already-exists-error
  54    i/o-file-already-exists-error?
  55    make-i/o-file-does-not-exist-error
  56    i/o-file-does-not-exist-error? make-i/o-port-error
  57    i/o-port-error? i/o-error-port make-i/o-decoding-error
  58    i/o-decoding-error? make-i/o-encoding-error
  59    i/o-encoding-error? i/o-encoding-error-char
  60    no-infinities-violation? make-no-infinities-violation
  61    no-nans-violation? make-no-nans-violation
  62    interrupted-condition? make-interrupted-condition
  63    make-source-position-condition source-position-condition?
  64    source-position-port-id
  65    source-position-byte source-position-character
  66    source-position-line source-position-column
  67
  68    &condition			&message		&warning
  69    &serious			&error			&violation
  70    &assertion			&irritants		&who
  71    &non-continuable		&implementation-restriction
  72    &lexical			&syntax			&undefined
  73    &i/o			&i/o-read		&i/o-write
  74    &i/o-invalid-position	&i/o-filename		&i/o-file-protection
  75    &i/o-file-is-read-only	&i/o-file-already-exists
  76    &i/o-file-does-not-exist	&i/o-port		&i/o-decoding
  77    &i/o-encoding		&no-infinities
  78    &no-nans			&interrupted		&source-position
  79
  80    &condition-rtd &condition-rcd &message-rtd &message-rcd
  81    &warning-rtd &warning-rcd &serious-rtd &serious-rcd
  82    &error-rtd &error-rcd &violation-rtd &violation-rcd
  83    &assertion-rtd &assertion-rcd &irritants-rtd
  84    &irritants-rcd &who-rtd &who-rcd &non-continuable-rtd
  85    &non-continuable-rcd &implementation-restriction-rtd
  86    &implementation-restriction-rcd &lexical-rtd &lexical-rcd
  87    &syntax-rtd &syntax-rcd &undefined-rtd &undefined-rcd
  88    &i/o-rtd &i/o-rcd &i/o-read-rtd &i/o-read-rcd
  89    &i/o-write-rtd &i/o-write-rcd &i/o-invalid-position-rtd
  90    &i/o-invalid-position-rcd &i/o-filename-rtd
  91    &i/o-filename-rcd &i/o-file-protection-rtd
  92    &i/o-file-protection-rcd &i/o-file-is-read-only-rtd
  93    &i/o-file-is-read-only-rcd &i/o-file-already-exists-rtd
  94    &i/o-file-already-exists-rcd &i/o-file-does-not-exist-rtd
  95    &i/o-file-does-not-exist-rcd &i/o-port-rtd &i/o-port-rcd
  96    &i/o-decoding-rtd &i/o-decoding-rcd &i/o-encoding-rtd
  97    &i/o-encoding-rcd &no-infinities-rtd &no-infinities-rcd
  98    &no-nans-rtd &no-nans-rcd
  99    &interrupted-rtd &interrupted-rcd
 100    &source-position-rtd &source-position-rcd
 101
 102    ;;&i/o-eagain
 103    make-i/o-eagain i/o-eagain-error?
 104    &i/o-eagain-rtd &i/o-eagain-rcd
 105
 106    ;;&errno
 107    &errno-rtd &errno-rcd
 108    make-errno-condition errno-condition? condition-errno
 109    ;;&h_errno
 110    &h_errno-rtd &h_errno-rcd
 111    make-h_errno-condition h_errno-condition? condition-h_errno
 112
 113    ;; &i/o-wrong-fasl-header-error
 114    &i/o-wrong-fasl-header-error-rtd &i/o-wrong-fasl-header-error-rcd
 115    make-i/o-wrong-fasl-header-error
 116    i/o-wrong-fasl-header-error?
 117
 118    ;;&out-of-memory-error
 119    &out-of-memory-error-rtd &out-of-memory-error-rcd
 120    make-out-of-memory-error out-of-memory-error?
 121
 122    ;;&failed-expression
 123    &failed-expression-rtd
 124    &failed-expression-rcd
 125    make-failed-expression-condition
 126    failed-expression-condition?
 127    condition-failed-expression
 128
 129    ;;&one-based-return-value-index
 130    &one-based-return-value-index-rtd
 131    &one-based-return-value-index-rcd
 132    make-one-based-return-value-index-condition
 133    one-based-return-value-index-condition?
 134    condition-one-based-return-value-index
 135
 136    ;;&procedure-precondition-violation
 137    &procedure-precondition-violation-rtd
 138    &procedure-precondition-violation-rcd
 139    make-procedure-precondition-violation
 140    procedure-precondition-violation?
 141
 142    ;;&procedure-postcondition-violation
 143    &procedure-postcondition-violation-rtd
 144    &procedure-postcondition-violation-rcd
 145    make-procedure-postcondition-violation
 146    procedure-postcondition-violation?
 147
 148    ;;&procedure-argument-violation
 149    &procedure-argument-violation-rtd
 150    &procedure-argument-violation-rcd
 151    make-procedure-argument-violation
 152    procedure-argument-violation?
 153    procedure-argument-violation
 154
 155    ;;&procedure-signature-argument-violation
 156    &procedure-signature-argument-violation-rtd
 157    &procedure-signature-argument-violation-rcd
 158    make-procedure-signature-argument-violation
 159    procedure-signature-argument-violation?
 160    procedure-signature-argument-violation.one-based-argument-index
 161    procedure-signature-argument-violation.failed-expression
 162    procedure-signature-argument-violation.offending-value
 163    procedure-signature-argument-violation
 164
 165    ;;&procedure-signature-return-value-violation
 166    &procedure-signature-return-value-violation-rtd
 167    &procedure-signature-return-value-violation-rcd
 168    make-procedure-signature-return-value-violation
 169    procedure-signature-return-value-violation?
 170    procedure-signature-return-value-violation.one-based-return-value-index
 171    procedure-signature-return-value-violation.failed-expression
 172    procedure-signature-return-value-violation.offending-value
 173    procedure-signature-return-value-violation
 174
 175    ;;&procedure-arguments-consistency-violation
 176    &procedure-arguments-consistency-violation-rtd
 177    &procedure-arguments-consistency-violation-rcd
 178    make-procedure-arguments-consistency-violation
 179    procedure-arguments-consistency-violation?
 180    procedure-arguments-consistency-violation
 181    procedure-arguments-consistency-violation/failed-expression
 182
 183    ;;&expression-return-value-violation
 184    &expression-return-value-violation-rtd
 185    &expression-return-value-violation-rcd
 186    make-expression-return-value-violation
 187    expression-return-value-violation?
 188    expression-return-value-violation
 189
 190    ;;&non-reinstatable
 191    &non-reinstatable-rtd
 192    &non-reinstatable-rcd
 193    make-non-reinstatable-violation
 194    non-reinstatable-violation?
 195    non-reinstatable-violation
 196
 197    ;; late binding errors
 198    &late-binding-error-rtd
 199    &late-binding-error-rcd
 200    make-late-binding-error
 201    late-binding-error?
 202
 203    &method-late-binding-error-rtd
 204    &method-late-binding-error-rcd
 205    make-method-late-binding-error
 206    method-late-binding-error?
 207
 208    &overloaded-function-late-binding-error-rtd
 209    &overloaded-function-late-binding-error-rcd
 210    make-overloaded-function-late-binding-error
 211    overloaded-function-late-binding-error?
 212    overloaded-function-late-binding-error.overloaded-function-descriptor
 213
 214    &interface-method-late-binding-error-rtd
 215    &interface-method-late-binding-error-rcd
 216    make-interface-method-late-binding-error
 217    interface-method-late-binding-error?
 218    interface-method-late-binding-error.interface-uid
 219    interface-method-late-binding-error.method-name
 220    interface-method-late-binding-error.subject
 221    interface-method-late-binding-error.type-descriptor
 222
 223    ;; string encoding and decoding
 224    ;;&string-encoding
 225    &string-encoding-rtd
 226    &string-encoding-rcd
 227    make-string-encoding-error
 228    string-encoding-error?
 229
 230    ;;&string-decoding
 231    &string-decoding-rtd
 232    &string-decoding-rcd
 233    make-string-decoding-error
 234    string-decoding-error?
 235
 236;;;
 237
 238    ;;&utf8-string-encoding
 239    &utf8-string-encoding-rtd
 240    &utf8-string-encoding-rcd
 241    make-utf8-string-encoding-error
 242    utf8-string-encoding-error?
 243
 244    ;;&utf16-string-encoding
 245    &utf16-string-encoding-rtd
 246    &utf16-string-encoding-rcd
 247    make-utf16-string-encoding-error
 248    utf16-string-encoding-error?
 249
 250    ;;&utf32-string-encoding
 251    &utf32-string-encoding-rtd
 252    &utf32-string-encoding-rcd
 253    make-utf32-string-encoding-error
 254    utf32-string-encoding-error?
 255
 256    ;;&utf8-string-decoding
 257    &utf8-string-decoding-rtd
 258    &utf8-string-decoding-rcd
 259    make-utf8-string-decoding-error
 260    utf8-string-decoding-error?
 261
 262    ;;&utf16-string-decoding
 263    &utf16-string-decoding-rtd
 264    &utf16-string-decoding-rcd
 265    make-utf16-string-decoding-error
 266    utf16-string-decoding-error?
 267
 268    ;;&utf32-string-decoding
 269    &utf32-string-decoding-rtd
 270    &utf32-string-decoding-rcd
 271    make-utf32-string-decoding-error
 272    utf32-string-decoding-error?
 273
 274;;;
 275
 276    ;;&utf8-string-decoding-invalid-octet
 277    &utf8-string-decoding-invalid-octet-rtd
 278    &utf8-string-decoding-invalid-octet-rcd
 279    make-utf8-string-decoding-invalid-octet
 280    utf8-string-decoding-invalid-octet?
 281    utf8-string-decoding-invalid-octet.bytevector
 282    utf8-string-decoding-invalid-octet.index
 283    utf8-string-decoding-invalid-octet.octets
 284
 285    ;;&utf8-string-decoding-invalid-2-tuple
 286    &utf8-string-decoding-invalid-2-tuple-rtd
 287    &utf8-string-decoding-invalid-2-tuple-rcd
 288    make-utf8-string-decoding-invalid-2-tuple
 289    utf8-string-decoding-invalid-2-tuple?
 290    utf8-string-decoding-invalid-2-tuple.bytevector
 291    utf8-string-decoding-invalid-2-tuple.index
 292    utf8-string-decoding-invalid-2-tuple.octets
 293
 294    ;;&utf8-string-decoding-invalid-3-tuple
 295    &utf8-string-decoding-invalid-3-tuple-rtd
 296    &utf8-string-decoding-invalid-3-tuple-rcd
 297    make-utf8-string-decoding-invalid-3-tuple
 298    utf8-string-decoding-invalid-3-tuple?
 299    utf8-string-decoding-invalid-3-tuple.bytevector
 300    utf8-string-decoding-invalid-3-tuple.index
 301    utf8-string-decoding-invalid-3-tuple.octets
 302
 303    ;;&utf8-string-decoding-invalid-4-tuple
 304    &utf8-string-decoding-invalid-4-tuple-rtd
 305    &utf8-string-decoding-invalid-4-tuple-rcd
 306    make-utf8-string-decoding-invalid-4-tuple
 307    utf8-string-decoding-invalid-4-tuple?
 308    utf8-string-decoding-invalid-4-tuple.bytevector
 309    utf8-string-decoding-invalid-4-tuple.index
 310    utf8-string-decoding-invalid-4-tuple.octets
 311
 312    ;;&utf8-string-decoding-incomplete-2-tuple
 313    &utf8-string-decoding-incomplete-2-tuple-rtd
 314    &utf8-string-decoding-incomplete-2-tuple-rcd
 315    make-utf8-string-decoding-incomplete-2-tuple
 316    utf8-string-decoding-incomplete-2-tuple?
 317    utf8-string-decoding-incomplete-2-tuple.bytevector
 318    utf8-string-decoding-incomplete-2-tuple.index
 319    utf8-string-decoding-incomplete-2-tuple.octets
 320
 321    ;;&utf8-string-decoding-incomplete-3-tuple
 322    &utf8-string-decoding-incomplete-3-tuple-rtd
 323    &utf8-string-decoding-incomplete-3-tuple-rcd
 324    make-utf8-string-decoding-incomplete-3-tuple
 325    utf8-string-decoding-incomplete-3-tuple?
 326    utf8-string-decoding-incomplete-3-tuple.bytevector
 327    utf8-string-decoding-incomplete-3-tuple.index
 328    utf8-string-decoding-incomplete-3-tuple.octets
 329
 330    ;;&utf8-string-decoding-incomplete-4-tuple
 331    &utf8-string-decoding-incomplete-4-tuple-rtd
 332    &utf8-string-decoding-incomplete-4-tuple-rcd
 333    make-utf8-string-decoding-incomplete-4-tuple
 334    utf8-string-decoding-incomplete-4-tuple?
 335    utf8-string-decoding-incomplete-4-tuple.bytevector
 336    utf8-string-decoding-incomplete-4-tuple.index
 337    utf8-string-decoding-incomplete-4-tuple.octets
 338
 339;;;
 340
 341    ;;&utf16-string-decoding-invalid-first-word
 342    &utf16-string-decoding-invalid-first-word-rtd
 343    &utf16-string-decoding-invalid-first-word-rcd
 344    make-utf16-string-decoding-invalid-first-word
 345    utf16-string-decoding-invalid-first-word?
 346    utf16-string-decoding-invalid-first-word.bytevector
 347    utf16-string-decoding-invalid-first-word.index
 348    utf16-string-decoding-invalid-first-word.word
 349
 350    ;;&utf16-string-decoding-invalid-second-word
 351    &utf16-string-decoding-invalid-second-word-rtd
 352    &utf16-string-decoding-invalid-second-word-rcd
 353    make-utf16-string-decoding-invalid-second-word
 354    utf16-string-decoding-invalid-second-word?
 355    utf16-string-decoding-invalid-second-word.bytevector
 356    utf16-string-decoding-invalid-second-word.index
 357    utf16-string-decoding-invalid-second-word.first-word
 358    utf16-string-decoding-invalid-second-word.second-word
 359
 360    ;;&utf16-string-decoding-missing-second-word
 361    &utf16-string-decoding-missing-second-word-rtd
 362    &utf16-string-decoding-missing-second-word-rcd
 363    make-utf16-string-decoding-missing-second-word
 364    utf16-string-decoding-missing-second-word?
 365    utf16-string-decoding-missing-second-word.bytevector
 366    utf16-string-decoding-missing-second-word.index
 367    utf16-string-decoding-missing-second-word.word
 368
 369    ;;&utf16-string-decoding-standalone-octet
 370    &utf16-string-decoding-standalone-octet-rtd
 371    &utf16-string-decoding-standalone-octet-rcd
 372    make-utf16-string-decoding-standalone-octet
 373    utf16-string-decoding-standalone-octet?
 374    utf16-string-decoding-standalone-octet.bytevector
 375    utf16-string-decoding-standalone-octet.index
 376    utf16-string-decoding-standalone-octet.octet
 377
 378;;;
 379
 380    ;;&utf32-string-decoding-invalid-word
 381    &utf32-string-decoding-invalid-word-rtd
 382    &utf32-string-decoding-invalid-word-rcd
 383    make-utf32-string-decoding-invalid-word
 384    utf32-string-decoding-invalid-word?
 385    utf32-string-decoding-invalid-word.bytevector
 386    utf32-string-decoding-invalid-word.index
 387    utf32-string-decoding-invalid-word.word
 388
 389    ;;&utf32-string-decoding-orphan-octets
 390    &utf32-string-decoding-orphan-octets-rtd
 391    &utf32-string-decoding-orphan-octets-rcd
 392    make-utf32-string-decoding-orphan-octets
 393    utf32-string-decoding-orphan-octets?
 394    utf32-string-decoding-orphan-octets.bytevector
 395    utf32-string-decoding-orphan-octets.index
 396    utf32-string-decoding-orphan-octets.octets
 397
 398    ;; macros
 399    preconditions
 400
 401    ;; for internal use only
 402    $condition-predicate			$condition-accessor
 403    make-simple-condition			%raise-out-of-memory)
 404  (import (except (vicare)
 405		  ;;We use an internal macro  definition to define condition types in
 406		  ;;this library.
 407		  define-condition-type
 408
 409		  condition? compound-condition? condition-and-rtd?
 410		  simple-condition?
 411		  list-of-conditions?
 412		  list-of-simple-conditions?
 413		  simple-conditions
 414		  condition condition-predicate condition-accessor
 415		  print-condition
 416
 417		  raise-non-continuable-standard-condition
 418
 419		  &condition &message &warning &serious &error &violation
 420		  &assertion &irritants &who &non-continuable
 421		  &implementation-restriction &lexical &syntax &undefined
 422		  &i/o &i/o-read &i/o-write &i/o-invalid-position
 423		  &i/o-filename &i/o-file-protection &i/o-file-is-read-only
 424		  &i/o-file-already-exists &i/o-file-does-not-exist
 425		  &i/o-port &i/o-decoding &i/o-encoding &no-infinities
 426		  &no-nans
 427
 428		  make-message-condition message-condition?
 429		  condition-message make-warning warning?
 430		  make-serious-condition serious-condition? make-error
 431		  error? make-violation violation? make-assertion-violation
 432		  assertion-violation? make-irritants-condition
 433		  irritants-condition? condition-irritants
 434		  make-who-condition who-condition? condition-who
 435		  make-non-continuable-violation non-continuable-violation?
 436		  make-implementation-restriction-violation
 437		  implementation-restriction-violation?
 438		  make-lexical-violation lexical-violation?
 439		  make-syntax-violation syntax-violation?
 440		  syntax-violation-form syntax-violation-subform
 441		  make-undefined-violation undefined-violation?
 442		  make-i/o-error i/o-error? make-i/o-read-error
 443		  i/o-read-error? make-i/o-write-error i/o-write-error?
 444		  make-i/o-invalid-position-error
 445		  i/o-invalid-position-error? i/o-error-position
 446		  make-i/o-filename-error i/o-filename-error?
 447		  i/o-error-filename make-i/o-file-protection-error
 448		  i/o-file-protection-error? make-i/o-file-is-read-only-error
 449		  i/o-file-is-read-only-error?
 450		  make-i/o-file-already-exists-error
 451		  i/o-file-already-exists-error?
 452		  make-i/o-file-does-not-exist-error
 453		  i/o-file-does-not-exist-error? make-i/o-port-error
 454		  i/o-port-error? i/o-error-port make-i/o-decoding-error
 455		  i/o-decoding-error? make-i/o-encoding-error
 456		  i/o-encoding-error? i/o-encoding-error-char
 457		  no-infinities-violation? make-no-infinities-violation
 458		  no-nans-violation? make-no-nans-violation
 459
 460		  &i/o-eagain make-i/o-eagain i/o-eagain-error?
 461		  &i/o-eagain-rtd &i/o-eagain-rcd
 462
 463		  &errno &errno-rtd &errno-rcd
 464		  make-errno-condition errno-condition?
 465		  condition-errno
 466
 467		  &h_errno &h_errno-rtd &h_errno-rcd
 468		  make-h_errno-condition h_errno-condition?
 469		  condition-h_errno
 470
 471		  &i/o-wrong-fasl-header-error-rtd &i/o-wrong-fasl-header-error-rcd
 472		  &i/o-wrong-fasl-header-error
 473		  make-i/o-wrong-fasl-header-error
 474		  i/o-wrong-fasl-header-error?
 475
 476		  &out-of-memory-error-rtd &out-of-memory-error-rcd
 477		  &out-of-memory-error
 478		  make-out-of-memory-error out-of-memory-error?
 479
 480		  &interrupted &interrupted-rtd &interrupted-rcd
 481		  interrupted-condition? make-interrupted-condition
 482
 483		  &source-position &source-position-rtd &source-position-rcd
 484		  make-source-position-condition source-position-condition?
 485		  source-position-port-id
 486		  source-position-byte source-position-character
 487		  source-position-line source-position-column
 488
 489		  &failed-expression
 490		  &failed-expression-rtd
 491		  &failed-expression-rcd
 492		  make-failed-expression-condition
 493		  failed-expression-condition?
 494		  condition-failed-expression
 495
 496		  &one-based-return-value-index
 497		  &one-based-return-value-index-rtd
 498		  &one-based-return-value-index-rcd
 499		  make-one-based-return-value-index-condition
 500		  one-based-return-value-index-condition?
 501		  condition-one-based-return-value-index
 502
 503		  &procedure-precondition-violation
 504		  &procedure-precondition-violation-rtd
 505		  &procedure-precondition-violation-rcd
 506		  make-procedure-precondition-violation
 507		  procedure-precondition-violation?
 508
 509		  &procedure-postcondition-violation
 510		  &procedure-postcondition-violation-rtd
 511		  &procedure-postcondition-violation-rcd
 512		  make-procedure-postcondition-violation
 513		  procedure-postcondition-violation?
 514
 515		  &procedure-argument-violation
 516		  &procedure-argument-violation-rtd
 517		  &procedure-argument-violation-rcd
 518		  make-procedure-argument-violation
 519		  procedure-argument-violation?
 520		  procedure-argument-violation
 521
 522		  &procedure-signature-argument-violation
 523		  &procedure-signature-argument-violation-rtd
 524		  &procedure-signature-argument-violation-rcd
 525		  make-procedure-signature-argument-violation
 526		  procedure-signature-argument-violation?
 527		  procedure-signature-argument-violation.one-based-argument-index
 528		  procedure-signature-argument-violation.failed-expression
 529		  procedure-signature-argument-violation.offending-value
 530		  procedure-signature-argument-violation
 531
 532		  &procedure-signature-return-value-violation
 533		  &procedure-signature-return-value-violation-rtd
 534		  &procedure-signature-return-value-violation-rcd
 535		  make-procedure-signature-return-value-violation
 536		  procedure-signature-return-value-violation?
 537		  procedure-signature-return-value-violation.one-based-return-value-index
 538		  procedure-signature-return-value-violation.failed-expression
 539		  procedure-signature-return-value-violation.offending-value
 540		  procedure-signature-return-value-violation
 541
 542		  &procedure-arguments-consistency-violation
 543		  &procedure-arguments-consistency-violation-rtd
 544		  &procedure-arguments-consistency-violation-rcd
 545		  make-procedure-arguments-consistency-violation
 546		  procedure-arguments-consistency-violation?
 547		  procedure-arguments-consistency-violation
 548		  procedure-arguments-consistency-violation/failed-expression
 549
 550		  &expression-return-value-violation
 551		  &expression-return-value-violation-rtd
 552		  &expression-return-value-violation-rcd
 553		  make-expression-return-value-violation
 554		  expression-return-value-violation?
 555		  expression-return-value-violation
 556
 557		  &non-reinstatable
 558		  &non-reinstatable-rtd
 559		  &non-reinstatable-rcd
 560		  make-non-reinstatable-violation
 561		  non-reinstatable-violation?
 562		  non-reinstatable-violation
 563
 564		  &late-binding-error-rtd
 565		  &late-binding-error-rcd
 566		  &late-binding-error
 567		  make-late-binding-error
 568		  late-binding-error?
 569
 570		  &method-late-binding-error-rtd
 571		  &method-late-binding-error-rcd
 572		  &method-late-binding-error
 573		  make-method-late-binding-error
 574		  method-late-binding-error?
 575
 576		  &overloaded-function-late-binding-error-rtd
 577		  &overloaded-function-late-binding-error-rcd
 578		  &overloaded-function-late-binding-error
 579		  make-overloaded-function-late-binding-error
 580		  overloaded-function-late-binding-error?
 581		  overloaded-function-late-binding-error.overloaded-function-descriptor
 582
 583		  &interface-method-late-binding-error-rtd
 584		  &interface-method-late-binding-error-rcd
 585		  &interface-method-late-binding-error
 586		  make-interface-method-late-binding-error
 587		  interface-method-late-binding-error?
 588		  interface-method-late-binding-error.interface-uid
 589		  interface-method-late-binding-error.method-name
 590		  interface-method-late-binding-error.subject
 591		  interface-method-late-binding-error.type-descriptor
 592
 593		  ;; string encoding and decoding
 594		  &string-encoding
 595		  &string-encoding-rtd
 596		  &string-encoding-rcd
 597		  make-string-encoding-error
 598		  string-encoding-error?
 599
 600		  &string-decoding
 601		  &string-decoding-rtd
 602		  &string-decoding-rcd
 603		  make-string-decoding-error
 604		  string-decoding-error?
 605
 606		  &utf8-string-encoding
 607		  &utf8-string-encoding-rtd
 608		  &utf8-string-encoding-rcd
 609		  make-utf8-string-encoding-error
 610		  utf8-string-encoding-error?
 611
 612		  &utf16-string-encoding
 613		  &utf16-string-encoding-rtd
 614		  &utf16-string-encoding-rcd
 615		  make-utf16-string-encoding-error
 616		  utf16-string-encoding-error?
 617
 618		  &utf32-string-encoding
 619		  &utf32-string-encoding-rtd
 620		  &utf32-string-encoding-rcd
 621		  make-utf32-string-encoding-error
 622		  utf32-string-encoding-error?
 623
 624		  &utf8-string-decoding
 625		  &utf8-string-decoding-rtd
 626		  &utf8-string-decoding-rcd
 627		  make-utf8-string-decoding-error
 628		  utf8-string-decoding-error?
 629
 630		  &utf16-string-decoding
 631		  &utf16-string-decoding-rtd
 632		  &utf16-string-decoding-rcd
 633		  make-utf16-string-decoding-error
 634		  utf16-string-decoding-error?
 635
 636		  &utf32-string-decoding
 637		  &utf32-string-decoding-rtd
 638		  &utf32-string-decoding-rcd
 639		  make-utf32-string-decoding-error
 640		  utf32-string-decoding-error?
 641
 642		  &utf8-string-decoding-invalid-octet
 643		  &utf8-string-decoding-invalid-octet-rtd
 644		  &utf8-string-decoding-invalid-octet-rcd
 645		  make-utf8-string-decoding-invalid-octet
 646		  utf8-string-decoding-invalid-octet?
 647		  utf8-string-decoding-invalid-octet.bytevector
 648		  utf8-string-decoding-invalid-octet.index
 649		  utf8-string-decoding-invalid-octet.octets
 650
 651		  &utf8-string-decoding-invalid-2-tuple
 652		  &utf8-string-decoding-invalid-2-tuple-rtd
 653		  &utf8-string-decoding-invalid-2-tuple-rcd
 654		  make-utf8-string-decoding-invalid-2-tuple
 655		  utf8-string-decoding-invalid-2-tuple?
 656		  utf8-string-decoding-invalid-2-tuple.bytevector
 657		  utf8-string-decoding-invalid-2-tuple.index
 658		  utf8-string-decoding-invalid-2-tuple.octets
 659
 660		  &utf8-string-decoding-invalid-3-tuple
 661		  &utf8-string-decoding-invalid-3-tuple-rtd
 662		  &utf8-string-decoding-invalid-3-tuple-rcd
 663		  make-utf8-string-decoding-invalid-3-tuple
 664		  utf8-string-decoding-invalid-3-tuple?
 665		  utf8-string-decoding-invalid-3-tuple.bytevector
 666		  utf8-string-decoding-invalid-3-tuple.index
 667		  utf8-string-decoding-invalid-3-tuple.octets
 668
 669		  &utf8-string-decoding-invalid-4-tuple
 670		  &utf8-string-decoding-invalid-4-tuple-rtd
 671		  &utf8-string-decoding-invalid-4-tuple-rcd
 672		  make-utf8-string-decoding-invalid-4-tuple
 673		  utf8-string-decoding-invalid-4-tuple?
 674		  utf8-string-decoding-invalid-4-tuple.bytevector
 675		  utf8-string-decoding-invalid-4-tuple.index
 676		  utf8-string-decoding-invalid-4-tuple.octets
 677
 678		  &utf8-string-decoding-incomplete-2-tuple
 679		  &utf8-string-decoding-incomplete-2-tuple-rtd
 680		  &utf8-string-decoding-incomplete-2-tuple-rcd
 681		  make-utf8-string-decoding-incomplete-2-tuple
 682		  utf8-string-decoding-incomplete-2-tuple?
 683		  utf8-string-decoding-incomplete-2-tuple.bytevector
 684		  utf8-string-decoding-incomplete-2-tuple.index
 685		  utf8-string-decoding-incomplete-2-tuple.octets
 686
 687		  &utf8-string-decoding-incomplete-3-tuple
 688		  &utf8-string-decoding-incomplete-3-tuple-rtd
 689		  &utf8-string-decoding-incomplete-3-tuple-rcd
 690		  make-utf8-string-decoding-incomplete-3-tuple
 691		  utf8-string-decoding-incomplete-3-tuple?
 692		  utf8-string-decoding-incomplete-3-tuple.bytevector
 693		  utf8-string-decoding-incomplete-3-tuple.index
 694		  utf8-string-decoding-incomplete-3-tuple.octets
 695
 696		  &utf8-string-decoding-incomplete-4-tuple
 697		  &utf8-string-decoding-incomplete-4-tuple-rtd
 698		  &utf8-string-decoding-incomplete-4-tuple-rcd
 699		  make-utf8-string-decoding-incomplete-4-tuple
 700		  utf8-string-decoding-incomplete-4-tuple?
 701		  utf8-string-decoding-incomplete-4-tuple.bytevector
 702		  utf8-string-decoding-incomplete-4-tuple.index
 703		  utf8-string-decoding-incomplete-4-tuple.octets
 704
 705
 706		  &utf16-string-decoding-invalid-first-word
 707		  &utf16-string-decoding-invalid-first-word-rtd
 708		  &utf16-string-decoding-invalid-first-word-rcd
 709		  make-utf16-string-decoding-invalid-first-word
 710		  utf16-string-decoding-invalid-first-word?
 711		  utf16-string-decoding-invalid-first-word.bytevector
 712		  utf16-string-decoding-invalid-first-word.index
 713		  utf16-string-decoding-invalid-first-word.word
 714
 715		  &utf16-string-decoding-invalid-second-word
 716		  &utf16-string-decoding-invalid-second-word-rtd
 717		  &utf16-string-decoding-invalid-second-word-rcd
 718		  make-utf16-string-decoding-invalid-second-word
 719		  utf16-string-decoding-invalid-second-word?
 720		  utf16-string-decoding-invalid-second-word.bytevector
 721		  utf16-string-decoding-invalid-second-word.index
 722		  utf16-string-decoding-invalid-second-word.first-word
 723		  utf16-string-decoding-invalid-second-word.second-word
 724
 725		  &utf16-string-decoding-missing-second-word
 726		  &utf16-string-decoding-missing-second-word-rtd
 727		  &utf16-string-decoding-missing-second-word-rcd
 728		  make-utf16-string-decoding-missing-second-word
 729		  utf16-string-decoding-missing-second-word?
 730		  utf16-string-decoding-missing-second-word.bytevector
 731		  utf16-string-decoding-missing-second-word.index
 732		  utf16-string-decoding-missing-second-word.word
 733
 734		  &utf16-string-decoding-standalone-octet
 735		  &utf16-string-decoding-standalone-octet-rtd
 736		  &utf16-string-decoding-standalone-octet-rcd
 737		  make-utf16-string-decoding-standalone-octet
 738		  utf16-string-decoding-standalone-octet?
 739		  utf16-string-decoding-standalone-octet.bytevector
 740		  utf16-string-decoding-standalone-octet.index
 741		  utf16-string-decoding-standalone-octet.octet
 742
 743		  &utf32-string-decoding-invalid-word
 744		  &utf32-string-decoding-invalid-word-rtd
 745		  &utf32-string-decoding-invalid-word-rcd
 746		  make-utf32-string-decoding-invalid-word
 747		  utf32-string-decoding-invalid-word?
 748		  utf32-string-decoding-invalid-word.bytevector
 749		  utf32-string-decoding-invalid-word.index
 750		  utf32-string-decoding-invalid-word.word
 751
 752		  &utf32-string-decoding-orphan-octets
 753		  &utf32-string-decoding-orphan-octets-rtd
 754		  &utf32-string-decoding-orphan-octets-rcd
 755		  make-utf32-string-decoding-orphan-octets
 756		  utf32-string-decoding-orphan-octets?
 757		  utf32-string-decoding-orphan-octets.bytevector
 758		  utf32-string-decoding-orphan-octets.index
 759		  utf32-string-decoding-orphan-octets.octets
 760		  )
 761    (only (ikarus records procedural)
 762	  $make-record-type-descriptor
 763	  $make-record-type-descriptor-ex
 764	  $make-record-constructor-descriptor
 765	  $record-and-rtd?
 766	  $record-constructor
 767	  $rtd-subtype?
 768	  $record-accessor/index)
 769    (vicare system $structs)
 770    (prefix (only (ikarus records procedural)
 771		  record-type-method-retriever-set!)
 772	    records::)
 773    (only (vicare language-extensions syntaxes)
 774	  define-list-of-type-predicate))
 775
 776
 777(define-syntax define-condition-type-syntax
 778  ;;This  syntax is  used by  DEFINE-CORE-CONDITION-TYPE.  It  defines the  syntactic
 779  ;;binding for the  type name of condition-object  types, so that it  is possible to
 780  ;;use the name to access the RTD and CTD of the record-type.  Example:
 781  ;;
 782  ;;   (define-core-condition-type &demo
 783  ;;       &condition
 784  ;;     make-demo-condition condition-decmo?)
 785  ;;
 786  ;;   (&demo rtd)	==> &demo-rtd
 787  ;;   (&demo rcd)	==> &demo-ctd
 788  ;;
 789  (syntax-rules ()
 790    ((_ ?type-name ?rtd ?rcd)
 791     (define-syntax ?type-name
 792       (lambda (stx)
 793	 (syntax-case stx ()
 794	   ((_ ?command)
 795	    (identifier? #'?command)
 796	    (case (syntax->datum #'?command)
 797	      ((rtd)	#'?rtd)
 798	      ((rcd)	#'?rcd)
 799	      (else
 800	       (syntax-violation (quote ?type-name)
 801		 "invalid command for core condition-object type name" stx #'?command))))
 802	   (_
 803	    (syntax-violation (quote ?type-name) "invalid use of core condition-object type name" stx #f))))))
 804    ))
 805
 806
 807(define-syntax (define-core-condition-type stx)
 808  ;;This macro is used in this library to define condition object types.
 809  ;;
 810  ;;NOTE Remember that this  macro is *not* the one exported by  the boot image.  The
 811  ;;transformer of  the keyword  binding DEFINE-CONDITION-TYPE  exported by  the boot
 812  ;;image is integrated in the expander.
 813  ;;
 814  (define (main input-form.stx)
 815    (syntax-case input-form.stx ()
 816      ((?kwd ?name ?parent-name ?constructor ?predicate (?field ?accessor) ...)
 817       (and (identifier? #'?name)
 818	    (identifier? #'?parent-name)
 819	    (identifier? #'?constructor)
 820	    (identifier? #'?predicate)
 821	    (andmap identifier? #'(?field ...))
 822	    (andmap identifier? #'(?accessor ...)))
 823       (with-syntax
 824	   ((UID		(mkname "vicare:core-type:" #'?name ""))
 825	    (GENERATIVE?	#f)
 826	    (RTD		(mkname "" #'?name "-rtd"))
 827	    (RCD		(mkname "" #'?name "-rcd"))
 828	    ((ACCESSOR-IDX ...)	(iota 0 #'(?accessor ...)))
 829	    (SEALED?		#f)
 830	    (OPAQUE?		#f)
 831	    (METHOD-RETRIEVER	(if (null? (syntax->datum #'(?field ...)))
 832				    #f
 833				  #'(lambda (name)
 834				      (case name
 835					((?field)	?accessor)
 836					...
 837					(else #f))))))
 838	 ;;We use the records procedural layer  and the unsafe functions to make it
 839	 ;;easier to rotate the boot images.
 840	 #'(begin ;;module (RTD RCD ?constructor ?predicate ?accessor ...)
 841	     (define RTD
 842	       ($make-record-type-descriptor-ex (quote ?name) (?parent-name rtd)
 843						(quote UID) GENERATIVE? SEALED? OPAQUE?
 844						'#((immutable ?field) ...) '#((#f . ?field) ...)
 845						#f ;destructor
 846						#f ;printer
 847						#f ;equality-predicate
 848						#f ;comparison-procedure
 849						#f ;hash-function
 850						METHOD-RETRIEVER
 851						METHOD-RETRIEVER ;method-retriever-private
 852						#f ;implemented-interfaces
 853						))
 854	     (define RCD
 855	       ($make-record-constructor-descriptor RTD (?parent-name rcd) #f))
 856	     (define ?constructor
 857	       ($record-constructor RCD))
 858	     (define ?predicate
 859	       ($condition-predicate RTD))
 860	     (define ?accessor
 861	       ($condition-accessor RTD ($record-accessor/index RTD ACCESSOR-IDX (quote ?accessor)) (quote ?accessor)))
 862	     ...
 863	     ;;We define this syntactic binding with  the only purpose of using it to
 864	     ;;access the  syntactic bindings RTD and  RCD in the lexical  context of
 865	     ;;the definition.
 866	     (define-condition-type-syntax ?name RTD RCD)
 867	     )))
 868      ))
 869
 870  (define (mkname prefix name suffix)
 871    (datum->syntax name (string->symbol (string-append prefix (symbol->string (syntax->datum name)) suffix))))
 872
 873  (define (iota idx stx)
 874    (syntax-case stx ()
 875      (()	'())
 876      ((?x . ?x*)
 877       (cons idx (iota (fxadd1 idx) #'?x*)))))
 878
 879  ;; (receive-and-return (out)
 880  ;;     (main stx)
 881  ;;   (debug-print 'ikarus.conditions (syntax->datum out)))
 882  (main stx))
 883
 884
 885;;;; arguments validation
 886
 887(define (simple-condition-rtd-subtype? obj)
 888  (and (record-type-descriptor? obj)
 889       ($rtd-subtype? obj &condition-rtd)))
 890
 891(define-list-of-type-predicate list-of-conditions? condition?)
 892(define-list-of-type-predicate list-of-simple-conditions? simple-condition?)
 893
 894(define-syntax-rule ($record-of-type ?obj ?rtd)
 895  (and ($struct? ?obj)
 896       ($record-and-rtd? ?obj ?rtd)))
 897
 898(define (who-condition-value? obj)
 899  (or (not     obj)
 900      (symbol? obj)
 901      (string? obj)))
 902
 903
 904;;;; data types and some predicates
 905
 906;;NOTE We could  use the records syntactic  layer as shown below, but  instead we use
 907;;the procedural  layer to allow  boot image  initialisation (without crashes  due to
 908;;not-yet-initialised core primitives).
 909;;
 910;; (begin
 911;;   (define-record-type (&condition make-simple-condition simple-condition?)
 912;;     (nongenerative))
 913;;   (define &condition-rtd
 914;;     (record-type-descriptor &condition))
 915;;   (define &condition-rcd
 916;;     (record-constructor-descriptor &condition))
 917;;   (define-record-type compound-condition
 918;;     (nongenerative)
 919;;     (fields (immutable components))
 920;;     (sealed #t)
 921;;     (opaque #f))
 922;;   #| end of BEGIN |# )
 923
 924(begin
 925  (define &condition-rtd
 926    ($make-record-type-descriptor '&condition #f 'vicare:conditions:&condition #f #f '#() '#()))
 927  (define &condition-rcd
 928    ($make-record-constructor-descriptor &condition-rtd #f #f))
 929  (define make-simple-condition
 930    ($record-constructor &condition-rcd))
 931  (define (simple-condition? X)
 932    ($record-of-type X &condition-rtd))
 933  ;;We define this syntactic binding with the  only purpose of using it to access the
 934  ;;syntactic bindings  &CONDITION-RTD and &CONDITION-RCD  in the lexical  context of
 935  ;;the definition.
 936  (define-condition-type-syntax &condition &condition-rtd &condition-rcd)
 937  #| end of BEGIN |# )
 938
 939(begin
 940  (define compound-condition-rtd
 941    ($make-record-type-descriptor 'compound-condition #f 'vicare:conditions:compound-condition #t #f
 942				  '#((immutable . components)) '#((#f . components))))
 943  (define compound-condition-rcd
 944    ($make-record-constructor-descriptor compound-condition-rtd #f #f))
 945  (define make-compound-condition
 946    ($record-constructor compound-condition-rcd))
 947  (define (compound-condition? X)
 948    ($record-of-type X compound-condition-rtd))
 949  ;; (define compound-condition-components
 950  ;;   (record-accessor compound-condition-rtd 0))
 951  (define ($compound-condition-components cnd)
 952    ($struct-ref cnd 0))
 953  ;;We define this syntactic binding with the  only purpose of using it to access the
 954  ;;syntactic  bindings &COMPOUND-CONDITION-RTD  and  &COMPOUND-CONDITION-RCD in  the
 955  ;;lexical context of the definition.
 956  (define-condition-type-syntax &compound-condition &compound-condition-rtd &compound-condition-rcd)
 957  #| end of BEGIN |# )
 958
 959;;; --------------------------------------------------------------------
 960
 961(define (condition? x)
 962  ;;Defined by R6RS.  Return  #t if X is a (simple  or compound) condition, otherwise
 963  ;;return #f.
 964  ;;
 965  (or (simple-condition? x)
 966      (compound-condition? x)))
 967
 968(define* (condition-and-rtd? obj {rtd simple-condition-rtd-subtype?})
 969  (cond ((compound-condition? obj)
 970	 (let loop ((ls ($compound-condition-components obj)))
 971	   (and (pair? ls)
 972		(or ($record-of-type (car ls) rtd)
 973		    (loop (cdr ls))))))
 974	((simple-condition? obj)
 975	 ($record-of-type obj rtd))
 976	(else #f)))
 977
 978
 979(case-define* condition
 980  ;;Defined by R6RS.  Return a condition  object with the components of the condition
 981  ;;arguments  as its  components,  in the  same order.   The  returned condition  is
 982  ;;compound  if  the  total number  of  components  is  zero  or greater  than  one.
 983  ;;Otherwise, it may be compound or simple.
 984  ;;
 985  (()
 986   (make-compound-condition '()))
 987  (({x condition?})
 988   x)
 989  (x*
 990   (let ((ls (let recur ((x* x*))
 991	       (if (pair? x*)
 992		   (cond ((simple-condition? (car x*))
 993			  (cons (car x*) (recur (cdr x*))))
 994			 ((compound-condition? (car x*))
 995			  (append (simple-conditions (car x*)) (recur (cdr x*))))
 996			 (else
 997			  (procedure-argument-violation 'condition
 998			    "expected condition object as argument" (car x*))))
 999		 '()))))
1000     (cond ((null? ls)
1001	    (make-compound-condition '()))
1002	   ((null? (cdr ls))
1003	    (car ls))
1004	   (else
1005	    (make-compound-condition ls))))))
1006
1007(define* (simple-conditions x)
1008  ;;Defined by R6RS.  Return a list of the components of X, in the same order as they
1009  ;;appeared  in the  construction of  X.  The  returned list  is immutable.   If the
1010  ;;returned list is modified, the effect on X is unspecified.
1011  ;;
1012  ;;NOTE  Because   CONDITION  decomposes  its  arguments   into  simple  conditions,
1013  ;;SIMPLE-CONDITIONS always returns a ``flattened'' list of simple conditions.
1014  ;;
1015  (cond ((compound-condition? x)
1016	 ($compound-condition-components x))
1017	((simple-condition? x)
1018	 (list x))
1019	(else
1020	 (procedure-argument-violation __who__
1021	   "expected condition object as argument"
1022	   x))))
1023
1024
1025(define* (condition-predicate {rtd simple-condition-rtd-subtype?})
1026  ;;Defined  by  R6RS.   RTD  must  be  a record-type  descriptor  of  a  subtype  of
1027  ;;"&condition".  The  CONDITION-PREDICATE procedure returns a  procedure that takes
1028  ;;one argument.  This  procedure returns #t if  its argument is a  condition of the
1029  ;;condition type represented  by RTD, i.e., if  it is either a  simple condition of
1030  ;;that record type (or  one of its subtypes) or a compound  conditition with such a
1031  ;;simple condition as one of its components, and #f otherwise.
1032  ;;
1033  ($condition-predicate rtd))
1034
1035(define ($condition-predicate rtd)
1036  (lambda (X)
1037    (or (and (compound-condition? X)
1038	     (let loop ((ls ($compound-condition-components X)))
1039	       (and (pair? ls)
1040		    (or ($record-of-type (car ls) rtd)
1041			(loop (cdr ls))))))
1042	($record-of-type X rtd))))
1043
1044(case-define* condition-accessor
1045  ;;Defined  by  R6RS.   RTD  must  be  a record-type  descriptor  of  a  subtype  of
1046  ;;"&condition".  PROC  should accept one argument,  a record of the  record type of
1047  ;;RTD.
1048  ;;
1049  ;;The  CONDITION-ACCESSOR  procedure returns  a  procedure  that accepts  a  single
1050  ;;argument,  which must  be  a condition  of  the type  represented  by RTD.   This
1051  ;;procedure extracts the  first component of the condition of  the type represented
1052  ;;by RTD, and returns the result of applying PROC to that component.
1053  ;;
1054  (({rtd simple-condition-rtd-subtype?} {proc procedure?})
1055   ($condition-accessor rtd proc 'anonymous-condition-accessor))
1056  (({rtd simple-condition-rtd-subtype?} {proc procedure?} {accessor-who (or not symbol?)})
1057   ($condition-accessor rtd proc accessor-who)))
1058
1059(define ($condition-accessor rtd proc accessor-who)
1060  (lambda (X)
1061    (define (%error)
1062      (procedure-arguments-consistency-violation accessor-who "not a condition of correct type" X rtd))
1063    (cond ((compound-condition? X)
1064	   (let loop ((ls ($compound-condition-components X)))
1065	     (cond ((pair? ls)
1066		    (if ($record-of-type (car ls) rtd)
1067			(proc (car ls))
1068		      (loop (cdr ls))))
1069		   (else
1070		    (%error)))))
1071	  (($record-of-type X rtd)
1072	   (proc X))
1073	  (else
1074	   (%error)))))
1075
1076
1077;;;; raising exceptions
1078
1079(case-define* raise-non-continuable-standard-condition
1080  ;;NOTE Remember that the order in  which we concatenate simple condition objects in
1081  ;;compound condition  objects is  important: it  is the order  in which  the simple
1082  ;;objects  will  be shown  to  the  user, when  an  exception  is raised  and  goes
1083  ;;uncatched.
1084  ((who {message string?} {irritants list?})
1085   (let ((C (condition (make-message-condition message)
1086		       (make-irritants-condition irritants))))
1087     (raise (if who
1088		(if (or (symbol? who)
1089			(string? who))
1090		    (condition (make-who-condition who) C)
1091		  (procedure-signature-argument-violation __who__
1092		    "invalid value for &who" 1 '(or (symbol? who) (string? who)) who))
1093	      C))))
1094  ((who {message string?} {irritants list?} {cnd condition?})
1095   (let ((C (condition (make-message-condition message)
1096		       cnd
1097		       (make-irritants-condition irritants))))
1098     (raise (if who
1099		(if (or (symbol? who)
1100			(string? who))
1101		    (condition (make-who-condition who) C)
1102		  (procedure-signature-argument-violation __who__
1103		    "invalid value for &who" 1 '(or (symbol? who) (string? who)) who))
1104	      C)))))
1105
1106
1107;;;; R6RS condition types
1108
1109(define-core-condition-type &message &condition
1110  make-message-condition message-condition?
1111  (message condition-message))
1112
1113(define-core-condition-type &warning &condition
1114  make-warning warning?)
1115
1116(define-core-condition-type &serious &condition
1117  make-serious-condition serious-condition?)
1118
1119(define-core-condition-type &error &serious
1120  make-error error?)
1121
1122(define-core-condition-type &violation &serious
1123  make-violation violation?)
1124
1125(define-core-condition-type &assertion &violation
1126  make-assertion-violation assertion-violation?)
1127
1128(define-core-condition-type &irritants &condition
1129  make-irritants-condition irritants-condition?
1130  (irritants condition-irritants))
1131
1132(define-core-condition-type &who &condition
1133  %make-who-condition who-condition?
1134  (who condition-who))
1135
1136(define* (make-who-condition {who who-condition-value?})
1137  (%make-who-condition who))
1138
1139(define-core-condition-type &non-continuable &violation
1140  make-non-continuable-violation non-continuable-violation?)
1141
1142(define-core-condition-type &implementation-restriction &violation
1143  make-implementation-restriction-violation
1144  implementation-restriction-violation?)
1145
1146(define-core-condition-type &lexical &violation
1147  make-lexical-violation lexical-violation?)
1148
1149(define-core-condition-type &syntax &violation
1150  make-syntax-violation syntax-violation?
1151  (form syntax-violation-form)
1152  (subform syntax-violation-subform))
1153
1154(define-core-condition-type &undefined &violation
1155  make-undefined-violation undefined-violation?)
1156
1157(define-core-condition-type &i/o &error
1158  make-i/o-error i/o-error?)
1159
1160(define-core-condition-type &i/o-read &i/o
1161  make-i/o-read-error i/o-read-error?)
1162
1163(define-core-condition-type &i/o-write &i/o
1164  make-i/o-write-error i/o-write-error?)
1165
1166(define-core-condition-type &i/o-invalid-position &i/o
1167  make-i/o-invalid-position-error i/o-invalid-position-error?
1168  (position i/o-error-position))
1169
1170(define-core-condition-type &i/o-filename &i/o
1171  make-i/o-filename-error i/o-filename-error?
1172  (filename i/o-error-filename))
1173
1174(define-core-condition-type &i/o-file-protection &i/o-filename
1175  make-i/o-file-protection-error i/o-file-protection-error?)
1176
1177(define-core-condition-type &i/o-file-is-read-only &i/o-file-protection
1178  make-i/o-file-is-read-only-error i/o-file-is-read-only-error?)
1179
1180(define-core-condition-type &i/o-file-already-exists &i/o-filename
1181  make-i/o-file-already-exists-error i/o-file-already-exists-error?)
1182
1183(define-core-condition-type &i/o-file-does-not-exist &i/o-filename
1184  make-i/o-file-does-not-exist-error i/o-file-does-not-exist-error?)
1185
1186(define-core-condition-type &i/o-port &i/o
1187  make-i/o-port-error i/o-port-error?
1188  (port i/o-error-port))
1189
1190(define-core-condition-type &i/o-decoding &i/o-port
1191  make-i/o-decoding-error i/o-decoding-error?)
1192
1193(define-core-condition-type &i/o-encoding &i/o-port
1194  make-i/o-encoding-error i/o-encoding-error?
1195  (char i/o-encoding-error-char))
1196
1197(define-core-condition-type &no-infinities &implementation-restriction
1198  make-no-infinities-violation no-infinities-violation?)
1199
1200(define-core-condition-type &no-nans &implementation-restriction
1201  make-no-nans-violation no-nans-violation?)
1202
1203;;; --------------------------------------------------------------------
1204;;; Ikarus specific condition types
1205
1206(define-core-condition-type &interrupted &serious
1207  make-interrupted-condition interrupted-condition?)
1208
1209(define-core-condition-type &source-position &condition
1210  make-source-position-condition source-position-condition?
1211  (port-id	source-position-port-id)
1212  (byte		source-position-byte)
1213  (character	source-position-character)
1214  (line		source-position-line)
1215  (column	source-position-column))
1216
1217
1218;;; Vicare specific condition types
1219
1220(define-core-condition-type &i/o-eagain
1221    &i/o
1222  make-i/o-eagain i/o-eagain-error?)
1223
1224(define-core-condition-type &errno
1225    &condition
1226  make-errno-condition errno-condition?
1227  (code		condition-errno))
1228
1229(define-core-condition-type &h_errno
1230    &condition
1231  make-h_errno-condition h_errno-condition?
1232  (code		condition-h_errno))
1233
1234(define-core-condition-type &i/o-wrong-fasl-header-error
1235    &i/o
1236  make-i/o-wrong-fasl-header-error
1237  i/o-wrong-fasl-header-error?)
1238
1239;;; --------------------------------------------------------------------
1240
1241(define-core-condition-type &out-of-memory-error
1242    &error
1243  make-out-of-memory-error
1244  out-of-memory-error?)
1245
1246(define (%raise-out-of-memory who)
1247  (raise
1248   (condition (make-who-condition who)
1249	      (make-message-condition "failed raw memory allocation")
1250	      (make-out-of-memory-error))))
1251
1252;;; --------------------------------------------------------------------
1253
1254(define-core-condition-type &failed-expression
1255    &condition
1256  make-failed-expression-condition
1257  failed-expression-condition?
1258  (failed-expression	condition-failed-expression))
1259
1260;;; --------------------------------------------------------------------
1261
1262(define-core-condition-type &one-based-return-value-index
1263    &condition
1264  make-one-based-return-value-index-condition
1265  one-based-return-value-index-condition?
1266  (index	condition-one-based-return-value-index))
1267
1268;;; --------------------------------------------------------------------
1269
1270(define-core-condition-type &procedure-precondition-violation
1271    &assertion
1272  make-procedure-precondition-violation
1273  procedure-precondition-violation?)
1274
1275;;; --------------------------------------------------------------------
1276
1277(define-core-condition-type &procedure-postcondition-violation
1278    &assertion
1279  make-procedure-postcondition-violation
1280  procedure-postcondition-violation?)
1281
1282;;; --------------------------------------------------------------------
1283
1284(define-core-condition-type &procedure-argument-violation
1285    &procedure-precondition-violation
1286  make-procedure-argument-violation procedure-argument-violation?)
1287
1288(define (procedure-argument-violation who message . irritants)
1289  (raise-non-continuable-standard-condition who
1290    message irritants (make-procedure-argument-violation)))
1291
1292;;; --------------------------------------------------------------------
1293
1294(define-core-condition-type &procedure-signature-argument-violation
1295    &procedure-argument-violation
1296  make-procedure-signature-argument-violation procedure-signature-argument-violation?
1297  ;;One-base index of the offending operand.
1298  (one-based-argument-index	procedure-signature-argument-violation.one-based-argument-index)
1299  ;;Symbolic expression representing the predicate used to validate the operand.
1300  (failed-expression		procedure-signature-argument-violation.failed-expression)
1301  ;;The actual operand.
1302  (offending-value		procedure-signature-argument-violation.offending-value))
1303
1304(define (procedure-signature-argument-violation who message operand-index failed-expression offending-value)
1305  (raise-non-continuable-standard-condition who
1306    message (list offending-value)
1307    (make-procedure-signature-argument-violation operand-index failed-expression offending-value)))
1308
1309;;; --------------------------------------------------------------------
1310
1311(define-core-condition-type &procedure-signature-return-value-violation
1312    &procedure-postcondition-violation
1313  make-procedure-signature-return-value-violation procedure-signature-return-value-violation?
1314  ;;One-base index of the  offending return value in the tuple  of values returned by
1315  ;;the expression.
1316  (one-based-return-value-index	procedure-signature-return-value-violation.one-based-return-value-index)
1317  ;;Symbolic expression representing the predicate used to validate the return value.
1318  (failed-expression		procedure-signature-return-value-violation.failed-expression)
1319  ;;The actual value returned by the expression.
1320  (offending-value		procedure-signature-return-value-violation.offending-value))
1321
1322(define (procedure-signature-return-value-violation who message retval-index failed-expression offending-value)
1323  (raise-non-continuable-standard-condition who
1324    message (list offending-value)
1325    (make-procedure-signature-return-value-violation retval-index failed-expression offending-value)))
1326
1327;;; --------------------------------------------------------------------
1328
1329(define-core-condition-type &procedure-arguments-consistency-violation
1330    &procedure-precondition-violation
1331  make-procedure-arguments-consistency-violation
1332  procedure-arguments-consistency-violation?)
1333
1334(define (procedure-arguments-consistency-violation who message . irritants)
1335  (raise-non-continuable-standard-condition who
1336    message irritants
1337    (make-procedure-arguments-consistency-violation)))
1338
1339(define (procedure-arguments-consistency-violation/failed-expression who message failed-expression . irritants)
1340  (raise-non-continuable-standard-condition who
1341    message irritants
1342    (condition (make-procedure-arguments-consistency-violation)
1343	       (make-failed-expression-con…

Large files files are truncated, but you can click here to view the full file