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

;;; syntactic.scm --- Syntactic 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
\f

(library (rnrs records syntactic (6))
  (export define-record-type 
	  record-type-descriptor 
	  record-constructor-descriptor)
  (import (only (guile) *unspecified* and=> gensym unspecified?)
          (rnrs base (6))
	  (rnrs conditions (6))
	  (rnrs exceptions (6))
	  (rnrs hashtables (6))
	  (rnrs lists (6))
	  (rnrs records procedural (6))
	  (rnrs syntax-case (6))
	  (only (srfi :1) take))

  (define record-type-registry (make-eq-hashtable))

  (define (guess-constructor-name record-name)
    (string->symbol (string-append "make-" (symbol->string record-name))))
  (define (guess-predicate-name record-name)
    (string->symbol (string-append (symbol->string record-name) "?")))
  (define (register-record-type name rtd rcd)
    (hashtable-set! record-type-registry name (cons rtd rcd)))
  (define (lookup-record-type-descriptor name)
    (and=> (hashtable-ref record-type-registry name #f) car))
  (define (lookup-record-constructor-descriptor name)
    (and=> (hashtable-ref record-type-registry name #f) cdr))
  
  (define-syntax define-record-type
    (lambda (stx)
      (syntax-case stx ()
	((_ (record-name constructor-name predicate-name) record-clause ...)
	 #'(define-record-type0 
	     (record-name constructor-name predicate-name)
	     record-clause ...))
	((_ record-name record-clause ...)
	 (let* ((record-name-sym (syntax->datum #'record-name))
		(constructor-name 
		 (datum->syntax 
		  #'record-name (guess-constructor-name record-name-sym)))
		(predicate-name 
		 (datum->syntax 
		  #'record-name (guess-predicate-name record-name-sym))))
	   #`(define-record-type0 
	       (record-name #,constructor-name #,predicate-name) 
	       record-clause ...))))))

  (define (sequence n)
    (define (seq-inner n) (if (= n 0) '(0) (cons n (seq-inner (- n 1)))))
    (reverse (seq-inner n)))
  (define (number-fields fields)
    (define (number-fields-inner fields counter)
      (if (null? fields)
	  '()
	  (cons (cons fields counter) 
		(number-fields-inner (cdr fields) (+ counter 1)))))
    (number-fields-inner fields 0))
  
  (define (process-fields record-name fields)
    (define record-name-str (symbol->string record-name))
    (define (guess-accessor-name field-name)
      (string->symbol (string-append 
		       record-name-str "-" (symbol->string field-name))))
    (define (guess-mutator-name field-name)
      (string->symbol 
       (string-append 
	record-name-str "-" (symbol->string field-name) "-set!")))
    
    (define (f x)
      (cond ((symbol? x) (list 'immutable x (guess-accessor-name x) #f))
	    ((not (list? x)) (error))
	    ((eq? (car x) 'immutable)
	     (cons 'immutable
		   (case (length x)
		     ((2) (list (cadr x) (guess-accessor-name (cadr x)) #f))
		     ((3) (list (cadr x) (caddr x) #f))
		     (else (error)))))
	    ((eq? (car x) 'mutable)
	     (cons 'mutable
		   (case (length x)
		     ((2) (list (cadr x) 
				(guess-accessor-name (cadr x))
				(guess-mutator-name (cadr x))))
		     ((4) (cdr x))
		     (else (error)))))
	    (else (error))))
    (map f fields))
  
  (define-syntax define-record-type0
    (lambda (stx)	  
      (syntax-case stx ()
	((_ (record-name constructor-name predicate-name) record-clause ...)
	 (let loop ((fields *unspecified*)
		    (parent *unspecified*)
		    (protocol *unspecified*)
		    (sealed *unspecified*)
		    (opaque *unspecified*)
		    (nongenerative *unspecified*)
		    (constructor *unspecified*)
		    (parent-rtd *unspecified*)
		    (record-clauses (syntax->datum #'(record-clause ...))))
	   (if (null? record-clauses)
	       (let*
		((fields (if (unspecified? fields) '() fields))
		 (field-names
		  (datum->syntax 
		   #'record-name
		   (list->vector (map (lambda (x) (take x 2)) fields))))
		 (field-accessors
		  (fold-left (lambda (x c lst) 
			       (cons #`(define #,(datum->syntax 
						  #'record-name (caddr x))
					 (record-accessor record-name #,c))
				     lst))
			     '() fields (sequence (length fields))))
		 (field-mutators
		  (fold-left (lambda (x c lst) 
			       (if (cadddr x)
				   (cons #`(define #,(datum->syntax 
						      #'record-name (cadddr x))
					     (record-mutator record-name #,c))
					 lst)
				   lst))
			     '() fields (sequence (length fields))))

		 (parent-cd 
		  (datum->syntax
		   stx (cond ((not (unspecified? parent))
			      `(record-constructor-descriptor ,parent))
			     ((not (unspecified? parent-rtd)) (cadr parent-rtd))
			     (else #f))))
		 (parent-rtd
		  (datum->syntax 
		   stx (cond ((not (unspecified? parent))
			      `(record-type-descriptor ,parent))
			     ((not (unspecified? parent-rtd)) (car parent-rtd))
			     (else #f))))

		 (protocol (datum->syntax
			    #'record-name (if (unspecified? protocol) 
					      #f protocol)))
		 (uid (datum->syntax 
		       #'record-name (if (unspecified? nongenerative) 
					 #f nongenerative)))
		 (sealed? (if (unspecified? sealed) #f sealed))
		 (opaque? (if (unspecified? opaque) #f opaque))

		 (record-name-sym (datum->syntax 
				   stx (list 'quote 
					     (syntax->datum #'record-name)))))
		  
		#`(begin 
		    (define record-name 
		      (make-record-type-descriptor 
		       #,record-name-sym
		       #,parent-rtd #,uid #,sealed? #,opaque? 
		       #,field-names))
		    (define constructor-name 
		      (record-constructor
		       (make-record-constructor-descriptor 
			record-name #,parent-cd #,protocol)))
		    (register-record-type 
		     #,record-name-sym 
		     record-name (make-record-constructor-descriptor 
				  record-name #,parent-cd #,protocol))
		    (define predicate-name (record-predicate record-name))
		    #,@field-accessors
		    #,@field-mutators))
	       (let ((cr (car record-clauses)))
		 (case (car cr)
		   ((fields) 
		    (if (unspecified? fields)
			(loop (process-fields (syntax->datum #'record-name) 
					      (cdr cr))
			      parent protocol sealed opaque nongenerative 
			      constructor parent-rtd (cdr record-clauses))
			(raise (make-assertion-violation))))
		   ((parent)
		    (if (not (unspecified? parent-rtd))
			(raise (make-assertion-violation)))
		    (if (unspecified? parent)
			(loop fields (cadr cr) protocol sealed opaque
			      nongenerative constructor parent-rtd
			      (cdr record-clauses))
			(raise (make-assertion-violation))))
		   ((protocol) 
		    (if (unspecified? protocol)
			(loop fields parent (cadr cr) sealed opaque
			      nongenerative constructor parent-rtd
			      (cdr record-clauses))
			(raise (make-assertion-violation))))
		   ((sealed) 
		    (if (unspecified? sealed)
			(loop fields parent protocol (cadr cr) opaque
			      nongenerative constructor parent-rtd
			      (cdr record-clauses))
			(raise (make-assertion-violation))))
		   ((opaque) (if (unspecified? opaque)
				 (loop fields parent protocol sealed (cadr cr)
				       nongenerative constructor parent-rtd
				       (cdr record-clauses))
				 (raise (make-assertion-violation))))
		   ((nongenerative) 
		    (if (unspecified? nongenerative)
			(let ((uid (list 'quote
					 (or (and (> (length cr) 1) (cadr cr))
					     (gensym)))))
			  (loop fields parent protocol sealed
				opaque uid constructor
				parent-rtd (cdr record-clauses)))
			(raise (make-assertion-violation))))
		   ((parent-rtd) 
		    (if (not (unspecified? parent))
			(raise (make-assertion-violation)))
		    (if (unspecified? parent-rtd)
			(loop fields parent protocol sealed opaque
			      nongenerative constructor (cdr cr)
			      (cdr record-clauses))
			(raise (make-assertion-violation))))
		   (else (raise (make-assertion-violation)))))))))))

  (define-syntax record-type-descriptor
    (lambda (stx)
      (syntax-case stx ()
	((_ name) #`(lookup-record-type-descriptor 
		     #,(datum->syntax 
			stx (list 'quote (syntax->datum #'name))))))))

  (define-syntax record-constructor-descriptor
    (lambda (stx)
      (syntax-case stx ()
	((_ name) #`(lookup-record-constructor-descriptor 
		     #,(datum->syntax 
			stx (list 'quote (syntax->datum #'name))))))))
)
Commit	Line	Data
ce543a9f JG	1	;;; syntactic.scm --- Syntactic support for 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 syntactic (6))
f797da47 JG	21	(export define-record-type
	22	record-type-descriptor
	23	record-constructor-descriptor)
	24	(import (only (guile) unspecified and=> gensym unspecified?)
ce543a9f	25	(rnrs base (6))
f797da47 JG	26	(rnrs conditions (6))
	27	(rnrs exceptions (6))
	28	(rnrs hashtables (6))
ce543a9f JG	29	(rnrs lists (6))
	30	(rnrs records procedural (6))
	31	(rnrs syntax-case (6))
	32	(only (srfi :1) take))
	33
f797da47 JG	34	(define record-type-registry (make-eq-hashtable))
	35
	36	(define (guess-constructor-name record-name)
	37	(string->symbol (string-append "make-" (symbol->string record-name))))
	38	(define (guess-predicate-name record-name)
	39	(string->symbol (string-append (symbol->string record-name) "?")))
	40	(define (register-record-type name rtd rcd)
	41	(hashtable-set! record-type-registry name (cons rtd rcd)))
	42	(define (lookup-record-type-descriptor name)
	43	(and=> (hashtable-ref record-type-registry name #f) car))
	44	(define (lookup-record-constructor-descriptor name)
	45	(and=> (hashtable-ref record-type-registry name #f) cdr))
	46
ce543a9f JG	47	(define-syntax define-record-type
ce543a9f JG	48	(lambda (stx)
ce543a9f JG	49	(syntax-case stx ()
	50	((_ (record-name constructor-name predicate-name) record-clause ...)
	51	#'(define-record-type0
	52	(record-name constructor-name predicate-name)
	53	record-clause ...))
	54	((_ record-name record-clause ...)
	55	(let* ((record-name-sym (syntax->datum #'record-name))
	56	(constructor-name
	57	(datum->syntax
	58	#'record-name (guess-constructor-name record-name-sym)))
	59	(predicate-name
	60	(datum->syntax
	61	#'record-name (guess-predicate-name record-name-sym))))
	62	#`(define-record-type0
	63	(record-name #,constructor-name #,predicate-name)
	64	record-clause ...))))))
	65
f797da47 JG	66	(define (sequence n)
	67	(define (seq-inner n) (if (= n 0) '(0) (cons n (seq-inner (- n 1)))))
	68	(reverse (seq-inner n)))
	69	(define (number-fields fields)
	70	(define (number-fields-inner fields counter)
	71	(if (null? fields)
	72	'()
	73	(cons (cons fields counter)
	74	(number-fields-inner (cdr fields) (+ counter 1)))))
	75	(number-fields-inner fields 0))
	76
	77	(define (process-fields record-name fields)
	78	(define record-name-str (symbol->string record-name))
	79	(define (guess-accessor-name field-name)
	80	(string->symbol (string-append
	81	record-name-str "-" (symbol->string field-name))))
	82	(define (guess-mutator-name field-name)
	83	(string->symbol
	84	(string-append
	85	record-name-str "-" (symbol->string field-name) "-set!")))
	86
	87	(define (f x)
	88	(cond ((symbol? x) (list 'immutable x (guess-accessor-name x) #f))
	89	((not (list? x)) (error))
	90	((eq? (car x) 'immutable)
	91	(cons 'immutable
	92	(case (length x)
	93	((2) (list (cadr x) (guess-accessor-name (cadr x)) #f))
	94	((3) (list (cadr x) (caddr x) #f))
	95	(else (error)))))
	96	((eq? (car x) 'mutable)
	97	(cons 'mutable
	98	(case (length x)
	99	((2) (list (cadr x)
	100	(guess-accessor-name (cadr x))
	101	(guess-mutator-name (cadr x))))
	102	((4) (cdr x))
	103	(else (error)))))
	104	(else (error))))
	105	(map f fields))
	106
ce543a9f	107	(define-syntax define-record-type0
f797da47	108	(lambda (stx)
ce543a9f JG	109	(syntax-case stx ()
	110	((_ (record-name constructor-name predicate-name) record-clause ...)
	111	(let loop ((fields unspecified)
	112	(parent unspecified)
	113	(protocol unspecified)
	114	(sealed unspecified)
	115	(opaque unspecified)
	116	(nongenerative unspecified)
	117	(constructor unspecified)
	118	(parent-rtd unspecified)
	119	(record-clauses (syntax->datum #'(record-clause ...))))
	120	(if (null? record-clauses)
f797da47 JG	121	(let*
	122	((fields (if (unspecified? fields) '() fields))
	123	(field-names
ce543a9f JG	124	(datum->syntax
ce543a9f JG	125	#'record-name
f797da47	126	(list->vector (map (lambda (x) (take x 2)) fields))))
ce543a9f JG	127	(field-accessors
	128	(fold-left (lambda (x c lst)
	129	(cons #`(define #,(datum->syntax
	130	#'record-name (caddr x))
	131	(record-accessor record-name #,c))
	132	lst))
	133	'() fields (sequence (length fields))))
	134	(field-mutators
	135	(fold-left (lambda (x c lst)
	136	(if (cadddr x)
	137	(cons #`(define #,(datum->syntax
	138	#'record-name (cadddr x))
	139	(record-mutator record-name #,c))
	140	lst)
	141	lst))
	142	'() fields (sequence (length fields))))
f797da47 JG	143
	144	(parent-cd
	145	(datum->syntax
	146	stx (cond ((not (unspecified? parent))
	147	`(record-constructor-descriptor ,parent))
	148	((not (unspecified? parent-rtd)) (cadr parent-rtd))
	149	(else #f))))
	150	(parent-rtd
	151	(datum->syntax
	152	stx (cond ((not (unspecified? parent))
	153	`(record-type-descriptor ,parent))
	154	((not (unspecified? parent-rtd)) (car parent-rtd))
	155	(else #f))))
	156
ce543a9f JG	157	(protocol (datum->syntax
	158	#'record-name (if (unspecified? protocol)
	159	#f protocol)))
	160	(uid (datum->syntax
	161	#'record-name (if (unspecified? nongenerative)
	162	#f nongenerative)))
	163	(sealed? (if (unspecified? sealed) #f sealed))
	164	(opaque? (if (unspecified? opaque) #f opaque))
f797da47 JG	165
	166	(record-name-sym (datum->syntax
	167	stx (list 'quote
	168	(syntax->datum #'record-name)))))
ce543a9f JG	169
	170	#`(begin
	171	(define record-name
	172	(make-record-type-descriptor
f797da47 JG	173	#,record-name-sym
f797da47 JG	174	#,parent-rtd #,uid #,sealed? #,opaque?
ce543a9f JG	175	#,field-names))
	176	(define constructor-name
	177	(record-constructor
	178	(make-record-constructor-descriptor
	179	record-name #,parent-cd #,protocol)))
f797da47 JG	180	(register-record-type
	181	#,record-name-sym
	182	record-name (make-record-constructor-descriptor
	183	record-name #,parent-cd #,protocol))
ce543a9f JG	184	(define predicate-name (record-predicate record-name))
	185	#,@field-accessors
	186	#,@field-mutators))
	187	(let ((cr (car record-clauses)))
	188	(case (car cr)
	189	((fields)
	190	(if (unspecified? fields)
	191	(loop (process-fields (syntax->datum #'record-name)
	192	(cdr cr))
	193	parent protocol sealed opaque nongenerative
	194	constructor parent-rtd (cdr record-clauses))
f797da47 JG	195	(raise (make-assertion-violation))))
	196	((parent)
	197	(if (not (unspecified? parent-rtd))
	198	(raise (make-assertion-violation)))
	199	(if (unspecified? parent)
	200	(loop fields (cadr cr) protocol sealed opaque
	201	nongenerative constructor parent-rtd
	202	(cdr record-clauses))
	203	(raise (make-assertion-violation))))
	204	((protocol)
	205	(if (unspecified? protocol)
	206	(loop fields parent (cadr cr) sealed opaque
	207	nongenerative constructor parent-rtd
	208	(cdr record-clauses))
	209	(raise (make-assertion-violation))))
	210	((sealed)
	211	(if (unspecified? sealed)
	212	(loop fields parent protocol (cadr cr) opaque
	213	nongenerative constructor parent-rtd
	214	(cdr record-clauses))
	215	(raise (make-assertion-violation))))
ce543a9f JG	216	((opaque) (if (unspecified? opaque)
	217	(loop fields parent protocol sealed (cadr cr)
	218	nongenerative constructor parent-rtd
	219	(cdr record-clauses))
f797da47 JG	220	(raise (make-assertion-violation))))
	221	((nongenerative)
	222	(if (unspecified? nongenerative)
	223	(let ((uid (list 'quote
	224	(or (and (> (length cr) 1) (cadr cr))
	225	(gensym)))))
	226	(loop fields parent protocol sealed
	227	opaque uid constructor
	228	parent-rtd (cdr record-clauses)))
	229	(raise (make-assertion-violation))))
	230	((parent-rtd)
	231	(if (not (unspecified? parent))
	232	(raise (make-assertion-violation)))
	233	(if (unspecified? parent-rtd)
	234	(loop fields parent protocol sealed opaque
	235	nongenerative constructor (cdr cr)
	236	(cdr record-clauses))
	237	(raise (make-assertion-violation))))
	238	(else (raise (make-assertion-violation)))))))))))
	239
	240	(define-syntax record-type-descriptor
	241	(lambda (stx)
	242	(syntax-case stx ()
	243	((_ name) #`(lookup-record-type-descriptor
	244	#,(datum->syntax
	245	stx (list 'quote (syntax->datum #'name))))))))
	246
	247	(define-syntax record-constructor-descriptor
	248	(lambda (stx)
	249	(syntax-case stx ()
	250	((_ name) #`(lookup-record-constructor-descriptor
	251	#,(datum->syntax
	252	stx (list 'quote (syntax->datum #'name))))))))
ce543a9f	253	)