<commit_before>! Copyright (C) 2004, 2009 <NAME>.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays arrays assocs kernel kernel.private libc math
namespaces make parser sequences strings words splitting math.parser
cpu.architecture alien alien.accessors alien.strings quotations
layouts system compiler.units io io.files io.encodings.binary
io.streams.memory accessors combinators effects continuations fry
classes vocabs vocabs.loader ;
IN: alien.c-types

DEFER: <int>
DEFER: *char

: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable

TUPLE: abstract-c-type
{ class class initial: object }
{ boxed-class class initial: object }
{ boxer-quot callable }
{ unboxer-quot callable }
{ getter callable }
{ setter callable }
size
align ;

TUPLE: c-type < abstract-c-type
boxer
unboxer
{ rep initial: int-rep }
stack-align?
array-class
array-constructor
direct-array-class
direct-array-constructor
sequence-mixin-class ;

: <c-type> ( -- type )
    \ c-type new ;

SYMBOL: c-types

global [
    c-types [ H{ } assoc-like ] change
] bind

ERROR: no-c-type name ;

: (c-type) ( name -- type/f )
    c-types get-global at dup [
        dup string? [ (c-type) ] when
    ] when ;

! C type protocol
GENERIC: c-type ( name -- type ) foldable

: resolve-pointer-type ( name -- name )
    c-types get at dup string?
    [ "*" append ] [ drop "void*" ] if
    c-type ;

: resolve-typedef ( name -- type )
    dup string? [ c-type ] when ;

: parse-array-type ( name -- array )
    "[" split unclip
    [ [ "]" ?tail drop string>number ] map ] dip prefix ;

M: string c-type ( name -- type )
    CHAR: ] over member? [
        parse-array-type
    ] [
        dup c-types get at [
            resolve-typedef
        ] [
            "*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
        ] ?if
    ] if ;

: ?require-word ( word/pair -- )
    dup word? [ drop ] [ first require ] ?if ;

GENERIC: require-c-type-arrays ( c-type -- )

M: object require-c-type-arrays
    drop ;

M: c-type require-c-type-arrays
    [ array-class>> ?require-word ]
    [ sequence-mixin-class>> ?require-word ]
    [ direct-array-class>> ?require-word ] tri ;

M: string require-c-type-arrays
    c-type require-c-type-arrays ;

M: array require-c-type-arrays
    first c-type require-c-type-arrays ;

GENERIC: c-type-array-constructor ( c-type -- word ) foldable

M: string c-type-array-constructor 
    c-type c-type-array-constructor ;
M: array c-type-array-constructor
    first c-type c-type-array-constructor ;
M: c-type c-type-array-constructor
    array-constructor>> ;

GENERIC: c-type-direct-array-constructor ( c-type -- word ) foldable

M: string c-type-direct-array-constructor 
    c-type c-type-array-constructor ;
M: array c-type-direct-array-constructor
    first c-type c-type-direct-array-constructor ;
M: c-type c-type-direct-array-constructor
    direct-array-constructor>> ;

: <c-type-array> ( len c-type -- array )
    c-type-array-constructor execute( len -- array ) ; inline
: <c-type-direct-array> ( len c-type -- array )
    c-type-direct-array-constructor execute( len -- array ) ; inline

GENERIC: c-type-class ( name -- class )

M: abstract-c-type c-type-class class>> ;

M: string c-type-class c-type c-type-class ;

GENERIC: c-type-boxed-class ( name -- class )

M: abstract-c-type c-type-boxed-class boxed-class>> ;

M: string c-type-boxed-class c-type c-type-boxed-class ;

GENERIC: c-type-boxer ( name -- boxer )

M: c-type c-type-boxer boxer>> ;

M: string c-type-boxer c-type c-type-boxer ;

GENERIC: c-type-boxer-quot ( name -- quot )

M: abstract-c-type c-type-boxer-quot boxer-quot>> ;

M: string c-type-boxer-quot c-type c-type-boxer-quot ;

GENERIC: c-type-unboxer ( name -- boxer )
<commit_msg>throw a better error if <c-type*-array> is called when specialized array vocab isn't loaded. fix <c-type-direct-array><commit_after>! Copyright (C) 2004, 2009 <NAME>.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays arrays assocs kernel kernel.private libc math
namespaces make parser sequences strings words splitting math.parser
cpu.architecture alien alien.accessors alien.strings quotations
layouts system compiler.units io io.files io.encodings.binary
io.streams.memory accessors combinators effects continuations fry
classes vocabs vocabs.loader ;
IN: alien.c-types

DEFER: <int>
DEFER: *char

: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable

TUPLE: abstract-c-type
{ class class initial: object }
{ boxed-class class initial: object }
{ boxer-quot callable }
{ unboxer-quot callable }
{ getter callable }
{ setter callable }
size
align ;

TUPLE: c-type < abstract-c-type
boxer
unboxer
{ rep initial: int-rep }
stack-align?
array-class
array-constructor
direct-array-class
direct-array-constructor
sequence-mixin-class ;

: <c-type> ( -- type )
    \ c-type new ;

SYMBOL: c-types

global [
    c-types [ H{ } assoc-like ] change
] bind

ERROR: no-c-type name ;

: (c-type) ( name -- type/f )
    c-types get-global at dup [
        dup string? [ (c-type) ] when
    ] when ;

! C type protocol
GENERIC: c-type ( name -- type ) foldable

: resolve-pointer-type ( name -- name )
    c-types get at dup string?
    [ "*" append ] [ drop "void*" ] if
    c-type ;

: resolve-typedef ( name -- type )
    dup string? [ c-type ] when ;

: parse-array-type ( name -- array )
    "[" split unclip
    [ [ "]" ?tail drop string>number ] map ] dip prefix ;

M: string c-type ( name -- type )
    CHAR: ] over member? [
        parse-array-type
    ] [
        dup c-types get at [
            resolve-typedef
        ] [
            "*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
        ] ?if
    ] if ;

: ?require-word ( word/pair -- )
    dup word? [ drop ] [ first require ] ?if ;

GENERIC: require-c-type-arrays ( c-type -- )

M: object require-c-type-arrays
    drop ;

M: c-type require-c-type-arrays
    [ array-class>> ?require-word ]
    [ sequence-mixin-class>> ?require-word ]
    [ direct-array-class>> ?require-word ] tri ;

M: string require-c-type-arrays
    c-type require-c-type-arrays ;

M: array require-c-type-arrays
    first c-type require-c-type-arrays ;

ERROR: specialized-array-vocab-not-loaded vocab word ;

GENERIC: c-type-array-constructor ( c-type -- word ) foldable

M: string c-type-array-constructor 
    c-type c-type-array-constructor ;
M: array c-type-array-constructor
    first c-type c-type-array-constructor ;
M: c-type c-type-array-constructor
    array-constructor>> dup word?
    [ first2 specialized-array-vocab-not-loaded ] unless ;

GENERIC: c-type-direct-array-constructor ( c-type -- word ) foldable

M: string c-type-direct-array-constructor 
    c-type c-type-direct-array-constructor ;
M: array c-type-direct-array-constructor
    first c-type c-type-direct-array-constructor ;
M: c-type c-type-direct-array-constructor
    direct-array-constructor>> dup word?
    [ first2 specialized-array-vocab-not-loaded ] unless ;

GENERIC: <c-type-array> ( len c-type -- array )
M: object <c-type-array>
    c-type-array-constructor execute( len -- array ) ; inline

GENERIC: <c-type-direct-array> ( alien len c-type -- array )
M: object <c-type-direct-array>
    c-type-direct-array-constructor execute( alien len -- array ) ; inline

GENERIC: c-type-class ( name -- class )

M: abstract-c-type c-type-class class>> ;

M: string c-type-class c-type c-type-class ;

GENERIC: c-type-boxed-class ( name -- class )

M: abstract-c-type c-type-boxed-class boxed-class>> ;

M: string c-type-boxed-class c-type c-type-boxed-class ;

GENERIC: c-type-boxer ( name -- boxer )

M: c-type c-type-boxer boxer>> ;

M: string c-type-boxer c-type c-type-boxer ;

GENERIC: c-type-boxer-quot ( name -- quot )

M: abstract-c-type c-type-boxer-quot boxer-quot>> ;

M: string c-type-boxer-quot c-type c-type-boxer-quot ;

GENERIC: c-type-unboxer ( name -- boxer )

{'fraction_non_alphanumeric': 0.14049376431662, 'fraction_numerical': 0.002799694578773225, 'mean_word_length': 2.8467939304943712, 'pattern_counts': {'":': 0, '<': 21, '<?xml version=': 0, '>': 57, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '800515', 'n_tokens_mistral': 2793, 'n_tokens_neox': 2729, 'n_words': 697}