SPDX-FileCopyrightText: 2009 Joo ChurlSoo
SPDX-License-Identifier: MIT

Title

define-lambda-object


Author

Joo ChurlSoo


Abstract

This SRFI introduces a macro, DEFINE-LAMBDA-OBJECT which defines a set of
procedures, that is, a group, two constructors, and a predicate.  The
constructors also make a group of procedures, namely lambda objects.  The
macro extends DEFINE-RECORD-TYPE (SRFI 9) in being more general but much less
general than DEFCLASS (CLOS).  The macro has no explicit field accessors and
mutators but child groups, read-write fields, read-only fields, required
fields, optional fields, hidden fields, virtual fields, and automatic fields.


Rationale

An object created by a constructor procedure is a procedure whose first
argument is a symbolized field name that is used to identify fields.  The
lambda object plays the role of the accessor and mutator of each field.
Though the average time required to access a randomly chosen field is more for
the lambda object than for the accessors and mutators of most other
record-defining macros that use field indices to indentify fields, the lambda
object makes the troublesome explicit or implicit accessors and mutators
unnecessary.  In addition, this makes the accesors and mutators to be
automatically `nongenerative' and reduces the role of the predicate procedure.
Although DEFINE-RECORD-TYPE of R6RS can also have implicit accessors and
mutators, they should know their own record name.  Further more, when there
are parents, they should know both their own record name and their parents'
record names, whch could make users confused, though there is an advantage
that a record can have another field with the same name.

This macro works not only as DEFINE-RECORD-TYPE with required fields but also
as DEFSTRUCT of Common Lisp with optional fields.  The automatic field can be
used as a procedure that modifies or handles the values of the other fields.

When a group has multiple parent groups, all the fields of parent groups must
exist in the field spec of the child group in contrary with DEFINE-RECORD-TYPE
of R6RS.  This is too much trouble in case parent groups have several tens of
fields.  But it also has the advantage of reconfirming the existence and
properties of each field, and making the constructors to be able to be defined
irrespectively the order of the parents' fields.  From a practical point of
view, inheritance may be superfluous in this macro as the lambda object itself
has data and methods as well as their accessors and mutators.


Specification

(define-lambda-object <group spec> <field spec>)

<group spec> --> <group> | (<group> <parent group>*)

<parent group> --> <group>				;unamendable group
		| (<group>)				;amendable group

<field spec> --> <required field>* <optional field>* <automatic field>*

<required field> --> <field>		     	     	;read-only field
		  | (<field>)				;read-write field

<optional field> --> (<field>  <default>) 		;read-only field
		  | ((<field>) <default>) 		;read-write field

<automatic field> --> <automatic real field>		;automatic field
		    | <automatic hidden field>		;hidden field
	   	    | <automatic virtual field>		;virtual field

<automatic real field> --> (,<field>  <default>) 	;read-only field
		        | ((,<field>) <default>) 	;read-write field

<automatic hidden field>  --> (,,<field>  <default>)	;inaccessable field
<automatic virtual field> --> (,@<field>  <default>) 	;immutable field

The name of <constructor> is generated by prefixing `make-' to the group name,
or by prefixing `make-' and postfixing `-by-name' to the group name.
The name of <predicate> is generated by adding a question mark (`?') to the
end of the group name.

The <group> and <field> must be identifiers.

Each <default> is an <expression> that is evaluated in an environment that the
values of all the previous <field>s are visible.

The define-lambda-object form is a definition and can appear anywhere any
other <definition> can appear.  Each time define-lambda-object form is
evaluated, a new group is created with distinct <group>, <constructor>, and
<predicate> procedures.

The <group> is bound to a procedure of one argument.  Like a gene, it has
information on its <parent group>s, <constructor>s, <predicate>, and the
number and properties of <field>s.  And they are checked out whenever
define-lambda-object form is evaluated.  In case of inheritance, all the
<field>s of <parent group>s must exist in the <field spec> of the child group,
irrespectively of the order.  Otherwise an error is signaled.  In addition,
the properties (mutability, sort of field, and default expression) of <field>s
of unamendable groups must be preserved in contrast with those of amendable
groups.  Otherwise an error is signaled.

The <constructor> is bound to a procedure that takes at least as many
arguments as the number of <required field>s.  Whenever it is called, it
returns an object of the <group>, namely a procedure, which has information on
its own group and all that goes with it.  Its first argument must be a symbol
of the same name as <field>.  Otherwise an error is signaled.  The object
becomes an accessor procedure of each <field> in case of one argument and a
mutator procedure of each <field> in case of two arguments where the second
argument is a new field value.

The names of <field>s are used to access the <field>s as symbols of the same
names.  So they must be distinct.  Otherwise an error is signaled.  The
read-write fields can be modified, whereas any attempt to modify the values of
the read-only fields via mutators signals an error.
Note: The read-only fields are not immutable.  Their values, for instance, can
      be modified by other fields whose values work like their mutators.

The <required field> is initialized to the first one of the remaining
arguments.  If there are no more remaining arguments, an error is signaled.

The initialization of the <optional field>s is done by two types of
<constructor>s:
1. <make-`group-name'> constructor
   The initialization method of <optional field>s is the same as that of
<required field>s except that the field is bound to the <default> instead of
signaling an error if there are no more remaining arguments.

2. <make-`group-name'-by-name> constructor
   The name used at a call site for the corresponding <optional field> is a
symbol of the same name as the <field>.  The remaining arguments are
sequentially interpreted as a series of pairs, where the first member of each
pair is a field name and the second is the corresponding value.  If there is
no element for a particular field name, the field is initialized to the
<default>.

The <automatic real field> and <automatic hidden field> are initialized to
each corresponding <default> that is evaluated at the time the lambda object
is made by a constructor.
The <automatic hidden field> is an externally nonexistent field, that is, the
field is invisible outside of the define-lambda-object form but visible inside
of it.  On the contrary, the <automatic virtual field> is an internally
nonexistent field whose <default> is evaluated each time when the field is
accessed.

The <predicate> is a predicate procedure that returns #t for objects
constructed by <constructor> or <constructor>s for child groups and #f for
everything else.


Examples

;; The `x' is a read-write field.
;; The `y' is a read-only field.
(define-lambda-object ppoint (x) y)

(define pp  (make-ppoint 10 20))
(pp 'x)					=> 10
(pp 'y)					=> 20
(pp 'x 11) (pp 'x)			=> 11
(pp 'y 22)				=> error: read-only field y

;; The parent group `ppoint' is an unamendable group.
(define-lambda-object (cpoint ppoint) x y color) 
=> error: incompatible read-write field ppoint x

;; The 'color-init' and 'area-init' are automatic fields.
;; The 'color' and 'area' are virtual fields.
(define color 'black)
(define-lambda-object (cpoint ppoint)
  (x) y
  (,color-init color) (,area-init (* x y))
  (,@color color) (,@area (* x y)))

(define ap (make-cpoint 3 33 'black))		=> error: expects 2 arguments
(define ap (make-cpoint 10 20))
(map ap '(x y color-init color area-init area))	=> (10 20 black black 200 200)
(ap 'x 30)
(map ap '(x y color-init color area-init area))	=> (30 20 black black 200 600)
(set! color 'white)
(map ap '(x y color-init color area-init area))	=> (30 20 black white 200 600)
(cpoint? ap)   	    	      		=> #t
(ppoint? ap)				=> #t

;; The 'color' is an optional field.
;; The 'adbmal' and 'set/add' are automatic fields.
(define-lambda-object (cpoint ppoint)
  (x) y
  ((color) 'blue)
  (,@area (* x y)) 
  (,adbmal (lambda (f) (f x y color (* x y))))
  (,set/add (lambda (i j) (set! x (+ i x)) (set! y (+ j y)))))

(define cp (make-cpoint 3 33 'red))
(map cp '(x y color area))		=> (3 33 red 99)
(define cp (make-cpoint 30 20))
(map cp '(x y color area))		=> (30 20 blue 600)
((cp 'set/add) 20 80)  
((cp 'adbmal) list)			=> (50 100 blue 5000)
(cpoint? ap)   				=> #f
(cpoint? cp)				=> #t
(ppoint? cp)				=> #t

;; The parent group `ppoint' is an amendable group.
;; The 'stack' is a hidden field.
;; The 'pop' is a virtual field.
;; The 'push' is an automatic field.
(define-lambda-object (spoint (ppoint))
  (x 0) (y x) (z x)
  (,,stack '())
  (,@pop (if (null? stack)
	     (error 'spoint "null stack" stack)
	     (let ((s (car stack))) (set! stack (cdr stack)) s)))
  (,push (lambda (s) (set! stack (cons s stack)))))

(define sp (make-spoint))
(map sp '(x y z))			=> (0 0 0)
(define sp (make-spoint 5 55))
(map sp '(x y z))			=> (5 55 5)
(define sp (make-spoint-by-name 'z 100))
(map sp '(x y z))			=> (0 0 100)
((sp 'push) 'rose) ((sp 'push) 'lily)
(sp 'pop)				=> lily
(sp 'pop)				=> rose
(sp 'pop)				=> error: null stack ()
(sp 'stack)				=> error: absent field stack 

;; The `set/add' is the same automatic field as that of `cpoint' group,
;; but it has a different default which simulates polymorphism and overloading.
(define-lambda-object (epoint (spoint) (cpoint))
  ((x) 5) ((y) 10) ((z) 15) ((color) "brown") ((planet) "earth")
  (,@area (* x y))
  (,@volume (* x y z)) 
  (,,stack '())
  (,@pop (if (null? stack)
	     (error 'spoint "null stack" stack)
	     (let ((s (car stack))) (set! stack (cdr stack)) s)))
  (,push (lambda (s) (set! stack (cons s stack))))
  (,adbmal (lambda (f) (f x y z color planet (* x y) (* x y z))))
  (,set/add
   (case-lambda
    ((i j) (cond
	    ((and (string? i) (string? j)) (set! color i) (set! planet j))
	    ((and (number? i) (number? j)) (set! x (+ i x)) (set! y (+ j y)))
	    (else (error 'epoint "set/add: wrong data type" i j))))
    ((i j k) (set! x (+ i x)) (set! y (+ j y)) (set! z (+ k z))))))

(define ep (make-epoint-by-name 'color "blue"))
((ep 'adbmal) list)			=> (5 10 15 "blue" "earth" 50 750)
(map (lambda (o) (o 'x)) (list pp ap cp sp ep))
     	     	    	       	     	=> (11 30 50 0 5)
(map (lambda (p) (p ep)) (list ppoint? cpoint? spoint? epoint?))
     	     	    	       	       	=> (#t #t #t #t)
((ep 'set/add) "red" "mars")
((ep 'adbmal) list)  			=> (5 10 15 "red" "mars" 50 750)
((ep 'set/add) 5 10)
((ep 'adbmal) list)  			=> (10 20 15 "red" "mars" 200 3000)
((ep 'set/add) 10 30 50)
(map ep '(x y z area volume))		=> (20 50 65 1000 65000)
(map cp '(x y area))			=> (50 100 5000)
((cp 'set/add) 20 200)
(map cp '(x y area))			=> (70 300 21000)
((cp 'set/add) 10 100 1000) 		=> error: expects 2 arguments

epoint				=> #<procedure:epoint>
(epoint 'parent)		=> (#<procedure:spoint> #<procedure:cpoint>)
(epoint 'constructor)		=> (#<procedure:make-epoint> #<procedure:make-epoint-by-name>)
(epoint 'predicate)		=> #<procedure:epoint?>
(epoint 'read-write-field)	=> (x y z color planet)
(epoint 'read-only-field)	=> (area volume pop push adbmal set/add)
(epoint 'required-field)	=> ()
(epoint 'optional-field)	=> ((x 5) (y 10) (z 15) (color "brown") (planet "earth"))
(epoint 'hidden-field)	   	=> ((stack '()))
(epoint 'virtual-field)
=> ((area (* x y))
    (volume (* x y z))
    (pop (if (null? stack)
	     (error 'spoint "null stack" stack)
	     (let ((s (car stack))) (set! stack (cdr stack)) s))))
(epoint 'automatic-field)
=> ((push (lambda (s) (set! stack (cons s stack))))
    (adbmal (lambda (f) (f x y z color planet (* x y) (* x y z))))
    (set/add
     (case-lambda
      ((i j) (cond
	      ((and (string? i) (string? j)) (set! color i) (set! planet j))
	      ((and (number? i) (number? j)) (set! x (+ i x)) (set! y (+ j y)))
	      (else (error 'epoint "set/add: wrong data type" i j))))
      ((i j k) (set! x (+ i x)) (set! y (+ j y)) (set! z (+ k z))))))


Reference Implementation

The implementation below is written in R6RS hygienic macro and define-macro.

The predicate procedure is implementation dependant.
For instance, a procedure such as procedure-name or object-name, which returns
the name of procedure or object, must be available to distinguish objects
created by all the constructors from the others.

;;; define-lambda-object --- define-syntax

(define-syntax unquote-get
  (syntax-rules ()
    ((unquote-get symbol ((n0 d0) (n1 d1) ...))
     (if (eq? symbol 'n0)
	 d0
	 (unquote-get symbol ((n1 d1) ...))))
    ((unquote-get symbol ())
     (error 'define-lambda-object "absent field" symbol))))

(define-syntax unquote-get*
  (syntax-rules ()
    ((unquote-get* symbol (n0 n1 ...))
     (if (eq? symbol 'n0)
	 n0
	 (unquote-get* symbol (n1 ...))))
    ((unquote-get* symbol ())
     (error 'define-lambda-object "not available inspection" symbol))))

(define-syntax unquote-set!
  (syntax-rules ()
    ((unquote-set! symbol new-val (n0 n1 ...) fi)
     (if (eq? symbol 'n0)
	 (set! n0 new-val)
	 (unquote-set! symbol new-val (n1 ...) fi)))
    ((unquote-set! symbol new-val () fi)
     (if (memq symbol 'fi)
	 (error 'define-lambda-object "read-only field" symbol)
	 (error 'define-lambda-object "absent field" symbol)))))

(define-syntax seq-lambda
  (syntax-rules ()
    ((seq-lambda () (r ...) () body)
     (lambda (r ...) body))
    ((seq-lambda () (r ...) (o oo ...) body)
     (lambda (r ... . z)
       (seq-lambda (z) () (o oo ...) body)))
    ((seq-lambda (z) () ((n d) . e) body)
     (let ((y (if (null? z) z (cdr z)))
	   (n (if (null? z) d (car z))))
       (seq-lambda (y) () e body)))
    ((seq-lambda (z) () () body)
     (if (null? z)
	 body
	 (error 'define-lambda-object "too many arguments" z)))))

;; Choose either procedure type or macro type according to your implementation.
;; 1. procedure opt-key
(define (opt-key z k d)
  (let ((x (car z)) (y (cdr z)))
    (if (null? y)
	(cons d z)
	(if (eq? k x)
	    y
	    (let lp ((head (list x (car y))) (tail (cdr y)))
	      (if (null? tail)
		  (cons d z)
		  (let ((x (car tail)) (y (cdr tail)))
		    (if (null? y)
			(cons d z)
			(if (eq? k x)
			    (cons (car y) (append head (cdr y)))
			    (lp (cons x (cons (car y) head)) (cdr y)))))))))))
;; 2. macro opt-key!
(define-syntax opt-key!
  (syntax-rules ()
    ((opt-key! z n d)
     (let ((x (car z)) (y (cdr z)))
       (if (null? y)
	   d
	   (if (eq? 'n x)
	       (begin (set! z (cdr y)) (car y))
	       (let lp ((head (list x (car y)))
			(tail (cdr y)))
		 (if (null? tail)
		     d
		     (let ((x (car tail)) (y (cdr tail)))
		       (if (null? y)
			   d
			   (if (eq? 'n x)
			       (begin (set! z (append head (cdr y))) (car y))
			       (lp (cons x (cons (car y) head)) (cdr y)))))))))))))

(define-syntax key-lambda
  (syntax-rules ()
    ((key-lambda () (r ...) () body)
     (lambda (r ...) body))
    ((key-lambda () (r ...) (o oo ...) body)
     (lambda (r ... . z)
       (key-lambda (z) () (o oo ...) body)))
    ((key-lambda (z) () ((n d) . e) body)
     ;; 1. procedure opt-key
     (let* ((y (if (null? z) (cons d z) (opt-key z 'n d)))
     	    (n (car y))
     	    (y (cdr y)))
       (key-lambda (y) () e body)))
     ;; 2. macro opt-key!
     ;; (let ((n (if (null? z) d (opt-key! z n d))))
     ;;   (key-lambda (z) () e body)))
    ((key-lambda (z) () () body)
     (if (null? z)
	 body
	 (error 'define-lambda-object "too many arguments" z)))))

(define (check-duplicate ls err-str)
  (cond ((null? ls) #f)
	((memq (car ls) (cdr ls)) (error 'define-lambda-object err-str (car ls)))
	(else (check-duplicate (cdr ls) err-str))))

(define (check-field part-list main-list cmp name err-str)
  (let lp ((part part-list) (main main-list))
    (if (null? part)
	main
	(if (null? main)
	    (error 'define-lambda-object err-str name (car part))
	    (let ((field (car part)))
	      (if (cmp field (car main))
		  (lp (cdr part) (cdr main))
		  (let loop ((head (list (car main))) (tail (cdr main)))
		    (if (null? tail)
			(error 'define-lambda-object err-str name field)
			(if (cmp field (car tail))
			    (lp (cdr part) (append head (cdr tail)))
			    (loop (cons (car tail) head) (cdr tail)))))))))))

(define-syntax define-object
  (syntax-rules ()
    ((define-object name make-object make-object-by-name pred-object (gr ...) (gi ...) (fm ...) ((fi id) ...) (r ...) (o ...) (s ...) (v ...) ((h hd) ...) (a ...))
     (begin
       (define safe-parent
	 (begin
	   ;; check duplication
	   (check-duplicate '(name gi ... gr ...) "duplicated group")
	   (check-duplicate '(fm ... fi ... h ...) "duplicated field")
	   ;; check field
	   (check-field (gi 'read-write-field) '(fm ...) eq? 'gi "incompatible read-write field") ...
	   (check-field (gi 'read-only-field) '(fi ...) eq? 'gi "incompatible read-only field") ...
	   (check-field (gi 'required-field) '(r ...) eq? 'gi "incompatible required field") ...
	   (check-field (gi 'optional-field) '(o ...) equal? 'gi "incompatible optional field") ...
	   (check-field (gi 'virtual-field) '(v ...) equal? 'gi "incompatible virtual field") ...
	   (check-field (gi 'hidden-field) '((h hd) ...) equal? 'gi "incompatible hidden field") ...
	   (check-field (gi 'automatic-field) '(a ...) equal? 'gi "incompatible automatic field") ...
	   (check-field (append (gr 'read-write-field) (gr 'read-only-field) (map car (gr 'hidden-field))) '(fm ... fi ... h ...) eq? 'gr "incompatible whole field") ...
	   (list gi ... gr ...)))
       (define safe-name 'tmp)
       ;; Alist, vector/enum, vector/alist or hashtable can be used instead of
       ;; unquote-get & unquote-set! according to your implementation.
       ;; cf. (eval-variant expression implementation-specific-namespace)
       ;; An example of vector/enum:
       ;; (define enum-a (make-enumeration '(fm ... fi ...)))
       ;; (define enum-m (make-enumeration '(fm ...)))
       ;; (define enum-index-a (enum-set-indexer enum-a))
       ;; (define enum-index-m (enum-set-indexer enum-m))
       ;; (define make-object
       ;; 	 (seq-lambda () (r ...) (o ...)
       ;; 		     (let* (s ... (array (vector (lambda (x) (if (eq? enum-index-a x) fm (set! fm x))) ... (lambda (x) id) ...)))
       ;; 		       (define *%lambda-object%*
       ;; 			 (lambda (arg . args)
       ;; 			   (if (null? args)
       ;; 			       (let ((n (enum-index-a arg)))
       ;; 				 (if n
       ;; 				     ((vector-ref array n) enum-index-a)
       ;; 				     (error 'define-lambda-object "absent field" arg)))
       ;; 			       (if (null? (cdr args))
       ;; 				   (let ((n (enum-index-m arg)))
       ;; 				     (if n
       ;; 					 ((vector-ref array n) (car args))
       ;; 					 (if (enum-set-member? arg enum-a)
       ;; 					     (error 'define-lambda-object "read-only field" arg)
       ;; 					     (error 'define-lambda-object "absent field" arg))))
       ;; 				   safe-name))))
       ;; 		       *%lambda-object%*)))
       (define make-object
       	 (seq-lambda () (r ...) (o ...)
       		     (let* (s ...)
       		       (define *%lambda-object%*
       			 (lambda (arg . args)
       			   (if (null? args)
       			       (unquote-get arg ((fm fm) ... (fi id) ...))
       			       (if (null? (cdr args))
       				   (unquote-set! arg (car args) (fm ...) (fi ...))
       				   safe-name))))
       		       *%lambda-object%*)))
       (define make-object-by-name
       	 (key-lambda () (r ...) (o ...)
		     (let* (s ...)
		       (define *%lambda-object%*
			 (lambda (arg . args)
			   (if (null? args)
			       (unquote-get arg ((fm fm) ... (fi id) ...))
			       (if (null? (cdr args))
				   (unquote-set! arg (car args) (fm ...) (fi ...))
				   safe-name))))
		       *%lambda-object%*)))
       ;; The predicate procedure is implementation dependant.
       (define (pred-object object)
	 (and (eq? '*%lambda-object%* (object-name object)) ;mzscheme
	      (let ((group (object #f #f #f)))
		(or (eq? safe-name group)
		    (let lp ((group-list (group 'parent)))
		      (if (null? group-list)
			  #f
			   (or (eq? safe-name (car group-list))
			       (lp ((car group-list) 'parent))
			       (lp (cdr group-list)))))))))
       (define name
	 (let ((parent safe-parent)
	       (constructor (list make-object make-object-by-name))
	       (predicate pred-object)
	       (read-write-field '(fm ...))
	       (read-only-field '(fi ...))
	       (required-field '(r ...))
	       (optional-field '(o ...))
	       (virtual-field '(v ...))
	       (hidden-field '((h hd) ...))
	       (automatic-field '(a ...)))
	   (lambda (symbol)
	     (unquote-get* symbol (parent constructor predicate
					  read-write-field read-only-field
					  required-field optional-field
					  virtual-field hidden-field
					  automatic-field)))))
       (define tmp (set! safe-name name))))))

(define-syntax define-make-object
  (lambda (x)
    (syntax-case x ()
      ((_ nm gr gi fm fi r o s v h a)
       (let ((name (syntax->datum #'nm)))
	 (let ((make-obj (string->symbol (string-append "make-" (symbol->string name))))
	       (make-obj-by-name (string->symbol (string-append "make-" (symbol->string name) "-by-name")))
	       (pred-obj (string->symbol (string-append (symbol->string name) "?"))))
	   (with-syntax
	    ((make-object (datum->syntax #'nm make-obj))
	     (make-object-by-name (datum->syntax #'nm make-obj-by-name))
	     (pred-object (datum->syntax #'nm pred-obj)))
	    #'(define-object nm make-object make-object-by-name pred-object gr gi fm fi r o s v h a))))))))

(define-syntax field-sort
  (syntax-rules (unquote unquote-splicing)
    ((field-sort gr gi fm fi r o (s ...) v (h ...) a ((,,n d) . e))
     (field-sort gr gi fm fi r o (s ... (n d)) v (h ... (n d)) a e))
    ((field-sort gr gi (fm ...) fi r o (s ...) v h (a ...) (((,n) d) . e))
     (field-sort gr gi (fm ... n) fi r o (s ... (n d)) v h (a ... (n d)) e))
    ((field-sort gr gi fm (fi ...) r o (s ...) v h (a ...) ((,n d) . e))
     (field-sort gr gi fm (fi ... (n n)) r o (s ... (n d)) v h (a ... (n d)) e))
    ((field-sort gr gi fm (fi ...) r o s (v ...) h a ((,@n d) . e))
     (field-sort gr gi fm (fi ... (n d)) r o s (v ... (n d)) h a e))
    ((field-sort gr gi (fm ...) fi r (o ...) () () () () (((n) d) . e))
     (field-sort gr gi (fm ... n) fi r (o ... (n d)) () () () () e))
    ((field-sort gr gi fm (fi ...) r (o ...) () () () () ((n d) . e))
     (field-sort gr gi fm (fi ... (n n)) r (o ... (n d)) () () () () e))
    ((field-sort gr gi (fm ...) fi (r ...) () () () () () ((n) . e))
     (field-sort gr gi (fm ... n) fi (r ... n) () () () () () e))
    ((field-sort gr gi fm (fi ...) (r ...) () () () () () (n . e))
     (field-sort gr gi fm (fi ... (n n)) (r ... n) () () () () () e))
    ((field-sort gr (name gi ...) fm fi r o s v h a ())
     (define-make-object name gr (gi ...) fm fi r o s v h a))))

(define-syntax group-sort
  (syntax-rules ()
    ((group-sort (gr ...) (gi ...) ((g) gg ...) f)
     (group-sort (gr ... g) (gi ...) (gg ...) f))
    ((group-sort (gr ...) (gi ...)  (g gg ...) f)
     (group-sort (gr ...) (gi ... g) (gg ...) f))
    ((group-sort () () g f)
     (group-sort () (g) () f))
    ((group-sort gr gi () f)
     (field-sort gr gi () () () () () () () () f))))

(define-syntax define-lambda-object
  (syntax-rules ()
    ((define-lambda-object g . f)
     (group-sort () () g f))))


;;; define-lambda-object --- define-macro

(define-macro (unquote-get symbol args)
  (if (null? args)
      `(error 'define-lambda-object "absent field" ,symbol)
      (let ((arg (car args)))
	`(if (eq? ,symbol ',(car arg))
	     ,(cdr arg)
	     (unquote-get ,symbol ,(cdr args))))))

(define-macro (unquote-get* symbol args)
  (if (null? args)
      `(error 'define-lambda-object "not available inspection" ,symbol)
      (let ((arg (car args)))
	`(if (eq? ,symbol ',arg)
	     ,arg
	     (unquote-get* ,symbol ,(cdr args))))))

(define-macro (unquote-set! symbol new-val args iargs)
  (define (lp args)
    (if (null? args)
	`(if (memq ,symbol ',iargs)
	     (error 'define-lambda-object "read-only field" ,symbol)
	     (error 'define-lambda-object "absent field" ,symbol))
	(let ((arg (car args)))
	  `(if (eq? ,symbol ',arg)
	       (set! ,arg ,new-val)
	       ,(lp (cdr args))))))
  (lp args))

(define-macro (seq-lambda r o body)
  (define (opt-seq z cls body)
    (if (null? cls)
	`(if (null? ,z)
	     ,body
	     (error 'define-lambda-object "too many arguments" ,z))
	(let ((cl (car cls)))
	  `(let ((,(car cl) (if (null? ,z) ,(cadr cl) (car ,z)))
		 (,z (if (null? ,z) ,z (cdr ,z))))
	     ,(opt-seq z (cdr cls) body)))))
  (if (null? o)
      `(lambda ,r ,body)
      (let ((z (gensym)))
	`(lambda (,@r . ,z)
	   ,(opt-seq z o body)))))

;; Choose either procedure type or macro type according to your implementation.
;; 1. procedure field-key
(define (field-key z k d)
  (let ((x (car z)) (y (cdr z)))
    (if (null? y)
	(cons d z)
	(if (eq? k x)
	    y
	    (let lp ((head (list x (car y))) (tail (cdr y)))
	      (if (null? tail)
		  (cons d z)
		  (let ((x (car tail)) (y (cdr tail)))
		    (if (null? y)
			(cons d z)
			(if (eq? k x)
			    (cons (car y) (append head (cdr y)))
			    (lp (cons x (cons (car y) head)) (cdr y)))))))))))
;; 2. macro field-key!
(define-macro (field-key! z n d)
  (let ((x (gensym)) (y (gensym)) (head (gensym)) (tail (gensym)))
    `(let ((,x (car ,z)) (,y (cdr ,z)))
       (if (null? ,y)
	   ,d
	   (if (eq? ',n ,x)
	       (begin (set! ,z (cdr ,y)) (car ,y))
	       (let lp ((,head (list ,x (car ,y)))
			(,tail (cdr ,y)))
		 (if (null? ,tail)
		     ,d
		     (let ((,x (car ,tail)) (,y (cdr ,tail)))
		       (if (null? ,y)
			   ,d
			   (if (eq? ',n ,x)
			       (begin (set! ,z (append ,head (cdr ,y)))
				      (car ,y))
			       (lp (cons ,x (cons (car ,y) ,head)) (cdr ,y))))))))))))

(define-macro (key-lambda r o body)
  (define (opt-key z cls body)
    (if (null? cls)
	`(if (null? ,z)
	     ,body
	     (error 'define-lambda-object "too many arguments" ,z))
	(let ((cl (car cls)))
	  (let ((var (car cl)) (val (cadr cl)))
	    ;; 1. procedure field-key
	    `(let* ((,z (if (null? ,z) (cons ,val ,z) (field-key ,z ',var ,val)))  
	    	    (,var (car ,z))
	    	    (,z (cdr ,z)))
	    ;; 2. macro field-key!
	    ;; `(let* ((,var (if (null? ,z) ,val (field-key! ,z ,var ,val))))
	       ,(opt-key z (cdr cls) body))))))
  (if (null? o)
      `(lambda ,r ,body)
      (let ((z (gensym)))
	`(lambda (,@r . ,z) ,(opt-key z o body)))))

(define (check-duplicate ls err-str)
  (cond ((null? ls) #f)
	((memq (car ls) (cdr ls)) (error 'define-lambda-object err-str (car ls)))
	(else (check-duplicate (cdr ls) err-str))))

(define (check-field part-list main-list cmp name err-str)
  (let lp ((part part-list) (main main-list))
    (if (null? part)
	main
	(if (null? main)
	    (error 'define-lambda-object err-str name (car part))
	    (let ((field (car part)))
	      (if (cmp field (car main))
		  (lp (cdr part) (cdr main))
		  (let loop ((head (list (car main))) (tail (cdr main)))
		    (if (null? tail)
			(error 'define-lambda-object err-str name field)
			(if (cmp field (car tail))
			    (lp (cdr part) (append head (cdr tail)))
			    (loop (cons (car tail) head) (cdr tail)))))))))))

;; (define (number-alist ls)
;;   (let loop ((ls ls) (n 0))
;;     (if (null? ls)
;; 	'()
;; 	(cons (cons (car ls) n) (loop (cdr ls) (+ 1 n))))))

(define-macro (define-object name gr gi fm fi r o s v h a)
  (let ((safe-name (gensym))
	(safe-parent (gensym))
	(arg (gensym))
	(args (gensym))
	;; (alist-a (gensym))
	;; (alist-m (gensym))
	;; (array (gensym))
	;; (safe-eq (gensym))
	;; (safe-arg (gensym))
	(group-name (symbol->string name)))
    (let ((make-object (string->symbol (string-append "make-" group-name)))
	  (make-object-by-name (string->symbol (string-append "make-" group-name "-by-name")))
	  (pred-object (string->symbol (string-append group-name "?"))))
      `(begin
	 (define ,safe-parent
	   (begin
	     ;; check duplication
	     (check-duplicate (append (list ',name) ',gi ',gr) "duplicated group")
	     (check-duplicate ',(append fm (map car fi) (map car h)) "duplicated field")
	     ;; check field
	     (for-each (lambda (g y)
			 (check-field (g 'read-write-field) ',fm eq? y "incompatible read-write field")
			 (check-field (g 'read-only-field) ',(map car fi) eq? y "incompatible read-only field")
			 (check-field (g 'required-field) ',r eq? y "incompatible required field")
			 (check-field (g 'optional-field) ',o equal? y "incompatible optional field")
			 (check-field (g 'virtual-field) ',v equal? y "incompatible virtual field")
			 (check-field (g 'hidden-field) ',h equal? y "incompatible hidden field")
			 (check-field (g 'automatic-field) ',a equal? y "incompatible automatic field"))
		       (list ,@gi) ',gi)
	     (for-each (lambda (g y)
			 (check-field (append (g 'read-write-field) (g 'read-only-field) (map car (g 'hidden-field))) ',(append fm (map car fi) (map car h)) eq? y "incompatible whole field"))
		       (list ,@gr) ',gr)
	     (list ,@gi ,@gr)))
	 ;; Alist, vector/enum, vector/alist or hashtable can be used instead of
	 ;; unquote-get & unquote-set! according to your implementation.
	 ;; cf. (eval-variant expression implementation-specific-namespace)
	 ;; An example of vector/alist:
	 ;; (define ,alist-a (number-alist ',(append fm (map car fi))))
	 ;; (define ,alist-m (number-alist ',fm))
	 ;; (define ,make-object
	 ;;   (seq-lambda ,r ,o
	 ;; 	       (let* (,@s (,array (vector ,@(map (lambda (f) `(lambda (,safe-arg) (if (eq? ,safe-arg ',safe-eq) ,f (set! ,f ,safe-arg)))) fm)  ,@(map (lambda (f) `(lambda (,safe-arg) ,f)) (map cdr fi)))))
	 ;; 		 (define *%lambda-object%*
	 ;; 		   (lambda (,arg . ,args)
	 ;; 		     (if (null? ,args)
	 ;; 			 (let ((pair (assq ,arg ,alist-a)))
	 ;; 			   (if pair
	 ;; 			       ((vector-ref ,array (cdr pair)) ',safe-eq)
	 ;; 			       (error 'define-lambda-object "absent field" ,arg)))
	 ;; 			 (if (null? (cdr ,args))
	 ;; 			     (let ((pair (assq ,arg ,alist-m)))
	 ;; 			       (if pair
	 ;; 				   ((vector-ref ,array (cdr pair)) (car ,args))
	 ;; 				   (if (assq ,arg ',fi)
	 ;; 				       (error 'define-lambda-object "read-only field" ,arg)
	 ;; 				       (error 'define-lambda-object "absent field" ,arg))))
	 ;; 			     ,safe-name))))
	 ;; 		 *%lambda-object%*)))
	 (define ,make-object
	   (seq-lambda ,r ,o
		       (let* ,s
			 (define *%lambda-object%*
			   (lambda (,arg . ,args)
			     (if (null? ,args)
				 (unquote-get ,arg ,(append (map cons fm fm) fi))
				 (if (null? (cdr ,args))
				     (unquote-set! ,arg (car ,args) ,fm ,(map car fi))
				     ,safe-name))))
			 *%lambda-object%*)))
	 (define ,make-object-by-name
	   (key-lambda ,r ,o
		       (let* ,s
			 (define *%lambda-object%*
			   (lambda (,arg . ,args)
			     (if (null? ,args)
				 (unquote-get ,arg ,(append (map cons fm fm) fi))
				 (if (null? (cdr ,args))
				     (unquote-set! ,arg (car ,args) ,fm ,(map car fi))
				     ,safe-name))))
			 *%lambda-object%*)))
	 ;; The predicate procedure is implementation dependant.
	 (define (,pred-object object)
	   (and (eq? '*%lambda-object%* (object-name object)) ;mzscheme
		(let ((group (object #f #f #f)))
		  (or (eq? ,safe-name group)
		      (let lp ((group-list (group 'parent)))
			(if (null? group-list)
			    #f
			    (or (eq? ,safe-name (car group-list))
				(lp ((car group-list) 'parent))
				(lp (cdr group-list)))))))))
	 (define ,name
	   (let ((parent ,safe-parent)
		 (constructor (list ,make-object ,make-object-by-name))
		 (predicate ,pred-object)
		 (read-write-field ',fm)
		 (read-only-field ',(map car fi))
		 (required-field ',r)
		 (optional-field ',o)
		 (virtual-field ',v)
		 (hidden-field ',h)
		 (automatic-field ',a))
	     (lambda (symbol)
	       (unquote-get* symbol (parent constructor predicate
					    read-write-field read-only-field
					    required-field optional-field
					    virtual-field hidden-field
					    automatic-field)))))
	 (define ,safe-name ,name)))))

(define-macro (define-lambda-object group . field)
  (define (field-sort gr gi field fm fi r o s t h a)
    (if (null? field)
	`(define-object ,(car gi) ,gr ,(cdr gi) ,fm ,fi ,r ,o ,s ,t ,h ,a)
	(let ((vars (car field)))
	  (if (symbol? vars)		;r
	      (if (and (null? o) (null? s) (null? t))
		  (field-sort gr gi (cdr field)
			      fm (append fi (list (cons vars vars)))
			      (append r (list vars)) o s t h a)
		  (error 'define-lambda-object "required-field should precede optional-field and automatic-field" vars))
	      (let ((var (car vars)))
		(if (symbol? var)
		    (if (null? (cdr vars)) ;(r)
			(if (and (null? o) (null? s) (null? t))
			    (field-sort gr gi (cdr field)
					(append fm (list var)) fi
					(append r vars) o s t h a)
			    (error 'define-lambda-object "required-field should precede optional-field and automatic-field" var))
			(if (null? (cddr vars)) ;(o val)
			    (if (and (null? s) (null? t))
				(field-sort gr gi (cdr field)
					    fm (append fi (list (cons var var)))
					    r (append o (list vars)) s t h a)
				(error 'define-lambda-object "optional-field should precede automatic-field" var))
			    (error 'define-lambda-object "incorrect syntax" vars)))
		    (let ((v (car var)))
		      (if (or (null? (cdr vars)) (pair? (cddr vars)))
			  (error 'define-lambda-object "incorrect syntax" vars)
			  (if (symbol? v)
			      (if (null? (cdr var)) ;((o) val)
				  (if (and (null? s) (null? t))
				      (field-sort gr gi (cdr field)
						  (append fm (list v)) fi
						  r (append o (list (cons v (cdr vars)))) s t h a)
				      (error 'define-lambda-object "optional-field should precede automatic-field" v))
				  (if (null? (cddr var))
				      (let ((d (cadr var)))
					(if (symbol? d)
					    (if (eq? 'unquote-splicing v) ;(,@a val)
						(field-sort gr gi (cdr field)
							    fm (append fi (list (cons d (cadr vars))))
							    r o s (append t (list (cons d (cdr vars)))) h a)
						(if (eq? 'unquote v) ;(,a val)
						    (field-sort gr gi (cdr field)
								fm (append fi (list (cons d d)))
								r o (append s (list (cons d (cdr vars)))) t h (append a (list (cons d (cdr vars)))))
						    (error 'define-lambda-object "incorrect syntax" vars)))
					    (if (and (eq? 'unquote v) (eq? 'unquote (car d)) (symbol? (cadr d)) (null? (cddr d))) ;(,,a val)
						(field-sort gr gi (cdr field)
								fm fi
								r o (append s (list (cons (cadr d) (cdr vars)))) t (append h (list (cons (cadr d) (cdr vars)))) a)
						(error 'define-lambda-object "incorrect syntax" vars))))
				      (error 'define-lambda-object "incorrect syntax" vars)))
			      (if (and (null? (cdr var))
				       (null? (cddr v))
				       (eq? 'unquote (car v))) ;((,a) val)
				  (field-sort gr gi (cdr field)
					      (append fm (list (cadr v))) fi
					      r o (append s (list (cons (cadr v) (cdr vars)))) t h (append a (list (cons (cadr v) (cdr vars)))))
				  (error 'define-lambda-object "incorrect syntax" vars)))))))))))
  (define (group-sort gr gi gg field)
    (if (pair? gg)
	(let ((g (car gg)))
	  (if (pair? g)
	      (group-sort (append gr g) gi (cdr gg) field)
	      (group-sort gr (append gi (list g)) (cdr gg) field)))
	(if (symbol? gg)
	    (group-sort gr (cons gg gi) '() field)
	    (field-sort gr gi field '() '() '() '() '() '() '() '()))))
  (group-sort '() '() group field))

;;; eof


References

[R6RS]	    Michael Sperber, R. Kent Dybvig, Matthew Flatt, and
	    Anton von Straaten:
	    Revised(6) Report on the Algorithmic Language Scheme
	    http://www.r6rs.org
[SRFI 9]    Richard Kelsey: Defining Record Type
	    http://srfi.schemers.org/srfi-9
[On Lisp]   Paul Graham:
    	    http://www.paulgraham.com/onlisp.html


Copyright

Copyright (c) 2009 Joo ChurlSoo.

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the ``Software''), to
deal in the Software without restriction, including without limitation the
rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
sell copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.