|
|
||
| Home | SwiftForth Archive | SwiftX Archive | |
I need to ask some questions.
1) In the word list at the end of your post it says you create methods with : .
I have assumed that they are created with VIRTUAL:
2) If I create a object with NEW, how do I execute an method within that object.
If anton's code this would be:
: fred
class_name new \ obj<--
DUP method
destroy \ <--
;
Regards
Charles Esson
talk_at_forth.com wrote:
> Original sender: ForthCAD <mail_at_forthcad.com>
> This is my pre-final OOF system. The final version will be send in +- 3 =
> months because I think its now time to use it in reals applications to =
> validate some (theorical) choises. Also I must now terminates other =
> works...
>
> The system use normals Forth definitions without any preambule nor =
> postambule. So there is NO overhead on methods.=20
>
> The overhead on data will be minimized: its just a offset calculation =
> always necessary when seeking data in a buffer. (The same in any STRUCT =
> systems)
>
> Encapsulation is done by using unnnamed normal Forth wordlist.
>
> Thanks to Will Baden: I think his proposal is very good: its a minimum =
> that enable multiple models, with a very clear syntax. ( sometime I =
> regret the BUILD word existence, but... )
>
> So I hope this minimum will become near a ANSI standard extension.
>
> Already some extra on the Yerk version are:=20
>
> - easy to write: no multiple SELF, (ouf!)
> - easy to read: same syntax as normal Forth, natural word sequence
> - fastest: no pre/postambule on methods inside a class
> - array of class: (I think Yerk only use "indexed objects" )
> - virtual functions with constant small overhead
> - true encapsulation: Yerk place all methods in the same vocabulary
>
> (Source from here, wordset description at the bottom)
> \ =
> =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
> =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
> \ ANSI-CLASS minimum system
> \ Version 0.9 - 31/01/1999
> \ Author: Charles Melice
> \ MAIL: mail_at_forthcad.com
> \ WEB: www.forthcad.com
> \ =
> =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
> =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
>
> ONLY FORTH ALSO DEFINITIONS
>
> \ EMPTY
>
> \ ------------------------------------------------
> \ TO DEFINE IF MISSING
> \ ------------------------------------------------
>
> \ : @REL POSTPONE @ ; IMMEDIATE
> \ : !REL POSTPONE ! ; IMMEDIATE
> \ : ,REL POSTPONE , ; IMMEDIATE
> \ +TO to replace by equivalence
>
> \ ------------------------------------------------
> \ WORDLISTS ENCAPSULATION
> \ ------------------------------------------------
>
> WORDLIST CONSTANT CLASS-WORDLIST
>
> CLASS-WORDLIST SET-CURRENT
>
> WORDLIST DUP CONSTANT PRIVATE-WORDLIST
>
> FORTH-WORDLIST SWAP CLASS-WORDLIST 3 SET-ORDER
>
> \ ------------------------------------------------
> \ IMPORTANT VALUES
> \ ------------------------------------------------
>
> FORTH-WORDLIST SET-CURRENT
>
> 0 VALUE THIS \ seek the object-data base
> 0 VALUE ^CLASS \ seek the in-context class
>
> \ ------------------------------------------------
> \ SOME IMPLEMENTATION WORDS
> \ ------------------------------------------------
>
> PRIVATE-WORDLIST SET-CURRENT
>
> CREATE ^PREV-ORDER 33 CELLS ALLOT
> 0 VALUE PREV-CURRENT
>
> \ used later to define VIRTUAL:=20
> DEFER attach-class-vtable
> DEFER inherit-to-vtemp
>
> : WID> ( class -- addr ) ; IMMEDIATE
> : PARENT> ( class -- addr ) CELL+ ;
> : SIZE> ( class -- addr ) CELL+ CELL+ ;
> : VTABLE> ( class -- addr ) [ 3 CELLS ] LITERAL + ;
>
> : ^SIZE ( -- addr ) ^CLASS SIZE> ;
> : ^VTABLE ( -- addr ) ^CLASS VTABLE> ;
> : ^PARENT ( -- addr ) ^CLASS CELL+ ;
>
> : SaveSearchOrder ( -- )
> get-order dup \ s: widn .. wid1 n n
> ^prev-order ! \ s: widn .. wid1 n
> ^prev-order over cells + \ s: widn .. wid1 n addrmax
> swap 0 \ s: widn .. wid1 addrmax n 0
> ?DO dup >r ! r> cell- LOOP
> drop ;
>
> : RestoreSearchOrder ( -- )
> only
> ^prev-order @ 1+ 1 \ s: n 0
> ?DO \ s: -
> i cells ^prev-order +
> @ context ! also
> LOOP
> previous ;
>
> : AlsoClassSearchOrder ( ^class -- )
> dup parent> @rel ?dup \ have a parent ?
> IF RECURSE THEN \ yes -> SetParentClassSearchOrder
> also @ context ! ;
>
> : SetClassSearchOrder ( -- )
> only forth
> also class-wordlist context !
> ^class AlsoClassSearchOrder ;
>
> : ResetClassSearchOrder ( -- )
> ^class
> BEGIN \ s: -
> previous
> PARENT> @REL
> ?dup 0=3D
> UNTIL ;
>
> : ClassView ( ^CLASS -- )
> to ^class SetClassSearchOrder ;
>
> \ ------------------------------------------------
> \ CLASS DEFINITION
> \ ------------------------------------------------
>
> FORTH-WORDLIST SET-CURRENT
>
> : SUBCLASS ( <<name>> ^parent -- ) \ replace VOCABULARY
> wordlist=20
> create here to ^class \ S: ^parent ^wid
> , \ S: ^parent
> dup ,rel \ S: ^parent
> dup IF size> @ THEN , \ S: - PFA: <wid><parent><size>
> 0 ,REL \ vtable^
> SaveSearchOrder
> get-current to prev-current
> SetClassSearchOrder
> ^class wid> @ set-current \ definitions
> inherit-to-vtemp
> DOES> ; ( -- ^CLASS )
>
> : CLASS ( <<name>> -- )
> 0 SUBCLASS ;
>
> CLASS-WORDLIST SET-CURRENT
>
> : END ( -- )
> attach-class-vtable
> RestoreSearchOrder
> prev-current set-current ;
>
> \ ------------------------------------------------
> \ DATA DEFINITION
> \ ------------------------------------------------
>
> CLASS-WORDLIST SET-CURRENT
>
> : BUFFER: ( <<name>> size -- )
> create
> ^size @ ,
> ^size +!
> DOES> ( body -- offset+THIS )
> @ this + ;
>
> : VARIABLE ( <<name>> -- ) cell BUFFER: ;
>
> \ ------------------------------------------------
> \ SPECIAL WORDLIST LOOKUP
> \ ------------------------------------------------
>
> CLASS-WORDLIST SET-CURRENT
>
> : SUPER ( <<name>> -- )
> ^class cell+ @rel
> dup 0=3D abort" class have no parent"
> ^class >r to ^class
> previous
> '
> state @
> IF compile, ELSE execute THEN
> r> to ^class
> also ^class wid> @ context ! ;
> IMMEDIATE
>
> : COMMON ( <<name>> -- )
> RestoreSearchOrder
> '
> state @
> IF compile, ELSE execute THEN
> SetClassSearchOrder ;
> IMMEDIATE
>
> \ ------------------------------------------------
> \ CLASS-OBJECTS INSTANCE
> \ ------------------------------------------------
>
> PRIVATE-WORDLIST SET-CURRENT
>
> \ TODO: Possibles optimisations:
> \ case...
> \ A - data exist - size > 0
> \ B - data exist with offset
> \ C - virtual method exist vtable <> 0
> \
> \ A B C TODO:
> \ -- -- -- ---------------
> \ 0 0 0 compile,
> \ 0 0 1 save-class compile, restore
> \ 0 1 0 -
> \ 0 1 1 -
> \ 1 0 0 compile,
> \ 1 0 1 save-class compile, restore
> \ 1 1 0 save-this +to compile, restore
> \ 1 1 1 save-class-this compile, restore
> \
>
> : execute-ivar ( ^obj xt -- ) \ not optimal
> ^class this 2>R
> swap
> dup @REL to ^class \ must because virtuals
> cell+ @ +to this
> execute
> 2R> to this to ^class ;
>
> : execute-ivar[] ( index ^obj xt -- ) \ not optimal
> ^class this 2>R
> swap
> dup @REL to ^class \ must because virtuals
> cell+ @ \ S: index xt offset
> rot ^size @ * + \ S: xt offset+index*size
> +to this
> execute
> 2R> to this to ^class ;
>
> : execute-iobj ( ^obj xt -- ) \ not optimal
> ^class this 2>R
> swap
> dup @REL to ^class \ must because virtuals
> cell+ to this
> execute
> 2R> to this to ^class ;
>
> : execute-iobj[] ( index ^obj xt -- )
> ^class this 2>R
> swap
> dup @REL to ^class \ must because virtuals
> cell+ rot \ S: xt ^base index=20
> ^size @ * + \ S: xt offset
> to this
> execute
> 2R> to this to ^class ;
>
> CLASS-WORDLIST SET-CURRENT
>
> : BUILD ( <<objname>> ^CLASS -- )
> ^class >R ClassView \ set new class context
> ^size @ ^CLASS \ S: SIZE CLASS
> R> ClassView \ set original class context
> create
> ,REL ^size @ , \ PFA: <OBJCLASS><OFFSET>
> ^size +! \ S: -
> IMMEDIATE
> DOES>
> ^class >r \ save prev context
> dup @REL \ S: ^obj CLASS
> ClassView \ S: ^obj
> ' \ S: ^obj xt=20
> STATE @
> IF
> postpone 2literal
> postpone execute-ivar
> ELSE
> execute-ivar
> THEN
> r> dup to ^class
> ClassView ;
>
> : BUILD[] ( <<objname>> count ^class -- )
> create
> dup ,REL ^size @ , \ PFA: <OBJCLASS><OFFSET>
> size> @ * ^size +! \ S: -
> IMMEDIATE
> DOES> ( index ^obj -- )
> ^class >r \ save prev context
> dup @REL \ S: index ^obj CLASS
> ClassView \ S: index ^obj
> ' \ S: index ^obj xt
> STATE @
> IF
> postpone 2literal
> postpone execute-ivar[]
> ELSE
> execute-ivar[]
> THEN
> r> dup to ^class
> ClassView ;
>
> FORTH-WORDLIST SET-CURRENT
>
> : BUILD ( <<objname>> ^class -- )
> create
> dup ,rel
> here swap \ S: here ^class
> size> @ dup allot \ PFA: <CLASS><..DATA..>
> 0 fill \ proposal is to initialize
> IMMEDIATE
> DOES>
> SaveSearchOrder
> dup @REL \ S: ^obj CLASS
> ClassView \ S: ^obj
> ' \ S: ^obj xt
> STATE @
> IF
> postpone 2literal
> postpone execute-iobj
> ELSE
> execute-iobj
> THEN
> RestoreSearchOrder ;
>
> : BUILD[] ( <<objname>> count ^class -- )
> create
> dup ,rel \ S: count ^class
> size> @ * \ S: count*size
> here swap \ S: here count*size
> dup allot \ PFA: <CLASS><..DATA..>
> 0 fill \ proposal is to initialize
> IMMEDIATE
> DOES> ( index ^obj -- )
> SaveSearchOrder
> dup @REL \ S: index ^obj CLASS
> ClassView \ S: index ^obj
> ' \ S: index ^obj xt
> STATE @
> IF
> postpone 2literal
> postpone execute-iobj[]
> ELSE
> execute-iobj[]
> THEN
> RestoreSearchOrder ;
>
> =20
>
> \ ------------------------------------------------
> \ (optional) VIRTUAL: ( <<name>> -- )
> \ define a virtual method
> \ ------------------------------------------------
>
> PRIVATE-WORDLIST SET-CURRENT
>
> 100 constant MAX-VIRTUAL
>
> create vTblTemp 0 , MAX-VIRTUAL 2* cells allot
>
> : virt-count ( -- addr )
> ^VTABLE @REL ;
>
> : vtable[] ( n -- addr )
> 2* 1+ cells virt-count + ;
>
> :noname [ IS inherit-to-vtemp ] ( -- )
> 0 vTblTemp !
> ^parent @REL
> IF
> ^class >r
> ^parent @REL to ^class
> ^vtable @REL
> IF
> virt-count @ vTblTemp !
> vTblTemp cell+
> virt-count @ 0
> ?DO
> i vtable[] @REL over !REL
> cell+
> i vtable[] cell+ @REL over !REL
> cell+
> LOOP
> drop
> THEN
> r> to ^class
> THEN
> vTblTemp ^vtable !REL ;
>
> :noname [ IS attach-class-vtable ] ( -- )
> virt-count @
> IF
> here
> virt-count dup @ \ S: body addr count
> dup , 0 \ S: body addr count 0
> ?DO \ S: body addr
> cell+ dup @REL ,REL
> cell+ dup @REL ,REL
> LOOP
> drop
> ^vtable !REL
> ELSE
> 0 ^vtable !REL
> THEN ;
> =20
>
> : in-vtable ( body^ -- pos true | false )
> virt-count @ 0
> ?DO
> i vtable[] cell+ @REL over =3D
> IF drop i TRUE unloop EXIT THEN
> LOOP
> drop FALSE ;
>
> : append-to-vtable ( body^ -- n )
> \ later, we should use allocate/resize
> virt-count @
> dup MAX-VIRTUAL >=3D abort" virtual table overflow - see =
> MAX-VIRTUAL"
>
> vtable[] cell+ !REL
> virt-count @
> dup 1+ virt-count ! ;
>
> : CreateVirtual: ( <<method>> -- vn )
> Create here \ S: bod
> append-to-vtable \ S: vn
> dup 2* 1+ cells , \ S: byte-offset
> \ offset in bytes to speed-up
> DOES> \ TODO: better optimisation
> @ ^vtable @REL + \ this is the virtual overhead
> @REL execute ;=20
>
> \ ------------------------------------------------
> \ Extra words - not defined in ANSI proposal
> \ ------------------------------------------------
>
> CLASS-WORDLIST SET-CURRENT
>
> : VIRTUAL: ( <<name>> -- )
> >IN @
> bl word find
> IF \ S: in^ xt
> >body in-vtable
> IF
> nip \ S: vn
> ELSE
> >IN !
> CreateVirtual: \ S: vn
> THEN
> ELSE \ S: in^ cstr
> drop >IN ! \ S: -
> CreateVirtual: \ S: vn
> THEN
> :noname swap \ S: xt vn
> vtable[] !REL ;
> =20
>
> FORTH-WORDLIST SET-CURRENT
>
> : >THIS ( ^object -- ^membase ) \ usage ' obj >this
> >body cell+ ;
>
> : >CLASS ( ^object -- ^class ) \ usage ' obj >class
> >body @REL ;
>
> : USER> ( ^class -- addr ) \ ' obj >class user> @
> [ 4 CELLS ] LITERAL + ;
>
> : NEW ( ^class -- ^obj )
> dup SIZE> @ cell+
> allocate abort" memory allocation error"
> swap over !REL ;
>
> : NEW[] ( count ^class -- ^obj )
> dup SIZE> @ rot * cell+
> allocate abort" memory allocation error"
> swap over !REL ;
>
> \ FREE DROP can be used - so no collision with RELEASE
>
> : ->" ( <<obj]>> <<method>> -- )
> [char] " word count evaluate
> ^class >R
> dup @REL to ^class \ S: ^obj
> ^class AlsoClassSearchOrder
> ' \ S: ^obj xt
> state @
> IF
> postpone 2literal
> postpone execute-iobj
> ELSE
> execute-iobj
> THEN
> ResetClassSearchOrder
> R> to ^class ;
> IMMEDIATE
>
> : []->" ( index <<obj]>> <<method>> -- )
> [char] " word count evaluate
> ^class >R
> dup @REL to ^class \ S: index ^obj
> ^class AlsoClassSearchOrder
> ' \ S: index ^obj xt
> state @
> IF
> postpone literal
> postpone execute-iobj[]
> ELSE
> execute-iobj[]
> THEN
> ResetClassSearchOrder
> R> to ^class ;
> IMMEDIATE
>
> : .CLASSINFO ( ^class -- )
> SaveSearchOrder
> cr 0 >r
> BEGIN
> dup body> >name count
> swap over cr r@ spaces type cr
> r@ spaces 0 ?DO [char] - emit LOOP
> dup wid> @ context !
> cr r@ spaces words cr
> parent> @rel ?dup 0=3D
> r> 3 + >r=20
> UNTIL
> r> drop
> RestoreSearchOrder ;
>
> : SIZEOF ( ^class -- size )
> size> @ ;
>
> ONLY FORTH ALSO DEFINITIONS
>
> \ ------------------------------------------------
> \ SOURCE END
> \ ------------------------------------------------
>
> =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3DWil Baden ANSI Class wordset =
> proposal=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
>
> CLASS
> CLASS class
> Construct a class.
> A class is a defining word for a collection of future definitions.
>
> SUBCLASS
> class SUBCLASS classname
> Construct an extension or specialization of a class.
>
> VARIABLE WITHIN A CLASS
> VARIABLE membername
> Define a variable member of a class.
>
> BUFFER: WITHIN A CLASS
> n CHARS BUFFER: membername
> n CELLS BUFFER: membername
> Define a data area member of a class.
>
> CONSTANT WITHIN A CLASS
> n CONSTANT membername
> Define a constant member of a class.
>
> : WITHIN A CLASS
> : membername ... ;
> Define a function member of a class.
>
> ; WITHIN A CLASS
> : membername ... ;
> Terminate the definition of a function member of a class.
>
> END WITHIN A CLASS
> END
> Terminate the construction of a class.
>
> BUILD
> class BUILD objectname
> Build object objectname as an instance of class .
> Objects are used object member .
>
> COMMON WITHIN A CLASS
> COMMON forthword
> Compile forthword from standard dictionary.
>
> SUPER WITHIN A CLASS
> SUPER member
> Compile a member, beginning lookup for it in the superclass.
> This disambiguates members with the same name.
>
> =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3DMy extension in the above =
> object base memory adress.
>
> ^CLASS
> This value return the context class body adress.
>
>
.
>From talk_at_forth.com Tue Feb 2 11:51:47 1999
To: sftalk_at_forth.com
Message-Id: <m0000131_at_gerd.forthinc.com>
Subject: - oof NEW NEW[] -> []->
From: ForthCAD <mail_at_forthcad.com>
Date: Tue, 2 Feb 1999 11:51:47 -0000
Charles,
There is a bug, but is it Swift or me ?
This test sequence don't work in SwiftForth:
: eval" [char] " parse evaluate ; immediate
: TEST eval" 9 . 8 . " ; \ don't display 9 8 - BUG ?
A solution is to modify the ->" and []->" definition as this:
\ -------------------------------------------------
\ the following to replace ->"
\ -------------------------------------------------
: -> ( <<method>> -- ) ( S: ^obj -- )
^class >R
dup @REL to ^class \ S: ^obj
^class AlsoClassSearchOrder
' \ S: ^obj xt
state @
IF
postpone 2literal
postpone execute-iobj
ELSE
execute-iobj
THEN
ResetClassSearchOrder
R> to ^class ;
IMMEDIATE
\ -------------------------------------------------
\ the following to replace []->"
\ -------------------------------------------------
: ->[] ( index <<method>> -- ) ( S: ^obj -- )
^class >R
dup @REL to ^class \ S: index ^obj
^class AlsoClassSearchOrder
' \ S: index ^obj xt
state @
IF
postpone literal
postpone execute-iobj[]
ELSE
execute-iobj[]
THEN
ResetClassSearchOrder
R> to ^class ;
IMMEDIATE
\ =
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
\ BASIC-CLASSES.F
\ =
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
empty
REQUIRES CLASS09
\ =
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
\ BASIC CLASSES
\ =
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
Class cVar
variable addr
: @ ( -- val ) addr @ ;
: ! ( val -- ) addr ! ;
: ? ( -- ) addr ? ;
: +! ( val -- ) addr +! ;
: 0! ( -- ) 0 addr COMMON ! ;
: inc ( -- ) 1 +! ;
: dec ( -- ) -1 +! ;
: neg ( -- ) @ negate ! ;
End
cVar SubClass cPtr
cVar build Size
: _?err ( -- ) abort" memory allocation error" ;
: allocate ( size -- ) dup Size ! allocate _?err ! ;
: resize ( size -- ) dup Size ! @ swap resize _?err ! ;
: free ( -- ) Size 0! @ ?dup IF free _?err 0! THEN ;
End
cPtr SubClass cString
cVar build _Len
: _dozstr ( -- ) 0 @ _Len @ chars + C! ;
: zComputeLen ( zstr -- len )
0 swap
BEGIN dup c@ WHILE
char+
swap 1+ swap
REPEAT
drop ;
: GetLen ( -- len ) _Len @ ;
: Type ( -- ) @ _Len @ Type ;
: ? ( -- ) Type ;
: Put ( addr len -- )
_Len ! \ S: addr
GetLen Size @ >=3D \ S: addr flag
IF free GetLen 1+ allocate THEN
@ GetLen move
_dozstr ;
: zPut ( zaddr -- ) dup zComputeLen Put ;
: Concat ( addr len -- )
dup GetLen + dup Size @ >=3D \ S: addr len size flag
IF dup 1+ resize THEN \ S: addr len size
dup _Len !
over - @ + \ S: addr len ptr+
swap move
_dozstr ;
: zConcat ( zaddr -- ) dup zComputeLen Concat ;
: SetEmpty ( -- ) _Len 0! _dozstr ;
: Get ( -- addr count ) @ _Len @ ;
: [] ( index -- addr ) chars @ + ;
: FindCharPos ( ch -- index true | false )
>R @ _Len @ 0
?DO
i [] c@ r@ =3D
IF
r> drop i TRUE
UNLOOP EXIT
THEN
LOOP
r> drop FALSE ;
: free ( -- ) SUPER free _Len 0! ;
End
Class cPoint
Variable x
Variable y
VIRTUAL: NameOf c" cPoint" ;
: .Name NameOf count type ;
: @ ( -- x y ) x @ y @ ;
: ! ( x y -- ) y ! x ! ;
: ? ( -- ) x ? y ? ;
End
Class cRect
cPoint build lt \ left-top
cPoint build rb \ right-bottom
: @ ( -- left top right bottom ) lt @ rb @ ;
: ! ( left top right bottom -- ) rb ! lt ! ;
: ? ( -- ) lt ? [CHAR] - emit 1 spaces =
rb ? ;
End
\ =3D=3D=3D=3D=3D=3D examples =3D=3D=3D=3D=3D=3D
cr
..( NEW immediate mode usage ) cr
cPoint NEW value pPt
1 2 pPt -> !
pPt -> ? cr
pPt -> .Name
cr
..( NEW in a definition ) cr
: m1 [ pPt dup ] -> .Name 1 spaces -> ? ;
m1 cr
8 9 pPt -> !
m1 cr
cr
pPt free drop
( NB:
Using another pointer type -a cRect where there was a cPoint- is
an error.
Best regards
Charles Melice )
----------
From: talk_at_forth.com
Sent: mardi 2 f=E9vrier 1999 4:34
To: Members of SF Talk
Subject: re: - OOF pre-final
Original sender: Charles Esson <charlese_at_cvs.com.au>
I need to ask some questions.
1) In the word list at the end of your post it says you create methods =
with : .
I have assumed that they are created with VIRTUAL:
2) If I create a object with NEW, how do I execute an method within that =
object.
If anton's code this would be:
: fred
class_name new \ obj<--
DUP method
destroy \ <--
;
Regards
Charles Esson
.
>From rvn_at_forth.com Tue Feb 2 06:20:57 1999
To: sftalk_at_forth.com
Message-Id: <m0000132_at_gerd.forthinc.com>
Subject: Re: [sftalk] - oof NEW NEW[] -> []->
From: "Rick VanNorman" <rvn_at_forth.com>
Date: Tue, 2 Feb 1999 06:20:57 -0800
>Original sender: ForthCAD <mail_at_forthcad.com>
>Charles,
>
>There is a bug, but is it Swift or me ?
>
>This test sequence don't work in SwiftForth:
>
>: eval" [char] " parse evaluate ; immediate
>: TEST eval" 9 . 8 . " ; \ don't display 9 8 - BUG ?
This is proper behavior of EVALUATE. Notice that the word TEST
is executable, and prints 9 and 8 when run. Evaluate acts on
the string given it in the current system context, either
compilation or interpretation. Here it was compiling, and
so EVALUATE _compiled_ "9 . 8 ." into the word TEST.
Rick
.
>From talk_at_forth.com Tue Feb 2 15:54:09 1999
To: sftalk_at_forth.com
Message-Id: <m0000133_at_gerd.forthinc.com>
Subject: Re: [sftalk] - oof NEW NEW[] -> []->
From: ForthCAD <mail_at_forthcad.com>
Date: Tue, 2 Feb 1999 15:54:09 -0000
Charles Esson, Rick,=20
Thanks for the information on "evaluate".
My last invoice have a big error: I compile a ALLOCATE result as a =
literal.
Its strange because there is no vodka here...
I send now a solution for -> and ->[] with runtime binding. Its slow.
Later I send a solution to make static binding with object adress. (easy =
and
optimal)
Next: CLASS.F BASIC-CLASSES.F WORDSET.TXT
\ =
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
\ CLASS.F
\ Version 0.92 - 02/02/1999
\ =
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
ONLY FORTH ALSO DEFINITIONS
\ EMPTY
\ ------------------------------------------------
\ TO DEFINE IF MISSING
\ ------------------------------------------------
\ : @REL POSTPONE @ ; IMMEDIATE
\ : !REL POSTPONE ! ; IMMEDIATE
\ : ,REL POSTPONE , ; IMMEDIATE
\ +TO to replace by equivalence
\ ------------------------------------------------
\ WORDLISTS ENCAPSULATION
\ ------------------------------------------------
WORDLIST CONSTANT CLASS-WORDLIST
CLASS-WORDLIST SET-CURRENT
WORDLIST DUP CONSTANT PRIVATE-WORDLIST
FORTH-WORDLIST SWAP CLASS-WORDLIST 3 SET-ORDER
\ ------------------------------------------------
\ IMPORTANT VALUES
\ ------------------------------------------------
FORTH-WORDLIST SET-CURRENT
0 VALUE THIS \ seek the object-data base
0 VALUE ^CLASS \ seek the in-context class
\ ------------------------------------------------
\ SOME IMPLEMENTATION WORDS
\ ------------------------------------------------
PRIVATE-WORDLIST SET-CURRENT
CREATE ^PREV-ORDER 33 CELLS ALLOT
0 VALUE PREV-CURRENT
\ used later to define VIRTUAL:=20
DEFER attach-class-vtable
DEFER inherit-to-vtemp
: WID> ( class -- addr ) ; IMMEDIATE
: PARENT> ( class -- addr ) CELL+ ;
: SIZE> ( class -- addr ) CELL+ CELL+ ;
: VTABLE> ( class -- addr ) [ 3 CELLS ] LITERAL + ;
: ^SIZE ( -- addr ) ^CLASS SIZE> ;
: ^VTABLE ( -- addr ) ^CLASS VTABLE> ;
: ^PARENT ( -- addr ) ^CLASS CELL+ ;
: SaveSearchOrder ( -- )
get-order dup \ s: widn .. wid1 n n
^prev-order ! \ s: widn .. wid1 n
^prev-order over cells + \ s: widn .. wid1 n addrmax
swap 0 \ s: widn .. wid1 addrmax n 0
?DO dup >r ! r> cell- LOOP
drop ;
: RestoreSearchOrder ( -- )
only
^prev-order @ 1+ 1 \ s: n 0
?DO \ s: -
i cells ^prev-order +
@ context ! also
LOOP
previous ;
: AlsoClassSearchOrder ( ^class -- )
dup parent> @rel ?dup \ have a parent ?
IF RECURSE THEN \ yes -> SetParentClassSearchOrder
also @ context ! ;
: SetClassSearchOrder ( -- )
only forth
also class-wordlist context !
^class AlsoClassSearchOrder ;
: ResetClassSearchOrder ( -- )
^class
BEGIN \ s: -
previous
PARENT> @REL
?dup 0=3D
UNTIL ;
: ClassView ( ^CLASS -- )
to ^class SetClassSearchOrder ;
\ ------------------------------------------------
\ CLASS DEFINITION
\ ------------------------------------------------
FORTH-WORDLIST SET-CURRENT
: SUBCLASS ( <<name>> ^parent -- ) \ replace VOCABULARY
wordlist=20
create here to ^class \ S: ^parent ^wid
, \ S: ^parent
dup ,rel \ S: ^parent
dup IF size> @ THEN , \ S: - PFA: <wid><parent><size>
0 ,REL \ vtable^
SaveSearchOrder
get-current to prev-current
SetClassSearchOrder
^class wid> @ set-current \ definitions
inherit-to-vtemp
DOES> ; ( -- ^CLASS )
: CLASS ( <<name>> -- )
0 SUBCLASS ;
CLASS-WORDLIST SET-CURRENT
: END ( -- )
attach-class-vtable
RestoreSearchOrder
prev-current set-current ;
\ ------------------------------------------------
\ DATA DEFINITION
\ ------------------------------------------------
CLASS-WORDLIST SET-CURRENT
: BUFFER: ( <<name>> size -- )
create
^size @ ,
^size +!
DOES> ( body -- offset+THIS )
@ this + ;
: VARIABLE ( <<name>> -- ) cell BUFFER: ;
\ ------------------------------------------------
\ SPECIAL WORDLIST LOOKUP
\ ------------------------------------------------
CLASS-WORDLIST SET-CURRENT
: SUPER ( <<name>> -- )
^class cell+ @rel
dup 0=3D abort" class have no parent"
^class >r to ^class
previous
'
state @
IF compile, ELSE execute THEN
r> to ^class
also ^class wid> @ context ! ;
IMMEDIATE
: COMMON ( <<name>> -- )
RestoreSearchOrder
'
state @
IF compile, ELSE execute THEN
SetClassSearchOrder ;
IMMEDIATE
\ ------------------------------------------------
\ CLASS-OBJECTS INSTANCE
\ ------------------------------------------------
PRIVATE-WORDLIST SET-CURRENT
\ TODO: Possibles optimisations:
\ case...
\ A - data exist - size > 0
\ B - data exist with offset
\ C - virtual method exist vtable <> 0
\
\ A B C TODO:
\ -- -- -- ---------------
\ 0 0 0 compile,
\ 0 0 1 save-class compile, restore
\ 0 1 0 -
\ 0 1 1 -
\ 1 0 0 compile,
\ 1 0 1 save-class compile, restore
\ 1 1 0 save-this +to compile, restore
\ 1 1 1 save-class-this compile, restore
\
: execute-ivar ( ^obj xt -- ) \ not optimal
^class this 2>R
swap
dup @REL to ^class \ must because virtuals
cell+ @ +to this
execute
2R> to this to ^class ;
: execute-ivar[] ( index ^obj xt -- ) \ not optimal
^class this 2>R
swap
dup @REL to ^class \ must because virtuals
cell+ @ \ S: index xt offset
rot ^size @ * + \ S: xt offset+index*size
+to this
execute
2R> to this to ^class ;
: execute-iobj ( ^obj xt -- ) \ not optimal
^class this 2>R
swap
dup @REL to ^class \ must because virtuals
cell+ to this
execute
2R> to this to ^class ;
: execute-iobj[] ( index ^obj xt -- )
^class this 2>R
swap
dup @REL to ^class \ must because virtuals
cell+ rot \ S: xt ^base index=20
^size @ * + \ S: xt offset
to this
execute
2R> to this to ^class ;
CLASS-WORDLIST SET-CURRENT
: BUILD ( <<objname>> ^CLASS -- )
^class >R ClassView \ set new class context
^size @ ^CLASS \ S: SIZE CLASS
R> ClassView \ set original class context
create
,REL ^size @ , \ PFA: <OBJCLASS><OFFSET>
^size +! \ S: -
IMMEDIATE
DOES> ( ^obj -- )
^class >r \ save prev context
dup @REL \ S: ^obj CLASS
ClassView \ S: ^obj
' \ S: ^obj xt=20
STATE @
IF
postpone 2literal
postpone execute-ivar
ELSE
execute-ivar
THEN
r> dup to ^class
ClassView ;
: BUILD[] ( <<objname>> count ^class -- )
create
dup ,REL ^size @ , \ PFA: <OBJCLASS><OFFSET>
size> @ * ^size +! \ S: -
IMMEDIATE
DOES> ( index ^obj -- )
^class >r \ save prev context
dup @REL \ S: index ^obj CLASS
ClassView \ S: index ^obj
' \ S: index ^obj xt
STATE @
IF
postpone 2literal
postpone execute-ivar[]
ELSE
execute-ivar[]
THEN
r> dup to ^class
ClassView ;
FORTH-WORDLIST SET-CURRENT
: BUILD ( <<objname>> ^class -- )
create
dup ,rel
here swap \ S: here ^class
size> @ dup allot \ PFA: <CLASS><..DATA..>
0 fill \ proposal is to initialize
IMMEDIATE
DOES>
SaveSearchOrder
dup @REL \ S: ^obj CLASS
ClassView \ S: ^obj
' \ S: ^obj xt
STATE @
IF
postpone 2literal
postpone execute-iobj
ELSE
execute-iobj
THEN
RestoreSearchOrder ;
: BUILD[] ( <<objname>> count ^class -- )
create
dup ,rel \ S: count ^class
size> @ * \ S: count*size
here swap \ S: here count*size
dup allot \ PFA: <CLASS><..DATA..>
0 fill \ proposal is to initialize
IMMEDIATE
DOES> ( index ^obj -- )
SaveSearchOrder
dup @REL \ S: index ^obj CLASS
ClassView \ S: index ^obj
' \ S: index ^obj xt
STATE @
IF
postpone 2literal
postpone execute-iobj[]
ELSE
execute-iobj[]
THEN
RestoreSearchOrder ;
=20
\ ------------------------------------------------
\ (optional) VIRTUAL: ( <<name>> -- )
\ define a virtual method
\ ------------------------------------------------
PRIVATE-WORDLIST SET-CURRENT
100 constant MAX-VIRTUAL
create vTblTemp 0 , MAX-VIRTUAL 2* cells allot
: virt-count ( -- addr )
^VTABLE @REL ;
: vtable[] ( n -- addr )
2* 1+ cells virt-count + ;
:noname [ IS inherit-to-vtemp ] ( -- )
0 vTblTemp !
^parent @REL
IF
^class >r
^parent @REL to ^class
^vtable @REL
IF
virt-count @ vTblTemp !
vTblTemp cell+
virt-count @ 0
?DO
i vtable[] @REL over !REL
cell+
i vtable[] cell+ @REL over !REL
cell+
LOOP
drop
THEN
r> to ^class
THEN
vTblTemp ^vtable !REL ;
:noname [ IS attach-class-vtable ] ( -- )
virt-count @
IF
here
virt-count dup @ \ S: body addr count
dup , 0 \ S: body addr count 0
?DO \ S: body addr
cell+ dup @REL ,REL
cell+ dup @REL ,REL
LOOP
drop
^vtable !REL
ELSE
0 ^vtable !REL
THEN ;
=20
: in-vtable ( body^ -- pos true | false )
virt-count @ 0
?DO
i vtable[] cell+ @REL over =3D
IF drop i TRUE unloop EXIT THEN
LOOP
drop FALSE ;
: append-to-vtable ( body^ -- n )
\ later, we should use allocate/resize
virt-count @
dup MAX-VIRTUAL >=3D abort" virtual table overflow - see =
MAX-VIRTUAL"
vtable[] cell+ !REL
virt-count @
dup 1+ virt-count ! ;
: CreateVirtual: ( <<method>> -- vn )
Create here \ S: bod
append-to-vtable \ S: vn
dup 2* 1+ cells , \ S: byte-offset
\ offset in bytes to speed-up
DOES> \ TODO: better optimisation
@ ^vtable @REL + \ this is the virtual overhead
@REL execute ;=20
\ ------------------------------------------------
\ Extra words - not defined in ANSI proposal
\ ------------------------------------------------
CLASS-WORDLIST SET-CURRENT
: VIRTUAL: ( <<name>> -- )
>IN @
bl word find
IF \ S: in^ xt
>body in-vtable
IF
nip \ S: vn
ELSE
>IN !
CreateVirtual: \ S: vn
THEN
ELSE \ S: in^ cstr
drop >IN ! \ S: -
CreateVirtual: \ S: vn
THEN
:noname swap \ S: xt vn
vtable[] !REL ;
=20
FORTH-WORDLIST SET-CURRENT
: >THIS ( ^object -- ^membase ) \ usage ' obj >this
>body cell+ ;
: >CLASS ( ^object -- ^class ) \ usage ' obj >class
>body @REL ;
: USER> ( ^class -- addr ) \ ' obj >class user> @
[ 4 CELLS ] LITERAL + ;
: NEW ( ^class -- ^obj )
dup SIZE> @ cell+
allocate abort" memory allocation error"
swap over !REL ;
: NEW[] ( count ^class -- ^obj )
dup SIZE> @ rot * cell+
allocate abort" memory allocation error"
swap over !REL ;
\ FREE DROP can be used with object^ allocated with NEW
PRIVATE-WORDLIST SET-CURRENT
create methname 81 allot \ assume method-name maxlen =3D 80 chars
: execute-> ( ^obj caddr count -- )
methname place
^class this 2>R
dup @REL to ^class
cell+ to this
^class AlsoClassSearchOrder
methname find \ S: ^obj xt
ResetClassSearchOrder
0=3D abort" method not found"
execute=20
2R> to this to ^class ;
: execute->[] ( index ^obj caddr count -- )
methname place \ S: index ^obj
^class this 2>R
dup @REL to ^class
cell+ swap ^size @ * + to this \ S: -
^class AlsoClassSearchOrder
methname find \ S: ^obj xt
ResetClassSearchOrder
0=3D abort" method not found"
execute=20
2R> to this to ^class ;
FORTH-WORDLIST SET-CURRENT
\ runtime binding - slow
: -> ( <<method>> ^obj -- )
state @
IF
bl parse postpone sliteral
postpone execute->
ELSE
bl parse
execute->
THEN ;
IMMEDIATE
: ->[] ( <<method>> index ^obj -- )
state @
IF
bl parse postpone sliteral
postpone execute->[]
ELSE
bl parse
execute->[]
THEN ;
IMMEDIATE
: .CLASSINFO ( ^class -- )
SaveSearchOrder
cr 0 >r
BEGIN
dup body> >name count
swap over cr r@ spaces type cr
r@ spaces 0 ?DO [char] - emit LOOP
dup wid> @ context !
cr r@ spaces words cr
parent> @rel ?dup 0=3D
r> 3 + >r=20
UNTIL
r> drop
RestoreSearchOrder ;
: SIZEOF ( ^class -- size )
size> @ ;
ONLY FORTH ALSO DEFINITIONS
\ ------------------------------------------------
\ THE END
\ ------------------------------------------------
\ =
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
\ BASIC CLASSES
\ =
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
empty
REQUIRES CLASS09
Class cVar
variable addr
: @ ( -- val ) addr @ ;
: ! ( val -- ) addr ! ;
: ? ( -- ) addr ? ;
: +! ( val -- ) addr +! ;
: 0! ( -- ) 0 addr COMMON ! ;
: inc ( -- ) 1 +! ;
: dec ( -- ) -1 +! ;
: neg ( -- ) @ negate ! ;
End
cVar SubClass cPtr
cVar build Size
: _?err ( -- ) abort" memory allocation error" ;
: allocate ( size -- ) dup Size ! allocate _?err ! ;
: resize ( size -- ) dup Size ! @ swap resize _?err ! ;
: free ( -- ) Size 0! @ ?dup IF free _?err 0! THEN ;
End
cPtr SubClass cString
cVar build _Len
: _dozstr ( -- ) 0 @ _Len @ chars + C! ;
: zComputeLen ( zstr -- len )
0 swap
BEGIN dup c@ WHILE
char+
swap 1+ swap
REPEAT
drop ;
: GetLen ( -- len ) _Len @ ;
: Type ( -- ) @ _Len @ Type ;
: ? ( -- ) Type ;
: Put ( addr len -- )
_Len ! \ S: addr
GetLen Size @ >=3D \ S: addr flag
IF free GetLen 1+ allocate THEN
@ GetLen move
_dozstr ;
: zPut ( zaddr -- ) dup zComputeLen Put ;
: Concat ( addr len -- )
dup GetLen + dup Size @ >=3D \ S: addr len size flag
IF dup 1+ resize THEN \ S: addr len size
dup _Len !
over - @ + \ S: addr len ptr+
swap move
_dozstr ;
: zConcat ( zaddr -- ) dup zComputeLen Concat ;
: SetEmpty ( -- ) _Len 0! _dozstr ;
: Get ( -- addr count ) @ _Len @ ;
: [] ( index -- addr ) chars @ + ;
: FindCharPos ( ch -- index true | false )
>R @ _Len @ 0
?DO
i [] c@ r@ =3D
IF
r> drop i TRUE
UNLOOP EXIT
THEN
LOOP
r> drop FALSE ;
: free ( -- ) SUPER free _Len 0! ;
End
Class cPoint
Variable x
Variable y
VIRTUAL: NameOf c" cPoint" ;
: .Name NameOf count type ;
: @ ( -- x y ) x @ y @ ;
: ! ( x y -- ) y ! x ! ;
: ? ( -- ) x ? y ? ;
End
Class cRect
cPoint build lt \ left-top
cPoint build rb \ right-bottom
: @ ( -- left top right bottom ) lt @ rb @ ;
: ! ( left top right bottom -- ) rb ! lt ! ;
: ? ( -- ) lt ? [CHAR] - emit 1 spaces =
rb ? ;
End
\ =3D=3D=3D=3D=3D=3D examples =3D=3D=3D=3D=3D=3D
cr
..( NEW immediate mode usage ) cr
cPoint NEW value pPt
1 2 pPt -> !
pPt -> ? cr
pPt -> .Name
cr
..( -> in a definition ) cr
: m1 pPt -> .Name 1 spaces pPt -> ? ;
m1 cr
8 9 pPt -> !
m1 cr
pPt free drop
cr
..( ->[] immediate mode ) cr
10 cPoint NEW[] value pPt
1 2 0 pPt ->[] !
0 pPt ->[] ? cr=20
3 4 1 pPt ->[] !
1 pPt ->[] ? cr
0 pPt ->[] .Name cr
1 pPt ->[] .Name cr
cr
..( ->[] in definition ) cr
: m2
10 0
?DO \ write i i in pPt[i]
i i i pPt ->[] !
LOOP
10 0
?DO \ display pPt[i]
0 pPt ->[] .Name 1 spaces
i pPt ->[] ?
3 spaces
LOOP ;
m2 cr
pPt free drop
\ =
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
\ Wil Baden ANSI Class wordset proposal
\ =
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
CLASS
CLASS class
Construct a class.
A class is a defining word for a collection of future definitions.
SUBCLASS
class SUBCLASS classname
Construct an extension or specialization of a class.
VARIABLE WITHIN A CLASS
VARIABLE membername
Define a variable member of a class.
BUFFER: WITHIN A CLASS
n CHARS BUFFER: membername
n CELLS BUFFER: membername
Define a data area member of a class.
CONSTANT WITHIN A CLASS
n CONSTANT membername
Define a constant member of a class.
: WITHIN A CLASS
: membername ... ;
Define a function member of a class.
; WITHIN A CLASS
: membername ... ;
Terminate the definition of a function member of a class.
END WITHIN A CLASS
END
Terminate the construction of a class.
BUILD
class BUILD objectname
Build object objectname as an instance of class .
Objects are used object member .
COMMON WITHIN A CLASS
COMMON forthword
Compile forthword from standard dictionary.
SUPER WITHIN A CLASS
SUPER member
Compile a member, beginning lookup for it in the superclass.
This disambiguates members with the same name.
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3DMy extension in the above =
wordset=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
VIRTUAL: WITHIN A CLASS
VIRTUAL: method ... ;
Define a virtual method. By default, method defined with : are=20
no virtual. (see examples)
BUILD[]
COUNT class BUILD[] objectname
Build object array objectname.
Objects are used object member.
Example: 10 VAR BUILD[] var-array
------- 44 5 var-array ! ( store 44 in var-array[5] )
NEW
class NEW
Allocate object objectname as an instance of class, and return
an object pointer. Later, FREE can be used to release the allocated
memory. ( Probably better to garant portability with a RELEASE word =
)
See ->
NEW[]
COUNT class NEW[] value ptr
Allocate object (0 based) array objectname as an instance of class,=20
and return an object pointer.
Later, FREE can be used to release the allocated memory.
Example: variable va
------- 10 VAR NEW[] va !
44 5 []->" va @" ! ( store 44 in va[5] )
See []->
->
^obj -> method
Used with object pointer allocated with NEW. Runtime binding (slow)
Compile time: Compile "method" as a string literal.
Run time: Set the class context to the ^obj-class context
Set the THIS context to the ^obj-data base
Find-execute "method"
Reset class/this context=20
=20
Example: VARIABLE v
------- Point NEW v !
: X@ ( -- x ) =20
v @ -> GetX ;
See NEW
->[]
index ^obj -> method
Used with object pointer allocated with NEW[]. Runtime binding =
(slow)
Compile time: Compile "method" as a string literal.
Run time: Set the class context to the ^obj-class context
Set the THIS context to the ^obj-data base +indexed =
offset
Find-execute "method"
Reset class/this context=20
=20
Example: VARIABLE v
------- 10 Point NEW[] v !
: X[]@ ( i -- x[i] ) =20
v @ ->[] GetX ;
See NEW
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3DOther unnececcary ? =
words=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
SIZEOF
class SIZEOF
Returns the class data size.
THIS
THIS ( -- addr )
PAD TO THIS
The current object data base address. a VALUE.
>THIS
' obj >THIS ( xt -- membase )
Convert XT object adress to the object base memory adress.
^CLASS
This value return the context class body adress.
----------
From: talk_at_forth.com
Sent: mardi 2 f=E9vrier 1999 14:22
To: Members of SF Talk
Subject: re: - oof NEW NEW[] -> []->=20
Original sender: "Rick VanNorman" <rvn_at_forth.com>
>Original sender: ForthCAD <mail_at_forthcad.com>
>Charles,
>
>There is a bug, but is it Swift or me ?
>
>This test sequence don't work in SwiftForth:
>
>: eval" [char] " parse evaluate ; immediate
>: TEST eval" 9 . 8 . " ; \ don't display 9 8 - BUG ?
This is proper behavior of EVALUATE. Notice that the word TEST
is executable, and prints 9 and 8 when run. Evaluate acts on
the string given it in the current system context, either
compilation or interpretation. Here it was compiling, and
so EVALUATE _compiled_ "9 . 8 ." into the word TEST.
Rick
=20
.
>From mail_at_forthcad.com Sun Feb 7 10:13:08 1999
To: sftalk_at_forth.com
Message-Id: <m0000134_at_gerd.forthinc.com>
Subject: - oof 0.95 with test suite 1/3
From: ForthCAD <mail_at_forthcad.com>
Date: Sun, 7 Feb 1999 10:13:08 -0800
This message to cut in 2 files:
- CLASS.F
- BASIC-CLASSES.F
\ ------------------------------------------------
\ ------------------------------------------------
\ CLASS.F
\ Version 0.95 - 07/02/1999
\ Author: Charles Melice
\ MAIL: mail_at_forthcad.com
\ WEB: www.forthcad.com
\ ------------------------------------------------
\ ------------------------------------------------
ONLY FORTH ALSO DEFINITIONS DECIMAL
\ EMPTY
\ ------------------------------------------------
\ TO DEFINE IF MISSING
\ ------------------------------------------------
\ : @REL POSTPONE @ ; IMMEDIATE
\ : !REL POSTPONE ! ; IMMEDIATE
\ : ,REL POSTPONE , ; IMMEDIATE
\ ------------------------------------------------
\ WORDLISTS ENCAPSULATION
\ ------------------------------------------------
WORDLIST CONSTANT CLASS-WORDLIST
CLASS-WORDLIST SET-CURRENT
WORDLIST DUP CONSTANT PRIVATE-WORDLIST
FORTH-WORDLIST SWAP CLASS-WORDLIST 3 SET-ORDER
\ ------------------------------------------------
\ USER VARS - How to use this !!!!
\ ------------------------------------------------
CLASS-WORDLIST SET-CURRENT
(
#USER
CELL +USER ^THIS \ seek the object-data base
CELL +USER ^CLASS \ seek the in-context class
TO #USER
)
VARIABLE ^THIS
VARIABLE ^CLASS
\ ------------------------------------------------
\ DIVERS
\ ------------------------------------------------
PRIVATE-WORDLIST SET-CURRENT
CREATE ^PREV-ORDER 33 CELLS ALLOT
0 VALUE PREV-CURRENT
\ used later to define VIRTUAL:
DEFER attach-class-vtable
DEFER inherit-to-vtemp
: WID> ( class -- addr ) ; IMMEDIATE
: PARENT> ( class -- addr ) CELL+ ;
: SIZE> ( class -- addr ) CELL+ CELL+ ;
: VTABLE> ( class -- addr ) [ 3 CELLS ] LITERAL + ;
: ^SIZE ( -- addr ) ^CLASS @ SIZE> ;
: ^VTABLE ( -- addr ) ^CLASS @ VTABLE> ;
: ^PARENT ( -- addr ) ^CLASS @ CELL+ ;
: SaveSearchOrder ( -- )
get-order dup \ s: widn .. wid1 n n
^prev-order ! \ s: widn .. wid1 n
^prev-order over cells + \ s: widn .. wid1 n addrmax
swap 0 \ s: widn .. wid1 addrmax n 0
?DO dup >R ! R> cell- LOOP
drop ;
: RestoreSearchOrder ( -- )
only
^prev-order @ 1+ 1 \ s: n 0
?DO \ s: -
i cells ^prev-order +
@ context ! also
LOOP
previous ;
: AlsoClassSearchOrder ( ^class -- )
dup parent> @rel ?dup \ have a parent ?
IF RECURSE THEN \ yes -> SetParentClassSearchOrder
also @ context ! ;
: SetClassSearchOrder ( -- )
only forth
also class-wordlist context !
^CLASS @ AlsoClassSearchOrder ;
: ResetClassSearchOrder ( -- )
^CLASS @
BEGIN \ s: -
previous
PARENT> @REL
?dup 0=
UNTIL ;
: ClassView ( ^CLASS -- )
^CLASS ! SetClassSearchOrder ;
\ ------------------------------------------------
\ CLASS DEFINITION
\ ------------------------------------------------
FORTH-WORDLIST SET-CURRENT
: SUBCLASS ( <<name>> ^parent -- ) \ replace VOCABULARY
wordlist
create here ^CLASS ! \ S: ^parent ^wid
, \ S: ^parent
dup ,rel \ S: ^parent
dup IF size> @ THEN , \ S: - PFA: <wid><parent><size>
0 ,REL \ vtable^
SaveSearchOrder
get-current to prev-current
SetClassSearchOrder
^CLASS @ wid> @ set-current \ definitions
inherit-to-vtemp
DOES> ; ( -- ^CLASS )
: CLASS ( <<name>> -- )
0 SUBCLASS ;
CLASS-WORDLIST SET-CURRENT
: END ( -- )
attach-class-vtable
RestoreSearchOrder
prev-current set-current ;
\ ------------------------------------------------
\ DATA DEFINITION
\ ------------------------------------------------
CLASS-WORDLIST SET-CURRENT
: BUFFER: ( <<name>> size -- )
create
^size @ ,
^size +!
DOES> ( body -- offset+THIS )
@ ^THIS @ + ;
: VARIABLE ( <<name>> -- ) cell BUFFER: ;
\ ------------------------------------------------
\ SPECIAL WORDLIST LOOKUP
\ ------------------------------------------------
PRIVATE-WORDLIST SET-CURRENT
: exe-newclass ( xt class -- )
^CLASS @ >R ^CLASS !
execute
R> ^CLASS ! ;
CLASS-WORDLIST SET-CURRENT
: SUPER ( <<name>> -- )
^CLASS @ cell+ @REL
dup 0= abort" class have no parent"
previous
bl word find 0=
IF
END
TRUE abort" method not found"
THEN \ S: class xt
also ^CLASS @ wid> @ context !
swap \ S: xt class
state @
IF
postpone 2literal \ TODO: optimize when no virtual:
postpone exe-newclass
ELSE
exe-newclass
THEN ;
IMMEDIATE
: COMMON ( <<name>> -- )
RestoreSearchOrder
'
state @
IF compile, ELSE execute THEN
SetClassSearchOrder ;
IMMEDIATE
\ ------------------------------------------------
\ CLASS-OBJECTS INSTANCE
\ ------------------------------------------------
PRIVATE-WORDLIST SET-CURRENT
\ TODO: Possibles optimisations:
\ case...
\ A - data exist - size > 0
\ B - data exist with offset
\ C - virtual method exist vtable <> 0
\
\ A B C TODO:
\ -- -- -- ---------------
\ 0 0 0 compile,
\ 0 0 1 save-class compile, restore
\ 0 1 0 -
\ 0 1 1 -
\ 1 0 0 compile,
\ 1 0 1 save-class compile, restore
\ 1 1 0 save-this +to compile, restore
\ 1 1 1 save-class-this compile, restore
\
: execute-ivar ( ^obj xt -- ) \ not optimal
^CLASS @ ^THIS @ 2>R
swap
dup @REL ^CLASS ! \ must because virtuals
cell+ @ ^THIS +!
execute
2R> ^THIS ! ^CLASS ! ;
: execute-ivar[] ( index ^obj xt -- ) \ not optimal
^CLASS @ ^THIS @ 2>R
swap
dup @REL ^CLASS ! \ must because virtuals
cell+ @ \ S: index xt offset
rot ^size @ * + \ S: xt offset+index*size
^THIS +!
execute
2R> ^THIS ! ^CLASS ! ;
: execute-iobj ( ^obj xt -- ) \ not optimal
^CLASS @ ^THIS @ 2>R
swap
dup @REL ^CLASS ! \ must because virtuals
cell+ ^THIS !
execute
2R> ^THIS ! ^CLASS ! ;
: execute-iobj[] ( index ^obj xt -- )
^CLASS @ ^THIS @ 2>R
swap
dup @REL ^CLASS ! \ must because virtuals
cell+ rot \ S: xt ^base index
^size @ * + \ S: xt offset
^THIS !
execute
2R> ^THIS ! ^CLASS ! ;
: INTERPRET-OBJECT-METHOD ( ^obj xt-exe-xx <<method>> -- )
>R
^CLASS @ >R \ save prev context
dup @REL \ S: ^obj CLASS
ClassView \ S: ^obj
bl word find \ S: ^obj xt
R> ClassView
0= abort" method not found"
STATE @
IF
postpone 2literal
R> compile,
ELSE
ResetClassSearchOrder
R> execute
THEN ;
CLASS-WORDLIST SET-CURRENT
: BUILD ( <<objname>> ^CLASS -- )
create
dup ,REL ^size @ , \ PFA: <OBJCLASS><OFFSET>
size> @ ^size +! \ S: -
IMMEDIATE
DOES> ( ^obj -- )
['] execute-ivar
INTERPRET-OBJECT-METHOD ;
: BUILD[] ( <<objname>> count ^class -- )
create
dup ,REL ^size @ , \ PFA: <OBJCLASS><OFFSET>
size> @ * ^size +! \ S: -
IMMEDIATE
DOES> ( index ^obj -- )
['] execute-ivar[]
INTERPRET-OBJECT-METHOD ;
FORTH-WORDLIST SET-CURRENT
: BUILD ( <<objname>> ^class -- )
create
dup ,rel
here swap \ S: here ^class
size> @ dup allot \ PFA: <CLASS><..DATA..>
0 fill \ proposal is to initialize
IMMEDIATE
DOES>
SaveSearchOrder
['] execute-iobj
INTERPRET-OBJECT-METHOD
RestoreSearchOrder ;
: BUILD[] ( <<objname>> count ^class -- )
create
dup ,rel \ S: count ^class
size> @ * \ S: count*size
here swap \ S: here count*size
dup allot \ PFA: <CLASS><..DATA..>
0 fill \ proposal is to initialize
IMMEDIATE
DOES> ( index ^obj -- )
SaveSearchOrder
['] execute-iobj[]
INTERPRET-OBJECT-METHOD
RestoreSearchOrder ;
\ ------------------------------------------------
\ (optional) VIRTUAL: ( <<name>> -- )
\ define a virtual method
\ ------------------------------------------------
PRIVATE-WORDLIST SET-CURRENT
100 constant MAX-VIRTUAL
create vTblTemp 0 , MAX-VIRTUAL 2* cells allot
: virt-count ( -- addr )
^VTABLE @REL ;
: vtable[] ( n -- addr )
2* 1+ cells virt-count + ;
:noname [ IS inherit-to-vtemp ] ( -- )
0 vTblTemp !
^parent @REL
IF
^CLASS @ >R
^parent @REL ^CLASS !
^vtable @REL
IF
virt-count @ vTblTemp !
vTblTemp cell+
virt-count @ 0
?DO
i vtable[] @REL over !REL
cell+
i vtable[] cell+ @REL over !REL
cell+
LOOP
drop
THEN
R> ^CLASS !
THEN
vTblTemp ^vtable !REL ;
:noname [ IS attach-class-vtable ] ( -- )
virt-count @
IF
here
virt-count dup @ \ S: body addr count
dup , 0 \ S: body addr count 0
?DO \ S: body addr
cell+ dup @REL ,REL
cell+ dup @REL ,REL
LOOP
drop
^vtable !REL
ELSE
0 ^vtable !REL
THEN ;
: in-vtable ( body^ -- pos true | false )
virt-count @ 0
?DO
i vtable[] cell+ @REL over =
IF drop i TRUE unloop EXIT THEN
LOOP
drop FALSE ;
: append-to-vtable ( body^ -- n )
\ later, we should use allocate/resize
virt-count @
dup MAX-VIRTUAL >= abort" virtual table overflow - see MAX-VIRTUAL"
vtable[] cell+ !REL
virt-count @
dup 1+ virt-count ! ;
: CreateVirtual: ( <<method>> -- vn )
Create here \ S: bod
append-to-vtable \ S: vn
dup 2* 1+ cells , \ S: byte-offset
\ offset in bytes to speed-up
DOES> \ TODO: better optimisation
@ ^vtable @REL + \ this is the virtual overhead
@REL execute ;
\ ------------------------------------------------
\ Extra words - not defined in ANSI proposal
\ ------------------------------------------------
CLASS-WORDLIST SET-CURRENT
: VIRTUAL: ( <<name>> -- )
>IN @
bl word find
IF \ S: in^ xt
>body in-vtable
IF
nip \ S: vn
ELSE
>IN !
CreateVirtual: \ S: vn
THEN
ELSE \ S: in^ cstr
drop >IN ! \ S: -
CreateVirtual: \ S: vn
THEN
:noname swap \ S: xt vn
vtable[] !REL ;
FORTH-WORDLIST SET-CURRENT
: THIS ( -- mem-base ) ^THIS @ ;
: >THIS ( ^object -- ^membase ) \ usage ' obj >this
>body cell+ ;
: >CLASS ( ^object -- class ) \ usage ' obj >class
>body @REL ;
: USER> ( ^class -- addr ) \ ' obj >class user> @
[ 4 CELLS ] LITERAL + ;
: NEW ( ^class -- ^obj )
dup SIZE> @ cell+
allocate abort" memory allocation error"
swap over !REL ;
: NEW[] ( count ^class -- ^obj )
dup SIZE> @ rot * cell+
allocate abort" memory allocation error"
swap over !REL ;
\ FREE DROP can be used with object^ allocated with NEW
PRIVATE-WORDLIST SET-CURRENT
create methname 81 allot \ assume method-name maxlen = 80 chars
: execute-> ( ^obj caddr count -- )
methname place
^CLASS @ THIS @ 2>R
dup @REL ^CLASS !
cell+ THIS !
^CLASS @ AlsoClassSearchOrder
methname find \ S: ^obj xt
ResetClassSearchOrder
0= abort" method not found"
execute
2R> THIS ! ^CLASS ! ;
: execute->[] ( index ^obj caddr count -- )
methname place \ S: index ^obj
^CLASS @ THIS @ 2>R
dup @REL ^CLASS !
cell+ swap ^size @ * + THIS ! \ S: -
^CLASS @ AlsoClassSearchOrder
methname find \ S: ^obj xt
ResetClassSearchOrder
0= abort" method not found"
execute
2R> THIS ! ^CLASS ! ;
FORTH-WORDLIST SET-CURRENT
\ runtime binding - slow
: LATER ( ^obj <<method>> -- )
state @
IF
bl parse postpone sliteral
postpone execute->
ELSE
bl parse
execute->
THEN ;
IMMEDIATE
: LATER[] ( <<method>> index ^obj -- )
state @
IF
bl parse postpone sliteral
postpone execute->[]
ELSE
bl parse
execute->[]
THEN ;
IMMEDIATE
\ static binding - fast
PRIVATE-WORDLIST SET-CURRENT
: M' ( ^class <<method>> -- xt )
SaveSearchOrder
only AlsoClassSearchOrder
bl word find
RestoreSearchOrder
0= abort" method not found" ;
: CM' ( ^class <<method>> -- xt )
only AlsoClassSearchOrder
bl word find
SetClassSearchOrder
0= abort" method not found" ;
CLASS-WORDLIST SET-CURRENT
\ TODO: test - nothing tested
: -> ( ^class <<method>> -- )
CM'
postpone literal
postpone execute-ivar ;
IMMEDIATE
: ->[] ( index ^class <<method>> -- )
CM'
postpone literal
postpone execute-ivar[] ;
IMMEDIATE
FORTH-WORDLIST SET-CURRENT
\ TODO: test - a few tested
: -> ( ^class <<method>> -- )
M'
postpone literal
postpone execute-iobj ;
IMMEDIATE
: ->[] ( index ^class <<method>> -- )
M'
postpone literal
postpone execute-iobj[] ;
IMMEDIATE
: .CLASSINFO ( ^class -- )
context @ >R
cr 0 >R
BEGIN \ S: ^class
dup body> >name count
swap over cr r@ spaces type cr
r@ spaces 0 ?DO [char] - emit LOOP
dup wid> @ context !
cr r@ spaces words cr
parent> @rel ?dup 0=
R> 3 + >R
UNTIL
R> drop
R> context ! ;
: SIZEOF ( ^class -- size )
size> @ ;
ONLY FORTH ALSO DEFINITIONS
\ -- The End --
\ ------------------------------------------------
\ ------------------------------------------------
\ BASIC-CLASSES.F
\ Author: Charles Melice
\ MAIL: mail_at_forthcad.com
\ ------------------------------------------------
\ ------------------------------------------------
ONLY FORTH ALSO DEFINITIONS DECIMAL
EMPTY
REQUIRES CLASS
1 IMPORT: MessageBeep ( 0 )
: beep 0 MessageBeep drop ;
Class cVar
variable addr
: @ ( -- val ) addr @ ;
: ! ( val -- ) addr ! ;
: ? ( -- ) addr ? ;
: +! ( val -- ) addr +! ;
: 0! ( -- ) 0 addr COMMON ! ;
: inc ( -- ) 1 +!