! :folding=indent:collapseFolds=1:

! $Id$
!
! Copyright (C) 2004 Slava Pestov.
! 
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
! 
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
! 
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
! 
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

IN: generic
USE: errors
USE: hashtables
USE: kernel
USE: lists
USE: namespaces
USE: parser
USE: strings
USE: words
USE: vectors
USE: math
USE: math-internals

! A simple single-dispatch generic word system.

! "if I say I'd rather eat cheese than shit... doesn't mean
! those are the only two things I can eat." - Tac

: predicate-word ( word -- word )
    word-name "?" cat2 "in" get create ;

! Terminology:
! - type: a datatype built in to the runtime, eg fixnum, word
! cons. All objects have exactly one type, new types cannot be
! defined, and types are disjoint.
! - class: a user defined way of differentiating objects, either
! based on type, or some combination of type, predicate, or
! method map.
! - traits: a hashtable has traits of its traits slot is set to
! a hashtable mapping selector names to method definitions.
! The class of an object with traits is determined by the object
! identity of the traits method map.
! - metaclass: a metaclass is a symbol with a handful of word
! properties: "define-method" "builtin-types" "priority"

! Metaclasses have priority -- this induces an order in which
! methods are added to the vtable.

: undefined-method
    "No applicable method." throw ;

: metaclass ( class -- metaclass )
    "metaclass" word-property ;

: builtin-supertypes ( class -- list )
    #! A list of builtin supertypes of the class.
    dup metaclass "builtin-supertypes" word-property call ;

: set-vtable ( definition class vtable -- )
    >r "builtin-type" word-property r> set-vector-nth ;

: <empty-vtable> ( -- vtable )
    num-types [ drop [ undefined-method ] ] vector-project ;

: class-ord ( class -- n ) metaclass "priority" word-property ;

: class< ( cls1 cls2 -- ? )
    swap car class-ord swap car class-ord < ;

: sort-methods ( methods -- alist )
    hash>alist [ class< ] sort ;

: add-method ( vtable definition class -- )
    #! Add the method entry to the vtable. Unlike define-method,
    #! this is called at vtable build time, and in the sorted
    #! order.
    dup metaclass "add-method" word-property
    [ [ undefined-method ] ] unless* call ;

: <vtable> ( methods -- vtable )
    <empty-vtable> swap sort-methods [
        dupd unswons add-method
    ] each ;

DEFER: add-traits-dispatch

: define-generic ( word vtable -- )
    over "combination" word-property cons define-compound ;

: (define-method) ( definition class generic -- )
    [ "methods" word-property [ set-hash ] keep <vtable> ] keep
    swap define-generic ;

! Defining generic words
: (GENERIC) ( combination -- )
    #! Takes a combination parameter. A combination is a
    #! quotation that takes some objects and a vtable from the
    #! stack, and calls the appropriate row of the vtable.
    CREATE 2dup "combination" word-property = [
        2drop
    ] [
        [ swap "combination" set-word-property ] keep
        dup <namespace> "methods" set-word-property
        <empty-vtable> [ add-traits-dispatch ] 2keep
        define-generic
    ] ifte ;

: single-combination ( obj vtable -- )
    >r dup type r> dispatch ; inline

: GENERIC:
    #! GENERIC: bar creates a generic word bar. Add methods to
    #! the generic word using M:.
    [ single-combination ] (GENERIC) ; parsing

: arithmetic-combination ( n n vtable -- )
    #! Note that the numbers remain on the stack, possibly after
    #! being coerced to a maximal type.
    >r arithmetic-type r> dispatch ; inline

: 2GENERIC:
    #! 2GENERIC: bar creates a generic word bar. Add methods to
    #! the generic word using M:. 2GENERIC words dispatch on
    #! arithmetic types and should not be used for non-numerical
    #! types.
    [ arithmetic-combination ] (GENERIC) ; parsing

: define-method ( class -- quotation )
    #! In a vain attempt at something resembling a "meta object
    #! protocol", we call the "define-method" word property with
    #! stack ( class generic definition -- ).
    metaclass "define-method" word-property
    [ [ -rot (define-method) ] ] unless* ;

: M: ( -- class generic [ ] )
    #! M: foo bar begins a definition of the bar generic word
    #! specialized to the foo type.
    scan-word  dup define-method  scan-word swap [ ] ; parsing