Paste: specialized-arrays

! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences sequences.private kernel math byte-arrays
accessors generic words quotations locals fry alien.c-types
classes classes.tuple parser lexer namespaces compiler.units
prettyprint.backend ;
IN: specialized-arrays

GENERIC: element-size ( array -- type )

TUPLE: specialized-array
{ length array-capacity }
{ underlying byte-array } ;

<PRIVATE

: new-specialized-array ( n class -- array )
    new
        2dup element-size * <byte-array> >>underlying
        swap >>length ; inline

M: specialized-array clone
    clone
        [ clone ] change-underlying ;

M: specialized-array length length>> ;

M: specialized-array resize
    [
        [ element-size * ] [ underlying>> ] bi
        resize-byte-array
    ] 2keep
    clone
        swap >>length
        swap >>underlying ;

M: specialized-array byte-length underlying>> length ;

INSTANCE: specialized-array sequence

: define-method ( class body generic -- )
    swap [ create-method ] dip define ;

: define-element-size-method ( class element-type -- )
    '[ drop _ ] \ element-size define-method ;

: define-nth-method ( class getter -- )
    '[ underlying>> @ ]
    \ nth-unsafe define-method ;

: define-set-nth-method ( class setter -- )
    '[ underlying>> @ ]
    \ set-nth-unsafe define-method ;

: define-new-sequence-method ( class constructor -- )
    '[ drop _ execute ]
    \ new-sequence define-method ;

: define-like-method ( class predicate conversion -- )
    '[ drop dup _ execute [ _ execute ] unless ]
    \ like define-method ;

: define-equal?-method ( class predicate -- )
    '[ over _ execute [ sequence= ] [ 2drop f ] if ]
    \ equal? define-method ;

: define-conversion ( conversion class -- )
    new '[ _ clone-like ] define-inline ;

: define-constructor ( constructor class -- )
    '[ _ new-specialized-array ] define-inline ;

: conversion-word ( class -- word )
    [ name>> ">" prepend ] [ vocabulary>> ] bi create ;

: parsing-word ( class -- word )
    [ name>> "{" append ] [ vocabulary>> ] bi create ;

: define-parsing-word ( parsing-word conversion -- )
    dupd '[ \ } [ _ execute ] parse-literal ] define make-parsing ;

: define-prettyprint-methods ( class parsing-word -- )
    [ '[ drop _ \ } ] \ pprint-delims define-method ]
    [ drop [ ] \ >pprint-sequence define-method ]
    [ drop [ pprint-object ] \ pprint* define-method ]
    2tri ;

:: define-specialized-array ( element-type vocab -- )
    [let* | class [ element-type "-array" append vocab create ]
            element-size [ element-type heap-size ]
            getter [ element-type dup c-getter array-accessor ]
            setter [ element-type dup c-setter array-accessor ]
            constructor [ element-type "-array" append vocab constructor-word ]
            predicate [ class predicate-word ]
            conversion [ class conversion-word ]
            parsing-word [ class parsing-word ] |
        class specialized-array { } define-tuple-class
        class element-size define-element-size-method
        class getter define-nth-method
        class setter define-set-nth-method
        class predicate conversion define-like-method
        class predicate define-equal?-method
        class constructor define-new-sequence-method
        conversion class define-conversion
        constructor class define-constructor
        parsing-word conversion define-parsing-word
        class parsing-word define-prettyprint-methods
    ] ;

: interesting-types
    {
        "char" "uchar"
        "short" "ushort"
        "int" "uint"
        "long" "ulong"
        "longlong" "ulonglong"
        "float" "double"
        "void*"
    } ;

PRIVATE>

[
    interesting-types [
        "specialized-arrays" define-specialized-array
    ] each
] with-compilation-unit