/hmsl/fth/obmethod.fth
https://github.com/philburk/hmsl · Forth · 272 lines · 245 code · 27 blank · 0 comment · 19 complexity · 5b7a9a37db837a4a435c0a042e543aed MD5 · raw file
- \ @(#) obmethod.fth 96/06/11 1.1
- \ This file defines the words used to define METHODS for a class.
- \ Methods are used to manipulate an objects instance variables.
- \
- \ Author: Phil Burk
- \ Copyright 1986 Phil Burk
- \
- \ MOD: PLB 11/29/86 Store CFAs in relocatable form for MAC
- \ MOD: PLB 2/10/87 Catch redeclared Methods!
- \ MOD: PLB 9/5/87 Add METHODS.OF and other tools.
- \ MOD: PLB 9/10/87 Attempt smart forget.
- \ MOD: PLB 11/16/87 Add CURRENT.OBJECT
- \ MOD: PLB 1/13/87 Use PFA for backlinking methods instead of NFA.
- \ MOD: PLB 9/13/88 Add [FORGET] to eliminate need for MRESET
- \ MOD: PLB 5/22/89 Add 0 ob-state ! to [FORGET]
- \ MOD: PLB 9/22/89 Fix stack checking for H4th.
- \ MOD: PLB 12/15/89 Add Defining Class for METHODS.OF
- \ MOD: PLB 3/31/92 Added INHERIT.METHOD
- \ 00001 PLB 8/3/92 Objects put absolute address on stack.
- ANEW TASK-OBMETHOD
- : MI++ ( -- index , allocate new method index )
- mi-next @ ( current )
- dup 1+ mi-next ! ( increment )
- ;
- \ Method contents:
- \ CELL 0 = method index.
- \ CELL 1 = method back link (in relocatable form ).
- \ Holds PFA of last defined method, relocatable.
- CREATE METHOD-LAST 0 ,
- : (METHOD) ( <name:> -- , declare method for later definition )
- CREATE
- here ( for linking )
- mi++ , ( cell1: set index )
- method-last @ , ( cell2: back pointer )
- use->rel method-last ! ( point to PFA of this method. )
- immediate ( make it immediate )
- DOES> @ ob.bind ( bind message to object )
- ;
- : METHOD ( <name:> -- , declare method if new )
- >in @ >r \ save input pointer
- ho.find.pfa
- r> >in ! \ restore input pointer
- IF
- @ mi-next <
- IF bl word count type ." - method already declared." cr
- ELSE (method)
- THEN
- ELSE (method)
- THEN
- ;
- : OB.MIND@ ( <WORD> -- INDEX , return index )
- ho.find.pfa NOT
- IF
- " OB.MIND@" " Method not declared!"
- ER_FATAL ER.REPORT
- ELSE ( save NFA of method for debugger )
- dup pfa->nfa current-method ! @
- THEN
- ;
- \ Pairs checking for Method definitions.
- : OB.CHECK:M ( flag -- , report pairing error if flag different )
- dup ob-inside-:m @ =
- IF not ob-inside-:m !
- ELSE drop " OB.CHECK:M" " Missing :M or ;M in class definition!"
- er_fatal er.report
- THEN
- ;
- \ :M is one of the most complicated words in the system.
- \ It generates a headerless secondary with some object stack manipulations
- \ at the beginning and end.
- \ It will have to be hand tweaked for each FORTH because of
- \ differences in the compilers.
- : :M ( <method> -- , COMPILE A METHOD FOR A CLASS )
- false ob.check:m
- ob.mind@ dup ob-current-mind !
- :noname ( -- mi exectoken , save exectoken )
- \
- \ Calculate offset into cfa table for this method.
- swap cell* ( -- cfa moffset )
- \ Store CFA in methods table.
- ob-current-class @ ob_cfas + ( -- base_cfas ) + !
- ;
- defer ;M immediate
- : <;M> ( -- , Terminate method definition )
- true ob.check:m
- current-method off
- -1 ob-current-mind !
- [compile] ; ( Go back to interpretation mode , checks stack )
- ; immediate
- \ Use deferred ;M for Locals and Debugger.
- ' <;M> is ;M
-
- 0 MI-NEXT ! ( reset method counter )
- METHOD INIT: ( INIT: MUST have method index = 0 !!! )
- \ This is handy for inside Forth words called from a method.
- : CURRENT.OBJECT ( -- object )
- os.copy
- \ use->rel \ 00001
- ;
- create MRESET-WARN true ,
- : MRESET ( <method> -- )
- 32 word
- mreset-warn @
- IF ." MRESET " $type
- ." is no longer needed!" cr
- ELSE drop
- THEN
- ;
- : [FORGET] ( -- , reset method index )
- [forget]
- method-last @ rel->use ( get last method )
- BEGIN dup here > ( is it forgotten )
- WHILE ( -- method_pfa )
- cell+ @ if.rel->use
- REPEAT
- dup if.use->rel method-last ! ( set pointer to last )
- @ 1+ mi-next ! ( reset index so CFA tables don't grow)
- 0 ob-state ! ( reset state to avoid :CLASS warnings )
- ;
- : METHOD.LINK ( method_PFA -- index previous_pfa )
- dup @ swap cell+ @ ?dup
- IF rel->use
- ELSE 0 ( for the Mac )
- THEN
- ;
- : (.METHOD) ( method_pfa method_index -- , print it )
- 4 .r space pfa->nfa id.
- ;
- : ALL.METHODS ( -- list all methods )
- cr method-last @ rel->use
- BEGIN dup
- WHILE dup method.link -rot
- (.method) cr ?pause
- REPEAT drop
- ;
- variable OB-SCRATCH
- : ?DEFINING.CLASS ( method_index pfa_class -- pfa_class' )
- \ Scan backwards in Class list to find first occurrence of method.
- \ Do this by checking superclass for bad method, index overrange,
- \ or 0 pointer.
- 2dup method@ >r ( cfa to match with )
- \ Give up if 0 super link.
- BEGIN dup ..@ ob_super dup ob-scratch ! ( non-zero? )
- IF ( super class = 0 for object class )
- \ Give up if method count of superclass too low.
- ob-scratch @ ..@ ob_#methods 2 pick >
- \ Give up if method CFA doesn't match
- IF over ob-scratch @ method@ r@ =
- IF drop ob-scratch @ ( use super ) false
- ELSE true
- THEN
- ELSE true
- THEN
- ELSE true
- THEN
- UNTIL rdrop nip
- ;
- : METHODS.OF ( <class> -- , list valid methods for class )
- cr ho.find.pfa
- IF dup ob.check.class
- >r
- \ Start with last method defined, scan all methods,
- \ print it if its method cfa is not the OB.BAD.METHOD cfa.
- method-last @ rel->use
- BEGIN dup ?pause
- \ Link to next method header in dictionary.
- WHILE dup method.link -rot ( -- prev pfa i )
- \ Check to see if class method table is big enough.
- dup r@ ..@ ob_#methods < ( -- prev pfa i f )
- IF ( prev pfa index )
- \ Compare CFA of method.
- dup r@ method@ 'c ob.bad.method -
- IF tuck (.method) 4 spaces
- r@ ?defining.class pfa->nfa
- BL 20 emit-to-column id. cr
- ELSE 2drop
- THEN
- ELSE 2drop
- THEN
- REPEAT drop
- rdrop
- ELSE " METHODS.OF" " Not a class!"
- er_fatal er.report
- THEN
- ;
- : IS.SUPER? { pfa_class1 pfa_class2 | flag -- flag , is class2 a superclass of class1 }
- false -> flag
- pfa_class1
- BEGIN
- ..@ ob_super ?dup
- WHILE
- dup pfa_class2 =
- IF
- true -> flag
- THEN
- REPEAT
- flag
- ;
- : INHERIT.METHOD ( <method> <class> -- )
- ob-state @ 0=
- abort" INHERIT.METHOD only valid between :CLASS and ;CLASS"
- \
- \ get method index of method given
- ho.find.pfa NOT
- IF " INHERIT.METHOD" " METHOD not found"
- ER_FATAL ER.REPORT
- THEN ( -- method-pfa )
- @ >r \ get method index
- \
- \ get class
- ho.find.pfa NOT
- IF " INHERIT.METHOD" " CLASS not found"
- ER_FATAL ER.REPORT
- THEN ( -- class-pfa )
- dup ob.check.class
- \
- \ warn if not superclass of current class
- ob-current-class @ over is.super? not
- IF
- ." Warning from INHERIT.METHOD. "
- dup pfa->nfa id.
- ." not a SUPER-class of "
- ob-current-class @ pfa->nfa id. cr
- THEN
- \
- \ get cfa for that method
- .. ob_cfas
- r@ cells + @ ( method cfa )
- \
- \ save in current class
- ob-current-class @ ( -- pfa-class )
- .. ob_cfas
- r> cells + !
- ;
- \ Required Initialization
- : OB.INIT ( -- )
- os.sp! ( set object stack pointers )
- 0 ob-state !
- 0 ob-current-class !
- 0 ob-self-cfas !
- 0 ob-super-cfas !
- 0 ob-dooper-cfas !
- true ob-if-check-bind !
- ;
- : OB.TERM ( -- )
- ;