As this originally was Refinements, it needed some fiddling:
; method creator
meth: func [
{defines a user method with given spec and body}
spec [block!]
body [block!]
] [
; use copies of the original spec and body blocks
spec: copy spec
body: copy/deep body
; find the right place to insert the Self specification
while [
all [
not tail? spec
any [string? first spec block? first spec]
]
] [spec: next spec]
; insert the Self specification
insert spec copy/deep [self [object!]]
func head spec compose/deep [
do bind/copy [(body)] in self 'self
]
]
; method calling dialect:
!: func [
{method caller}
[catch]
message [block!] {
The structure of a message is as follows:
method-path
object
additional arguments according to the method spec
}
/local method-path method-name self position cls
] [
if not (length? message) > 1 [
throw make error! {invalid message}
]
if not any [
word? set/any 'method-path first message
path? get/any 'method-path
] [
throw make error!
{invalid method - must be a word or a path}
]
if not path? :method-path [
method-path: to path! method-path
]
method-name: first :method-path
position: next message
set/any [self position] do/next position
if not object? get/any 'self [
throw make error! {self is not an object}
]
if not cls: in self 'class [
throw make error! {incompatible object}
]
if not object? set/any 'cls get/any get cls [
throw make error! {incompatible class}
]
if not method-name: in cls method-name [
throw make error! {no such method}
]
change :method-path method-name
do compose [(:method-path) (self) (position)]
]
; sample class, feel free to change it as you please:
sample-class: make object! [
; a method returning the object type
type: meth [] [
class
]
; a static value - counter
counter: 0
; a counting method
count: meth [] [
counter: counter + 1
]
reftest: meth [/ref] [
either ref [
print "Ref"
] [
print "No ref"
]
]
]
; sample objects of a sample-class
sample-object1: make object! [
class: 'sample-class
number: ! [count self]
]
sample-object2: make sample-object [
number: ! [count self]
]
; sample method calls
! [type sample-object1]
! [type sample-object2]
! [nonsense sample-object1]
! [reftest sample-object2]
! [reftest/ref sample-object2]
