[bpt/guile.git] / module / rnrs / records / procedural.scm

;;; procedural.scm --- Procedural interface to 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
\f

(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) and=>
			throw
			display
		        make-struct 
			make-vtable 
			map
			simple-format
			string-append 
			
			struct? 
			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)
	 (let* ((vtable (struct-vtable obj))
		(layout (symbol->string
			 (struct-ref vtable vtable-index-layout))))
	   (and (>= (string-length layout) 4)
		(let ((rtd (struct-ref obj record-index-rtd)))
		  (and (record-type-descriptor? rtd)))))))

  (define record-index-parent 0)
  (define record-index-rtd 1)

  (define rtd-index-name 0)
  (define rtd-index-uid 1)
  (define rtd-index-parent 2)
  (define rtd-index-sealed? 3)
  (define rtd-index-opaque? 4)
  (define rtd-index-predicate 5)
  (define rtd-index-field-names 6)
  (define rtd-index-field-vtable 7)
  (define rtd-index-field-binder 8)

  (define rctd-index-rtd 0)
  (define rctd-index-parent 1)
  (define rctd-index-protocol 2)

  (define record-type-vtable 
    (make-vtable "prprprprprprprprpr" 
		 (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-vtable
      (make-vtable (fold (lambda (x p) 
			   (string-append p (case (car x)
					      ((immutable) "pr")
					      ((mutable) "pw"))))
			 "prpr" (vector->list fields))
		   (lambda (obj port)
		     (simple-format port "#<r6rs:record:~A>" name))))
    (define field-names (list->vector (map cadr (vector->list fields))))
    (define late-rtd #f)
    (define (private-record-predicate obj)       
      (and (record-internal? obj)
	   (let ((rtd (struct-ref obj record-index-rtd)))
	     (or (eq? (struct-ref rtd rtd-index-field-vtable) fields-vtable)
		 (and=> (struct-ref obj record-index-parent)
			private-record-predicate)))))

    (define (field-binder parent-struct . args)
      (apply make-struct (append (list fields-vtable 0 
				       parent-struct 
				       late-rtd) 
				 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
			    (struct-ref fields-vtable vtable-index-layout))
		      (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 (struct-ref matching-rtd 
						    rtd-index-field-vtable)
					vtable-index-layout)))
	      matching-rtd
	      (r6rs-raise (make-assertion-violation)))

	  (let ((rtd (make-struct record-type-vtable 0
				  
				  name
				  uid
				  parent 
				  sealed? 
				  opaque?
				  
				  private-record-predicate
				  field-names
				  fields-vtable
				  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 record-constructor-vtable 0 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 (not (record-internal? obj))
	  (r6rs-raise (make-assertion-violation)))
      (if (eq? (struct-ref obj record-index-rtd) rtd)
	  (struct-ref obj (+ k 2))
	  (record-accessor-inner (struct-ref obj record-index-parent))))
    (lambda (obj) (record-accessor-inner obj)))

  (define (record-mutator rtd k)
    (define (record-mutator-inner obj val)
      (and obj 
	   (or (and (eq? (struct-ref obj record-index-rtd) rtd) 
		    (struct-set! obj (+ k 2) val))
	       (record-mutator-inner (struct-ref obj record-index-parent) 
				     val))))
    (let* ((rtd-vtable (struct-ref rtd rtd-index-field-vtable))
	   (field-layout (symbol->string
			  (struct-ref rtd-vtable vtable-index-layout))))
      (if (not (eqv? (string-ref field-layout (+ (* (+ k 2) 2) 1)) #\w))
	  (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))
)
Commit	Line	Data
ce543a9f JG	1	;;; procedural.scm --- Procedural interface to R6RS records
	2
	3	;; Copyright (C) 2010 Free Software Foundation, Inc.
	4	;;
	5	;; This library is free software; you can redistribute it and/or
	6	;; modify it under the terms of the GNU Lesser General Public
	7	;; License as published by the Free Software Foundation; either
	8	;; version 3 of the License, or (at your option) any later version.
	9	;;
	10	;; This library is distributed in the hope that it will be useful,
	11	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	;; Lesser General Public License for more details.
	14	;;
	15	;; You should have received a copy of the GNU Lesser General Public
	16	;; License along with this library; if not, write to the Free Software
	17	;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
	18	\f
	19
	20	(library (rnrs records procedural (6))
	21	(export make-record-type-descriptor
	22	record-type-descriptor?
	23	make-record-constructor-descriptor
	24
	25	record-constructor
	26	record-predicate
	27	record-accessor
	28	record-mutator)
	29
	30	(import (rnrs base (6))
	31	(only (guile) and=>
	32	throw
	33	display
	34	make-struct
	35	make-vtable
	36	map
	37	simple-format
	38	string-append
	39
	40	struct?
	41	struct-ref
	42	struct-set!
	43	struct-vtable
	44	vtable-index-layout
	45
	46	make-hash-table
	47	hashq-ref
	48	hashq-set!
	49
	50	vector->list)
	51	(ice-9 receive)
55684b5e JG	52	(only (srfi :1) fold split-at take))
	53
	54	(define (record-internal? obj)
	55	(and (struct? obj)
	56	(let* ((vtable (struct-vtable obj))
	57	(layout (symbol->string
	58	(struct-ref vtable vtable-index-layout))))
	59	(and (>= (string-length layout) 4)
	60	(let ((rtd (struct-ref obj record-index-rtd)))
	61	(and (record-type-descriptor? rtd)))))))
	62
	63	(define record-index-parent 0)
	64	(define record-index-rtd 1)
	65
	66	(define rtd-index-name 0)
	67	(define rtd-index-uid 1)
	68	(define rtd-index-parent 2)
	69	(define rtd-index-sealed? 3)
	70	(define rtd-index-opaque? 4)
	71	(define rtd-index-predicate 5)
	72	(define rtd-index-field-names 6)
	73	(define rtd-index-field-vtable 7)
	74	(define rtd-index-field-binder 8)
	75
	76	(define rctd-index-rtd 0)
	77	(define rctd-index-parent 1)
	78	(define rctd-index-protocol 2)
ce543a9f JG	79
	80	(define record-type-vtable
	81	(make-vtable "prprprprprprprprpr"
	82	(lambda (obj port)
55684b5e JG	83	(simple-format port "#<r6rs:record-type:~A>"
55684b5e JG	84	(struct-ref obj rtd-index-name)))))
ce543a9f JG	85
	86	(define record-constructor-vtable
	87	(make-vtable "prprpr"
	88	(lambda (obj port)
55684b5e JG	89	(simple-format port "#<r6rs:record-constructor:~A>"
	90	(struct-ref (struct-ref obj rctd-index-rtd)
	91	rtd-index-name)))))
ce543a9f JG	92
	93	(define uid-table (make-hash-table))
	94
	95	(define (make-record-type-descriptor name parent uid sealed? opaque? fields)
	96	(define fields-vtable
55684b5e JG	97	(make-vtable (fold (lambda (x p)
	98	(string-append p (case (car x)
	99	((immutable) "pr")
	100	((mutable) "pw"))))
	101	"prpr" (vector->list fields))
ce543a9f	102	(lambda (obj port)
55684b5e JG	103	(simple-format port "#<r6rs:record:~A>" name))))
55684b5e JG	104	(define field-names (list->vector (map cadr (vector->list fields))))
ce543a9f JG	105	(define late-rtd #f)
ce543a9f JG	106	(define (private-record-predicate obj)
55684b5e JG	107	(and (record-internal? obj)
	108	(let ((rtd (struct-ref obj record-index-rtd)))
	109	(or (eq? (struct-ref rtd rtd-index-field-vtable) fields-vtable)
	110	(and=> (struct-ref obj record-index-parent)
	111	private-record-predicate)))))
ce543a9f JG	112
	113	(define (field-binder parent-struct . args)
	114	(apply make-struct (append (list fields-vtable 0
	115	parent-struct
	116	late-rtd)
	117	args)))
55684b5e	118	(if (and parent (struct-ref parent rtd-index-sealed?))
ce543a9f JG	119	(r6rs-raise (make-assertion-violation)))
ce543a9f JG	120
55684b5e JG	121	(let ((matching-rtd (and uid (hashq-ref uid-table uid)))
	122	(opaque? (or opaque? (and parent (struct-ref
	123	parent rtd-index-opaque?)))))
ce543a9f JG	124	(if matching-rtd
	125	(if (equal? (list name
	126	parent
	127	sealed?
	128	opaque?
	129	field-names
	130	(struct-ref fields-vtable vtable-index-layout))
55684b5e JG	131	(list (struct-ref matching-rtd rtd-index-name)
	132	(struct-ref matching-rtd rtd-index-parent)
	133	(struct-ref matching-rtd rtd-index-sealed?)
	134	(struct-ref matching-rtd rtd-index-opaque?)
	135	(struct-ref matching-rtd rtd-index-field-names)
	136	(struct-ref (struct-ref matching-rtd
	137	rtd-index-field-vtable)
ce543a9f JG	138	vtable-index-layout)))
	139	matching-rtd
	140	(r6rs-raise (make-assertion-violation)))
	141
	142	(let ((rtd (make-struct record-type-vtable 0
	143
	144	name
	145	uid
	146	parent
	147	sealed?
	148	opaque?
	149
	150	private-record-predicate
	151	field-names
	152	fields-vtable
	153	field-binder)))
	154	(set! late-rtd rtd)
	155	(if uid (hashq-set! uid-table uid rtd))
	156	rtd))))
	157
	158	(define (record-type-descriptor? obj)
	159	(and (struct? obj) (eq? (struct-vtable obj) record-type-vtable)))
	160
	161	(define (make-record-constructor-descriptor rtd
	162	parent-constructor-descriptor
	163	protocol)
55684b5e	164	(define rtd-arity (vector-length (struct-ref rtd rtd-index-field-names)))
ce543a9f JG	165	(define (default-inherited-protocol n)
	166	(lambda args
	167	(receive
	168	(n-args p-args)
	169	(split-at args (- (length args) rtd-arity))
	170	(let ((p (apply n n-args)))
	171	(apply p p-args)))))
	172	(define (default-protocol p) p)
	173
55684b5e	174	(let* ((prtd (struct-ref rtd rtd-index-parent))
ce543a9f JG	175	(pcd (or parent-constructor-descriptor
	176	(and=> prtd (lambda (d) (make-record-constructor-descriptor
	177	prtd #f #f)))))
	178	(prot (or protocol (if pcd
	179	default-inherited-protocol
	180	default-protocol))))
	181	(make-struct record-constructor-vtable 0 rtd pcd prot)))
	182
	183	(define (record-constructor rctd)
55684b5e JG	184	(let* ((rtd (struct-ref rctd rctd-index-rtd))
	185	(parent-rctd (struct-ref rctd rctd-index-parent))
	186	(protocol (struct-ref rctd rctd-index-protocol)))
ce543a9f JG	187	(protocol
	188	(if parent-rctd
	189	(let ((parent-record-constructor (record-constructor parent-rctd))
55684b5e	190	(parent-rtd (struct-ref parent-rctd rctd-index-rtd)))
ce543a9f JG	191	(lambda args
	192	(let ((struct (apply parent-record-constructor args)))
	193	(lambda args
55684b5e	194	(apply (struct-ref rtd rtd-index-field-binder)
ce543a9f	195	(cons struct args))))))
55684b5e JG	196	(lambda args (apply (struct-ref rtd rtd-index-field-binder)
55684b5e JG	197	(cons #f args)))))))
ce543a9f	198
55684b5e	199	(define (record-predicate rtd) (struct-ref rtd rtd-index-predicate))
ce543a9f JG	200
	201	(define (record-accessor rtd k)
	202	(define (record-accessor-inner obj)
55684b5e JG	203	(if (not (record-internal? obj))
	204	(r6rs-raise (make-assertion-violation)))
	205	(if (eq? (struct-ref obj record-index-rtd) rtd)
	206	(struct-ref obj (+ k 2))
	207	(record-accessor-inner (struct-ref obj record-index-parent))))
ce543a9f JG	208	(lambda (obj) (record-accessor-inner obj)))
	209
	210	(define (record-mutator rtd k)
	211	(define (record-mutator-inner obj val)
	212	(and obj
55684b5e JG	213	(or (and (eq? (struct-ref obj record-index-rtd) rtd)
	214	(struct-set! obj (+ k 2) val))
	215	(record-mutator-inner (struct-ref obj record-index-parent)
	216	val))))
	217	(let* ((rtd-vtable (struct-ref rtd rtd-index-field-vtable))
ce543a9f JG	218	(field-layout (symbol->string
	219	(struct-ref rtd-vtable vtable-index-layout))))
	220	(if (not (eqv? (string-ref field-layout (+ (* (+ k 2) 2) 1)) #\w))
	221	(r6rs-raise (make-assertion-violation))))
	222	(lambda (obj val) (record-mutator-inner obj val)))
	223
	224	;; Condition types that are used in the current library. These are defined
	225	;; here and not in (rnrs conditions) to avoid a circular dependency.
	226
	227	(define &condition (make-record-type-descriptor '&condition #f #f #f #f '#()))
	228	(define &condition-constructor-descriptor
	229	(make-record-constructor-descriptor &condition #f #f))
	230
	231	(define &serious (make-record-type-descriptor
	232	'&serious &condition #f #f #f '#()))
	233	(define &serious-constructor-descriptor
	234	(make-record-constructor-descriptor
	235	&serious &condition-constructor-descriptor #f))
	236
	237	(define make-serious-condition
	238	(record-constructor &serious-constructor-descriptor))
ce543a9f JG	239
	240	(define &violation (make-record-type-descriptor
	241	'&violation &serious #f #f #f '#()))
	242	(define &violation-constructor-descriptor
	243	(make-record-constructor-descriptor
	244	&violation &serious-constructor-descriptor #f))
	245	(define make-violation (record-constructor &violation-constructor-descriptor))
ce543a9f JG	246
	247	(define &assertion (make-record-type-descriptor
	248	'&assertion &violation #f #f #f '#()))
	249	(define make-assertion-violation
	250	(record-constructor
	251	(make-record-constructor-descriptor
	252	&assertion &violation-constructor-descriptor #f)))
ce543a9f JG	253
	254	;; Exception wrapper type, along with a wrapping `throw' implementation.
	255	;; These are used in the current library, and so they are defined here and not
	256	;; in (rnrs exceptions) to avoid a circular dependency.
	257
	258	(define &raise-object-wrapper
	259	(make-record-type-descriptor '&raise-object-wrapper #f #f #f #f
	260	'#((immutable obj) (immutable continuation))))
	261	(define make-raise-object-wrapper
	262	(record-constructor (make-record-constructor-descriptor
	263	&raise-object-wrapper #f #f)))
	264	(define raise-object-wrapper? (record-predicate &raise-object-wrapper))
	265	(define raise-object-wrapper-obj (record-accessor &raise-object-wrapper 0))
	266	(define raise-object-wrapper-continuation
	267	(record-accessor &raise-object-wrapper 1))
	268
	269	(define (r6rs-raise obj)
	270	(throw 'r6rs:exception (make-raise-object-wrapper obj #f)))
	271	(define (r6rs-raise-continuable obj)
	272	(define (r6rs-raise-continuable-internal continuation)
d1c83d38	273	(throw 'r6rs:exception (make-raise-object-wrapper obj continuation)))
ce543a9f JG	274	(call/cc r6rs-raise-continuable-internal))
ce543a9f JG	275	)