home *** CD-ROM | disk | FTP | other *** search
/ Dream 52 / Amiga_Dream_52.iso / RiscOS / APP / DEVS / FORTH / WIMPFO.ZIP / !WimpForth / class < prev    next >
Text File  |  1996-03-21  |  25KB  |  745 lines
  1. \ $Id: class.f 1.1 1994/04/01 07:52:15 andrew Exp $
  2.  
  3. comment:
  4.    This file introduces object orientation to WimpForth.
  5.    You declare a new class by
  6.      :class newcl <super parent
  7.          ...
  8.      ;class
  9.    where parent is an existing class (only one!!)
  10.    In between you define instance variables
  11.        int flag
  12.    and methods
  13.        :m SetFlag:  ( f -- ) to flag ;m
  14.    Available are all methods and instance variable of the parent class.
  15.    Until now this is like a type declaration. You define an object of
  16.    this class like that:
  17.       newcl newobj
  18.    newobj is now ready to receive messages: (=invocation of the methods)
  19.       0 SetFlag: newobj
  20.    The first message (ClassInit:) was automatically sent to it when
  21.    newobj was created 2 lines before. (This is part of the system!)
  22.    There are more aspects of the problem. Extensive use of classes
  23.    is made in the Wimp interface of WimpForth. Please have a look
  24.    at the files "icons", "windows", "menus", "controls" and for
  25.    defining objects at the file "extend".
  26. comment;
  27.  
  28. only forth also definitions
  29.  
  30. 0 Value  NewObject           \ Newest object being created
  31.  
  32. locals-on
  33.  
  34. \ : h.   ( u -- )               base @ hex  swap u.  base ! ;
  35. : @word  ( -<word>- addr )      bl word dup count upper ;
  36. : hash>  ( -<word>- )           @word count hash ;
  37.  
  38. classes also definitions
  39.  
  40. \ -------------------- Selectors --------------------
  41.  
  42. : ?is.Sel       ( addr -- addr f ) \ true if word at Here is a selector object.method
  43.                 dup count dup>r ':' scan 0>             \ found it and
  44.                 nip r> 3 > and ;                        \ longer than 3
  45.  
  46. : ?isSel  dup dup c@ +  c@ ascii :  =  ;
  47.  
  48. : >selector  ( str -- SelID )   \ get a selector from the input stream
  49.         ?isSel 0= abort" not a selector" count hash ;
  50.  
  51. : getSelect  ( -- SelID )   \ get a selector from the input stream
  52.         @word >selector ;
  53.  
  54.  
  55. \ -------------------- Class Structure --------------------
  56.  
  57. 0 value ^Class          \ pointer to class being defined
  58.  
  59. \ references are from class pfa
  60.  
  61. : MFA    [ voc-pfa-size 0 cells+ ] literal + ;  \ method dictionary
  62. : IFA    [ voc-pfa-size 1 cells+ ] literal + ;  \ instance variable dictionary
  63. : DFA    [ voc-pfa-size 2 cells+ ] literal + ;  \ data area
  64. : XFA    [ voc-pfa-size 3 cells+ ] literal + ;  \ width of indexed items
  65. : SFA    [ voc-pfa-size 4 cells+ ] literal + ;  \ pointer to superclass
  66. : FLAGS  [ voc-pfa-size 5 cells+ ] literal + ;  \ flags
  67.  
  68. voc-pfa-size 6 cells+ constant class-size       \ size of class pfa
  69.  
  70.  
  71. : >obj  ( objCfa -- ^obj )   >body cell+ ;
  72.  
  73. : >class  ( ^obj -- ^class )  CELL - @ ;
  74.  
  75. : classpointer?  ( class -- f )  FLAGS @ 1 AND ;
  76.  
  77. : class-allot  ( n -- )  ^class DFA +! ;
  78.  
  79.  
  80. \ -------------------- Find Methods --------------------
  81.  
  82. : (FINDM)   ( SelID ^class -- m0cfa )   \ find method in a class
  83.         2dup
  84.         MFA ((findm)) if  nip nip exit  then
  85. \        over 0 <# #s #> temp$ place
  86. \        s"  " temp$ +place
  87.         swap unhash temp$ place
  88.         S"  not understood by class " temp$ +place
  89.         body> >name nfa-count temp$ +place
  90.         temp$ msg !  -2 throw ;
  91.  
  92. create null-obj-buf 260 allot
  93.  
  94. : FIND-METHOD   ( SelID ^obj -- ^obj m0cfa )   \ find method in object
  95.                 ?dup 0= abort" Null Object"
  96.                 tuck >class (findm) ;
  97.  
  98. : (Defer)  ( ^obj -- )   \ look up SelID at IP and run the method
  99.         @(ip) swap  ( SelID ^obj )
  100.         Find-Method execute ;
  101.  
  102. : dbg-next-cell-class ( ip cfa -- ip' cfa )
  103.         dup ['] (Defer) =
  104.         if      swap cell+ swap
  105.         then    ;
  106.  
  107. dbg-next-cell chain-add dbg-next-cell-class \ link into the debugger
  108.  
  109. : dbg-nest-class ( top-of-user-stack cfa flag -- cfa false | true )
  110.         dup ?exit                       \ leave if already found
  111.         over ['] (Defer) =
  112.         if      2drop cr .s
  113. \ !!! USES A COPY OF THE ADDRESS ON TOP OF THE STACK TO LOCATE THE METHOD !!!
  114.         [ bug ] ip @ cell+ @ over Find-Method nip 3 cells+ ip !
  115.                 2 nesting +!
  116.                 true
  117.         then    ;
  118.  
  119. classes
  120.  
  121. dbg-nest-chain chain-add dbg-nest-class
  122.  
  123. : .word-type-class      ( cfa flag -- cfa false | true )
  124.         dup ?exit
  125.         over ['] (Defer) =
  126.         if      2drop
  127.                 ." Late: "
  128.                 true
  129.         then    ;
  130.  
  131. .word-type-chain chain-add .word-type-class
  132.  
  133. : .execution-class-class ( ip cfa flag -- ip' cfa flag )
  134.                 dup ?exit                       \ leave if non-zero flag
  135.                 over ['] (Defer) =              \ is it a late bound method
  136.                 if      drop                    \ discard original flag
  137.                         ." [[ " swap cell+
  138.                         dup @ unhash type
  139.                         cell+ swap ."  ]] "
  140.                         true                    \ return true if we handled it
  141.                 then    ;
  142.  
  143. .execution-class-chain chain-add .execution-class-class
  144.  
  145.    0 Value  ^Self
  146.    0 Value  ^Super              \ nfa of SUPER pseudo-Ivar
  147.    1 Value  rangeCheck          \ true if runtime range check desired
  148.  
  149. ' find      @ constant doDefer  \ Defer cfa
  150.  
  151. : ?isClass  ( cfa -- f )  call@ dup   doCLass =
  152.                             swap do|Class = or ;
  153. : ?isObj    ( cfa -- f )  call@ doObj = ;
  154. : ?isValue  ( cfa -- f )  call@ doValue = ;
  155. : ?isVect   ( cfa -- f )  call@ dup doValue =
  156.                            over doDefer = or
  157.                            swap (iv@) = or ;
  158.  
  159. : ?isParen  ( cfa -- f )  >name nfa-count drop c@ ascii [ = ;
  160.  
  161. \ ERROR if not compiling a new class definition
  162. : ?Class   ^class   0= abort" Not in a class" ;
  163.  
  164. \ Determine if next word is an instance var.
  165. \ Return pointer to class field in ivar structure.
  166. : vFind  ( str -- str f OR ^iclass t )
  167.         ^class
  168.         IF      dup count hash ^class IFA ((findm))
  169.                 dup if  rot drop  then
  170.         ELSE    0
  171.         THEN ;
  172.  
  173. : IDX-HDR   ( #elems ^class  OR ^class -- indlen )
  174.         XFA @ DUP IF  2DUP ( width ) W, ( #elems ) W,  *  THEN ;
  175.  
  176.  
  177. \ -------------------- Initialize Instance Variables --------------------
  178. ((
  179. Instance variable consists of four 4-byte fields.  A fifth field is
  180. used for indexed ivars only.
  181.  
  182.     Offset   Name      Description
  183.     ------   ----      ---------------------------------------
  184.        0 0   link      points to link of next ivar in chain
  185.        4 1   name      32-bit hash value of name
  186.        8 2   class     pointer to class pfa
  187.       12 3   offset    offset in object to start of ivar data
  188.       16 4   #elem     number of elemens (indexed ivars only)
  189.  
  190. In the stack diagrams, "ivar" refers to the starting address of this
  191. structure.  The IFA field of a class points to the first ivar.
  192. ))
  193.  
  194. : iclass     ( ivar -- 'class )   2 cells + ;
  195.  
  196. : @IvarOffs  ( ivar -- offset )   3 cells + @ ;
  197.  
  198. : @IvarElems ( ivar -- #elems )   4 cells + @ ;
  199.  
  200.  
  201. \ send ClassInit: message to ivar on stack
  202. : InitIvar  ( ivar offset -- )
  203.         over @IvarOffs + newObject +   ( ivar addr )
  204.         [ getSelect ClassInit: ] literal
  205.         rot iclass @ (findm) execute ;
  206.  
  207.  
  208. \ ITRAV traverses the tree of nested ivar definitions in a class,
  209. \ building necessary indexed area headers.
  210. : ITRAV   { ivar offset -- }
  211.         Begin
  212.                 ivar ^Self <>
  213.         While
  214.                 ivar iclass @ IFA @
  215.                 ivar @IVarOffs offset + RECURSE
  216.  
  217.                 ivar iclass @ ?dup  ( Why would an Ivar have no class ?? )
  218.                 if      dup classpointer?
  219.                         if      newObject offset + ivar @IvarOffs +
  220.                                 ( ^class ivarAddr )
  221.                                 2dup cell - !           \ store class pointer
  222.                                 over XFA @
  223.                                 if  over DFA @ +        \ addr of indexed area
  224.                                     swap XFA @ over W!  \ Index width
  225.                                     ivar @IvarElems swap 2 + w! \ #elems
  226.                                 else 2drop
  227.                                 then
  228.                         else drop
  229.                         then
  230.                         ivar offset initIvar    \ send ClassInit:
  231.                 then
  232.  
  233.                 ivar @ to ivar  \ next ivar in chain
  234.         Repeat ;
  235.  
  236.  
  237. defer ClassInit  ( -- )  \ send ClassInit: to newObject
  238. ' noop is classinit
  239.  
  240. \ ( #elems ^class OR ^class -- ) Compile an instance variable dictionary entry
  241. : <VAR
  242.         @word Vfind abort" Duplicate Instance Variable"
  243.  
  244.         dup count 2dup hash add-hash
  245.  
  246.         ^Class IFA link,                \ link
  247.         count hash ,                            \ name hash
  248.         dup ,                           \ class
  249.         dup ClassPointer?
  250.         if  4 class-allot  then         \ if indexed, save 4 for class ptr
  251.         ^class DFA @ ,                  \ offset
  252.         dup XFA @ dup
  253.         if  rot dup ,  * 4 +  then      \ #elems
  254.         swap DFA @ +                    \ Account for named ivar lengths
  255.         class-allot ;
  256.  
  257. : (|Build)   ( #elems ^class OR ^class -- )  \ Build an instance of a class
  258.         ^class
  259.         IF      <Var    \ build an ivar
  260.         ELSE    doObj call,         \ cfa
  261.                 dup ,           \ class
  262.                 here to newObject
  263.                 dup DFA @ reserve       \ allot space for ivars
  264.                 dup IDX-HDR reserve     \ allot space for indexed data
  265.                 IFA @ 0 ITRAV           \ init instance variables
  266.                 ClassInit               \ send CLASSINIT: message
  267.         THEN ;
  268.  
  269. : (Build)   ( #elems ^class OR ^class -- )  \ Build an instance of a class
  270.         ^class
  271.         IF      <Var    \ build an ivar
  272.         ELSE
  273.                 >in @
  274.                 @word (find)
  275.                 if      dup ?isValue
  276.                         if      \ create headerless object and store
  277.                                 \ address in a value
  278.                                 here >obj  swap cell+ ( 1cfa ) execute
  279.                                 drop ( >in )
  280.                         else
  281.                                 \ redefinition
  282.                                 drop >in ! header
  283. \                               cr last @ .id ."  is redefined "
  284.                         then
  285.                 else
  286.                         \ new object
  287.                         drop >in ! header
  288.                 then
  289.  
  290.                 doObj call,         \ cfa
  291.                 dup ,           \ class
  292.                 here to newObject
  293.                 dup DFA @ reserve       \ allot space for ivars
  294.                 dup IDX-HDR reserve     \ allot space for indexed data
  295.                 IFA @ 0 ITRAV           \ init instance variables
  296.                 ClassInit               \ send CLASSINIT: message
  297.         THEN ;
  298.  
  299. create obj-buf 260 allot
  300.  
  301. : (Obj-Build)   ( #elems ^class OR ^class -- )  \ Build an instance of a class
  302.                 obj-buf count upper (find)
  303.                 if      dup ?isValue
  304.                         if      \ create headerless object and store
  305.                                 \ address in a value
  306.                                 here >obj  swap cell+ ( 1cfa ) execute
  307.                         else
  308.                                 \ redefinition
  309.                                 obj-buf count "header
  310.                         then
  311.                 else
  312.                         \ new object
  313.                         obj-buf count "header
  314.                 then
  315.                 doObj call,         \ cfa
  316.                 dup ,           \ class
  317.                 here to newObject
  318.                 dup DFA @ reserve       \ allot space for ivars
  319.                 dup IDX-HDR reserve     \ allot space for indexed data
  320.                 IFA @ 0 ITRAV           \ init instance variables
  321.                 ClassInit               \ send CLASSINIT: message
  322.                 ;
  323.  
  324. \ -------------------- Heap Objects --------------------
  325.  
  326. \ build a new object on the heap for class. Use: Heap> className
  327. \ gets heap, and returns ptr.
  328.  
  329. : (heapObj)  { theClass \ dLen obAddr idWid #els -- } 0 to #els
  330.         theClass dfa @ to dlen  theClass XFA @ to idWid
  331.         idWid  IF to #els THEN
  332.         dLen cell+ idWid IF  idWid #els * cell+ + THEN  \ get total length of obj
  333.         allocate abort" Out of Memory"
  334.         theClass over !  \ create the class ptr
  335.         cell+ to obAddr    \ get nonReloc heap, save ptr to cfa
  336.         idWid  IF  obAddr dLen + idWid over w!  2 + #els swap w! THEN
  337.         obAddr to newObject  theClass IFA @  0 Itrav
  338.         classinit  obAddr  ;
  339.  
  340. : heap>   ( -- addr )
  341.         '  dup ?isClass not abort" Use: heap> classname "   >body
  342.         state @
  343.         IF   [compile] literal
  344.                 Compile (heapObj)  ELSE  (heapObj)
  345.         THEN
  346.         ; Immediate
  347.  
  348.  
  349. \ --------------- Build SUPER and SELF pseudo ivars ---------------
  350.  
  351. S" SUPER" hash> SUPER add-hash
  352.  
  353. Here to ^Super
  354.         0 ,             \ link
  355.         hash> SUPER ,   \ name
  356.         0 ,             \ class
  357.         0 ,             \ offset (was -1)
  358.  
  359. S" SELF" hash> SELF add-hash
  360.  
  361. Here to ^Self
  362.         ^Super ,        \ link
  363.         hash> SELF ,    \ name
  364.         0 ,             \ class
  365.         0 ,             \ offset (was -1)
  366.  
  367. ^Self   ' classes >body IFA !      \ latest ivar
  368.  
  369.  
  370. \ -------------------- Create a new Class --------------------
  371.  
  372. 0 value oldcurrent
  373.  
  374. \ Build a class header with its superclass pointer
  375. : inherit  ( pfa -- )
  376.         dup here class-size move        \ copy class data
  377.         here body> vcfa>voc voc>vlink
  378.         voc-link @ over !
  379.         voc-link !
  380.         class-size allot                \ reserve rest of class data
  381.  
  382.         dup ^Class SFA !                \ store pointer to superclass
  383.         ^Super iclass !                 \ store superclass in SUPER
  384.         ^Class ^Self iclass !           \ store my class in SELF
  385.                                         \ add to search order
  386.         also ^class body> vcfa>voc context ! definitions ;
  387.  
  388. forth definitions
  389.  
  390. here 0 , value Obj-CLASS
  391.        0 value Obj-LOADLINE
  392.  
  393. : :Object ( -<object-name>- )
  394.         bl word count 255 min obj-buf place
  395.         current @ to oldcurrent         \ save context for later restoral
  396.         false to ?:M
  397.         doClass ,                       \ dummy filler to fool the system
  398.                                         \ into thinking this is a definition
  399.         here to Obj-CLASS
  400.         here to ^Class
  401.         0 op!                           \ for error checking in runIvarRef
  402.         ?loading @
  403.         if      loadline @
  404.         else    -1
  405.         then    to Obj-LOADLINE ;
  406.  
  407. : :Class  ( -- )
  408.         current @ to oldcurrent         \ save context for later restoral
  409.         false to ?:M
  410.         create
  411.                 here to ^Class
  412.                 0 op!                   \ for error checking in runIvarRef
  413.         does>
  414.                 [ here 8 - to doClass ] \ a dirty trick!
  415.                 (Build) ;
  416.  
  417. : <Super  ( -- )        \ allow inheriting from a class or an object
  418.         ' dup  ?isClass
  419.         if      >body inherit
  420.         else    dup ?isObj 0= abort" not a class or object"
  421.                 >body @ inherit
  422.         then    ;
  423.  
  424. synonym <Object <Super
  425. synonym <Class  <Super
  426.  
  427. : |Class  ( -- )
  428.         current @ to oldcurrent         \ save context for later restoral
  429.         false to ?:M
  430.         create
  431.                 here to ^Class
  432.                 0 op!                   \ for error checking in runIvarRef
  433.         does>
  434.                 [ here 8 - to do|Class ]  \ a dirty trick!
  435.                 (|Build) ;
  436.  
  437. classes definitions
  438.  
  439. : ;Class  ( -- )
  440.         0 ^Super iclass !
  441.         0 ^Self  iclass !
  442.         0 to ^Class
  443.         forth definitions previous
  444.         oldcurrent ?dup
  445.         if      current !
  446.                 0 to oldcurrent
  447.         then    ;
  448.  
  449. : ;Object  ( -- )
  450.         0 ^Super iclass !
  451.         0 ^Self  iclass !
  452.         0 to ^Class
  453.         forth definitions previous
  454.         oldcurrent ?dup
  455.         if      current !
  456.                 0 to oldcurrent
  457.         then    Obj-CLASS (Obj-Build)
  458.         Obj-LOADLINE last @ name> >view ! ;
  459.  
  460.  
  461. \ -------------------- Method Compiler --------------------
  462.  
  463.  
  464. : method   ( SelID -- )   \ Build a methods dictionary entry for selector
  465.         ?Class ?Exec
  466.         dup pocket count rot add-hash
  467.         ^Class MFA link,        \ link
  468.         ,                       \ name is selector's hashed value
  469.         m0cfa call,                 \ build methods cfas
  470.         m1cfa call,
  471.         0 ,                     \ #locals & #args
  472.         !csp ] ;                \ start compiler
  473.  
  474. \ For Windows messages, we would like the selector to be a constant
  475. \ defined as the Window message number.  :M will support both types of
  476. \ selectors.
  477.  
  478. 260 constant unres-len
  479.  
  480. create unres-methods unres-len allot
  481.        unres-methods unres-len erase
  482.  
  483. : :M    ( -- )
  484. \       cr ." Method " >in @ bl word count type >in !
  485.         unres-methods unres-len erase   \ pre-clear unresolved methods array
  486.         @word (find)
  487.         if      execute  ( word must return selector value )
  488.         else    >selector
  489.         then    method
  490.         true to ?:M     ; immediate     \ mark as making a new method
  491.  
  492. : ;M    ( -- )
  493.         ?:M 0= abort" Methods must START with :M !"
  494.         false to ?:M
  495.         ?csp
  496.         postpone unnestm
  497.         postpone [
  498.         0 to Parms
  499.         semicolon-chain do-chain
  500.         voc-also                        \ don't add to hash table
  501.         ; Immediate
  502.  
  503. \ create make-amethod-buf 64 allot
  504.  
  505. : resolve-methods ( -- )
  506.                 unres-methods
  507.                 begin   count dup
  508.                 while   2dup
  509.                         2dup hash add-hash +
  510.                 repeat  2drop
  511.                 unres-methods unres-len erase ;
  512.  
  513. \ -------------------- Object Compiler --------------------
  514.  
  515. \ Key to instantiation actions
  516. \ 0 = notFnd            -not previously defined (not used)
  517. \ 1 = objTyp            -defined as an object
  518. \ 2 = classTyp          -as a class
  519. \ 3 = vecTyp            -as an object vector (value or defer)
  520. \ 4 = parmTyp           -as a named parm
  521. \ 5 = parenType         -open paren for defer group
  522.  
  523. \ ( str -- cfa tokenID )  Determine type of token referenced by string.
  524. : refToken
  525.         pFind if  4 exit  then
  526.         (find) 0= ?missing
  527.         dup ?IsObj   if  1 exit  then
  528.         dup ?IsClass if  2 exit  then
  529.         dup ?IsVect  if  3 exit  then
  530.         dup ?IsParen if  5 exit  then
  531.         1 abort" Invalid object type" ;
  532.  
  533. : ivarRef   ( selID ^iclass -- )                \ compile ivar reference
  534.         cell+ Find-Method >body ,  @ , ;        \ | 1cfa | offs |
  535.  
  536. : runIvarRef   ( selID ^iclass -- )    \ run ivar reference (DEBUG ONLY!!)
  537.         ^base 0= abort" No object exposed"
  538.         cell+ Find-Method
  539.         swap @ ( offset ) ^base + swap execute ;
  540.  
  541.  
  542. 0 value pSel  ( selector for [[ and ]] )  ( NOTE: NO NESTING!! )
  543.  
  544. \ ( selID $str -- )  Build a reference to an object or vector
  545. : objRef
  546.         Case refToken
  547.           0 ( ?      ) of  abort                        endof
  548.           1 ( object ) of  dup ,  >obj find-method , drop  endof
  549.           2 ( class  ) of  >body (findm) ,              endof
  550.           3 ( vector ) of  ,  compile (defer) ,         endof
  551.           4 ( parm   ) of  ,  compile (defer) ,         endof
  552.           5 ( paren  ) of  drop  to pSel  251           endof
  553.         Endcase ;
  554.  
  555. \ ( selPfa $str -- )  Execute using token in stream
  556. : runRef
  557.         Case refToken
  558.           0 ( ?      ) of  abort                        endof
  559.           1 ( object ) of  >obj find-method             endof
  560.           2 ( class  ) of  >body (findm)                endof
  561.           3 ( vector ) of  execute find-method          endof
  562.           4 ( parm   ) of  abort                        endof
  563.           5 ( paren  ) of  drop  to pSel  ['] noop      endof
  564.         Endcase
  565.         execute ( execute m0cfa ) ;
  566.  
  567.  
  568. \ ================= Selector support ==========================
  569.  
  570. : _do_message   ( val string -- )
  571.         STATE @
  572.         IF
  573.                 VFIND   \ instance variable?
  574.                 IF    ivarRef   \ ivar reference
  575.                 ELSE   objRef   \ compile object/vector reference
  576.                 THEN
  577.         ELSE
  578.                 VFIND
  579.                 IF      runIvarRef      ( Debug only )
  580.                 ELSE    runRef  \ run state - execute object/vector ref
  581.                 THEN
  582.         THEN    ;
  583.  
  584. -1 value method_hval
  585.  
  586. create method_hstring name-max-chars 2 + allot
  587.  
  588. \ message is the message compiler invoked by using a selector
  589. : do_message ( -- )
  590.         @word count name-max-chars min method_hstring place
  591.         method_hval method_hstring _do_message ; Immediate
  592.  
  593. : _msgFind      ( addr -- addr false | cfa true )
  594.                 ?isSel
  595.                 if      count name-max-chars min 2dup hash dup ?unhash
  596.                         if      nip nip
  597.                         else    >r unres-methods
  598.                                 begin   dup c@
  599.                                 while   count +
  600.                                 repeat  2dup + 1+            \ end of string
  601.                                 unres-methods unres-len + >  \ beyond end?
  602.                                 abort" Unresolved Methods buffer overflow!"
  603.                                 place
  604.                                 r>
  605.                         then    to method_hval ['] do_message
  606.                         1 EXIT
  607.                 then
  608.                 0 ;
  609.  
  610. \ msgFind is the new action for find.  We look in the following order:
  611. \ 1. Local variables
  612. \ 2. Forth Dictionary (full search order)
  613. \ 3. If word ends in ":" treat it as a selector
  614.  
  615. : msgFind       ( addr -- addr false | cfa true )
  616.                 pfind    ?dup if  exit  then
  617.                 (find)   ?dup if  exit  then
  618.                 _msgFind ;
  619.  
  620. ' msgfind is find
  621.  
  622. : _classInit  ( -- )    CLASSINIT: newObject  ;
  623. ' _classInit is ClassInit
  624.  
  625.  
  626. \ -------------------- Late Binding --------------------
  627.  
  628. \ Force late binding of method to object, as in SmallTalk
  629. \ a close bracket gets the last selID from pSel and
  630. \ compiles a defer: selID.  This will build a deferred reference to the
  631. \ parenthesized group.
  632.  
  633. : ]]    State @
  634.         IF      251 ?Pairs
  635.                 Compile (Defer)  pSel ,
  636.         ELSE
  637.                 pSel swap Find-Method execute
  638.         THEN
  639.         ; Immediate
  640.  
  641. \ left bracket has no meaning unless preceded by a selector.
  642.  
  643. : [[  true abort"  [[ must be preceeded by a selector "   ; immediate
  644.  
  645. \ Force a class pointer to be compiled when the object is used as
  646. \ an instance variable.  This is so that we can receive late-bound
  647. \ messages.
  648.  
  649. : <ClassPointer  ( -- )  1 ^Class FLAGS ! ;
  650.  
  651. \ Set a class and its subclasses to indexed
  652.  
  653. : <Indexed  ( width -- )  ?Class  ^Class XFA !  <ClassPointer ;
  654.  
  655. \ Compile a self reference, but only if the class is guaranteed to
  656. \ have a class pointer.  We can send ourself late-bound messages
  657. \ with the syntax:   Msg: [[ self ]]
  658.  
  659. : Self  ( -- addr )
  660.         ^Class ClassPointer? 0= abort" Must use <Indexed or <ClassPointer"
  661.         compile ^base ; immediate
  662.  
  663.  
  664. \ -------------------- Instance Variables --------------------
  665.  
  666. : bytes  ( n -- )
  667.         create  ^class DFA @ ,  class-allot
  668.         does> @  ^base + ;
  669.  
  670. : int   ( -- )
  671.         header
  672.         (iv@) call,
  673.         ^Class DFA @ ,
  674.         (iv!) call,
  675.         (iv+!) call,
  676.         cell class-allot ;
  677.  
  678. : int-array  ( size -- )
  679.         header
  680.         (iv[]@) call,
  681.         ^Class DFA @ ,
  682.         (iv[]!) call,
  683.         (iv[]+!) call,
  684.         cells class-allot ;
  685.  
  686. : &> ( -- )
  687.     r> lcount cell+ @ ^base + swap >r ;
  688.  
  689. : dispose ( addr -- )
  690.     ~: [[ dup ]] cell- free abort" Disposing Object failed!" ;
  691.  
  692. \ -------------------- Base Class "Object" --------------------
  693.  
  694. forth definitions
  695.  
  696. :Class object   ' classes >body classes inherit
  697.  
  698.         :M ClassInit:  ;M
  699.         :M ~:  ;M
  700.  
  701.         :M Addr:   ( -- addr )   ^base  ;M
  702.  
  703.         :M Print:  ( -- )    ." Object@"   ^base .  ;M
  704.  
  705. unres-methods unres-len erase
  706.  
  707. semicolon-chain chain-add resolve-methods  \ link into definition completion
  708.  
  709. ;Class
  710.  
  711. \ -------------------- Debugging Tools --------------------
  712.  
  713. 0 op!  ( to help catch incorrect use of expose.  See runIvarRef. )
  714.  
  715. ((
  716. : expose  ( expose vocabulary of class or object )
  717.         ' dup ?isClass
  718.         if
  719.                 >body   ( ^class )
  720.                 0 op!  ( no object to send messages to! )
  721.         else
  722.                 dup ?isObj not abort" Not an object or a class"
  723.                 >obj dup op!  ( make current )
  724.                 >class
  725.         then
  726.         to ^class                       \ reset current class
  727.         ^Class context !                \ add to search order
  728.         ^Class SFA @ ^Super iclass !    \ store superclass in SUPER
  729.         ^Class ^Self iclass !           \ store my class in SELF
  730.         ;
  731.  
  732. : unexpose  ( -- )
  733.         0 ^Super iclass !
  734.         0 ^Self  iclass !
  735.         0 to ^Class
  736.         0 op!
  737.         forth definitions ;
  738. ))
  739.  
  740.  
  741. only forth also definitions
  742.  
  743. cr .( Class loaded )
  744.  
  745.