! Copyright (C) 2011 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays classes classes.builtin classes.parser
classes.private kernel kernel.private layouts lexer namespaces
parser sequences slots vocabs.parser words ;
IN: builtins

: lookup-type-number ( word -- n )
    [ target-word ] with-global type-number ;

: set-type-number ( target-class existing-class -- )
    lookup-type-number "type" set-word-prop ;

: set-builtins-array ( class -- )
    dup "type" word-prop builtins get set-nth ;

: define-builtin-class ( class -- )
    f f f builtin-class define-class ;

: register-builtin ( class -- )
    [ dup set-type-number ]
    [ set-builtins-array ]
    [ define-builtin-class ]
    tri ;

ERROR: not-a-builtin object ;

: verify-builtin ( string -- )
    dup current-vocab lookup-word [
        nip
        dup "metaclass" word-prop builtin-class =
        [ drop ] [ not-a-builtin ] if
    ] [
        not-a-builtin
    ] if* ;

: prepare-slots ( slots -- slots' )
    [ [ dup pair? [ first2 create ] when ] map ] map ;

: define-builtin-slots ( class slots -- )
    prepare-slots make-slots 1 finalize-slots
    [ "slots" set-word-prop ] [ define-accessors ] 2bi ;

: define-builtin-predicate ( class -- )
    dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;

: define-builtin ( symbol slotspec -- )
    [ [ define-builtin-predicate ] keep ] dip define-builtin-slots ;

SYNTAX: REGISTER-BUILTIN: scan-object scan-object create register-builtin ;

SYNTAX: BUILTIN: scan-token verify-builtin ;