<commit_before>! (c) 2009 <NAME>, see BSD license
USING: accessors alien alien.c-types alien.complex alien.parser
alien.strings alien.structs alien.syntax arrays ascii assocs
byte-arrays combinators combinators.short-circuit fry generalizations
kernel lexer macros math math.parser namespaces parser sequences
splitting stack-checker vectors vocabs.parser words locals
io.encodings.ascii io.encodings.string shuffle effects math.ranges
math.order sorting strings system ;
IN: alien.fortran

SINGLETONS: f2c-abi gfortran-abi intel-unix-abi intel-windows-abi ;

<< 
: add-f2c-libraries ( -- )
    "I77" "libI77.so" "cdecl" add-library
    "F77" "libF77.so" "cdecl" add-library ;

os netbsd? [ add-f2c-libraries ] when
>>

: alien>nstring ( alien len encoding -- string )
    [ memory>byte-array ] dip decode ;

ERROR: invalid-fortran-type type ;

DEFER: fortran-sig>c-sig
DEFER: fortran-ret-type>c-type
DEFER: fortran-arg-type>c-type
DEFER: fortran-name>symbol-name

SYMBOL: library-fortran-abis
SYMBOL: fortran-abi
library-fortran-abis [ H{ } clone ] initialize

<PRIVATE

: lowercase-name-with-underscore ( name -- name' )
    >lower "_" append ;
: lowercase-name-with-extra-underscore ( name -- name' )
    >lower CHAR: _ over member? 
    [ "__" append ] [ "_" append ] if ;

HOOK: fortran-c-abi fortran-abi ( -- abi )
M: f2c-abi fortran-c-abi "cdecl" ;
M: gfortran-abi fortran-c-abi "cdecl" ;
M: intel-unix-abi fortran-c-abi "cdecl" ;
M: intel-windows-abi fortran-c-abi "cdecl" ;

HOOK: real-functions-return-double? fortran-abi ( -- ? )
M: f2c-abi real-functions-return-double? t ;
M: gfortran-abi real-functions-return-double? f ;
M: intel-unix-abi real-functions-return-double? f ;
M: intel-windows-abi real-functions-return-double? f ;

HOOK: complex-functions-return-by-value? fortran-abi ( -- ? )
M: f2c-abi complex-functions-return-by-value? f ;
M: gfortran-abi complex-functions-return-by-value? t ;
M: intel-unix-abi complex-functions-return-by-value? f ;
M: intel-windows-abi complex-functions-return-by-value? f ;

HOOK: character(1)-maps-to-char? fortran-abi ( -- ? )
M: f2c-abi character(1)-maps-to-char? f ;
M: gfortran-abi character(1)-maps-to-char? f ;
M: intel-unix-abi character(1)-maps-to-char? t ;
M: intel-windows-abi character(1)-maps-to-char? t ;

HOOK: mangle-name fortran-abi ( name -- name' )
M: f2c-abi mangle-name lowercase-name-with-extra-underscore ;
M: gfortran-abi mangle-name lowercase-name-with-underscore ;
M: intel-unix-abi mangle-name lowercase-name-with-underscore ;
M: intel-windows-abi mangle-name >upper ;

TUPLE: fortran-type dims size out? ;

TUPLE: number-type < fortran-type ;
TUPLE: integer-type < number-type ;
TUPLE: logical-type < integer-type ;
TUPLE: real-type < number-type ;
TUPLE: double-precision-type < number-type ;

TUPLE: character-type < fortran-type ;
TUPLE: misc-type < fortran-type name ;

TUPLE: complex-type < number-type ;
TUPLE: real-complex-type < complex-type ;
TUPLE: double-complex-type < complex-type ;

CONSTANT: fortran>c-types H{
    { "character"        character-type        }
    { "integer"          integer-type          }
    { "logical"          logical-type          }
    { "real"             real-type             }
    { "double-precision" double-precision-type }
    { "complex"          real-complex-type     }
    { "double-complex"   double-complex-type   }
}

: append-dimensions ( base-c-type type -- c-type )
    dims>>
    [ product number>string "[" "]" surround append ] when* ;

MACRO: size-case-type ( cases -- )
    [ invalid-fortran-type ] suffix
    '[ [ size>> _ case ] [ append-dimensions ] bi ] ;

: simple-type ( type base-c-type -- c-type )
    swap
    [ dup size>> [ invalid-fortran-type ] [ drop ] if ]
    [ append-dimensions ] bi ;

: new-fortran-type ( out? dims size class -- type )
    new [ [ (>>size) ] [ (>>dims) ] [ (>>out?) ] tri ] keep ;

GENERIC: (fortran-type>c-type) ( type -- c-type )

M: f (fortran-type>c-type) drop "void" ;

M: integer-type (fortran-type>c-type)
    {
        { f [ "int"      ] }
        { 1 [ "char"     ] }
        { 2 [ "short"    ] }
        { 4 [ "int"      ] }
        { 8 [ "longlong" ] }
    } size-case-type ;
M: real-type (fortran-type>c-type)
    {
        { f [ "float"  ] }
        { 4 [ "float"  ] }
        { 8 [ "double" ] }
    } size-case-type ;
M: real-complex-type (fortran-type>c-type)
    {
        {  f [ "complex-float"  ] }
        {  8 [ "complex-float"  ] }
        { 16 [ "complex-double" ] }
    } size-case-type ;

M: double-precision-type (fortran-type>c-type)
    "double" simple-type ;
M: double-complex-type (fortran-type>c-type)
    "complex-double" simple-type ;
M: misc-type (fortran-type>c-type)
    dup name>> simple-type ;

: single-char? ( character-type -- ? )
    { [ drop character(1)-maps-to-char? ] [ dims>> product 1 = ] } 1&& ;

: fix-character-type ( character-type -- character-type' )
    clone dup size>>
    [ dup dims>> [ invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ]
    [ dup dims>> [ ] [ f >>dims ] if ] if
    dup single-char? [ f >>dims ] when ;

M: character-type (fortran-type>c-type)
    fix-character-type "char" simple-type ;

: dimension>number ( string -- number )
    dup "*" = [ drop 0 ] [ string>number ] if ;

: parse-out ( string -- string' out? )
    "!" ?head ;

: parse-dims ( string -- string' dim )
    "(" split1 dup
    [ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ;

: parse-size ( string -- string' size )
    "*" split1 dup [ string>number ] when ;

: (parse-fortran-type) ( fortran-type-string -- type )
    parse-out swap parse-dims swap parse-size swap
    dup >lower fortran>c-types at*
    [ nip new-fortran-type ] [ drop misc-type boa ] if ;

: parse-fortran-type ( fortran-type-string/f -- type/f )
    dup [ (parse-fortran-type) ] when ;

: c-type>pointer ( c-type -- c-type* )
    "[" split1 drop "*" append ;

GENERIC: added-c-args ( type -- args )

M: fortran-type added-c-args drop { } ;
M: character-type added-c-args fix-character-type single-char? [ { } ] [ { "long" } ] if ;

GENERIC: returns-by-value? ( type -- ? )

M: f returns-by-value? drop t ;
M: fortran-type returns-by-value? drop f ;
M: number-type returns-by-value? dims>> not ;
M: character-type returns-by-value? fix-character-type single-char? ;
M: complex-type returns-by-value?
    { [ drop complex-functions-return-by-value? ] [ dims>> not ] } 1&& ;
<commit_msg>use ?at instead of at*<commit_after>! (c) 2009 <NAME>, see BSD license
USING: accessors alien alien.c-types alien.complex alien.parser
alien.strings alien.structs alien.syntax arrays ascii assocs
byte-arrays combinators combinators.short-circuit fry generalizations
kernel lexer macros math math.parser namespaces parser sequences
splitting stack-checker vectors vocabs.parser words locals
io.encodings.ascii io.encodings.string shuffle effects math.ranges
math.order sorting strings system ;
IN: alien.fortran

SINGLETONS: f2c-abi gfortran-abi intel-unix-abi intel-windows-abi ;

<< 
: add-f2c-libraries ( -- )
    "I77" "libI77.so" "cdecl" add-library
    "F77" "libF77.so" "cdecl" add-library ;

os netbsd? [ add-f2c-libraries ] when
>>

: alien>nstring ( alien len encoding -- string )
    [ memory>byte-array ] dip decode ;

ERROR: invalid-fortran-type type ;

DEFER: fortran-sig>c-sig
DEFER: fortran-ret-type>c-type
DEFER: fortran-arg-type>c-type
DEFER: fortran-name>symbol-name

SYMBOL: library-fortran-abis
SYMBOL: fortran-abi
library-fortran-abis [ H{ } clone ] initialize

<PRIVATE

: lowercase-name-with-underscore ( name -- name' )
    >lower "_" append ;
: lowercase-name-with-extra-underscore ( name -- name' )
    >lower CHAR: _ over member? 
    [ "__" append ] [ "_" append ] if ;

HOOK: fortran-c-abi fortran-abi ( -- abi )
M: f2c-abi fortran-c-abi "cdecl" ;
M: gfortran-abi fortran-c-abi "cdecl" ;
M: intel-unix-abi fortran-c-abi "cdecl" ;
M: intel-windows-abi fortran-c-abi "cdecl" ;

HOOK: real-functions-return-double? fortran-abi ( -- ? )
M: f2c-abi real-functions-return-double? t ;
M: gfortran-abi real-functions-return-double? f ;
M: intel-unix-abi real-functions-return-double? f ;
M: intel-windows-abi real-functions-return-double? f ;

HOOK: complex-functions-return-by-value? fortran-abi ( -- ? )
M: f2c-abi complex-functions-return-by-value? f ;
M: gfortran-abi complex-functions-return-by-value? t ;
M: intel-unix-abi complex-functions-return-by-value? f ;
M: intel-windows-abi complex-functions-return-by-value? f ;

HOOK: character(1)-maps-to-char? fortran-abi ( -- ? )
M: f2c-abi character(1)-maps-to-char? f ;
M: gfortran-abi character(1)-maps-to-char? f ;
M: intel-unix-abi character(1)-maps-to-char? t ;
M: intel-windows-abi character(1)-maps-to-char? t ;

HOOK: mangle-name fortran-abi ( name -- name' )
M: f2c-abi mangle-name lowercase-name-with-extra-underscore ;
M: gfortran-abi mangle-name lowercase-name-with-underscore ;
M: intel-unix-abi mangle-name lowercase-name-with-underscore ;
M: intel-windows-abi mangle-name >upper ;

TUPLE: fortran-type dims size out? ;

TUPLE: number-type < fortran-type ;
TUPLE: integer-type < number-type ;
TUPLE: logical-type < integer-type ;
TUPLE: real-type < number-type ;
TUPLE: double-precision-type < number-type ;

TUPLE: character-type < fortran-type ;
TUPLE: misc-type < fortran-type name ;

TUPLE: complex-type < number-type ;
TUPLE: real-complex-type < complex-type ;
TUPLE: double-complex-type < complex-type ;

CONSTANT: fortran>c-types H{
    { "character"        character-type        }
    { "integer"          integer-type          }
    { "logical"          logical-type          }
    { "real"             real-type             }
    { "double-precision" double-precision-type }
    { "complex"          real-complex-type     }
    { "double-complex"   double-complex-type   }
}

: append-dimensions ( base-c-type type -- c-type )
    dims>>
    [ product number>string "[" "]" surround append ] when* ;

MACRO: size-case-type ( cases -- )
    [ invalid-fortran-type ] suffix
    '[ [ size>> _ case ] [ append-dimensions ] bi ] ;

: simple-type ( type base-c-type -- c-type )
    swap
    [ dup size>> [ invalid-fortran-type ] [ drop ] if ]
    [ append-dimensions ] bi ;

: new-fortran-type ( out? dims size class -- type )
    new [ [ (>>size) ] [ (>>dims) ] [ (>>out?) ] tri ] keep ;

GENERIC: (fortran-type>c-type) ( type -- c-type )

M: f (fortran-type>c-type) drop "void" ;

M: integer-type (fortran-type>c-type)
    {
        { f [ "int"      ] }
        { 1 [ "char"     ] }
        { 2 [ "short"    ] }
        { 4 [ "int"      ] }
        { 8 [ "longlong" ] }
    } size-case-type ;
M: real-type (fortran-type>c-type)
    {
        { f [ "float"  ] }
        { 4 [ "float"  ] }
        { 8 [ "double" ] }
    } size-case-type ;
M: real-complex-type (fortran-type>c-type)
    {
        {  f [ "complex-float"  ] }
        {  8 [ "complex-float"  ] }
        { 16 [ "complex-double" ] }
    } size-case-type ;

M: double-precision-type (fortran-type>c-type)
    "double" simple-type ;
M: double-complex-type (fortran-type>c-type)
    "complex-double" simple-type ;
M: misc-type (fortran-type>c-type)
    dup name>> simple-type ;

: single-char? ( character-type -- ? )
    { [ drop character(1)-maps-to-char? ] [ dims>> product 1 = ] } 1&& ;

: fix-character-type ( character-type -- character-type' )
    clone dup size>>
    [ dup dims>> [ invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ]
    [ dup dims>> [ ] [ f >>dims ] if ] if
    dup single-char? [ f >>dims ] when ;

M: character-type (fortran-type>c-type)
    fix-character-type "char" simple-type ;

: dimension>number ( string -- number )
    dup "*" = [ drop 0 ] [ string>number ] if ;

: parse-out ( string -- string' out? )
    "!" ?head ;

: parse-dims ( string -- string' dim )
    "(" split1 dup
    [ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ;

: parse-size ( string -- string' size )
    "*" split1 dup [ string>number ] when ;

: (parse-fortran-type) ( fortran-type-string -- type )
    parse-out swap parse-dims swap parse-size swap
    >lower fortran>c-types ?at
    [ new-fortran-type ] [ misc-type boa ] if ;

: parse-fortran-type ( fortran-type-string/f -- type/f )
    dup [ (parse-fortran-type) ] when ;

: c-type>pointer ( c-type -- c-type* )
    "[" split1 drop "*" append ;

GENERIC: added-c-args ( type -- args )

M: fortran-type added-c-args drop { } ;
M: character-type added-c-args fix-character-type single-char? [ { } ] [ { "long" } ] if ;

GENERIC: returns-by-value? ( type -- ? )

M: f returns-by-value? drop t ;
M: fortran-type returns-by-value? drop f ;
M: number-type returns-by-value? dims>> not ;
M: character-type returns-by-value? fix-character-type single-char? ;
M: complex-type returns-by-value?
    { [ drop complex-functions-return-by-value? ] [ dims>> not ] } 1&& ;

{'fraction_non_alphanumeric': 0.16118984581840834, 'fraction_numerical': 0.006696776203083632, 'mean_word_length': 2.8064611736810905, 'pattern_counts': {'":': 0, '<': 31, '<?xml version=': 0, '>': 135, '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': '3203336', 'n_tokens_mistral': 4801, 'n_tokens_neox': 4720, 'n_words': 1033}