(defun check (instance type-list)
    (or (null instance)
	(and (instancep instance)
	     (member (send instance ':type) type-list))))

(defun var-type-error (location name value type-list)
    (format 'T "Type error in instance of type ~A~%"
	(send location ':type))
    (format 'T "The content of the instance variable ~A~%" name)
    (if (instancep value)
	(format 'T "    is an instance of the flavor type ~A~%"
	    (send value ':type))
	(format 'T "    is not a flavor instance~%"))
    (format 'T "It should be an instance of the following flavor types:~%")
    (format 'T "    ~A~%" type-list)
    (terpri))

(defun child-type-error (location value type-list)
    (format 'T "Type error in instance of type ~A~%"
	(send location ':type))
    (format 'T "An element of the child instance variable~%")
    (if (instancep value)
	(format 'T "    is an instance of the flavor type ~A~%"
	    (send value ':type))
	(format 'T "    is not a flavor instance~%"))
    (format 'T "It should be an instance of the following flavor types:~%")
    (format 'T "    ~A~%" type-list)
    (terpri))

(defmethod (terminal :type-check) (&optional (option 'walk))
    nil)

(defmethod (construction :type-check) (&optional (option 'walk))
    (loop for name in (send-self ':rhs)
	do (let ((type-list (send-self ':var-types name))
		 (instance (eval name)))
		(if (not (check instance type-list))
		    (var-type-error self name instance type-list)))))

(defmethod (construction :after :type-check) (&optional (option 'walk))
    (if (eq option 'walk)
	(loop for name in (send-self ':rhs)
	    do (let ((instance (eval name)))
		    (if instance (send instance ':type-check))))))

(defmethod (repetition :type-check) (&optional (option 'walk))
    (let ((type-list (send-self ':var-types)))
	 (loop for instance in child
	     do (if (not (check instance type-list))
		    (child-type-error self instance type-list)))))

(defmethod (repetition :after :type-check) (&optional (option 'walk))
    (if (eq option 'walk)
	(loop for instance in child
	    do (send instance ':type-check))))

(defmethod (construction :set-var) (name value)
    (let ((type-list (send-self ':var-types name)))
	 (if (check value type-list)
	     (send-self (concat ':set- name) value)
	     (var-type-error self name value type-list))))

(defmethod (repetition :set-child) (child-value)
    (if (not (listp child-value)) (print `(type-error in set-child   new child is not a list ,(break))))
    (let ((type-list (send-self ':var-types)))
	 (setf child nil)
	 (loop for instance in child-value
	     do (if (check instance type-list)
		    (setf child (append child (list instance)))
		    (child-type-error self instance type-list)))))

(defmethod (repetition :append-child) (value)
    (let ((type-list (send-self ':var-types)))
	 (if (check value type-list)
	     (setf child (append child (list value)))
	     (child-type-error self value type-list))))

(defmethod (repetition :prepend-child) (value)
    (let ((type-list (send-self ':var-types)))
	 (if (check value type-list)
	     (setf child (cons value child))
	     (child-type-error self value type-list))))

(defmethod (universal :after :init) (init-plist)
    (send-self ':type-check 'no-walk))

(defmethod (expressionlist :var-types) ()
    '(assignment lambdaexpression ifexpression application ident))

(defmethod (ifexpression :var-types) (var-name)
    (caseq var-name
        (testexp '(assignment lambdaexpression ifexpression application ident))
        (thenexp '(assignment lambdaexpression ifexpression application ident))
        (elseexp '(assignment lambdaexpression ifexpression application ident))))

(defmethod (application :var-types) (var-name)
    (caseq var-name
        (function '(assignment lambdaexpression ifexpression application ident))
        (actuals '(expressionlist))))

(defmethod (lambdaexpression :var-types) (var-name)
    (caseq var-name
        (formals '(identlist))
        (body '(expressionlist))))

(defmethod (identlist :var-types) ()
    '(ident))

(defmethod (assignment :var-types) (var-name)
    (caseq var-name
        (ident '(ident))
        (expression '(assignment lambdaexpression ifexpression application ident))))