Path: csiph.com!aioe.org!eternal-september.org!feeder.eternal-september.org!news.eternal-september.org!.POSTED!not-for-mail From: Carlos Newsgroups: comp.lang.postscript Subject: Experiments with multimethods Date: Fri, 28 Jul 2017 02:58:32 +0200 Organization: A noiseless patient Spider Lines: 301 Message-ID: <20170728025832.5882211d@samara.DOMA> Mime-Version: 1.0 Content-Type: text/plain; charset=US-ASCII Content-Transfer-Encoding: 7bit Injection-Info: mx02.eternal-september.org; posting-host="a6237b7442ed0a10279472c655cc6b7c"; logging-data="12304"; mail-complaints-to="abuse@eternal-september.org"; posting-account="U2FsdGVkX1/0VR5kVGYFOwOCX+Lw9O8n1Y9RQnr6UaU=" X-Newsreader: Claws Mail 3.14.1 (GTK+ 2.24.31; x86_64-pc-linux-gnu) Cancel-Lock: sha1:my7RY+0IWC9U+WeKQmSMiBXv2SQ= Xref: csiph.com comp.lang.postscript:3147 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 --