Ch7, Ex4

To allow multiple inheritance(for 1 or more), I have just generalized the "From" function from the book. Instead of taking fixed number of classes to be inherited it now takes a list of classes to be inherited.
I'm redoing the Account, LoggedAccount example from section 7.3.2 to show how to achieve static binding with the object system of section 7.6 . However, It doesn't look very clean solution... will change it once I can think something else.
For better understanding, Please read the code below along with the embedded comments.

%Helpers-----------------------------------------------------
declare NewWrapper Wrap Unwrap Union Inter Minus LogObj

LogObj = {New class $
                 attr entries
                 meth init
                    entries:=nil
                 end
                 meth addEntry(X)
                    entries:=X|(@entries)
                 end
                 meth getEntries(?X)
                    X={List.reverse @entries}
                 end
                 meth clear
                    entries:=nil
                 end
              end
          init}

proc {NewWrapper ?W ?U}
   Key={NewName}
in
   fun {W X}
      fun {$ K} if K==Key then X end end
   end
   fun {U Y}
      {Y Key}
   end
end

{NewWrapper Wrap Unwrap}

%Download Set.oz from book's suppliment site then
%create ozc file by running following command
%$ozc -c Set.oz
%CHANGE PATH
declare
[Set]= {Module.link ['/path/Set.ozf']}
Union=Set.union
Inter=Set.inter
Minus=Set.minus

declare New2
fun {New2 WClass InitialMethod}
   State Obj Class
in
   Class={Unwrap WClass}
   State = {MakeRecord s Class.attrs}
   {Record.forAll State proc {$ A} {NewCell _ A} end}
   proc {Obj M}
      {Class.methods.{Label M} M State Obj}
   end
   {Obj InitialMethod}
   Obj
end
%Helpers finished-------------------------------------------------

%New From to allow multiple inheritence,
%Returns new class record whose base defn
%is BaseC and inherits all classes in
%list Classes
declare
fun {From BaseC Classes}
   c(methods:M attrs:A) = {Unwrap BaseC}
   ParentMeths = {Map Classes
                  fun {$ X}
                     c(methods:M attrs:_)={Unwrap X}
                     in M
                  end}
   ParentMethArities = {Map ParentMeths
                        fun {$ M} {Arity M} end}
   ParentAttrs = {Map Classes
                  fun {$ X}
                     c(methods:_ attrs:A)={Unwrap X}
                     in A
                  end}
   ConfMeth=if {List.length Classes}>1 then
               {Minus {FoldL ParentMethArities
                       fun {$ MA1 MA2} {Inter MA1 MA2} end
                       ParentMeths.1} {Arity M}}
            else
               nil end
   ConfAttr=if {List.length Classes}>1 then
               {Minus {FoldL ParentAttrs
                       fun {$ A1 A2} {Inter A1 A2} end
                       ParentAttrs.1} A}
            else
               nil end
in
   if ConfMeth\=nil then
      raise illegalInheritance(methConf:ConfMeth) end
   end
   if ConfAttr\=nil then
      raise illegalInheritance(attrConf:ConfAttr) end
   end
   {Wrap c(methods:{Adjoin {FoldL ParentMeths
                            fun {$ M1 M2}
                               {Adjoin M1 M2}end
                            nil} M}
           attrs:{Union {FoldL ParentAttrs
                         fun {$ A1 A2}
                            {Union A1 A2} end
                         nil} A})}
end

%Account,LoggedAccount example
declare Account
local
   Attrs = [balance]
   MethodTable = m(init:Init
                   transfer:Transfer
                   getBal:GetBal
                   batchTransfer:BatchTransfer)
   proc {Init M S Self}
      init(Bal) = M
   in
      (S.balance):=Bal
   end

   proc {Transfer M S Self}
      transfer(Amt) = M
   in
      (S.balance):=Amt+@(S.balance)
   end

   proc {GetBal M S Self}
      getBal(Bal) = M
   in
      Bal = @(S.balance)
   end

   proc {BatchTransfer M S Self}
      batchTransfer(AmtList) = M
   in
      for A in AmtList do
         {Self transfer(A)} end
   end
in
   Account = {Wrap c(methods:MethodTable attrs:Attrs)}
end

% LoggedAccount inherits Account
declare LoggedAccountBase
local
   Attrs = nil
   MethodTable = m(transfer:Transfer)
   proc {Transfer M S Self}
      {LogObj addEntry(M)}
      %----------Static Binding----------
      %its fair to know about the superclasses at
      %the time of defining the subclass
      {{Unwrap Account}.methods.transfer M S Self}
   end
in
   LoggedAccountBase = {Wrap c(methods:MethodTable
                               attrs:Attrs)}
end

%Test
local
   LoggedAccClass
   LoggedAccObj
in
   {LogObj clear}
   LoggedAccClass = {From LoggedAccountBase [Account]}
   LoggedAccObj = {New2 LoggedAccClass init(0)}
   {LoggedAccObj transfer(100)}
   {LoggedAccObj transfer(200)}
   {LoggedAccObj transfer(300)}
   %This prints the above transactions that means the
   %Transfer code from LoggedAccount is executed
   {Browse {LogObj getEntries($)}}
   %This prints the balance=600(100+200+300) that means
   %static binding worked and Transfer code from Account
   %was executed.
   {Browse {LoggedAccObj getBal($)}}
end