LilyPond-Ruby 0.1.1 → 0.1.2

data/share/guile/2.2/rnrs/io/simple.scm

@@ -0,0 +1,167 @@
+;;; simple.scm --- The R6RS simple I/O library
+
+;;      Copyright (C) 2010, 2011, 2014, 2018 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 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
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(library (rnrs io simple (6))
+  (export eof-object 
+          eof-object?
+
+	  call-with-input-file
+	  call-with-output-file
+	  
+	  input-port?
+	  output-port?
+
+	  current-input-port
+	  current-output-port
+	  current-error-port
+
+	  with-input-from-file
+	  with-output-to-file
+
+	  open-input-file
+	  open-output-file
+
+	  close-input-port
+	  close-output-port
+
+	  read-char
+	  peek-char
+	  read
+	  write-char
+	  newline
+	  display
+	  write
+
+	  &i/o make-i/o-error i/o-error?
+	  &i/o-read make-i/o-read-error i/o-read-error?
+	  &i/o-write make-i/o-write-error i/o-write-error?
+
+	  &i/o-invalid-position 
+	  make-i/o-invalid-position-error 
+	  i/o-invalid-position-error? 
+	  i/o-error-position
+	  
+	  &i/o-filename
+	  make-i/o-filename-error
+	  i/o-filename-error?
+	  i/o-error-filename
+	  
+	  &i/o-file-protection 
+	  make-i/o-file-protection-error
+	  i/o-file-protection-error?
+
+	  &i/o-file-is-read-only
+	  make-i/o-file-is-read-only-error
+	  i/o-file-is-read-only-error?
+
+	  &i/o-file-already-exists
+	  make-i/o-file-already-exists-error
+	  i/o-file-already-exists-error?
+
+	  &i/o-file-does-not-exist
+	  make-i/o-file-does-not-exist-error
+	  i/o-file-does-not-exist-error?
+
+	  &i/o-port
+	  make-i/o-port-error
+	  i/o-port-error?
+	  i/o-error-port)	  
+
+  (import (only (rnrs io ports)
+                call-with-port
+                close-port
+                open-file-input-port
+                open-file-output-port
+                eof-object 
+                eof-object?
+                file-options
+                buffer-mode
+                native-transcoder
+                get-char
+                lookahead-char
+                get-datum
+                put-char
+                put-datum
+
+                input-port? 
+                output-port?)
+          (only (guile)
+                @@
+                current-input-port
+                current-output-port
+                current-error-port
+
+                define*
+
+                with-input-from-port
+                with-output-to-port)
+	  (rnrs base (6))
+          (rnrs files (6)) ;for the condition types
+          )
+
+  (define display (@@ (rnrs io ports) display))
+
+  (define (call-with-input-file filename proc)
+    (call-with-port (open-input-file filename) proc))
+
+  (define (call-with-output-file filename proc)
+    (call-with-port (open-output-file filename) proc))
+
+  (define (with-input-from-file filename thunk)
+    (call-with-input-file filename
+      (lambda (port) (with-input-from-port port thunk))))
+
+  (define (with-output-to-file filename thunk)
+    (call-with-output-file filename
+      (lambda (port) (with-output-to-port port thunk))))
+
+  (define (open-input-file filename)
+    (open-file-input-port filename
+                          (file-options)
+                          (buffer-mode block)
+                          (native-transcoder)))
+
+  (define (open-output-file filename)
+    (open-file-output-port filename
+                           (file-options)
+                           (buffer-mode block)
+                           (native-transcoder)))
+
+  (define close-input-port close-port)
+  (define close-output-port close-port)
+
+  (define* (read-char #:optional (port (current-input-port)))
+    (get-char port))
+
+  (define* (peek-char #:optional (port (current-input-port)))
+    (lookahead-char port))
+
+  (define* (read #:optional (port (current-input-port)))
+    (get-datum port))
+
+  (define* (write-char char #:optional (port (current-output-port)))
+    (put-char port char))
+
+  (define* (newline #:optional (port (current-output-port)))
+    (put-char port #\newline))
+
+  (define* (write object #:optional (port (current-output-port)))
+    (put-datum port object))
+
+  )

data/share/guile/2.2/rnrs/lists.scm

@@ -0,0 +1,55 @@
+;;; lists.scm --- The R6RS list utilities library
+
+;;      Copyright (C) 2010 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 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
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(library (rnrs lists (6))
+  (export find for-all exists filter partition fold-left fold-right remp remove 
+	  remv remq memp member memv memq assp assoc assv assq cons*)
+  (import (rnrs base (6))
+          (only (guile) filter member memv memq assoc assv assq cons*)
+	  (rename (only (srfi srfi-1) any 
+				      every 
+				      remove 
+				      member 
+				      assoc 
+				      find 
+				      partition
+				      fold-right 
+				      filter-map)
+		  (any exists) 
+		  (every for-all)
+		  (remove remp)
+		  
+		  (member memp-internal)
+		  (assoc assp-internal)))
+
+  (define (fold-left combine nil list . lists)
+    (define (fold nil lists)
+      (if (exists null? lists)
+          nil
+          (fold (apply combine nil (map car lists))
+                (map cdr lists))))
+    (fold nil (cons list lists)))
+
+  (define (remove obj list) (remp (lambda (elt) (equal? obj elt)) list))
+  (define (remv obj list) (remp (lambda (elt) (eqv? obj elt)) list))
+  (define (remq obj list) (remp (lambda (elt) (eq? obj elt)) list))
+
+  (define (memp pred list) (memp-internal #f list (lambda (x y) (pred y))))
+  (define (assp pred list) (assp-internal #f list (lambda (x y) (pred y))))
+)

data/share/guile/2.2/rnrs/mutable-pairs.scm

@@ -0,0 +1,23 @@
+;;; mutable-pairs.scm --- The R6RS mutable pair library
+
+;;      Copyright (C) 2010 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 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
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+
+(library (rnrs mutable-pairs (6))
+  (export set-car! set-cdr!)
+  (import (only (guile) set-car! set-cdr!)))

data/share/guile/2.2/rnrs/mutable-strings.scm

@@ -0,0 +1,23 @@
+;;; mutable-strings.scm --- The R6RS mutable string library
+
+;;      Copyright (C) 2010 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 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
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+
+(library (rnrs mutable-strings (6))
+  (export string-set! string-fill!)
+  (import (only (guile) string-set! string-fill!)))

data/share/guile/2.2/rnrs/programs.scm

@@ -0,0 +1,22 @@
+;;; programs.scm --- The R6RS process management library
+
+;;      Copyright (C) 2010 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 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
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(library (rnrs programs (6))
+  (export command-line exit)
+  (import (only (guile) command-line exit)))

data/share/guile/2.2/rnrs/r5rs.scm

@@ -0,0 +1,34 @@
+;;; r5rs.scm --- The R6RS / R5RS compatibility library
+
+;;      Copyright (C) 2010 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 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
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(library (rnrs r5rs (6))
+  (export exact->inexact inexact->exact 
+
+	  quotient remainder modulo 
+
+	  delay force 
+
+	  null-environment scheme-report-environment)
+  (import (only (guile) exact->inexact inexact->exact
+			
+			quotient remainder modulo
+			
+			delay force)
+          (only (ice-9 r5rs) scheme-report-environment)
+          (only (ice-9 safe-r5rs) null-environment)))

data/share/guile/2.2/rnrs/records/inspection.scm

@@ -0,0 +1,81 @@
+;;; inspection.scm --- Inspection support for R6RS records
+
+;;      Copyright (C) 2010 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 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
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(library (rnrs records inspection (6))
+  (export record? 
+          record-rtd 
+	  record-type-name 
+	  record-type-parent 
+	  record-type-uid 
+	  record-type-generative? 
+	  record-type-sealed? 
+	  record-type-opaque? 
+	  record-type-field-names 
+	  record-field-mutable?)
+  (import (rnrs arithmetic bitwise (6))
+          (rnrs base (6))
+	  (rnrs records procedural (6))
+	  (only (guile) struct-ref struct-vtable vtable-index-layout @@))
+
+  (define record-internal? (@@ (rnrs records procedural) record-internal?))
+
+  (define rtd-index-name (@@ (rnrs records procedural) rtd-index-name))
+  (define rtd-index-parent (@@ (rnrs records procedural) rtd-index-parent))
+  (define rtd-index-uid (@@ (rnrs records procedural) rtd-index-uid))
+  (define rtd-index-sealed? (@@ (rnrs records procedural) rtd-index-sealed?))
+  (define rtd-index-opaque? (@@ (rnrs records procedural) rtd-index-opaque?))
+  (define rtd-index-field-names 
+    (@@ (rnrs records procedural) rtd-index-field-names))
+  (define rtd-index-field-bit-field
+    (@@ (rnrs records procedural) rtd-index-field-bit-field))
+
+  (define (record? obj)
+    (and (record-internal? obj)
+	 (not (record-type-opaque? (struct-vtable obj)))))
+
+  (define (record-rtd record)
+    (or (and (record-internal? record)
+	     (let ((rtd (struct-vtable record)))
+	       (and (not (struct-ref rtd rtd-index-opaque?)) rtd)))
+	(assertion-violation 'record-rtd "not a record" record)))
+
+  (define (guarantee-rtd who rtd)
+    (if (record-type-descriptor? rtd)
+        rtd
+        (assertion-violation who "not a record type descriptor" rtd)))
+
+  (define (record-type-name rtd) 
+    (struct-ref (guarantee-rtd 'record-type-name rtd) rtd-index-name))
+  (define (record-type-parent rtd) 
+    (struct-ref (guarantee-rtd 'record-type-parent rtd) rtd-index-parent))
+  (define (record-type-uid rtd)
+    (struct-ref (guarantee-rtd 'record-type-uid rtd) rtd-index-uid))
+  (define (record-type-generative? rtd) 
+    (not (record-type-uid (guarantee-rtd 'record-type-generative? rtd))))
+  (define (record-type-sealed? rtd) 
+    (struct-ref (guarantee-rtd 'record-type-sealed? rtd) rtd-index-sealed?))
+  (define (record-type-opaque? rtd) 
+    (struct-ref (guarantee-rtd 'record-type-opaque? rtd) rtd-index-opaque?))
+  (define (record-type-field-names rtd)
+    (struct-ref (guarantee-rtd 'record-type-field-names rtd) rtd-index-field-names))
+  (define (record-field-mutable? rtd k)
+    (bitwise-bit-set? (struct-ref (guarantee-rtd 'record-field-mutable? rtd)
+                                  rtd-index-field-bit-field)
+                      k))
+)

data/share/guile/2.2/rnrs/records/procedural.scm

@@ -0,0 +1,289 @@
+;;; procedural.scm --- Procedural interface to R6RS records
+
+;;      Copyright (C) 2010, 2017 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 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
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(library (rnrs records procedural (6))
+  (export make-record-type-descriptor 
+	  record-type-descriptor?
+	  make-record-constructor-descriptor
+	  
+	  record-constructor
+	  record-predicate
+	  record-accessor	  
+	  record-mutator)
+	  
+  (import (rnrs base (6))
+          (only (guile) cons*
+                        logand 
+                        logior
+                        ash
+
+                        and=>
+			throw
+			display
+		        make-struct/no-tail
+			make-vtable 
+			map
+			simple-format
+			string-append 
+                        symbol-append
+			
+			struct? 
+                        struct-layout
+			struct-ref 
+			struct-set! 
+			struct-vtable
+			vtable-index-layout
+
+                        make-hash-table
+			hashq-ref
+			hashq-set!
+
+			vector->list)
+	  (ice-9 receive)
+	  (only (srfi :1) fold split-at take))
+
+  (define (record-internal? obj)
+    (and (struct? obj) (record-type-descriptor? (struct-vtable obj))))
+
+  (define rtd-index-name 8)
+  (define rtd-index-uid 9)
+  (define rtd-index-parent 10)
+  (define rtd-index-sealed? 11)
+  (define rtd-index-opaque? 12)
+  (define rtd-index-predicate 13)
+  (define rtd-index-field-names 14)
+  (define rtd-index-field-bit-field 15)
+  (define rtd-index-field-binder 16)
+
+  (define rctd-index-rtd 0)
+  (define rctd-index-parent 1)
+  (define rctd-index-protocol 2)
+
+  (define vtable-base-layout (symbol->string (struct-layout (make-vtable ""))))
+
+  (define record-type-vtable 
+    (make-vtable (string-append vtable-base-layout "prprprprprprprprprpr")
+		 (lambda (obj port) 
+		   (simple-format port "#<r6rs:record-type:~A>"
+				  (struct-ref obj rtd-index-name)))))
+
+  (define record-constructor-vtable 
+    (make-vtable "prprpr"
+		 (lambda (obj port) 
+		   (simple-format port "#<r6rs:record-constructor:~A>" 
+				  (struct-ref (struct-ref obj rctd-index-rtd)
+					      rtd-index-name)))))
+
+  (define uid-table (make-hash-table))    
+
+  (define (make-record-type-descriptor name parent uid sealed? opaque? fields)
+    (define fields-pair
+      (let loop ((field-list (vector->list fields))
+                 (layout-sym 'pr)
+                 (layout-bit-field 0)
+                 (counter 0))
+        (if (null? field-list)
+            (cons layout-sym layout-bit-field)
+            (case (caar field-list)
+              ((immutable) 
+               (loop (cdr field-list)
+                     (symbol-append layout-sym 'pr) 
+                     layout-bit-field 
+                     (+ counter 1)))
+              ((mutable)
+               (loop (cdr field-list)
+                     (symbol-append layout-sym 'pw)
+                     (logior layout-bit-field (ash 1 counter))
+                     (+ counter 1)))
+              (else (r6rs-raise (make-assertion-violation)))))))
+
+    (define fields-layout (car fields-pair))
+    (define fields-bit-field (cdr fields-pair))
+
+    (define field-names (list->vector (map cadr (vector->list fields))))
+    (define late-rtd #f)
+
+    (define (private-record-predicate obj)       
+      (and (record-internal? obj)
+           (or (eq? (struct-vtable obj) late-rtd)
+               (and=> (struct-ref obj 0) private-record-predicate))))
+
+    (define (field-binder parent-struct . args)
+      (apply make-struct/no-tail late-rtd parent-struct args))
+
+    (if (and parent (struct-ref parent rtd-index-sealed?))
+	(r6rs-raise (make-assertion-violation)))
+
+    (let ((matching-rtd (and uid (hashq-ref uid-table uid)))
+	  (opaque? (or opaque? (and parent (struct-ref 
+					    parent rtd-index-opaque?)))))
+      (if matching-rtd
+	  (if (equal? (list name 
+			    parent 
+			    sealed? 
+			    opaque?                            
+			    field-names
+                            fields-bit-field)
+		      (list (struct-ref matching-rtd rtd-index-name)
+			    (struct-ref matching-rtd rtd-index-parent)
+			    (struct-ref matching-rtd rtd-index-sealed?)
+			    (struct-ref matching-rtd rtd-index-opaque?)
+			    (struct-ref matching-rtd rtd-index-field-names)
+                            (struct-ref matching-rtd 
+                                        rtd-index-field-bit-field)))
+	      matching-rtd
+	      (r6rs-raise (make-assertion-violation)))
+          
+	  (let ((rtd (make-struct/no-tail
+                      record-type-vtable
+
+                      fields-layout
+                      (lambda (obj port)
+                        (simple-format 
+                         port "#<r6rs:record:~A>" name))
+				  
+                      name
+                      uid
+                      parent 
+                      sealed? 
+                      opaque?
+				  
+                      private-record-predicate
+                      field-names
+                      fields-bit-field
+                      field-binder)))
+	    (set! late-rtd rtd)
+	    (if uid (hashq-set! uid-table uid rtd))
+	    rtd))))
+
+  (define (record-type-descriptor? obj)
+    (and (struct? obj) (eq? (struct-vtable obj) record-type-vtable)))
+
+  (define (make-record-constructor-descriptor rtd 
+					      parent-constructor-descriptor
+					      protocol)
+    (define rtd-arity (vector-length (struct-ref rtd rtd-index-field-names)))
+    (define (default-inherited-protocol n)
+      (lambda args
+	(receive 
+          (n-args p-args) 
+	  (split-at args (- (length args) rtd-arity))
+	  (let ((p (apply n n-args)))
+	    (apply p p-args)))))
+    (define (default-protocol p) p)
+    
+    (let* ((prtd (struct-ref rtd rtd-index-parent))
+	   (pcd (or parent-constructor-descriptor
+		    (and=> prtd (lambda (d) (make-record-constructor-descriptor 
+					     prtd #f #f)))))
+	   (prot (or protocol (if pcd 
+				  default-inherited-protocol 
+				  default-protocol))))
+      (make-struct/no-tail record-constructor-vtable rtd pcd prot)))
+
+  (define (record-constructor rctd)
+    (let* ((rtd (struct-ref rctd rctd-index-rtd))
+	   (parent-rctd (struct-ref rctd rctd-index-parent))
+	   (protocol (struct-ref rctd rctd-index-protocol)))
+      (protocol 
+       (if parent-rctd
+	   (let ((parent-record-constructor (record-constructor parent-rctd))
+		 (parent-rtd (struct-ref parent-rctd rctd-index-rtd)))
+	     (lambda args
+	       (let ((struct (apply parent-record-constructor args)))
+		 (lambda args
+		   (apply (struct-ref rtd rtd-index-field-binder)
+			  (cons struct args))))))
+	   (lambda args (apply (struct-ref rtd rtd-index-field-binder)
+			       (cons #f args)))))))
+		    
+  (define (record-predicate rtd) (struct-ref rtd rtd-index-predicate))
+
+  (define (record-accessor rtd k)
+    (define (record-accessor-inner obj)
+      (if (eq? (struct-vtable obj) rtd)
+	  (struct-ref obj (+ k 1))
+          (and=> (struct-ref obj 0) record-accessor-inner)))
+    (lambda (obj) 
+      (if (not (record-internal? obj))
+          (r6rs-raise (make-assertion-violation)))
+      (record-accessor-inner obj)))
+
+  (define (record-mutator rtd k)
+    (define (record-mutator-inner obj val)
+      (and obj (or (and (eq? (struct-vtable obj) rtd)
+                        (struct-set! obj (+ k 1) val))
+                   (record-mutator-inner (struct-ref obj 0) val))))
+    (let ((bit-field (struct-ref rtd rtd-index-field-bit-field)))
+      (if (zero? (logand bit-field (ash 1 k)))
+	  (r6rs-raise (make-assertion-violation))))
+    (lambda (obj val) (record-mutator-inner obj val)))
+
+  ;; Condition types that are used in the current library.  These are defined
+  ;; here and not in (rnrs conditions) to avoid a circular dependency.
+
+  (define &condition (make-record-type-descriptor '&condition #f #f #f #f '#()))
+  (define &condition-constructor-descriptor 
+    (make-record-constructor-descriptor &condition #f #f))
+
+  (define &serious (make-record-type-descriptor 
+		    '&serious &condition #f #f #f '#()))
+  (define &serious-constructor-descriptor
+    (make-record-constructor-descriptor 
+     &serious &condition-constructor-descriptor #f))
+
+  (define make-serious-condition 
+    (record-constructor &serious-constructor-descriptor))
+
+  (define &violation (make-record-type-descriptor
+		      '&violation &serious #f #f #f '#()))
+  (define &violation-constructor-descriptor
+    (make-record-constructor-descriptor 
+     &violation &serious-constructor-descriptor #f))
+  (define make-violation (record-constructor &violation-constructor-descriptor))
+
+  (define &assertion (make-record-type-descriptor
+		      '&assertion &violation #f #f #f '#()))
+  (define make-assertion-violation 
+    (record-constructor 
+     (make-record-constructor-descriptor
+      &assertion &violation-constructor-descriptor #f)))
+
+  ;; Exception wrapper type, along with a wrapping `throw' implementation.
+  ;; These are used in the current library, and so they are defined here and not
+  ;; in (rnrs exceptions) to avoid a circular dependency.
+
+  (define &raise-object-wrapper
+    (make-record-type-descriptor '&raise-object-wrapper #f #f #f #f
+				 '#((immutable obj) (immutable continuation))))
+  (define make-raise-object-wrapper 
+    (record-constructor (make-record-constructor-descriptor 
+			 &raise-object-wrapper #f #f)))
+  (define raise-object-wrapper? (record-predicate &raise-object-wrapper))
+  (define raise-object-wrapper-obj (record-accessor &raise-object-wrapper 0))
+  (define raise-object-wrapper-continuation 
+    (record-accessor &raise-object-wrapper 1))
+
+  (define (r6rs-raise obj) 
+    (throw 'r6rs:exception (make-raise-object-wrapper obj #f)))
+  (define (r6rs-raise-continuable obj)
+    (define (r6rs-raise-continuable-internal continuation)
+      (throw 'r6rs:exception (make-raise-object-wrapper obj continuation)))
+    (call/cc r6rs-raise-continuable-internal))
+)