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, mutable fields, immutable fields, required fields,
optional fields, and automatic fields.


Rationale

Unlike most record-defining macros, an object created by a constructor
procedure is not a vector but a procedure whose first argument is a symbolized
field name.  Though the average time required to access a randomly chosen
field is more for the procedure-type object than for the vector-type one, the
lambda object plays the role of the accessor and mutator of each field.  This
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.  Automatic fields can be
used like METHODs of C++ as well as like checkers or modifiers of the values
of required and optional fields.  These make the macro to be able to work as a
simple but rudimentary CLASS.


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>			;immutable field
		  | (<field>)			;mutable field

<optional field> --> (<field>  <default>)	;immutable field
		  | ((<field>) <default>)	;mutable field

<automatic field> --> (,<field>  <default>)	;immutable field
		   | ((,<field>) <default>)	;mutable 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 a <expression> that is evaluated in an environment that the
values of all the previous <field>s are visible.

Each time define-lambda-object expression is evaluated, a new group is created
with distinct <group>, <constructor>, and <predicate> procedures.

<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 expression 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.

<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
mutable fields can be modified, whereas any attempt to modify the values of
the immutable fields signals an error.

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 field> is bound to the corresponding <default>.

<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 mutable required field.
;; The `y' is an immutable required 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: immutable field y
(ppoint? pp)				=> #t

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

;; The `color' and `coordinate' are immutable automatic fields.
(define-lambda-object (cpoint ppoint)
  (x) y
  (,color 'blue)
  (,coordinate (lambda (i j) (set! x (+ i x)) (set! y (+ j y)))))

(define cp (make-cpoint 3 33 'red))   	=> error: expects 2 arguments, given 3
(define cp (make-cpoint 3 33))
(cp 'color)				=> blue
(map cp '(x y))				=> (3 33)
((cp 'coordinate) 30 300)
(map cp '(x y))				=> (33 333)
(cpoint? cp)				=> #t
(ppoint? cp)				=> #t
(cpoint? pp)				=> #f

;; The `z' is an immutable optional field.
;; The `adbmal' is an immutable automatic field.
(define-lambda-object (spoint ppoint)
  (x) y
  (z 100)
  (,adbmal (lambda (f) (f x y z))))

(define zp (make-spoint 5 55))
((zp 'adbmal) list)			=> (5 55 100)
(define zp (make-spoint 5 55 555))
((zp 'adbmal) vector)			=> #(5 55 555)
((zp 'adbmal) +)			=> 615
(spoint? zp)				=> #t
(ppoint? zp)				=> #t
(cpoint? zp)				=> #f

;; The parent group `ppoint' is a amendable group.
;; All the fields are immutable and optional.
(define-lambda-object (spoint (ppoint)) (x 0) (y x) (z x))

(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)
(spoint? sp)				=> #t
(spoint? zp)				=> #f

;; The `coordinate' 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 7) (y 70) (z 700) ((color) "brown") ((planet) "earth")
  (,coordinate (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 "coordinate: wrong data type" i j))))
		((i j k) (set! x (+ i x)) (set! y (+ j y)) (set! z (+ k z)))))
  (,adbmal (lambda (f) (f x y z color planet))))

(define ep (make-epoint 7 70 700 "blue"))
(map ep '(x y z color planet))			=>  (7 70 700 "blue" "earth")
(define ep (make-epoint-by-name 'color "blue"))
((ep 'adbmal) vector)				=> #(7 70 700 "blue" "earth")
(map (lambda (o) (o 'x)) (list pp cp zp sp ep))			=> (11 33 5 0 7)
(map (lambda (p) (p ep)) (list ppoint? cpoint? spoint? epoint?))=> (#t #t #t #t)
((ep 'coordinate) "red" "mars")
((ep 'adbmal) list)  			=> (7 70 700 "red" "mars")
((ep 'coordinate) 1 10)
((ep 'adbmal) list)  			=> (8 80 700 "red" "mars")
((ep 'coordinate) 2 20 300)
(map ep '(x y z))			=> (10 100 1000)
(map cp '(x y))				=> (33 333)
((cp 'coordinate) 20 200)
(map cp '(x y))				=> (53 533)
((cp 'coordinate) 10 100 1000) 		=> error: expects 2 arguments, given 3

epoint				=> #<procedure:epoint>
(epoint 'parent)		=> (#<procedure:spoint> #<procedure:cpoint>)
(epoint 'constructor)		=> (#<procedure:make-epoint> #<procedure:make-epoint-by-name>)
(epoint 'predicate)		=> #<procedure:epoint?>
(epoint 'mutable-field)		=> (color planet)
(epoint 'immutable-field)	=> (x y z coordinate adbmal)
(epoint 'required-field)	=> ()
(epoint 'optional-field)	=> ((x 7) (y 70) (z 700) (color "brown") (planet "earth"))
(epoint 'automatic-field)
 => ((coordinate (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 "coordinate: wrong data type" i j))))
		  ((i j k) (set! x (+ i x)) (set! y (+ j y)) (set! z (+ k z)))))
     (adbmal (lambda (f) (f x y z color planet))))


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 n1 ...))
     (if (eq? symbol 'n0)
	 n0
	 (unquote-get symbol (n1 ...))))
    ((unquote-get symbol ())
     (error 'define-lambda-object "absent field" 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 "immutable 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)))))

(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)))))))))))

(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)
     (let* ((y (if (null? z) (cons d z) (opt-key z 'n d)))
	    (n (car y))
	    (y (cdr y)))
       (key-lambda (y) () 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 ...) (r ...) (o ...) (a ...))
     (begin
       (define safe-name 'tmp)
       (define safe-parent
	 (begin
	   ;; check duplication
	   (check-duplicate '(name gi ... gr ...) "duplicated group")
	   (check-duplicate '(fm ... fi ...) "duplicated field")
	   ;; check field
	   (check-field (gi 'mutable-field) '(fm ...) eq? 'gi "incompatible mutable field") ...
	   (check-field (gi 'immutable-field) '(fi ...) eq? 'gi "incompatible immutable 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 'automatic-field) '(a ...) equal? 'gi "incompatible automatic field") ...
	   (check-field (append (gr 'mutable-field) (gr 'immutable-field)) '(fm ... fi ...) eq? 'gr "incompatible whole field") ...
	   (list gi ... gr ...)))
       (define make-object
	 (seq-lambda () (r ...) (o ...)
		     (let* (a ...)
		       ;; Hashtable, enum plus vector, association list, or
		       ;; vector can be used according to your implementation.
		       ;; In this case, automatic fields become pure extra
		       ;; fields.
		       ;; Accessor takes precedence over mutator & predicate.
		       (define *%lambda-object%*
			 (lambda (arg . args)
			   (if (null? args)
			       (unquote-get arg (fm ... fi ...))
			       (if (null? (cdr args))
				   (unquote-set! arg (car args) (fm ...) (fi ...))
				   safe-name))))
		       ;; (define *%lambda-object%*
		       ;; 	 (lambda (arg . args)
		       ;; 	   (if (null? args)
		       ;; 	       (if (eq? arg #f)
		       ;; 		   safe-name
		       ;; 		   (unquote-get arg (fm ... fi ...)))
		       ;; 	       (unquote-set! arg (car args) (fm ...) (fi ...)))))
		       *%lambda-object%*)))
       (define make-object-by-name
	 (key-lambda () (r ...) (o ...)
		     (let* (a ...)
		       (define *%lambda-object%*
			 (lambda (arg . args)
			   (if (null? args)
			       (unquote-get arg (fm ... fi ...))
			       (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)))		    ;cf. (object #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)
	       (whole-field '(fm ... fi ...))
	       (mutable-field '(fm ...))
	       (immutable-field '(fi ...))
	       (required-field '(r ...))
	       (optional-field '(o ...))
	       (automatic-field '(a ...)))
	   (lambda (symbol)
	     (unquote-get symbol (parent constructor predicate
					 mutable-field immutable-field
					 required-field optional-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 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 a))))))))

(define-syntax field-sort
  (syntax-rules (unquote)
    ((field-sort gr gi (fm ...) fi r o (a ...) (((,n) d) . e))
     (field-sort gr gi (fm ... n) fi r o (a ... (n d)) e))
    ((field-sort gr gi fm (fi ...) r o (a ...) ((,n d) . e))
     (field-sort gr gi fm (fi ... n) r o (a ... (n d)) 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) 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) (r ... n) () () e))
    ((field-sort gr (name gi ...) fm fi r o a ())
     (define-make-object name gr (gi ...) fm fi r o 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 ',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 "immutable 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)))))

(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)))))))))))

(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)))
	    `(let* ((,z (if (null? ,z) (cons ,val ,z) (field-key ,z ',var ,val)))  
		    (,var (car ,z))
		    (,z (cdr ,z)))
	       ,(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-macro (define-object name gr gi fm fi r o a)
  (let ((safe-name (gensym))
	(safe-parent (gensym))
	(arg (gensym))
	(args (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 ',fi) "duplicated field")
	     ;; check field
	     (for-each (lambda (g v)
			 (check-field (g 'mutable-field) ',fm eq? v "incompatible mutable field")
			 (check-field (g 'immutable-field) ',fi eq? v "incompatible immutable field")
			 (check-field (g 'required-field) ',r eq? v "incompatible required field")
			 (check-field (g 'optional-field) ',o equal? v "incompatible optional field")
			 (check-field (g 'automatic-field) ',a equal? v "incompatible automatic field"))
		       (list ,@gi) ',gi)
	     (for-each (lambda (g v)
			 (check-field (append (g 'mutable-field) (g 'immutable-field)) (append ',fm ',fi) eq? v "incompatible whole field"))
		       (list ,@gr) ',gr)
	     (list ,@gi ,@gr)))
	 (define ,make-object
	   (seq-lambda ,r ,o
		       (let* ,a
			 ;; Hashtable, enum plus vector, association list, or
			 ;; vector can be used according to your implementation.
			 ;; In this case, automatic fields become pure extra
			 ;; fields.
			 ;; Accessor takes precedence over mutator & predicate.
			 (define *%lambda-object%*
			   (lambda (,arg . ,args)
			     (if (null? ,args)
				 (unquote-get ,arg ,(append fm fi))
				 (if (null? (cdr ,args))
				     (unquote-set! ,arg (car ,args) ,fm ,fi)
				     ,safe-name))))
			 ;; (define *%lambda-object%*
			 ;;   (lambda (,arg . ,args)
			 ;;     (if (null? ,args)
			 ;; 	 (if (eq? ,arg #f)
			 ;; 	     ,safe-name
			 ;; 	     (unquote-get ,arg ,(append fm fi)))
			 ;; 	 (unquote-set! ,arg (car ,args) ,fm ,fi))))
			 *%lambda-object%*)))
	 (define ,make-object-by-name
	   (key-lambda ,r ,o
		       (let* ,a
			 (define *%lambda-object%*
			   (lambda (,arg . ,args)
			     (if (null? ,args)
				 (unquote-get ,arg ,(append fm fi))
				 (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)))	      ;cf. (object #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)
		 (mutable-field ',fm)
		 (immutable-field ',fi)
		 (required-field ',r)
		 (optional-field ',o)
		 (automatic-field ',a))
	     (lambda (symbol)
	       (unquote-get symbol (parent constructor predicate
					   mutable-field immutable-field
					   required-field optional-field
					   automatic-field)))))
	 (define ,safe-name ,name)))))

(define-macro (define-lambda-object group . field)
  (define (field-sort gr gi field fm fi r o a)
    (if (null? field)
	`(define-object ,(car gi) ,gr ,(cdr gi) ,fm ,fi ,r ,o ,a)
	(let ((vars (car field)))
	  (if (symbol? vars)		;r
	      (if (and (null? o) (null? a))
		  (field-sort gr gi (cdr field)
			      fm (append fi (list vars))
			      (append r (list vars)) o 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? a))
			    (field-sort gr gi (cdr field)
					(append fm vars) fi
					(append r vars) o a)
			    (error 'define-lambda-object "required-field should precede optional-field and automatic-field" var))
			(if (null? (cddr vars)) ;(o val)
			    (if (null? a)
				(field-sort gr gi (cdr field)
					    fm (append fi (list var))
					    r (append o (list vars)) 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 (null? a)
				      (field-sort gr gi (cdr field)
						  (append fm var) fi
						  r (append o (list (cons v (cdr vars)))) a)
				      (error 'define-lambda-object "optional-field should precede automatic-field" v))
				  (if (and (eq? 'unquote v)
					   (null? (cddr var))) ;(,a val)
				      (field-sort gr gi (cdr field)
						  fm (append fi (list (cadr var)))
						  r o (append a (list (cons (cadr var) (cdr vars)))))
				      (error 'define-lambda-object "incorrect syntax" vars)))
			      (if (and (null? (cdr var))
				       (eq? 'unquote (car v))
				       (null? (cddr v))) ;((,a) val)
				  (field-sort gr gi (cdr field)
					      (append fm (list (cadr v))) fi
					      r o (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.