home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 5 / amigaformatcd05.iso / mui / developer / oberon / txt / rootclass.mod < prev    next >
Text File  |  1996-08-13  |  8KB  |  277 lines
  1. (*(***********************************************************************
  2.  
  3. :Program.    RootClass.mod
  4. :Contents.   Oberon-like interface to BOOPSI's rootclass
  5. :Author.     hartmut Goebel [hG]
  6. :Address.    Aufseßplatz 5, D-8500 Nürnberg 40
  7. :Address.    UseNet: hartmut@oberon.nbg.sub.org
  8. :Address.    Z-Netz: hartmut@asn.zer   Fido: 2:246/81.1
  9. :Copyright.  Copyright © 1993 by hartmut Goebel
  10. :Language.   Oberon-2
  11. :Translator. Amiga Oberon 3.0
  12. :Imports.    need Interfaces 40.15+
  13. :Version.    $VER: RootClass.mod 36.2 (10.9.93) Copyright © 1993 by hartmut Goebel
  14.  
  15. (****i* RootClass/--history-- ***************************************
  16. *
  17. *  ATTENTION:
  18. *  This modules is really implementation dependand! It will not work
  19. *  with any compiler but Amiga Oberon. It does a lot of assumptions
  20. *  on how records are represented and how type information (and
  21. *  Garbage-Collector) information is stored!
  22. *
  23. *
  24. *  V36.2  compiles with AmigaOberon 3.0, too (removed call of SYSTEM.MOVE(),
  25. *         which is only available in 3.01+)
  26. *  V36.1  oberon object is now created before the boopsi object and
  27. *         copied into the boopsi obj's instance data when New() has
  28. *         been successfull
  29. *  V36.0  initial version
  30. *
  31. *********************************************************************)*)*)
  32.  
  33. MODULE RootClass;
  34.  
  35. (* $StackChk- $NilChk- $RangeChk- $CaseChk- $OvflChk- $ReturnChk- $ClearVars- *)
  36.  
  37. IMPORT
  38.   BT:= BasicTypes,
  39.   cf:= Classface,
  40.   I := Intuition,
  41.   e := Exec,
  42.   u := Utility,
  43.   y := SYSTEM;
  44.  
  45. CONST
  46.   versionString = "$VER: RootClass 36.2 (10.9.93) Copyright © 1993 by hartmut Goebel";
  47.   emptySize = 4;
  48.  
  49. TYPE
  50.   Root = UNTRACED POINTER TO RootClass;
  51.   RootClass * = RECORD (BT.ANYDesc);
  52.     object -: I.ObjectPtr; (* boopsi object *)
  53.     class  -: I.IClassPtr; (* boopsi class  *)
  54.     userData *: e.APTR;
  55.   END;
  56.  
  57.   DispatcherPROC * = PROCEDURE (cl: I.IClassPtr; obj: I.ObjectPtr; msg: I.MsgPtr): e.APTR;
  58.  
  59. (*
  60. ** one oberon method for each boopsi message
  61. *)
  62.  
  63. PROCEDURE (VAR r: RootClass) New * (VAR msg: I.OpSet): e.APTR;
  64. BEGIN
  65.   msg.msg.methodID := I.new;
  66.   r.object := cf.DoSuperMethodA(r.class,r.object,msg); (* boopsi object *)
  67.   RETURN r.object;
  68. END New;
  69.  
  70. PROCEDURE (VAR r: RootClass) Dispose * (VAR msg: I.Msg): e.APTR;
  71. BEGIN
  72.   msg.methodID := I.dispose;
  73.   RETURN cf.DoSuperMethodA(r.class,r.object,msg);
  74. END Dispose;
  75.  
  76. PROCEDURE (VAR r: RootClass) AddTail * (VAR msg: I.OpAddTail): e.APTR;
  77. BEGIN
  78.   msg.msg.methodID := I.addTail;
  79.   RETURN cf.DoSuperMethodA(r.class,r.object, msg);
  80. END AddTail;
  81.  
  82. PROCEDURE (VAR r: RootClass) Remove * (VAR msg: I.Msg): e.APTR;
  83. BEGIN
  84.   msg.methodID := I.remove;
  85.   RETURN cf.DoSuperMethodA(r.class,r.object,msg);
  86. END Remove;
  87.  
  88. PROCEDURE (VAR r: RootClass) AddMember * (VAR msg: I.OpMember): e.APTR;
  89. BEGIN
  90.   msg.msg.methodID := I.addMember;
  91.   RETURN cf.DoSuperMethodA(r.class,r.object, msg);
  92. END AddMember;
  93.  
  94. PROCEDURE (VAR r: RootClass) RemMember * (VAR msg: I.OpMember): e.APTR;
  95. BEGIN
  96.   msg.msg.methodID := I.remMember;
  97.   RETURN cf.DoSuperMethodA(r.class,r.object, msg);
  98. END RemMember;
  99.  
  100. PROCEDURE (VAR r: RootClass) Get * (VAR msg: I.OpGet): e.APTR;
  101. BEGIN
  102.   msg.msg.methodID := I.get;
  103.   RETURN cf.DoSuperMethodA(r.class,r.object, msg);
  104. END Get;
  105.  
  106. PROCEDURE (VAR r: RootClass) Set * (VAR msg: I.OpSet): e.APTR;
  107. BEGIN
  108.   msg.msg.methodID := I.set;
  109.   RETURN cf.DoSuperMethodA(r.class,r.object, msg);
  110. END Set;
  111.  
  112. PROCEDURE (VAR r: RootClass) Update * (VAR msg: I.OpUpdate): e.APTR;
  113. BEGIN
  114.   msg.msg.methodID := I.update;
  115.   RETURN cf.DoSuperMethodA(r.class,r.object, msg);
  116. END Update;
  117.  
  118. PROCEDURE (VAR r: RootClass) Notify * (VAR msg: I.OpUpdate): e.APTR;
  119. BEGIN
  120.   msg.msg.methodID := I.notify;
  121.   RETURN cf.DoSuperMethodA(r.class,r.object, msg);
  122. END Notify;
  123.  
  124.  
  125. PROCEDURE BoopsiToObj * {"Classface.InstData"} (cl{8}: I.IClassPtr;
  126.                                                 obj{9}: I.ObjectPtr): Root;
  127.  
  128. PROCEDURE SetTypeDesc (r{8}: Root; cl{9}: I.IClassPtr);
  129. TYPE
  130.   ANY = UNTRACED POINTER TO STRUCT
  131.     td: y.ADDRESS;
  132.     (* data: LONGINT; *)
  133.   END;
  134. VAR
  135.   a: ANY;
  136. BEGIN
  137.   a := y.VAL(ANY,r);
  138.   a.td := cl.userData;
  139. END SetTypeDesc;
  140.  
  141.  
  142. (*
  143. ** dispatcher for rootclass
  144. ** handles all yet (V36) defined rootclass messages and dispatches to
  145. ** the apropriate oberon method
  146. *)
  147.  
  148. PROCEDURE Dispatch * (cl: I.IClassPtr; obj: I.ObjectPtr; msg: I.MsgPtr): e.APTR;
  149. VAR
  150.   r: Root;
  151. BEGIN
  152.   IF msg.methodID = I.new THEN
  153.       r := e.AllocMem(cl.instSize,LONGSET{e.memClear}); (* make oberon object *)
  154.       IF r # NIL THEN
  155.         SetTypeDesc(r,cl);
  156.         r.object := obj; (* here: objects real class *)
  157.         r.class := cl;
  158.         obj := r.New(msg^(I.OpSet));  (* init, object is now boopsi obj *)
  159.         IF obj # NIL THEN
  160.           e.CopyMemAPTR(r,cf.InstData(cl,obj),cl.instSize); (* copy into boopsi obj *)
  161.           (* y.MOVE(r,cf.InstData(cl,obj),cl.instSize); (* copy into boopsi obj *) *)
  162.         END;
  163.         e.FreeMem(r,cl.instSize);
  164.         RETURN obj;
  165.       END;
  166.       RETURN NIL;
  167.       (* old code, just to store it :-)
  168.       obj :=  cf.DoSuperMethodA(cl,obj,msg^); IF obj # NIL THEN
  169.       r := BoopsiToObj(cl,obj); SetTypeDesc(r,cl); r.object := obj;
  170.       r.class := cl; RETURN r.New(msg^(I.OpSet)); END; RETURN obj;
  171.       *)
  172.   ELSE
  173.     r := BoopsiToObj(cl,obj);
  174.     CASE msg.methodID OF
  175.     |I.dispose:
  176.       RETURN r.Dispose(msg^);
  177.     |I.set:
  178.       RETURN r.Set(msg^(I.OpSet));
  179.     |I.get:
  180.       RETURN r.Get(msg^(I.OpGet));
  181.     |I.addTail:
  182.       RETURN r.AddTail(msg^(I.OpAddTail));
  183.     |I.remove:
  184.       RETURN r.Remove(msg^);
  185.     |I.notify:
  186.       RETURN r.Notify(msg^(I.OpUpdate));
  187.     |I.update:
  188.       RETURN r.Update(msg^(I.OpUpdate));
  189.     |I.addMember:
  190.       RETURN r.AddMember(msg^(I.OpMember));
  191.     |I.remMember:
  192.       RETURN r.RemMember(msg^(I.OpMember));
  193.     ELSE
  194.       RETURN cf.DoSuperMethodA(cl,obj,msg^); (* for future methods *)
  195.     END;
  196.   END;
  197. END Dispatch;
  198.  
  199. (* ---------------------------------------------------------------- *)
  200.  
  201. PROCEDURE GetUserDataANY * (VAR r: RootClass): BT.ANY;
  202. BEGIN RETURN y.VAL(BT.ANY,r.userData); END GetUserDataANY;
  203.  
  204. (* ---------------------------------------------------------------- *)
  205.  
  206. PROCEDURE InitClass(cl{8}: I.IClassPtr;
  207.                     dispatcher{9}: DispatcherPROC;
  208.                     typeDesc{0}: y.ADDRESS);
  209. BEGIN
  210.   IF cl # NIL THEN
  211.     cl.userData := typeDesc;
  212.     u.InitHook(cl,y.VAL(u.HookFunc,dispatcher));
  213.   END;
  214. END InitClass;
  215.  
  216. PROCEDURE InitPrivFromName * (superClass: ARRAY OF CHAR; (* $CopyArrays- *)
  217.                               dispatcher: DispatcherPROC;
  218.                               size: INTEGER;
  219.                               typeDesc: y.ADDRESS): I.IClassPtr;
  220. VAR
  221.   cl: I.IClassPtr;
  222. BEGIN
  223.   cl := I.MakeClass(NIL,superClass,NIL,size+emptySize,LONGSET{});
  224.   InitClass(cl,dispatcher,typeDesc);
  225.   RETURN cl;
  226. END InitPrivFromName;
  227.  
  228.  
  229. PROCEDURE InitPrivFromClass * (superClass: I.IClassPtr;
  230.                                dispatcher: DispatcherPROC;
  231.                                size: INTEGER;
  232.                                typeDesc: y.ADDRESS): I.IClassPtr;
  233. VAR
  234.   cl: I.IClassPtr;
  235. BEGIN
  236.   cl := I.MakeClass(NIL,NIL,superClass,size+emptySize,LONGSET{});
  237.   InitClass(cl,dispatcher,typeDesc);
  238.   RETURN cl;
  239. END InitPrivFromClass;
  240.  
  241.  
  242. PROCEDURE InitPubFromName * (name: ARRAY OF CHAR;
  243.                              superClass: ARRAY OF CHAR; (* $CopyArrays- *)
  244.                              dispatcher: DispatcherPROC;
  245.                              size: INTEGER;
  246.                              typeDesc: y.ADDRESS): I.IClassPtr;
  247. VAR
  248.   cl: I.IClassPtr;
  249. BEGIN
  250.   cl := I.MakeClass(name,superClass,NIL,size+emptySize,LONGSET{});
  251.   IF cl # NIL THEN
  252.     InitClass(cl,dispatcher,typeDesc);
  253.     I.AddClass(cl);
  254.   END;
  255.   RETURN cl;
  256. END InitPubFromName;
  257.  
  258.  
  259. PROCEDURE InitPubFromClass * (name: ARRAY OF CHAR; (* $CopyArrays- *)
  260.                               superClass: I.IClassPtr;
  261.                               dispatcher: DispatcherPROC;
  262.                               size: INTEGER;
  263.                               typeDesc: y.ADDRESS): I.IClassPtr;
  264. VAR
  265.   cl: I.IClassPtr;
  266. BEGIN
  267.   cl := I.MakeClass(name,NIL,superClass,size+emptySize,LONGSET{});
  268.   IF cl # NIL THEN
  269.     InitClass(cl,dispatcher,typeDesc);
  270.     I.AddClass(cl);
  271.   END;
  272.   RETURN cl;
  273. END InitPubFromClass;
  274.  
  275. END RootClass.
  276.  
  277.