[foo-cvs] foo/elkfoo/scm/control/abstraction Makefile.am,NONE,1.1 abstr-functlity.foo,NONE,1.1 abstraction.foo,NONE,1.1 comp-type.foo,NONE,1.1 funx-type.foo,NONE,1.1 hier-type.foo,NONE,1.1 var-type.foo,NONE,1.1

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo/elkfoo/scm/control/abstraction
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6585/control/abstraction

Added Files:
	Makefile.am abstr-functlity.foo abstraction.foo comp-type.foo 
	funx-type.foo hier-type.foo var-type.foo 
Log Message:
initial checkin of scheme files, control, tools

--- NEW FILE: hier-type.foo ---
(define-class Hier-Type (instance-vars Descriptor
				       Init-Hier
				       Main-Hier
				       Coda-Hier))

(define-method Hier-Type (checkData)
   (let ((flg #t))
	(if (null? Descriptor)
	   (if (and (null? Init-Hier)
		    (null? Main-Hier)
		    (null? Coda-Hier))
		#t
		(if (not (send self 
		        'set-Descriptor (list (list 'Init-Hier Init-Hier)
					      (list 'Main-Hier Main-Hier)
					      (list 'Coda-Hier Coda-Hier))))
			(set! flg #f)))
	   (if (not (send self 'set-Descriptor Descriptor)) (set! flg #f)))
	(if (not flg) (prn "Error Hierarchy "Descriptor))
	flg))

(define-method Hier-Type (set-Descriptor Lst)
  (let ((SymLst (list 'Init-Hier 'Main-Hier 'Coda-Hier)) 
   	(aux) (flg #t))

    (if (not (null? Lst))
       (if (and  (not (pair? Lst))
		 (not (symbol? Lst)))
       	   (set! flg #f)

   	   (set! aux (first-symbol Lst))
           (if (not (member aux SymLst))
		(set! Lst (list (list 'Init-Hier Lst) (list 'Main-Hier Lst)
				                      (list 'Coda-Hier Lst)))
		(if (symbol? (car Lst)) (set! Lst (list Lst))))
   	   (for-each
   	     (lambda (x)
               (set! aux 
	         (cond
	           ((equal? (car x) 'Init-Hier)  
				 (send self 'set-Init-Hier (clean (cdr x))))
	           ((equal? (car x) 'Main-Hier)
				 (send self 'set-Main-Hier (clean (cdr x))))
	           ((equal? (car x) 'Coda-Hier)
				 (send self 'set-Coda-Hier (clean (cdr x))))))
               (if (not aux) (set! flg #f))) Lst)
   	   (if flg (set! Descriptor (list (list 'Init-Hier Init-Hier)
				    (list 'Main-Hier Main-Hier)
				    (list 'Coda-Hier Coda-Hier))))))
    flg))


(define-method Hier-Type (set-Init-Hier Lst)
    (set! Lst (send self 'check Lst))
    (if (or (null? Lst) Lst)
    	(begin (set! Init-Hier Lst)
	       (set! Descriptor '())
	       #t)
    	(prn "Error Hier-Type Init-Hier "Init-Hier)
	(set! Init-Hier '())
	#f))

(define-method Hier-Type (set-Main-Hier Lst)
    (set! Lst (send self 'check Lst))
    (if (or (null? Lst) Lst)
    	(begin (set! Main-Hier Lst)
	       (set! Descriptor '())
	       #t)
    	(prn "Error Hier-Type Main-Hier "Main-Hier)
	(set! Main-Hier '())
	#f))


(define-method Hier-Type (set-Coda-Hier Lst)
    (set! Lst (send self 'check Lst))
    (if (or (null? Lst) Lst)
    	(begin (set! Coda-Hier Lst)
	       (set! Descriptor '())
	       #t)
    	(prn "Error Hier-Type Coda-Hier "Coda-Hier)
	(set! Coda-Hier '())
	#f))

(define-method Hier-Type (check Lst)
   (if (not (list? Lst))
   	(if (not (symbol? Lst)) #f
				Lst)
			 (set! Lst (cleanlist Lst))
			 (if (or (null? Lst)
				 (symbolic? Lst)) Lst #f)))

(define-method Hier-Type (get-Descriptor)
   (if (null?  Descriptor) (list (list 'Init-Hier Init-Hier)
	    			 (list 'Main-Hier Main-Hier)
				 (list 'Coda-Hier Coda-Hier))
   			   Descriptor))

(define-method Hier-Type (get-Init-Hier)  Init-Hier)
(define-method Hier-Type (get-Main-Hier)  Main-Hier)
(define-method Hier-Type (get-Coda-Hier)  Coda-Hier)


--- NEW FILE: Makefile.am ---
# foo/elkfoo/scm/control/abstraction/Makefile.am
# 2004 rumori

# $Id: Makefile.am,v 1.1 2004/08/07 22:53:00 rumori Exp $

NULL = 

pkgabstraction_DATA = $(ELKFOO_ABSTRACTION_FILES)

pkgabstractiondir = $(pkgdatadir)/control/abstraction

ELKFOO_ABSTRACTION_FILES = \
	abstr-functlity.foo \
	abstraction.foo \
	comp-type.foo \
	funx-type.foo \
	hier-type.foo \
	var-type.foo \
	$(NULL)

--- NEW FILE: comp-type.foo ---
(define-class Comp-Type (instance-vars Types
				       Variables
				       Comp-List
				       NumbOfElems
				       TotalNumbOfElems
				       (checkd #f)))

(define-method Comp-Type (checkData)
   (let ((flg #t))
	(if (not (null? Types))
	    (if (and (send self 'check-Types)
		     (send self 'check-NumbOfElems)) (send self 'adjust)
		     				     (set! flg #f)))
	(set! checkd #t)
	flg))

(define-method Comp-Type (check-Types)
  (let ((aux #t))
	(if (not (pair? Types)) (set! Types (list Types)))
	(set! Types (flatout Types))
	(for-each
	   (lambda (x)
	       (if (not (send self 'checkelType x)) (set! aux #f))) Types)
	aux))

(define-method Comp-Type (checkelType el)
   (let ((aux #t))
	(cond
	    ((symbol? el)	(if (or (not (bound? el))
	    				(abstraction? (eval el))
					(abstraction-mold? (eval el))) #t #f))
	    ((abstraction? el)		#t)
	    ((abstraction-mold? el)	#t)
	    ((pair?  el)	(for-each 
	    			  (lambda (x)
				    (if (not (send self 'checkelType x))
				    	   (set! aux #f))) 
				           el) aux)
	    (#t			#f))))

(define-method Comp-Type (check-NumbOfElems)
  (let ((aux #t) (flg #f) (aux1))
    (cond
      ((and (null? NumbOfElems)
	    (null? TotalNumbOfElems)) 

		(set! NumbOfElems
			(map (lambda (x) (send self 'count x)) Types))
		(set! TotalNumbOfElems 0)
		(for-each
		   (lambda (x) (set! TotalNumbOfElems  (+ TotalNumbOfElems x)))
					     			NumbOfElems)
		NumbOfElems)

      ((null? NumbOfElems)

		(set! aux1 (length Types))
		(set! NumbOfElems
    		    (map (lambda (x)
		    	    (max 0 (truncate (/ TotalNumbOfElems aux1)))) Types))
		NumbOfElems)

      (#t
    		(if (not (pair? NumbOfElems))
		    (set! NumbOfElems (list NumbOfElems))
		    (set!  NumbOfElems (flatout NumbOfElems)))
		(if (= (length NumbOfElems)
	               (length Types))
	 	  (for-each 
		    (lambda (x y)
		      (if (not (send self 'checkNumbel x y)) (set! aux #f)))
							  NumbOfElems Types)
	 	  (set! aux #f))
	  	(if aux
		    (begin
			(set! TotalNumbOfElems 0)
			(for-each
			   (lambda (x)
			      (if (number? x)
			      	(set! TotalNumbOfElems (+ TotalNumbOfElems x))
				(set! flg #t))) NumbOfElems)
		    NumbOfElems)
		    #f)))))


    
(define-method Comp-Type (checkNumbel el ti)
  (let ((aux #t))
	(cond
	    ((and (pair? el)
	    	  (pair? ti)) (if (= (length el)
					(length ti))
				(for-each
				    (lambda (x y)
					(if (not (send self 'checkNumbel x y))
					    (set! aux #f))) el ti) 
				aux 
				#f))
	    ((symbol? el)     #t)
	    ((number? el)     #t)
	    (#t		      #f))))


(define-method Comp-Type (count el)
     (if (pair? el) (map (lambda (x) (send self 'count x)) el)
     		    1))

(define-method Comp-Type (adjust)
  (set! Types
	    (map (lambda (x) (send self 'get-TypeSymbs x)) (flatten Types)))
  (set! Variables
	    (map (lambda (x) (send self 'get-VarNames x)) Types))
  (set! Comp-List
	(map (lambda (x y) (send self 'make-Component x y)) Types NumbOfElems))
  Types)

(define-method Comp-Type (get-TypeSymbs el)
    (cond
	((pair? el)		(map (lambda (x)
					    (send self 'get-TypeSymbs x)) el))
	((symbol? el)		el)
	((abstraction? el)	el)
	((abstraction-mold? el)	(vector-ref el 1))))

(define-method Comp-Type (get-VarNames el)
    (cond
	((pair? el)		(map (lambda (x)
					    (send self 'get-VarNames x)) el))
	((symbol? el)		(if (not (bound? el)) '() 
					 (send self 'get-VarNames (eval el))))
	((abstraction? el)	(send el 'get-Varnames))
	((abstraction-mold? el)	(send (make-abstraction el) 'get-Varnames))))

(define-method Comp-Type (get-Types . pos)
    (if (not checkd) (send self 'checkData))
    (if (null? pos) Types
		    (if (< pos (length Types))
		    		 (nth Types pos)
				 (error 'Abstraction "Components ~a" pos))))

(define-method Comp-Type (get-Components . pos)
    (if (not checkd) (send self 'checkData))
    (set! pos (if (not (null? pos)) (car pos) '()))
    (cond
	((null? pos)			Comp-List)
	((and (symbol? pos)
	    (equal? pos 'flat))		(flatten Comp-List))
	((number? pos)			(nth (flatten Comp-List) pos))
	((member? pos Types)  		(send self 'Extract pos))
	((and (pair? pos)
	    (member? (car pos) Type)
	    (number? (cadr pos)))   (send self 'Extract (car pos) (cadr pos)))
	(#t			    (error 'Abstraction "Components ~a" pos))))

(define-method Comp-Type (get-NumbOfElems)
    (if (not checkd) (send self 'checkData))
    NumbOfElems)

(define-method Comp-Type (get-TotalNumbOfElems) 
    (if (not checkd) (send self 'checkData))
    TotalNumbOfElems)

(define-method Comp-Type (get-Variables)
    (if (not checkd) (send self 'checkData))
    (map (lambda (x y) (list x y)) Types Variables))


(define-method Comp-Type (get-VariablesValues . Tip)
    (if (not checkd) (send self 'checkData))
    (if (not (null? Tip)) (set! Tip (car Tip)))
    (map
	(lambda (x y)
	    (if (or (null? Tip)
		    (equal? x Tip))
	       (begin
		 (if (not (pair? y)) (set! y (list y)))
		 (cons x (map (lambda (z) (send z 'get-Variables)) y)))))
						(send self 'get-Types)
						(send self 'get-Components)))

(define-method Comp-Type (get-VariablesList . Tip)
  (if (not checkd) (send self 'checkData))
  (if (not (null? Tip)) (set! Tip (car Tip)))
  (map
   (lambda (x y)
     (if (or (null? Tip)
	     (equal? x Tip))
	(begin
	   (if (not (pair? y)) (set! y (list y)))
	   (cons x (map (lambda (z) (send z 'get-Variables 'List)) y)))))
						(send self 'get-Types)
						(send self 'get-Components)))

(define-method Comp-Type (get-VariablesDefaults . Tip)
  (if (not checkd) (send self 'checkData))
  (if (not (null? Tip)) (set! Tip (car Tip)))
  (map
   (lambda (x y)
     (if (or (null? Tip)
	     (equal? x Tip))
	(begin
	   (if (not (pair? y)) (set! y (list y)))
	   (cons x (map (lambda (z) (send z 'get-Variables 'Defaults)) y)))))
						(send self 'get-Types)
						(send self 'get-Components)))

(define-method Comp-Type (get-Values . Tip)
    (if (not checkd) (send self 'checkData))
    (if (not (null? Tip)) (set! Tip (car Tip)))
    (map
     (lambda (x y)
       (if (or (null? Tip)
	       (equal? x Tip))
	(begin
	   (if (not (pair? y)) (set! y (list y)))
	(cons x (map (lambda (z) (send z 'get-Variables 'Current)) y)))))
						(send self 'get-Types)
						(send self 'get-Components)))

(define (filtsymbs Lst)
   (map (lambda (x) (if (symbol? (car x)) (cadr x)
   			(map (lambda (y) (cadr y)) x))) (clean Lst)))

(define-method Comp-Type (get-Description)
    (newline)
    (prn " Total Number of Components :"TotalNumbOfElems)
    (prn " Number of different Types of Components :"(length Types))
    (for-each
       (lambda (x y z w)
       		(newline)
       		(prn "    Type "x)
		(prn "    Variables "z)
		(prn "    Number of Elements : "y)
		(prn "    Values : "(if (pair? w)
					(map (lambda (v)
						(send v 'get-Variables)) w)
					(if (abstraction? w)
					(send w 'get-Variables)))))
       Types NumbOfElems Variables Comp-List)
    (newline))

(define-method Comp-Type (make-Component tip numb)
    (let ((aux) (i numb))
	(while (> i 0)
	    (set! aux
	      (cons
		(cond
		    ((symbol? tip)   (if (not (bound? tip)) '()
		    		       (if (or (abstraction? (eval tip))
					       (abstraction-mold? (eval tip)))
					   (make-abstraction (eval tip)))))
		    ((abstraction-mold? tip)  (make-abstraction tip))
		    ((abstraction? tip)       (make-abstraction tip)))
		 aux))
	    (set! i (- i 1)))
	(if (= numb 1) (set! aux (car aux)))
	aux))

(define-method Comp-Type (set-Types Lst)
    (set! NumbOfElems '())
    (if (not (null? (clean Lst)))
       (begin
   	 (if (not (pair? Lst)) (set! Lst (list Lst)))
    	 (set! Types (clean Lst))
   	 (if (and (send self 'check-Types)
	          (send self 'check-NumbOfElems))
	 	(send self 'adjust)
		(error 'Components "check Types or NumbOfElems"))) #t))

(define-method Comp-Type (adjust-Type Code Elem) 
    (if (not checkd) (send self 'checkData))
    (if (or (null? Types)
    	    (not (symbol? Code)))
	(prn "Unable to adjust Component Type " Code)
	(if (not (send self 'checkelType Elem))
	    (prn "Unable to adjust Component Type " Elem)
	    (set! Types (map (lambda (x) (if (equal? Code x) Elem x)) Types))
	    (if (and (send self 'check-Types)
		     (send self 'check-NumbOfElems))
			(send self 'adjust)
			(error 'Components "check Types or NumbOfElems")))))

(define-method Comp-Type (add-Type Type . Numb)
    (if (not checkd) (send self 'checkData))
    (set! Numb (if (not (null? Numb))  (car Numb) 1))
    (if (not (number? Numb))
    	(prn "Unable to add Component Type "Numb)
    	(set! Types (append Types (list Type)))
    	(set! NumbOfElems (append NumbOfElems (list Numb)))
	(if (and (send self 'check-Types)
		 (send self 'check-NumbOfElems))
			(send self 'adjust)
			(error 'Components "check Types or NumbOfElems"))))
 
 (define-method Comp-Type (Extract-Component Tip . rfrnz)
  (let ((aux) (j -1) (resl))
    (set! rfrnz (cleanlist rfrnz))
    (for-each
	(lambda (x y) (if (equal? Tip x) (set! aux y))) Types Comp-List)
    (if (or (null? rfrnz)
    	    (not (pair? aux)))
	    aux
	    (for-each (lambda (x) (set! j (+ 1 j))
				 (if (= j (car rfrnz)) (set! resl x))) aux)
	    resl)))

(define-method Comp-Type (set-NumbOfElems Lst)
  (let ((aux1 (send self 'get-NumbOfElems))
  	(aux2 (send self 'get-TotalNumbOfElems)))
    (if (null? Lst) '()
	(set! TotalNumbOfElems '())
	(set! NumbOfElems Lst)
	(if (send self 'check-NumbOfElems)
	    (begin
	    	(send self 'adjust)
		(send self 'get-NumbOfElems))
	    (set! TotalNumbOfElems aux2)
	    (set! NumbOfElems aux1)
	    #f))))

(define-method Comp-Type (adjust-NumberofElement Tip Numb)
   (set! NumbOfElems 
   	(map (lambda (x y) (if (equal? x Tip) Numb y)) Types NumbOfElems))
   (send self 'check-NumbOfElems)
   (send self 'adjust))

(define-method Comp-Type (set-TotalNumbOfElems Num)
  (let ((aux1 (send self 'get-NumbOfElems))
  	(aux2 (send self 'get-TotalNumbOfElems)))
    (if (null? Num) '()
	(set! TotalNumbOfElems Num)
	(set! NumbOfElems '())
	(if (send self 'check-NumbOfElems)
	    (begin 
	    	(send self 'adjust)
		(send self 'get-NumbOfElems))
	    (set! TotalNumbOfElems aux2)
	    (set! NumbOfElems aux1)
	    #f))))

--- NEW FILE: abstr-functlity.foo ---
;
;;
;;;	Object Functionalities
;;
;


(define (make-an-instance2 Class . args)
  (check-class 'make-instance (eval Class))
  (let* ((e (the-environment))
	 (i (make-vector instance-size #f))
	 (class-env (class-env (eval Class)))
	 (instance-vars (class-instance-vars (eval Class))))
	(set-tag! i 'instance)
	(set-class-name! i Class)
	(set-instance-env! i
			    (eval `(let* ,instance-vars
				    (the-environment))
				    class-env))
	(eval `(set! self ',i) (instance-env i))
	(init-instance args (eval Class) i e)
	i))

(define (make-an-instance Class . args)
  (check-class 'make-instance Class)
  (let* ((e (the-environment))
	 (i (make-vector instance-size #f))
	 (class-env (class-env Class))
	 (instance-vars (class-instance-vars Class)))
	(set-tag! i 'instance)
	(set-class-name! i (vector-ref Class 1))
	(set-instance-env! i
			    (eval `(let* ,instance-vars
				    (the-environment))
				    class-env))
	(eval `(set! self ',i) (instance-env i))
	(init-instance args Class i e)
	i))

(define (make-a-class name . args)
  (let ((class-vars)
        (instance-vars (list (make-binding 'self)))
        (super)
        (super-class-env))
    (do ((a args (cdr a)))
        ((null? a))
        (cond ((not (pair? (car a)))
               (error 'define-class
                      "bad argument: ~s"
                      (car a)))
              ((eq? (caar a) 'class-vars)
               (check-vars (cdar a))
               (set! class-vars (cdar a)))
              ((eq? (caar a) 'instance-vars)
               (check-vars (cdar a))
               (set! instance-vars
                     (append instance-vars
                             (map make-binding
                                  (cdar a)))))
              ((eq? (caar a) 'super-class)
               (if (> (length (cdar a)) 1)
                   (error 'define-class
                          "only one super-class allowed"))
               (set! super (cadar a)))
              (else (error 'define-class
                           "bad keyword: ~s"
                           (caar a)))))
    (if (not (null? super))
        (let ((class (eval super)))
          (set! super-class-env (class-env class))
          (set! instance-vars
                (join-vars (class-instance-vars class)
                           instance-vars)))
        (set! super-class-env (the-environment)))
       (let ((c (make-vector class-size '())))
         (set-tag! c 'class)
         (set-class-name! c name)
         (set-class-instance-vars! c instance-vars)
         (set-class-env! c
                         (eval `(let* ,(map make-binding  class-vars)
                                       (the-environment))
                                        super-class-env))
         (set-class-super! c super)
         c)))

;
;;
;;;	Abstraction Functionalities
;;
;

(define (abstraction? f)
 (let ((name))
    (if (instance? f)
	  (begin
		(set! name (class-name f))
	  	(while (and (not (null? name))
	  	     	    (not (equal? name 'Abstraction)))
		    (set! name (get-SuperName (eval name))))
		(if (equal? name 'Abstraction) #t #f)) #f)))

(define (abstraction-mold? f)
   (let ((name))
	(if (class? f)
	  (begin
		(set! name (class-name f))
	  	(while (and (not (null? name))
	  	     	    (not (equal? name 'Abstraction)))
		    (set! name (get-SuperName (eval name))))
		(if (equal? name 'Abstraction) #t #f)) #f)))

(define HackdumVars)
(define HackdumFunx)
(define HackdumLocs)
(define HackdumHier)
(define HackdumNComps)
(define HackdumComps)

(define define-abstr-mold
  (macro (name . argms)
  `(define ,name (make-abstr-mold ',name ,@argms))))

(define (make-abstr-mold name . args)
  (let ((sup) (supPars) (Pars) (flg #t) (aux) (super 'Abstraction) (dum)
        (NLst (list 'Variables 'Locals 'NumbComponents 'Components
					     'Algorithm 'Hierarchy))
        (CLst (list 'Vars 'Locs 'NComps 'Comps 'Funx 'Hier)))

  (if (not (symbol? name))
   (begin
       (prn "The first argument should be a symbol :: The name of the mold")
       (prn "You should bind it to the same symbol-name. This is not a macro"))
   (if (not (null? args))
     (begin
       (for-each 
         (lambda (x) 
	   (cond
	      ((and (instance? x)
		    (abstraction? x))	     (set! sup x))
	      ((and (class? x)
		    (abstraction-mold? x))	     (set! sup x))
	      ((and (symbol? x)
		    (bound? x)
		    (instance? (eval x))
		    (abstraction? (eval x))) (set! sup (eval x)))
	      ((and (symbol? x)
		    (bound? x)
		    (class? (eval x))
		    (abstraction-mold? (eval x))) (set! sup (eval x)))
	      ((and (pair? x)
		    (symbol? (car x))
		    (member (car x) NLst))   (set! Pars (cons x Pars)))
	      (#t			     (set! flg #f)))) args)
       (if (not (null? sup))
       	  (begin
	   (set! super (class-name sup))
       	   (if (class? sup)
	   	(set! supPars (send (make-an-instance sup) 'getclassvars))
		(set! supPars (list 
			(cons 'Variables (send sup 'get-Variables 'List))
			(cons 'Locals (send sup 'get-Locals 'List))
			(cons 'Components (send sup 'get-Components 'Types))
		      (cons 'NumbComponents (send sup 'get-Components 'Number))
			(cons 'Algorithm (send sup 'get-Algorithm))
			(cons 'Hierarchy (send sup 'get-Hierarchy)))))))

       (for-each
         (lambda (x y)
	    (set! dum (assq x Pars))
	    (if (not dum) (set! dum (assq x supPars)))
	    (if dum
		(cond
		    ((equal? y 'Vars)  (set! HackdumVars (cdr dum))
				       (set! aux
				       	 (cons (list y (quote HackdumVars))
						aux)))
		    ((equal? y 'Locs)  (set! HackdumLocs (cdr dum))
				       (set! aux 
				         (cons (list y (quote HackdumLocs))
						aux)))
		    ((equal? y 'Comps) (set! HackdumComps (cdr dum))
				       (set! aux
				         (cons (list y (quote HackdumComps))
						aux)))
		   ((equal? y 'NComps) (set! HackdumNComps (cdr dum))
				       (set! aux
				         (cons (list y (quote HackdumNComps))
						aux)))
		    ((equal? y 'Funx)  (set! HackdumFunx (cdr dum))
				       (set! aux 
				         (cons (list y (quote HackdumFunx))
						aux)))
		    ((equal? y 'Hier)  (set! HackdumHier (cdr dum))
				       (set! aux 
				         (cons (list y (quote HackdumHier))
						aux)))))) NLst CLst)
	(make-a-class name `(super-class ,super) (cons 'class-vars aux)))
     (make-a-class name '(super-class Abstraction))))))


(define (make-abstraction . args)
  (let ((sup) (supPars) (Pars) (flg #t) (aux) (name 'Abstraction) (dum) (obj)
  	(NLst (list 'Variables 'Locals 'NumComponents 'Components
					    'Algorithm 'Hierarchy))
        (CLst (list 'Vars 'Locs 'NComps 'Comps 'Funx 'Hier)))

   (if (not (null? args))
     (begin
       (for-each 
         (lambda (x)
	   (cond
	      ((and (instance? x)
		    (abstraction? x))	     (set! sup x))
	      ((and (class? x)
		    (abstraction-mold? x))	     (set! sup x))
	      ((and (symbol? x)
		    (bound? x)
		    (instance? (eval x))
		    (abstraction? (eval x))) (set! sup (eval x)))
	      ((and (symbol? x)
		    (bound? x)
		    (class? (eval x))
		    (abstraction-mold? (eval x))) (set! sup (eval x)))
	      ((and (pair? x)
		    (symbol? (car x))
		    (member (car x) NLst))   (set! Pars (cons x Pars)))
	      (#t			     (set! flg #f)))) args)

       (if (not (null? sup))
       	  (begin
	   (set! name (class-name sup))
	   (if (instance? sup)
		(set! supPars (list 
			(cons 'Variables (send sup 'get-Variables 'List))
			(cons 'Locals (send sup 'get-Locals 'List))
		      (cons 'NumComponents (send sup 'get-Components 'Number))
			(cons 'Components (send sup 'get-Components 'Types))
			(cons 'Algorithm (send sup 'get-Algorithm))
			(cons 'Hierarchy (send sup 'get-Hierarchy))))) ))

       (for-each
         (lambda (x)
	    (set! dum (assq x Pars))
	    (if (not dum) (set! dum (assq x supPars)))
	    (if dum (set! aux (cons dum aux)))) NLst)
;       (define dum (make-an-instance2 name))
;	(define dum (eval name (the-environment)))
        (define dum (make-an-instance (eval name (the-environment))))
	(if (not (null? aux))
	  (begin
	    (apply send (append (list dum 'set-fields) aux))
	    (if (send dum 'checkData) dum (error 'Abstraction "Wrong Data")))
	  dum)
       )
       (make-instance Abstraction))))

(define (compute-abstraction obj . args)
   (if (abstraction? obj)
    (if (not (null? args)) (apply send (append (list obj 'compute) args))
	    	           (send obj 'compute))
    (error 'compute-abstraction "Not an Abstraction ~s" obj)))

(define (describe-abstraction obj)
    (if (abstraction? obj)
	(send obj 'get-Description)
	(if (abstraction-mold? obj)
	    (send (make-an-instance obj) 'get-mold-Description)
	    (prn" This is not an Abstraction"))))

(define (describe-abstr-mold obj)
    (if (abstraction-mold? obj)
	    (send (make-an-instance obj) 'get-mold-Description)
	    (prn" This is not an Abstraction-Mold")))

--- NEW FILE: abstraction.foo ---
(require 'oops)
(define-class Abstraction (class-vars Vars			;a List
				      Locs			;a List
				      Comps			;a List
				      NComps			;a List/Number
				      Funx			;a List
				      Hier)			;a List

			  (instance-vars Variables		;Var-type
					 Locals			;Var-type
					 Components		;Comp-type
					 Algorithm		;Funx-type
					 Hierarchy		;Hier-type
					 NumComponents		;Comp-type-var
					 Init-Val		;Private
					 Main-Val		;   "
					 Out-Val		;   "
					 Coda-Val))		;   "
;;;					 Unknown-Symbols))	;Listofsymbols
;;;					 ((Key-Words))		;Dictionary

(define-method Abstraction (getclassvars)
    (list (cons 'Variables Vars)
    	  (cons 'Locals Locs)
	  (cons 'Components Comps)
	  (cons 'NumComponents NComps)
	  (cons 'Algorithm Funx)
	  (cons 'Hierarchy Hier)))

(define-method Abstraction (setclassvars Lst)
   (for-each
	(lambda (x)
	    (cond
		((equal? (car x) 'Variables)	  (set! Vars  (cdr x)))
		((equal? (car x) 'Locals)	  (set! Locs  (cdr x)))
		((equal? (car x) 'NComponents)	  (set! NComps (cdr x)))
		((equal? (car x) 'Components)     (set! Comps (cdr x)))
		((equal? (car x) 'Algorithm)	  (set! Funx  (cdr x)))
		((equal? (car x) 'Hierarachy)	  (set! Hier  (cdr x))))) Lst)
    #t)

(define-method Abstraction (initialize-instance)
    (set! Variables   (make-instance Var-Type  (Variables Vars)))
    (set! Locals      (make-instance Var-Type  (Variables Locs)))
    (set! Components  (make-instance Comp-Type (Types Comps)))
    (set! Algorithm   (make-instance Funx-Type (Descriptor Funx)))
    (set! Hierarchy   (make-instance Hier-Type (Descriptor Hier)))
    (set! NumComponents (send Components 'set-NumbOfElems NComps))
    (if (send self 'checkData) #t (error 'Abstraction "Wrong Data")))

(define-method Abstraction (checkData)
  (let ((varunknwn))
  (if (and
	(send Variables  'checkData)
	(send Locals     'checkData)
	(send Components 'checkData)
	(send Algorithm  'checkData)
	(send Hierarchy  'checkData)) #t #f)))
;
(define-method Abstraction (get-Name) (class-name self))

(define-method Abstraction (compute . args)
  (let ((aux))

    (if (not (null? args))
    	 (apply send (append (list self 'set-Variables-Values) args)))
    (send self 'set-Initval '())
    (send self 'set-Mainval '())
    (send self 'set-Outval  '())
    (send self 'set-Codaval '())

    (send self 'Fix) 
    (send self 'set-Initval
    		  (send self 'parse 'Init (send self 'get-Algorithm 'Init)
    			           	  (send self 'get-Hierarchy 'Init)))
    (apply send (append (list self 'set-fields) (send self 'get-Initval)))
    (send self 'Fix) 
    (send self 'set-Mainval
    		  (send self 'parse 'Main (send self 'get-Algorithm 'Main)
    			                  (send self 'get-Hierarchy 'Main)))
    (apply send (append (list self 'set-fields) (send self 'get-Mainval)))
    (send self 'Fix) 
    (send self 'set-Outval 
    		  (send self 'parse 'Out  (send self 'get-Algorithm 'Out)
    			           	  '()))
    (apply send (append (list self 'set-fields) (send self 'get-Outval)))
    (send self 'Fix) 
    (send self 'set-Codaval 
    		  (send self 'parse 'Coda (send self 'get-Algorithm 'Coda)
    			           	  (send self 'get-Hierarchy 'Coda)))
    (apply send (append (list self 'set-fields) (send self 'get-Codaval)))
    (send self 'Fix) 

    (set! aux (assq 'out (send self 'get-Outval)))
    (if aux (cadr aux) (send self 'get-Outval))))

(define-method Abstraction (Fix)
  (let ((vars (send self 'get-Variables)) (aux))

    (for-each
      (lambda (x)
	(set! aux (assq (cadr x) vars))
	(if aux (send Locals 'set-Variables (cons (car x) aux))
      	 	(set! aux (assq (caddr x) vars))
	 	(if aux (send Locals 'set-Variables (cons (car x) aux)))))
					(send self 'get-Locals 'List))

    (set! vars (append vars (send self 'get-Locals)))
 
    (for-each
      (lambda (x)
	(if (assq x vars)
	   (send Components 'adjust-Type x (cadr (assq x vars)))))
					(send self 'get-Components 'Types))
   
    (set! aux (assq (send self 'get-NumComponents) vars))
    (if aux (send self 'set-NumComponents (cadr aux)))

    (for-each
      (lambda (x y)
	(if (assq x vars)
	   (send self 'set-Comp-Typ-Numb y (cadr (assq x vars)))))
					(send self 'get-Components 'Number)
					(send self 'get-Components 'Types))
    (for-each
      (lambda (x)
	(if (and (pair? (cadr x))
		 (= (length (cadr x)) 1))
	  (begin
	     (set! aux (assq (caadr x) vars))
	     (if aux
	         (send Hierarchy 'set-Descriptor (cons (car x) (cadr aux))))))) 
		  			(send self 'get-Hierarchy))))

(define-method Abstraction (set-fields . args)
  (let ((flg #t))

   (if (null? args) '()

    (for-each
      (lambda (x)

      (cond
        ((not (pair? x)) #f)
        ((= (length x) 1) #f)
	((equal? (car x) 'Variables)
	   (apply send (append (list self 'set-Variables) (cdr x))))
	((or (equal? (car x) 'Variables-Names)
	      	  (equal? (car x) 'VNames))
	   (apply send (append (list self 'set-Variables-Names) (cdr x))))
	((or (equal? (car x) 'Variables-Defaults)
	      	  (equal? (car x) 'VDefaults))
	   (apply send (append (list self 'set-Variables-Defaults) (cdr x))))
	((or (equal? (car x) 'VarValues)
	      	  (equal? (car x) 'Variables-Current)
	      	  (equal? (car x) 'Variables-Values)
	      	  (equal? (car x) 'VValues))
	   (apply send (append (list self 'set-Variables-Values) (cdr x))))

	((equal? (car x) 'Locals)
	   (apply send (append (list self 'set-Locals) (cdr x))))
	((or (equal? (car x) 'Locals-Names)
	      	  (equal? (car x) 'LNames))
	   (apply send (append (list self 'set-Locals-Names) (cdr x))))
	((or (equal? (car x) 'Locals-Defaults)
	      	  (equal? (car x) 'LDefaults))
	   (apply send (append (list self 'set-Locals-Defaults) (cdr x))))
	((or (equal? (car x) 'Locals-Values)
	      	  (equal? (car x) 'LValues))
	   (apply send (append (list self 'set-Locals-Values) (cdr x))))

	((equal? 'Hierarchy (car x))
	      			(send self 'set-Hierarchy (cdr x)))
	((equal? 'Init-Hier (car x))
	      			(send self 'set-Init-Hier (cdr x)))
	((equal? 'Main-Hier (car x))
	      			(send self 'set-Main-Hier (cdr x)))
	((equal? 'Coda-Hier (car x))
	      			(send self 'set-Coda-Hier (cdr x)))

	((equal? 'Algorithm (car x))
	      			(send self 'set-Algorithm (cdr x)))
	((equal? 'Init-Func (car x))
	      			(send self 'set-Init-Func (cdr x)))
	((equal? 'Main-Func (car x))
	      			(send self 'set-Main-Func (cdr x)))
	((equal? 'Out-Func (car x))
	      			(send self 'set-Out-Func (cdr x)))
	((equal? 'Coda-Func (car x))
	      			(send self 'set-Coda-Func (cdr x)))

	((and (equal? 'Components (car x))
	      (not (null? (cleanlist (cdr x)))))
	      			(send self 'set-Components (cdr x)))
	((equal? 'NumComponents (car x))
	      			(send self 'set-NumComponents (cadr x)))

	((member (car x) (send self 'get-Variables 'Names)) 
			(apply send (append (list self 'set-Variables) x)))
	((member (car x) (send self 'get-Locals 'Names))
	      		(apply send (append (list self 'set-Locals) x)))

	((symbol? (car x))
	        (for-each
	         (lambda (t v)
		  (if (member (car x) v)
			(send self 'set-Comp-Var-Val t x)))
			     (send self 'get-Components 'Types)
			     (send self 'get-Components 'VarNames)))
	(#t	(set! flg #f)))) args))
   flg))

(define-method Abstraction (parse Symb Funx Hier)
  (if (null? Funx) '()
    (let* ((aux) (resl) (varunknown) (symblst)
	   (db1 (append (list (list 'self self))
	   		(send self 'get-Variables)
			(send self 'get-Locals)
			(list (list 'Components (send self 'get-Components)))))
	   (db2 (reverse
	          (append (send self 'get-Initval) (send self 'get-Mainval)
		        (send self 'get-Outval)    (send self 'get-Codaval))))
	   (db3 (map
	 	   (lambda (x y) (list x y)) (send self 'get-Components 'Types)
					     (send self 'get-Components)))
	    (Funx (send self 'parse0 Funx Hier db1 db2 db3)))

    (set! varunknown (send self 'check Funx db1 db2 db3))
    (if (null? varunknown)
	  (map
	    (lambda (n)
	      (set! symblst (append symblst (cdr n)))
	      (set! n (car n))
	      (set! aux
		(list (car n)
		      (apply (cadr n)
			 (map (lambda (z)
			   (send self 'resolv z db1 db2 resl db3)) (cddr n)))))
	    (set! resl (cons aux resl))
	    (apply send (append (list self 'set-fields) (list aux)))
	    aux) Funx)
;else
      (if (or (equal? Symb 'Init)
	      (equal? Symb 'Main)
	      (equal? Symb 'Coda))
	(map
	    (lambda (n)
	      (set! symblst (append symblst (cdr n)))
	      (set! n (car n))
	      (set! aux
		(list (car n)
		  (apply (cadr n)
		     (map (lambda (z)
			(send self 'resolv z db1 db2 resl db3)) (cddr n)))))
	    (set! resl (cons aux resl))
	    aux) Funx)

	(prn "Undefined symbols in"Symb"Func : " varunknown)
	(list
	  (lambda v 
            (set! db1 (append (map (lambda (x y) (list x y)) varunknown v) 
	    		      db1))
	(cadr (assq 'out
            (map
	      (lambda (n)
		(set! symblst (append symblst  (cdr n)))
		(set! n (car n))
		(set! aux
		  (list (car n)
	                (apply (cadr n)
			(map (lambda (z)
			   (send self 'resolv z db1 db2 resl db3)) (cddr n)))))
		(set! resl (cons aux resl)) aux) Funx)))) varunknown))))))


(define-method Abstraction (parse0 Funx Hier db1 db2 db3)
  (let ((resl ()) (aux))
    (if (not (pair? (car Funx))) (set! Funx (list Funx)))
    (if (not (null? Hier))
	(begin
	  (for-each
	    (lambda (x)  (set! aux (assq x Funx))
		         (if aux (set! resl (cons aux resl)))) Hier)
	  (set! Funx (reverse resl))))
    (map
      (lambda (x) (if (symbol? (car x))
		         (begin
			   (set! aux (send self 'parse1 (cdr x) db1 db2 db3))
			   (list (append (list (car x)) (car aux)) (cadr aux)))
	 	         (send self 'parse1 x db1 db2 db3))) Funx)))


(define-method Abstraction (parse1 funx db1 db2 db3)
  (let ((fun (car funx)) (pars (cdr funx)) 
  	(allpars) (nwpars ())
        (n -1) (m -1) (l -1) (auxil)
        (varmap ()) (Symlst '()) (Resul))

    (if (not (procedure? fun))
    			   (set! fun (send self 'resolv fun db1 db2 '() db3)))
   (if (not (procedure? fun))
      (begin (prn "Error Abstraction : not a procedure "fun)
    	     (error 'Abstraction "Parse"))
      (set! allpars
	(map 
	  (lambda (x)
	    (cond
	       ((symbol? x)                (set! Symlst (cons x Symlst))
					   (set! nwpars (cons x nwpars))
					   (set! m (+ m 1)) (list 'L m))
	       ((and (pair? x)
		     (procedure? (car x))) (set! auxil (parse1 x db1 db2 db3))
					   (set! Symlst (append
					   (reverse (cadr auxil)) Symlst))
					   (set! auxil (car auxil))
					   (set! nwpars  (cons auxil nwpars))
					   (set! m (+ m 1)) (list 'L m))
	      ((and (pair? x)
		    (symbol? (car x))
		    (equal? (cadr x) 'map)) (set! Symlst (cons (car x) Symlst))
					    (set! varmap (cons (car x) varmap))
					    (set! n (+ 1 n)) (list 'M n))
	      ((and (pair? x)
		    (pair? (car x))
		    (procedure? (caar x))
		    (equal? (cadr x) 'map))
				(set! auxil
				     (send self 'parse1 (car x) db1 db2 db3))
				(set! Symlst (append
				(reverse (cadr auxil)) Symlst))
				(set! auxil (car auxil))
				(set! varmap (cons auxil varmap))
				(set! n (+ 1 n)) (list 'M n))
	      ((and (pair? x)
		    (pair? (car x))
		    (equal? (cadr x) 'map));(set! varmap (cons (car x) varmap))
					   ;(set! n (+ 1 n)) (list 'M n))
				(set! auxil
			   (send self 'parse1 (cons list (car x)) db1 db2 db3))
				(set! Symlst (append
				(reverse (cadr auxil)) Symlst))
				(set! auxil (car auxil))
				(set! varmap (cons auxil varmap))
				(set! n (+ 1 n)) (list 'M n))
	    ((pair? x)		(set! auxil
	    			 (send self 'parse1 (cons list x) db1 db2 db3))
				(set! Symlst (append
				(reverse (cadr auxil)) Symlst))
				(set! auxil (car auxil))
				(set! nwpars  (cons auxil nwpars))
				(set! m (+ m 1)) (list 'L m))
	    (#t                             (set! nwpars (cons x nwpars))
					    (set! m (+ m 1)) (list 'L m)))) 
	  pars))
      (set! nwpars (reverse nwpars))
      (set! varmap (reverse varmap))
      (set! n -1)

      (list
        (if (null? varmap)
            (cons fun nwpars)
	    (append (list map
		         (if (null? nwpars)
			     (lambda m (apply fun m))
			     (list apply (lambda l (lambda m (apply fun
				 (map (lambda (x)
			             (if (equal? (car x) 'L) (nth l (cadr x))
						             (nth m (cadr x))))
				     allpars))))
			         nwpars)))
		      varmap))
        Symlst))))

(define-method Abstraction (resolv el db1 db2 db3 db4)
  (let ((db (append db1 db2 db3)) (aux1) (aux2) (v) (aux3))
   (cond
      ((symbol? el)
      	    (set! aux1 (assq el (append db3 db2 db4)))
	    (if aux1
	      (cadr aux1)
      	      (set! aux2 (assq el db1))
	      (if aux2
	       (begin
		 (set! aux2 (cadr aux2))
      	         (cond
      	           ((symbol? aux2) (set! aux3 (assq aux2 (append db3 db2 db4)))
			           (if aux3 (cadr aux3) aux2))
      	           (#t	   aux2)))
      	       (if (equal? el 'out) (send self 'get-Outval) el))))
      ((pair? el)
      	    (if (procedure? (car el))
	       (apply (car el) 
                        (map (lambda (x) (send self 'resolv x db1 db2 db3 db4)) 
				     (cdr el)))
	       (map (lambda (x) (send self 'resolv x db1 db2 db3 db4)) el)))
      (#t            el))))
(define-method Abstraction  (check0 el db1 db2 db3 db4)
   (if  (or (assq el db1)
   	    (assq el db2)
	    (assq el db3)
	    (equal? el 'out)
   	    (member el db4)) #f el))

(define-method Abstraction (check funx db1 db2 db3)
    (let* ((dbvar ()) (resl) (aux) (symlst ()))
	(for-each
	  (lambda (n) 
	    	(set! symlst (append symlst  (cadr n)))
	    	(set! n (car n))
	    	(set! dbvar (cons  (car n) dbvar))) funx)
	(for-each
	  (lambda (x)
	  	(set! aux (send self 'check0 x db1 db2 db3 dbvar))
		(if (and aux 
			(not (member aux resl)))
				(set! resl (cons aux resl)))) symlst)
	(reverse resl)))
;
(define-method Abstraction (reset-VarLocs)
  (let ((lnz (length (send self 'get-Variables))))
     (apply send (append (list self 'set-Variables) (make-list lnz '())))
     (set! lnz (length (send self 'get-Locals)))
     (apply send (append (list self 'set-Locals) (make-list lnz '())))))
;
(define-method Abstraction (set-Initval Lst) (set! Init-Val Lst))
(define-method Abstraction (set-Mainval Lst) (set! Main-Val Lst))
(define-method Abstraction (set-Outval Lst)  (set! Out-Val Lst))
(define-method Abstraction (set-Codaval Lst) (set! Coda-Val Lst))
(define-method Abstraction (get-Initval) Init-Val)
(define-method Abstraction (get-Mainval) Main-Val)
(define-method Abstraction (get-Outval)  Out-Val)
(define-method Abstraction (get-Codaval) Coda-Val)

;
;;
;;;	Methods to set! the object-fields
;;
;

(define-method Abstraction (set-Variables . Lst)
  (if (send Variables 'set-Variables Lst)
	(send self 'get-Variables 'List)
	(error 'Abstraction "set-Variables : ~a" Lst)))

(define-method Abstraction  (reset-Variables . Lst)
  (if (send Variables 'reset-Variables Lst)
	(send self 'get-Variables 'List)
	(error 'Abstraction "reset-Variables : ~a" Lst)))

(define-method Abstraction (set-Variables-Names . Lst)
  (if (send Variables 'set-Names Lst)
	(send self 'get-Variables 'List)
	(error 'Abstraction "set-Variables-Names : ~a" Lst)))

(define-method Abstraction (set-Variables-Defaults . Lst)
  (if (send Variables 'set-Defaults Lst)
	(send self 'get-Variables 'List)
	(error 'Abstraction "set-Variables-Defaults : ~a" Lst)))

(define-method Abstraction (set-Variables-Values . Lst)
  (if (send Variables 'set-Values Lst)
	(send self 'get-Variables 'List)
	(error 'Abstraction "set-Variables-Values : ~a" Lst)))

(define-method Abstraction (add-Variable Lst . pos)
  (if (send Variables 'add-Variable Lst pos)
	(send self 'get-Variables 'List)
	(error 'Abstraction "add-Variable : ~a ~a" Lst pos)))

(define-method Abstraction (remove-Variable Elm)
  (if (send Variables 'remove-Variable Elm)
	(send self 'get-Variables 'List)
	(error 'Abstraction "remove-Variable : ~a" Elm)))

(define-method Abstraction (set-Locals . Lst)
  (if (send Locals 'set-Variables Lst)
	(send self 'get-Locals 'List)
	(error 'Abstraction "set-Locals : ~a" Lst)))

(define-method Abstraction (reset-Locals . Lst)
  (if (send Locals 'reset-Variables Lst)
	(send self 'get-Locals 'List)
	(error 'Abstraction "reset-Locals : ~a" Lst)))

(define-method Abstraction (set-Locals-Names . Lst)
  (if (send Locals 'set-Names Lst)
	(send self 'get-Locals 'List)
	(error 'Abstraction "set-Locals-Names : ~a" Lst)))

(define-method Abstraction (set-Locals-Defaults . Lst)
  (if (send Locals 'set-Defaults Lst)
	(send self 'get-Locals 'List)
	(error 'Abstraction "set-Locals-Defaults : ~a" Lst)))

(define-method Abstraction (set-Locals-Values . Lst)
  (if (send Locals 'set-Values Lst)
	(send self 'get-Locals 'List)
	(error 'Abstraction "set-Locals-Values : ~a" Lst)))

(define-method Abstraction (add-Local Lst . pos)
  (if (send Locals 'add-Variable Lst pos)
	(send self 'get-Variables 'List)
	(error 'Abstraction "add-Local : ~a ~a" Lst pos)))

(define-method Abstraction (remove-Local Elm)
  (if (send Locals 'remove-Variable Elm)
	(send self 'get-Variables 'List)
	(error 'Abstraction "remove-Local : ~a" Elm)))

(define-method Abstraction (set-Algorithm . Lst)
    (if (send Algorithm 'set-Descriptor (clean Lst))
    	(send self 'get-Algorithm)
	(error 'Abstraction "set-Algorithm : ~a" Lst)))

(define-method Abstraction (reset-Algorithm . Lst)
  (let ((aux (send self 'get-Algorithm)))
    (send Algorithm 'set-Descriptor '())
    (if (send Algorithm 'set-Descriptor (clean Lst))
    	(send self 'get-Algorithm)
	(error 'Abstraction "reset-Algorithm : ~a" Lst))))

(define-method Abstraction (set-Init-Func . Lst)
    (if (send Algorithm 'set-Init-Func Lst)
    	(send self 'get-Algorithm)
	(error 'Abstraction "set-Init-Func : ~a" Lst)))

(define-method Abstraction (set-Main-Func . Lst)
    (if (send Algorithm 'set-Main-Func Lst)
    	(send self 'get-Algorithm)
	(error 'Abstraction "set-Main-Func : ~a" Lst)))

(define-method Abstraction (set-Out-Func . Lst)
    (if (send Algorithm 'set-Out-Func Lst)
    	(send self 'get-Algorithm)
	(error 'Abstraction "set-Out-Func : ~a" Lst)))

(define-method Abstraction (set-Coda-Func . Lst)
    (if (send Algorithm 'set-Coda-Func Lst)
    	(send self 'get-Algorithm)
	(error 'Abstraction "set-Coda-Func : ~a" Lst)))

(define-method Abstraction (set-Hierarchy . Lst)
    (if (send Hierarchy 'set-Descriptor (clean Lst))
    	(send self 'get-Hierarchy)
	(error 'Abstraction "set-Hierarchy : ~a" Lst)))

(define-method Abstraction (set-Init-Hier Lst)
    (if (not (list? Lst)) (set! Lst (list Lst)))
    (if (send Hierarchy 'set-Init-Hier Lst)
    	(send self 'get-Hierarchy)
	(error 'Abstraction "set-Init-Hier : ~a" Lst)))

(define-method Abstraction (set-Main-Hier Lst)
    (if (not (list? Lst)) (set! Lst (list Lst)))
    (if (send Hierarchy 'set-Main-Hier Lst)
    	(send self 'get-Hierarchy)
	(error 'Abstraction "set-Main-Hier : ~a" Lst)))

(define-method Abstraction (set-Coda-Hier Lst)
    (if (not (list? Lst)) (set! Lst (list Lst)))
    (if (send Hierarchy 'set-Coda-Hier Lst)
    	(send self 'get-Hierarchy)
	(error 'Abstraction "set-Coda-Hier : ~a" Lst)))

(define-method Abstraction (set-Components . Lst)
    (if (send Components 'set-Types Lst)
    	(send self 'get-Components 'Types)
	(error 'Abstraction "set-Components : ~a" Lst)))

(define-method Abstraction (set-NumComponents Lst)
  (let ((aux (send self 'get-Components 'Types)) (flg #t))
    (if (symbol? Lst)
    	(begin
	    (set! NumComponents Lst)
	    Lst)
	(if (or (pair? Lst)
		(= (length aux) 1))
	    (set! flg (send Components 'set-NumbOfElems Lst))
	    (set! flg (send Components 'set-TotalNumbOfElems Lst)))
	(if flg
	   (begin
		(set! NumComponents (send self 'get-Components 'Number))
		NumComponents)
	(error 'Abstraction "set-NumComponents : ~a" Lst)))))

(define-method Abstraction (set-Comp-Typ-Numb Typ Num)
  (let ((aux (send self 'get-Components 'Types)) (flg #t))
    (if (and (member Typ aux)
    	     (number? Num))
	(set! flg (send Components 'adjust-NumberofElement Typ Num))
	(set! flg #f))
    (if flg (send self 'get-Components 'Number)
	(error 'Abstraction "set-Comp-Typ-Numb : ~a ~a" Typ Num))))

(define-method Abstraction (set-Comp-Var-Val Typ Lst . ind)
  (let ((aux) (i -1) (ind (if (not (null? ind)) (car ind) '())))
    (for-each 
     (lambda (x y)
      (if (equal? Typ x) (set! aux y))) (send self 'get-Components 'Types)
					(send self 'get-Components))
    (if (not (pair? aux)) (set! aux (list aux)))
    (if (not (null? aux))
       (for-each
	(lambda (x)
	  (set! i (+ i 1))
	  (if (or (null? ind) (= ind i))
	    (apply send (append (list x 'set-Variables-Values) Lst)))) aux)))
   #t)

(define-method Abstraction (set-Comp-Var-Def Typ Lst . ind)
  (let ((aux) (i -1) (ind (if (not (null? ind)) (car ind) '())))
    (for-each 
     (lambda (x y)
      (if (equal? Typ x) (set! aux y))) (send self 'get-Components 'Types)
					(send self 'get-Components))
    (if (not (pair? aux)) (set! aux (list aux)))
    (if (not (null? aux))
       (for-each
	(lambda (x)
	  (set! i (+ i 1))
	  (if (or (null? ind) (= ind i))
	   (apply send (append (list x 'set-Variables-Defaults) Lst)))) aux)))
  #t)


;
;;
;;;	Methods to get data from the object-fields
;;
;

(define-method Abstraction (get-NumComponents) NumComponents)
(define-method Abstraction (get-Varnames)  (send self 'get-Variables 'Names))
(define-method Abstraction (get-Varvalues) (send self 'get-Variables))
(define-method Abstraction (get-Localsnames) (send self 'get-Locals 'Names))
(define-method Abstraction (get-Localsvalues) (send self 'get-Locals))
(define-method Abstraction (get-Componentsnames)
					 (send self 'get-Components 'Types))
(define-method Abstraction (get-NumberOfComponents)
				   	(send self 'get-Components 'Number))
(define-method Abstraction (get-TotalNumberOfComponents)
				    (send self 'get-Components 'TotalNumber))

(define-method Abstraction (get-Variables . Args)
   (if (null? Args)
	(send Variables 'get-Variables)
	(set! Args (car Args))
	(cond
	   ((null? Args)		(send Variables 'get-Variables))
	   ((equal? Args 'List)		(send Variables 'get-Variables-List))
	   ((equal? Args 'Names)	(send Variables 'get-Names))
	   ((equal? Args 'Defaults)	(send Variables 'get-Defaults))
	   ((equal? Args 'Current)	(send Variables 'get-Values)))))

(define-method Abstraction (get-Locals . Args)
   (if (null? Args)
	(send Locals 'get-Variables)
	(set! Args (car Args))
	(cond
	   ((null? Args)		(send Locals 'get-Variables))
	   ((equal? Args 'List)		(send Locals 'get-Variables-List))
	   ((equal? Args 'Names)	(send Locals 'get-Names))
	   ((equal? Args 'Defaults)	(send Locals 'get-Defaults))
	   ((equal? Args 'Current)	(send Locals 'get-Values)))))

(define-method Abstraction (get-Algorithm . Args)
   (if (null? Args)
	(send Algorithm 'get-Descriptor)
	(set! Args (car Args))
	(cond
	   ((equal? Args 'Init)		(send Algorithm 'get-Init-Func))
	   ((equal? Args 'Main)		(send Algorithm 'get-Main-Func))
	   ((equal? Args 'Out)		(send Algorithm 'get-Out-Func))
	   ((equal? Args 'Coda)		(send Algorithm 'get-Coda-Func)))))

(define-method Abstraction (get-Hierarchy . Args)
   (if (null? Args)
	(send Hierarchy 'get-Descriptor)
	(set! Args (car Args))
	(cond
	   ((equal? Args 'Init)		(send Hierarchy 'get-Init-Hier))
	   ((equal? Args 'Main)		(send Hierarchy 'get-Main-Hier))
	   ((equal? Args 'Coda)		(send Hierarchy 'get-Coda-Hier)))))


(define-method Abstraction (get-Components . Args)
 (if (null? Args)
   (send Components 'get-Components)
   (set! Args (car Args))
   (cond
    ((null? Args)		      (send Components 'get-Components))
    ((equal? Args 'Description)       (send Components 'get-Description))
    ((equal? Args 'Number)	      (send Components 'get-NumbOfElems))
    ((equal? Args 'TotalNumber)       (send Components 'get-TotalNumbOfElems))
    ((equal? Args 'Types)	      (send Components 'get-Types))
    ((equal? Args 'Variables)	      (send Components 'get-VariablesValues))
    ((equal? Args 'VariablesList)     (send Components 'get-VariablesList))
    ((equal? Args 'VariablesNames)    (send Components 'get-Variables))
    ((equal? Args 'VariablesCurrent)  (send Components 'get-Values))
    ((equal? Args 'VariablesDefaults) (send Components 'get-VariablesDefaults))
    ((equal? Args 'VarNames)          (send Components 'get-Variables))
    ((equal? Args 'VarValues)         (send Components 'get-Values)))))

(define-method Abstraction (Extract-Component Typ . rfrnz)
    (send Components 'Extract-Component Typ rfrnz))

(define-method Abstraction (get-Description)
    (newline)
    (prn "This is an Abstraction of Type : "(send self 'get-Name))
    (newline)
    (prn " Variables : "(send self 'get-Variables 'List))
    (prn " Locals    : "(send self 'get-Locals 'List))
    (send self 'get-Components 'Description)
    (prn " Algorithm : ")
    (prn "    Initialization  :"(send self 'get-Algorithm 'Init))
    (prn "    Main-Body       :"(send self 'get-Algorithm 'Main))
    (prn "    Output Function :"(send self 'get-Algorithm 'Out))
    (prn "    Coda            :"(send self 'get-Algorithm 'Coda))
    (newline)
    (prn " Hierarchy : ")
    (prn "    Initialization  :"(send self 'get-Hierarchy 'Init))
    (prn "    Main-Body       :"(send self 'get-Hierarchy 'Main))
    (prn "    Coda            :"(send self 'get-Hierarchy 'Coda)))

(define-method Abstraction (get-mold-Description)
  (let ((aux (send self 'getclassvars)) (aux1))
    (newline)
    (prn "This is the Abstraction-mold : "(send self 'get-Name))
    (newline)

    (set! aux1 (assq 'Variables aux))
    (prn " Variables : "(if aux1 (cdr aux1) "Undefined"))
    (set! aux1 (assq 'Locals aux))
    (prn " Locals    : "(if aux1 (cdr aux1) "Undefined"))

    (set! aux1 (assq 'Components aux))
    (prn " Component Types : "(if aux1 (cdr aux1) "Undefined"))

    (set! aux1 (assq 'Algorithm aux))
    (set! aux1 (if aux1 (cdr (assq 'Algorithm aux)) '()))
    (if (null? aux1)
      (prn " Algorithm : Undefined")
      (prn " Algorithm : ")
      (prn "    Initialization  :"(if (assq 'Init-Func aux1) 
    				    (cdr (assq 'Init-Func aux1)) "Undefined"))
      (prn "    Main-Body       :"(if (assq 'Main-Func aux1) 
    				    (cdr (assq 'Main-Func aux1)) "Undefined"))
      (prn "    Output Function :"(if (assq 'Out-Func aux1) 
    				    (cdr (assq 'Out-Func aux1))
				    (if (assq 'out aux1)
				       (cdr (assq 'out aux1))
				       (car aux1))))
      (prn "    Coda            :"(if (assq 'Coda-Func aux1) 
    				    (cdr (assq 'Coda-Func aux1)) 
				    "Undefined")))
    (newline)
    (set! aux1 (assq 'Hierarchy aux))
    (set! aux1 (if aux1 (cdr (assq 'Hierarchy aux)) '()))
    (if (null? aux1)
      (prn " Hierarchy : Undefined")
      (prn " Hierarchy : ")
      (prn "    Initialization  :"(if (assq 'Init-Hier aux1) 
    				    (cadr (assq 'Init-Hier aux1)) "Undefined"))
      (prn "    Main-Body       :"(if (assq 'Main-Hier aux1) 
    				    (cadr (assq 'Main-Hier aux1)) "Undefined"))
      (prn "    Coda            :"(if (assq 'Coda-Hier aux1) 
    				    (cadr (assq 'Coda-Hier aux1)) 
				    "Undefined")))))

--- NEW FILE: funx-type.foo ---
(define-class Funx-Type (instance-vars Descriptor
				       Init-Func
			 	       Main-Func
				       Out-Func
				       Coda-Func
				       Init-Symbols
				       Main-Symbols
				       Out-Symbols
				       Coda-Symbols))

(define-method Funx-Type (checkData)
   (let ((flg #t))
	(if (null? Descriptor)
	   (if (and (null? Init-Func)
		    (null? Main-Func)
		    (null? Out-Func)
		    (null? Coda-Func))
		#t
		(if (not (send self 
		        'set-Descriptor (list (list 'Init-Func Init-Func)
					      (list 'Main-Func Main-Func)
					      (list 'Out-Func  Out-Func)
					      (list 'Coda-Func Coda-Func))))
			(set! flg #f)))
	   (if (not (send self 'set-Descriptor Descriptor)) (set! flg #f)))
	(if (not flg) (prn "Error Algorithm "Descriptor))
	flg))

(define-method Funx-Type (set-Descriptor Lst)
  (let ((SymLst (list 'Init-Func 'Main-Func 'Out-Func 'Coda-Func)) 
   	(aux) (flg #t))

    (if (not (null? (flatout Lst)))
       (if (not (pair? Lst))
       	   (set! flg #f)

   	   (set! aux (first-symbol Lst))
           (if (not (member aux SymLst))
		(set! Lst (list (list 'Out-Func Lst)))
		(if (symbol? (car Lst)) (set! Lst (list Lst))))
   	   (for-each
   	     (lambda (x)
               (set! aux 
	         (cond
	           ((equal? (car x) 'Init-Func)
				 (send self 'set-Init-Func (clean (cdr x))))
	           ((equal? (car x) 'Main-Func)
				 (send self 'set-Main-Func (clean (cdr x))))
	           ((equal? (car x) 'Out-Func)
				 (send self 'set-Out-Func  (clean (cdr x))))
	           ((equal? (car x) 'Coda-Func)
				 (send self 'set-Coda-Func (clean (cdr x))))))
               (if (not aux) (set! flg #f))) Lst)
   	   (if flg (set! Descriptor (list (list 'Init-Func Init-Func)
				          (list 'Main-Func Main-Func)
				          (list 'Out-Func  Out-Func)
				          (list 'Coda-Func Coda-Func)))))
		   (set! Init-Func '()) (set! Main-Func '())
		   (set! Out-Func '()) (set! Coda-Func '())
		   (set! Descriptor (list (list 'Init-Func '())
		   			  (list 'Main-Func '())
					  (list 'Out-Func '())
					  (list 'Coda-Func '()))))
	flg))

(define (first-symbol Lst)
    (let ((resl '()) (Lst (flatten Lst)))
    	(while (and (null? resl) (not (null? Lst)))
	    (if (symbol? (car Lst)) (set! resl (car Lst))
	    			    (set! Lst (cdr Lst))))
	resl))

(define-method Funx-Type (set-Init-Func Lst)
    (set! Lst (send self 'check Lst))
    (if (or (null? Lst) Lst)
    	(begin (set! Init-Func Lst)
	       (set! Descriptor '())
	       (set! Init-Symbols (symbols Lst))
	       #t)
	(set! Init-Func '())
	#f))

(define-method Funx-Type (set-Main-Func Lst)
    (set! Lst (send self 'check Lst))
    (if (or (null? Lst) Lst)
    	(begin (set! Main-Func Lst)
	       (set! Descriptor '())
	       (set! Main-Symbols (symbols Lst))
	       #t)
	(set! Main-Func '())
	#f))

(define-method Funx-Type (set-Out-Func Lst)
  (if (or (null? Lst)
  	  (null? (flatout Lst)))
     (begin (set! Out-Func Lst)
	       (set! Descriptor '())
	       (set! Out-Symbols '())
	       #t)
     (while (and (= (length Lst) 1)
   	         (pair? (car Lst)))	(set! Lst (car Lst)))
     (if (and (symbol? (car Lst))
    	      (equal? 'out (car Lst))) (set! Lst (list Lst))
	     			       (set! Lst (list (cons 'out Lst))))
     (set! Lst (send self 'check Lst))
     (if (and Lst (not (null? Lst)))
    	(begin (set! Out-Func Lst)
	       (set! Descriptor '())
	       (set! Out-Symbols (symbols Lst))
	       #t)
	(set! Out-Func '())
	#f)))

(define-method Funx-Type (set-Coda-Func Lst)
    (set! Lst (send self 'check Lst))
    (if (or (null? Lst) Lst)
    	(begin (set! Coda-Func Lst)
	       (set! Descriptor '())
	       (set! Coda-Symbols (symbols Lst))
	       #t)
	(set! Coda-Func '())
	#f))

(define (symbols Lst)
    (map
	(lambda (x)
		(cons (car x) (body-symbs (cdr x)))) Lst))

(define (body-symbs Lst)
   (let ((aux))
   	(for-each
	    (lambda (x)
		(if (symbol? x) (set! aux (cons x aux)))) (flatten Lst))
	aux))

(define-method Funx-Type (canonic Lst)
  (let ((aux))

    (while (and (pair? Lst)
		(= (length Lst) 1)
		(pair? (car Lst))) (set! Lst (car Lst)))
    (if (symbol? (car Lst)) (set! Lst (list Lst)))

    (map (lambda (x) (set! aux (send self 'canterm x))
		     (cons (car aux) (send self 'canbody (cdr aux)))) Lst)))

(define-method Funx-Type  (canterm Lst)
    (if (and (pair? Lst)
        (= (length Lst) 1)) (send self 'canterm (car Lst)) Lst))

(define-method Funx-Type  (canbody Lst)
    (if (and (= (length Lst) 1)
	     (pair? (car Lst))) (set! Lst (send self 'canbody (car Lst))))
    (map (lambda (x) (send self 'canparm x)) Lst))

(define-method Funx-Type (canparm Lst) Lst)

(define-method Funx-Type (check Lst)
  (let ((flg #t))

    (if (null? (cleanlist Lst)) '()

	(set! Lst (send self 'canonic Lst))
	(for-each
	  (lambda (x) (if (not (send self 'checkterm x)) (set! flg #f))) Lst)
	(if flg Lst #f))))

(define-method Funx-Type (checkterm el)
    (if (and (symbol? (car el)) (send self 'checkbody (cdr el))) el #f))

(define-method Funx-Type (checkbody expr)
  (let ((flg #t))
    (for-each
     (lambda (x) (if (not (send self 'checkpars x)) (set! flg #f))) (cdr expr))

    (if (and flg
    	     (or (symbol? (car expr))
	     	 (procedure? (car expr)))) expr #f)))

(define-method Funx-Type (checkpars el)
    (cond
    	((pair? el)		(send self 'checkpairpar el))
	(#t			#t)))

(define-method Funx-Type (checkpairpar el)
  (let ((flg #t))
    (for-each (lambda (x) (if flg (set! flg (checkpars x)))) el)
    (cond
	(flg							#t)
	((and (equal? 'map (cadr el))
	      (or (symbol? (car el))
	      	  (and (pair? (car el))
		       (send self 'checkpairpar (car el)))))	#t)
        ((send self 'checkbody el)				#t)
	(#t							#f))))


(define-method Funx-Type (get-Descriptor)
   (if (null?  Descriptor) (list (list 'Init-Func Init-Func)
	    			 (list 'Main-Func Main-Func)
				 (list 'Out-Func  Out-Func)
				 (list 'Coda-Func Coda-Func))
   			   Descriptor))

(define-method Funx-Type (get-Init-Func)  Init-Func)
(define-method Funx-Type (get-Main-Func)  Main-Func)
(define-method Funx-Type (get-Out-Func)   Out-Func)
(define-method Funx-Type (get-Coda-Func)  Coda-Func)

(define-method Funx-Type (get-Symbols)
   (append Init-Symbols Main-Symbols Out-Symbols Coda-Symbols))

(define-method Funx-Type (get-Init-Symbols) Init-Symbols)
(define-method Funx-Type (get-Main-Symbols) Main-Symbols)
(define-method Funx-Type (get-Out-Symbols)  Out-Symbols)
(define-method Funx-Type (get-Coda-Symbols) Coda-Symbols)


--- NEW FILE: var-type.foo ---
(require 'oops)
(define-class Var-Type (instance-vars  Variables
				       (checkd #f)))

(define-method Var-Type (checkData)
  (let ((flg #t) (aux) (varis))
   (set! varis
    (cond
       ((null? Variables)	'())
       ((pair? Variables)	(map (lambda (x)
       					(set! aux (send self 'check0 x))
					(if (not aux) (set! flg #f)) aux)
				      Variables))
       ((symbol? Variables)	(list (list Variables '() '())))
       (#t			(set! flg #f))))
   (set! checkd #t)
   (if flg (begin (set! Variables varis) #t)
   	   (set! Variables '())   #f)))

(define-method Var-Type (check0 el)
    (cond
	((symbol? el)			(list el '() '()))
	((and (pair? el)
	      (= (length el) 1))	(send self 'check0 (car el)))
	((and (pair? el)
	      (= (length el) 2)
	      (symbol? (car el)))	(list (car el) (cadr el) '()))
	((and (pair? el)
	      (= (length el) 3)
	      (symbol? (car el)))	el)
	(#t				#f)))

(define-method Var-Type (get-Names)
    (if (not checkd) (send self 'checkData))
    (map (lambda (x) (car x)) Variables))

(define-method Var-Type (get-Defaults)
    (if (not checkd) (send self 'checkData))
    (map (lambda (x) (cadr x)) Variables))

(define-method Var-Type (get-Values)
    (if (not checkd) (send self 'checkData))
    (map (lambda (x) (caddr x)) Variables))

(define-method Var-Type (get-Variables)
    (if (not checkd) (send self 'checkData))
    (map (lambda (x) (if (null? (caddr x))
    			 (list (car x) (cadr x))
			 (list (car x) (caddr x))))  Variables))

(define-method Var-Type (get-Variables-List)
    (if (not checkd) (send self 'checkData))
    Variables)

(define-method Var-Type (reset-Variables . Lst)
   (set! Variables '())
   (if (not (null? Lst)) (apply send (append (list self 'set-Variables) Lst)))
   #t)

(define-method Var-Type (set-Names Lst)
   (set! Lst (flatten Lst))
   (if (not (symbolic? Lst))
   	'()
   	(send self 'set-Variables (map (lambda (x) (list x '() '())) Lst))))

(define-method Var-Type (set-Defaults Lst)
  (let ((vars (send self 'get-Variables-List)) (aux) (dum))


    (if (or (null? vars)
    	    (null? Lst))
       '()

	(if (not (pair? Lst))
	    (set! Variables
	    		(cons (list (caar vars) Lst (caddar vars)) (cdr vars)))

	    (set! dum (first-symbol Lst))
	    (if (assq dum vars)
	      (if (equal? (car Lst) dum)
	        (set! Variables
			(cons (list (caar vars) (car Lst) (caddar vars))
		  		    (cdr vars)))
		(set! Variables
		 (map
		  (lambda (x)
		     (set! aux (assq (car x) Lst))
		     (if (not aux) (set! aux (member (car x) Lst)))
		     (set! aux (if aux (cadr aux) '()))
		     (list (car x) aux (caddr x))) vars)))

	      	(set! aux
		 (map (lambda (x y) (list (car x) y (caddr x))) vars Lst))
	      	(set! dum (length aux))
	      	(if (< dum (length vars))
			(set! aux (append aux (list-tail vars dum))))
	      	(set! Variables aux)))

	(if (send self 'checkData)
		(send self 'get-Variables-List)
    		(set! Variables vars) #f))))

(define-method Var-Type (set-Values Lst)
  (let ((vars (send self 'get-Variables-List)) (dum) (aux))

    (if (or (null? vars)
    	    (null? Lst))
       '()

	(if (not (pair? Lst))
	    (set! Variables
	    		(cons (list (caar vars) (cadar vars) Lst) (cdr vars)))

	    (set! dum (first-symbol Lst))
	    (if (assq dum vars)
	      (if (equal? (car Lst) dum)
	        (set! Variables (cons (list (caar vars) (cadar vars) (car Lst))
		  		   (cdr vars)))
		(set! Variables
		 (map
		  (lambda (x)
		     (set! aux (assq (car x) Lst))
		     (if (not aux) (set! aux (member (car x) Lst)))
		     (set! aux (if aux (cadr aux) '()))
		     (list (car x) (cadr x) aux)) vars)))

	      	(set! aux
		 (map (lambda (x y) (list (car x) (cadr x) y)) vars Lst))
	      	(set! dum (length aux))
	      	(if (< dum (length vars))
			(set! aux (append aux (list-tail vars dum))))
	      	(set! Variables aux)))

	(if (send self 'checkData)
		(send self 'get-Variables-List)
    		(set! Variables vars) #f))))


(define-method Var-Type (set-Variables Lst)
  (let ((vars (send self 'get-Variables-List)) (dum) (aux) (i -1)
  	(flg1 #t) (flg2 #t) (flg3 #f))

   (if (or (null? Lst)
           (and (null? vars)
	   	(null? (car Lst))))
      #t
      (if (null? vars)
 ...
 
[truncated message content]