Groups | Search | Server Info | Keyboard shortcuts | Login | Register [http] [https] [nntp] [nntps]

Groups > comp.lang.postscript > #3147

Experiments with multimethods

Show all headers | View raw

This is somewhat related to parameter checking, which is a subject of
the other thread.

Last year there was a discussion about the capabilities of PostScript
as a programming language. It was argued that you can't define custom
overloads for the standard operators, so to prove that you can do
*everything* in PostScript I implemented a small proof-of-concept
library to add multimethods and a type system.

(Of course you can't do *everything* in PostScript, but thanks to the
fact that (1) code is data, and (2) it is garbage collected, you can
do a lot more than in other programming languages.)

Here is that particular message:

  https://groups.google.com/d/msg/comp.lang.postscript/fEyXR90-wq4/OofyLFEJBgAJ

With this library, you can define a new type by adding a constraint to
an existing type. For example,

/starts-with-A-type /stringtype {
    dup length 1 ge { 0 get 65 eq } { false } ifelse
} deftype

GS>(abcd) type ==
stringtype

GS>(Abcd) type ==
starts-with-A-type

GS>/starts-with-A-type ancestors ==
[/starts-with-A-type /stringtype /sequencetype /anytype]

A multimethod is like a method, but it's dispatched on the types of
all its arguments. It's akin to operator overloading.

/add [/sequencetype /sequencetype] {
    2 copy length exch length add
    1 index /basearraytype isa { array } { string } ifelse
    dup 4 -1 roll 1 index copy length 4 -1 roll putinterval
} defmethod

GS>(Abcd) (efgh) add ==
(Abcdefgh)

GS>1 1 add ==
2

(The example with mul in the linked message is maybe more
illustrative.)

The similarity with parameter checking comes from the fact that if a
method isn't found for the given arguments, an error is signaled (just
a message here).

/+ [/numbertype /numbertype] { add } defmethod

GS>1 1 + =
2

GS>(Abcd) (efgh) +
no applicable method

Now I think this "type system" is the wrong way to go for OOP. It's
better to leave built-in types alone and just use dicts for user
objects. It would make the system more efficient and flexible,
allowing multiple inheritance. The constraint based type definition
has maybe its uses, but OOP isn't one. Anyway, I didn't realize it at
the time.

%!PS

% /Inspect /Inspect /ProcSet findresource def

% /ppstack { Inspect /inspectstack get exec = } def


/builtintype systemdict /type get def

/TYPES <<
    /anytype <<
        /NAME /anytype
        /PARENT null
        /SUBTYPES 15 dict
        /CHECK { pop true } bind
    >>
    /~~BUILTIN~~ 15 dict
>> def

%: typename ->
/defbuiltintype {
    2 dict begin
    /typename exch def
    /typedata <<
        /NAME typename
        /PARENT TYPES /anytype get
        /SUBTYPES << >>
        /CHECK [ /builtintype cvx typename /eq cvx ] cvx bind
    >> def
    TYPES typename typedata put
    TYPES /anytype get /SUBTYPES get typename typedata put
    TYPES /~~BUILTIN~~ get typename typedata put
    end
} bind def


[ /arraytype /booleantype /dicttype /filetype /fonttype /gstatetype
  /integertype /marktype /nametype /nulltype /operatortype
  /packedarraytype /realtype /savetype /stringtype
] {
    defbuiltintype
} forall

currentdict /defbuiltintype undef

%: typename parenttypename checkproc ->
/deftype {
    5 dict begin
    /check exch def  /parentname exch def  /name exch def
    /parent TYPES parentname get def
    /typedata <<
        /NAME name   /PARENT parent   /CHECK /check load
        /SUBTYPES << >>
    >> def
    parent /SUBTYPES get name typedata put
    TYPES name typedata put
    end
} bind def

% some adjustments to builtin types:
%   insert numbertype (before real- and integertype),
%       basearraytype (before array- and packedarraytype)
%    and sequencetype (before basearray- and stringtype)

% [... name2 name1] -> dup name1 eq exch dup name2 eq exch ... ... or or
/@eq_to_any {
    2 dict begin
    /arr exch def  /len arr length def
    len 0 gt {
        len 1 gt { /dup cvx } if
        arr len 1 sub get
        /eq cvx
        len 1 gt { /exch cvx } if
        arr 0 len 1 sub getinterval @eq_to_any
        len 1 gt { /or cvx } if
    } if
    end
} bind def

[ /basearraytype [ /arraytype /packedarraytype ]
  /sequencetype  [ /basearraytype /stringtype  ]
  /numbertype    [ /integertype /realtype      ]
] 1 2 2 index length {
    5 dict begin
    /subtypenames 2 index 2 index get def
    /name exch 1 sub 2 index exch get def
    /subtypes [ subtypenames { TYPES exch get } forall ] def
    /check [ /type cvx subtypenames @eq_to_any ] cvx def
    name /anytype /check load deftype
    /t TYPES name get def
    subtypes {
        t /SUBTYPES get 1 index dup /NAME get exch put
        dup /PARENT t put
        TYPES /anytype get /SUBTYPES get exch undef
    } forall
    end
} for pop

currentdict /@eq_to_any undef

%: any -> typename
/type {
    3 dict begin
    /obj exch def
    /typename /obj load builtintype def
    /subtypes TYPES /typename load get /SUBTYPES get def
    true  % exit loop
    {
        subtypes {
            exch pop
            dup /CHECK get /obj load exch exec {
                dup /typename exch /NAME get def
                /subtypes exch /SUBTYPES get def
                pop false  % don't exit loop
                exit
            } {
                pop
            } ifelse
        } forall
        % exit loop?
        { exit } { true } ifelse
    } loop
    /typename load cvx
    end
} bind def

%: typename -> array
/ancestors {
    [
        TYPES 3 -1 roll get
        {
            dup /NAME get exch
            /PARENT get dup null eq { pop exit } if
        } loop
    ]
} bind def

%: any typename -> bool
/isa {
    false 3 -1 roll
    type ancestors {
        2 index eq { pop true exit } if
    } forall
    exch pop
} bind def


/METHODS << >> def

%: name [argtypes] proc ->
/defmethod {
    3 -1 roll
    dup METHODS exch known not {
        dup where {
            1 index get
        } {
            null
        } ifelse
        % stack: [argtypes] proc name originalproc/null
        1 index
        3 dict begin
        /name exch def  /orig exch def  /arity 3 index length def
        METHODS name <<
            /ORIGINAL /orig load
            /ARITY arity
            /DISPATCH << >>
        >> put
        end
    } if
    4 dict begin
    /name exch def  /proc exch def  /argtypes exch def
    /method METHODS name get def
    method /ARITY get argtypes length ne {
        % signal error "invalid arity"
        stop
    } if
    method /DISPATCH get
    argtypes 0 argtypes length 1 sub getinterval {
        2 copy known not {
            2 copy 1 dict put
        } if
        get
    } forall
    argtypes argtypes length 1 sub get /proc load put
    name
    end
    dup [ exch /callmethod cvx ] cvx def
} bind def

%: methodname -> ...
/callmethod {
    dup METHODS exch known {
        METHODS exch get
        dup /ORIGINAL get exch
        dup /DISPATCH get
        exch /ARITY get 1 add -1 2 {
            % stack: argN ... arg1 orig dispatch idx
            index type ancestors false % found?
            exch {
                % stack: ... dispatch false typename
                dup 3 index exch known {
                    3 -1 roll exch get exch pop true
                    exit
                } {
                    pop
                } ifelse
            } forall
            % if found, continue with next argument; else leave
            { } { exit } ifelse
        } for
        dup builtintype /dicttype eq {  % we didn't reach the proc
            pop  dup null eq {  % no fallback function
                % signal error "no applicable method"
                (no applicable method)=
                pop stop
            } {
                exec % call fallback function
            } ifelse
        } {
            exch pop
            exec % call method
        } ifelse
    } {
        % signal error "no such method"
        (no such method (!))=
        stop
    } ifelse
} bind def

-- 

Back to comp.lang.postscript | Previous | Next — Next in thread | Find similar | Unroll thread

Thread

Experiments with multimethods Carlos <carlos@cvkm.cz> - 2017-07-28 02:58 +0200
  Re: Experiments with multimethods luser droog <luser.droog@gmail.com> - 2017-07-29 09:12 -0700
    Re: Experiments with multimethods luser droog <luser.droog@gmail.com> - 2017-08-01 22:33 -0700
      Re: Experiments with multimethods luser droog <luser.droog@gmail.com> - 2017-08-01 23:37 -0700
        Re: Experiments with multimethods luser droog <luser.droog@gmail.com> - 2017-08-05 17:29 -0700
          Re: Experiments with multimethods Carlos <carlos@cvkm.cz> - 2017-08-06 14:45 +0200
            Re: Experiments with multimethods luser droog <luser.droog@gmail.com> - 2017-08-22 09:25 -0700

csiph-web