1 ! (c) 2009 Joe Groff, see BSD license
2 USING: accessors alien alien.c-types alien.complex alien.parser
3 alien.strings alien.structs alien.syntax arrays ascii assocs
4 byte-arrays combinators combinators.short-circuit fry generalizations
5 kernel lexer macros math math.parser namespaces parser sequences
6 splitting stack-checker vectors vocabs.parser words locals
7 io.encodings.ascii io.encodings.string shuffle effects math.ranges
8 math.order sorting strings system alien.libraries ;
11 SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ;
14 : add-f2c-libraries ( -- )
15 "I77" "libI77.so" "cdecl" add-library
16 "F77" "libF77.so" "cdecl" add-library ;
18 os netbsd? [ add-f2c-libraries ] when
21 : alien>nstring ( alien len encoding -- string )
22 [ memory>byte-array ] dip decode ;
24 ERROR: invalid-fortran-type type ;
26 DEFER: fortran-sig>c-sig
27 DEFER: fortran-ret-type>c-type
28 DEFER: fortran-arg-type>c-type
29 DEFER: fortran-name>symbol-name
31 SYMBOL: library-fortran-abis
33 library-fortran-abis [ H{ } clone ] initialize
37 : lowercase-name-with-underscore ( name -- name' )
39 : lowercase-name-with-extra-underscore ( name -- name' )
40 >lower CHAR: _ over member?
41 [ "__" append ] [ "_" append ] if ;
43 HOOK: fortran-c-abi fortran-abi ( -- abi )
44 M: f2c-abi fortran-c-abi "cdecl" ;
45 M: g95-abi fortran-c-abi "cdecl" ;
46 M: gfortran-abi fortran-c-abi "cdecl" ;
47 M: intel-unix-abi fortran-c-abi "cdecl" ;
48 M: intel-windows-abi fortran-c-abi "cdecl" ;
50 HOOK: real-functions-return-double? fortran-abi ( -- ? )
51 M: f2c-abi real-functions-return-double? t ;
52 M: g95-abi real-functions-return-double? f ;
53 M: gfortran-abi real-functions-return-double? f ;
54 M: intel-unix-abi real-functions-return-double? f ;
55 M: intel-windows-abi real-functions-return-double? f ;
57 HOOK: complex-functions-return-by-value? fortran-abi ( -- ? )
58 M: f2c-abi complex-functions-return-by-value? f ;
59 M: g95-abi complex-functions-return-by-value? f ;
60 M: gfortran-abi complex-functions-return-by-value? t ;
61 M: intel-unix-abi complex-functions-return-by-value? f ;
62 M: intel-windows-abi complex-functions-return-by-value? f ;
64 HOOK: character(1)-maps-to-char? fortran-abi ( -- ? )
65 M: f2c-abi character(1)-maps-to-char? f ;
66 M: g95-abi character(1)-maps-to-char? f ;
67 M: gfortran-abi character(1)-maps-to-char? f ;
68 M: intel-unix-abi character(1)-maps-to-char? t ;
69 M: intel-windows-abi character(1)-maps-to-char? t ;
71 HOOK: mangle-name fortran-abi ( name -- name' )
72 M: f2c-abi mangle-name lowercase-name-with-extra-underscore ;
73 M: g95-abi mangle-name lowercase-name-with-extra-underscore ;
74 M: gfortran-abi mangle-name lowercase-name-with-underscore ;
75 M: intel-unix-abi mangle-name lowercase-name-with-underscore ;
76 M: intel-windows-abi mangle-name >upper ;
78 TUPLE: fortran-type dims size out? ;
80 TUPLE: number-type < fortran-type ;
81 TUPLE: integer-type < number-type ;
82 TUPLE: logical-type < integer-type ;
83 TUPLE: real-type < number-type ;
84 TUPLE: double-precision-type < number-type ;
86 TUPLE: character-type < fortran-type ;
87 TUPLE: misc-type < fortran-type name ;
89 TUPLE: complex-type < number-type ;
90 TUPLE: real-complex-type < complex-type ;
91 TUPLE: double-complex-type < complex-type ;
93 CONSTANT: fortran>c-types H{
94 { "character" character-type }
95 { "integer" integer-type }
96 { "logical" logical-type }
98 { "double-precision" double-precision-type }
99 { "complex" real-complex-type }
100 { "double-complex" double-complex-type }
103 : append-dimensions ( base-c-type type -- c-type )
105 [ product number>string "[" "]" surround append ] when* ;
107 MACRO: size-case-type ( cases -- )
108 [ invalid-fortran-type ] suffix
109 '[ [ size>> _ case ] [ append-dimensions ] bi ] ;
111 : simple-type ( type base-c-type -- c-type )
113 [ dup size>> [ invalid-fortran-type ] [ drop ] if ]
114 [ append-dimensions ] bi ;
116 : new-fortran-type ( out? dims size class -- type )
117 new [ [ (>>size) ] [ (>>dims) ] [ (>>out?) ] tri ] keep ;
119 GENERIC: (fortran-type>c-type) ( type -- c-type )
121 M: f (fortran-type>c-type) drop "void" ;
123 M: integer-type (fortran-type>c-type)
131 M: real-type (fortran-type>c-type)
137 M: real-complex-type (fortran-type>c-type)
139 { f [ "complex-float" ] }
140 { 8 [ "complex-float" ] }
141 { 16 [ "complex-double" ] }
144 M: double-precision-type (fortran-type>c-type)
145 "double" simple-type ;
146 M: double-complex-type (fortran-type>c-type)
147 "complex-double" simple-type ;
148 M: misc-type (fortran-type>c-type)
149 dup name>> simple-type ;
151 : single-char? ( character-type -- ? )
152 { [ drop character(1)-maps-to-char? ] [ dims>> product 1 = ] } 1&& ;
154 : fix-character-type ( character-type -- character-type' )
156 [ dup dims>> [ invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ]
157 [ dup dims>> [ ] [ f >>dims ] if ] if
158 dup single-char? [ f >>dims ] when ;
160 M: character-type (fortran-type>c-type)
161 fix-character-type "char" simple-type ;
163 : dimension>number ( string -- number )
164 dup "*" = [ drop 0 ] [ string>number ] if ;
166 : parse-out ( string -- string' out? )
169 : parse-dims ( string -- string' dim )
171 [ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ;
173 : parse-size ( string -- string' size )
174 "*" split1 dup [ string>number ] when ;
176 : (parse-fortran-type) ( fortran-type-string -- type )
177 parse-out swap parse-dims swap parse-size swap
178 >lower fortran>c-types ?at
179 [ new-fortran-type ] [ misc-type boa ] if ;
181 : parse-fortran-type ( fortran-type-string/f -- type/f )
182 dup [ (parse-fortran-type) ] when ;
184 : c-type>pointer ( c-type -- c-type* )
185 "[" split1 drop "*" append ;
187 GENERIC: added-c-args ( type -- args )
189 M: fortran-type added-c-args drop { } ;
190 M: character-type added-c-args fix-character-type single-char? [ { } ] [ { "long" } ] if ;
192 GENERIC: returns-by-value? ( type -- ? )
194 M: f returns-by-value? drop t ;
195 M: fortran-type returns-by-value? drop f ;
196 M: number-type returns-by-value? dims>> not ;
197 M: character-type returns-by-value? fix-character-type single-char? ;
198 M: complex-type returns-by-value?
199 { [ drop complex-functions-return-by-value? ] [ dims>> not ] } 1&& ;
201 GENERIC: (fortran-ret-type>c-type) ( type -- c-type )
203 M: f (fortran-ret-type>c-type) drop "void" ;
204 M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ;
205 M: real-type (fortran-ret-type>c-type)
206 drop real-functions-return-double? [ "double" ] [ "float" ] if ;
208 : suffix! ( seq elt -- seq ) over push ; inline
209 : append! ( seq-a seq-b -- seq-a ) over push-all ; inline
211 GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
213 : args?dims ( type quot -- main-quot added-quot )
214 [ dup dims>> [ drop [ ] [ drop ] ] ] dip if ; inline
216 M: integer-type (fortran-arg>c-args)
219 { f [ [ <int> ] [ drop ] ] }
220 { 1 [ [ <char> ] [ drop ] ] }
221 { 2 [ [ <short> ] [ drop ] ] }
222 { 4 [ [ <int> ] [ drop ] ] }
223 { 8 [ [ <longlong> ] [ drop ] ] }
224 [ invalid-fortran-type ]
228 M: logical-type (fortran-arg>c-args)
229 [ call-next-method [ [ 1 0 ? ] prepend ] dip ] args?dims ;
231 M: real-type (fortran-arg>c-args)
234 { f [ [ <float> ] [ drop ] ] }
235 { 4 [ [ <float> ] [ drop ] ] }
236 { 8 [ [ <double> ] [ drop ] ] }
237 [ invalid-fortran-type ]
241 M: real-complex-type (fortran-arg>c-args)
244 { f [ [ <complex-float> ] [ drop ] ] }
245 { 8 [ [ <complex-float> ] [ drop ] ] }
246 { 16 [ [ <complex-double> ] [ drop ] ] }
247 [ invalid-fortran-type ]
251 M: double-precision-type (fortran-arg>c-args)
252 [ drop [ <double> ] [ drop ] ] args?dims ;
254 M: double-complex-type (fortran-arg>c-args)
255 [ drop [ <complex-double> ] [ drop ] ] args?dims ;
257 M: character-type (fortran-arg>c-args)
258 fix-character-type single-char?
259 [ [ first <char> ] [ drop ] ]
260 [ [ ascii string>alien ] [ length ] ] if ;
262 M: misc-type (fortran-arg>c-args)
265 GENERIC: (fortran-result>) ( type -- quots )
267 : result?dims ( type quot -- quot )
268 [ dup dims>> [ drop { [ ] } ] ] dip if ; inline
270 M: integer-type (fortran-result>)
272 { f [ { [ *int ] } ] }
273 { 1 [ { [ *char ] } ] }
274 { 2 [ { [ *short ] } ] }
275 { 4 [ { [ *int ] } ] }
276 { 8 [ { [ *longlong ] } ] }
277 [ invalid-fortran-type ]
278 } case ] result?dims ;
280 M: logical-type (fortran-result>)
281 [ call-next-method first [ zero? not ] append 1array ] result?dims ;
283 M: real-type (fortran-result>)
285 { f [ { [ *float ] } ] }
286 { 4 [ { [ *float ] } ] }
287 { 8 [ { [ *double ] } ] }
288 [ invalid-fortran-type ]
289 } case ] result?dims ;
291 M: real-complex-type (fortran-result>)
293 { f [ { [ *complex-float ] } ] }
294 { 8 [ { [ *complex-float ] } ] }
295 { 16 [ { [ *complex-double ] } ] }
296 [ invalid-fortran-type ]
297 } case ] result?dims ;
299 M: double-precision-type (fortran-result>)
300 [ drop { [ *double ] } ] result?dims ;
302 M: double-complex-type (fortran-result>)
303 [ drop { [ *complex-double ] } ] result?dims ;
305 M: character-type (fortran-result>)
306 fix-character-type single-char?
307 [ { [ *char 1string ] } ]
308 [ { [ ] [ ascii alien>nstring ] } ] if ;
310 M: misc-type (fortran-result>)
313 GENERIC: (<fortran-result>) ( type -- quot )
315 M: fortran-type (<fortran-result>)
316 (fortran-type>c-type) \ <c-object> [ ] 2sequence ;
318 M: character-type (<fortran-result>)
319 fix-character-type dims>> product dup
320 [ \ <byte-array> ] dip [ ] 3sequence ;
322 : [<fortran-result>] ( return parameters -- quot )
323 [ parse-fortran-type ] dip
324 over returns-by-value?
326 [ [ (<fortran-result>) ] [ length \ ndip [ ] 3sequence ] bi* ] if ;
328 : [fortran-args>c-args] ( parameters -- quot )
330 [ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2
331 [ [ \ spread [ ] 2sequence ] bi@ 2array ] [ length ] bi
332 \ ncleave [ ] 3sequence
335 :: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot )
336 return parameters fortran-sig>c-sig :> c-parameters :> c-return
337 function fortran-name>symbol-name :> c-function
339 c-return library c-function c-parameters \ alien-invoke
341 c-parameters length \ nkeep
344 : [fortran-out-param>] ( parameter -- quot )
346 [ (fortran-result>) ] [ out?>> ] bi
347 [ ] [ [ drop [ drop ] ] map ] if ;
349 : [fortran-return>] ( return -- quot )
351 { [ dup not ] [ drop { } ] }
352 { [ dup returns-by-value? ] [ drop { [ ] } ] }
353 [ (fortran-result>) ]
356 : letters ( -- seq ) CHAR: a CHAR: z [a,b] ;
358 : (shuffle-map) ( return parameters -- ret par )
360 fortran-ret-type>c-type length swap "void" = [ 1 + ] unless
361 letters swap head [ "ret" swap suffix ] map
363 [ fortran-arg-type>c-type nip length 1 + ] map letters swap zip
364 [ first2 letters swap head [ "" 2sequence ] with map ] map concat
367 : (fortran-in-shuffle) ( ret par -- seq )
368 [ second ] sort-with append ;
370 : (fortran-out-shuffle) ( ret par -- seq )
373 : [fortran-result-shuffle] ( return parameters -- quot )
374 (shuffle-map) [ (fortran-in-shuffle) ] [ (fortran-out-shuffle) ] 2bi <effect>
375 \ shuffle-effect [ ] 2sequence ;
377 : [fortran-results>] ( return parameters -- quot )
378 [ [fortran-result-shuffle] ]
379 [ drop [fortran-return>] ]
380 [ nip [ [fortran-out-param>] ] map concat ] 2tri
382 \ spread [ ] 2sequence append ;
384 : (add-fortran-library) ( fortran-abi name -- )
385 library-fortran-abis get-global set-at ;
389 : add-fortran-library ( name soname fortran-abi -- )
390 [ fortran-abi [ fortran-c-abi ] with-variable add-library ]
391 [ nip swap (add-fortran-library) ] 3bi ;
393 : fortran-name>symbol-name ( fortran-name -- c-name )
396 : fortran-type>c-type ( fortran-type -- c-type )
397 parse-fortran-type (fortran-type>c-type) ;
399 : fortran-arg-type>c-type ( fortran-type -- c-type added-args )
401 [ (fortran-type>c-type) c-type>pointer ]
402 [ added-c-args ] bi ;
403 : fortran-ret-type>c-type ( fortran-type -- c-type added-args )
404 parse-fortran-type dup returns-by-value?
405 [ (fortran-ret-type>c-type) { } ] [
407 [ added-c-args ] [ (fortran-type>c-type) c-type>pointer ] bi prefix
410 : fortran-arg-types>c-types ( fortran-types -- c-types )
411 [ length <vector> 1 <vector> ] keep
412 [ fortran-arg-type>c-type swapd [ suffix! ] [ append! ] 2bi* ] each
415 : fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args )
416 [ fortran-ret-type>c-type ] [ fortran-arg-types>c-types ] bi* append ;
418 : fortran-record>c-struct ( record -- struct )
419 [ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ;
421 : define-fortran-record ( name vocab fields -- )
422 [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
424 SYNTAX: RECORD: scan current-vocab parse-definition define-fortran-record ;
426 : set-fortran-abi ( library -- )
427 library-fortran-abis get-global at fortran-abi set ;
429 : (fortran-invoke) ( return library function parameters -- quot )
431 [ 2nip [<fortran-result>] ]
432 [ nip nip nip [fortran-args>c-args] ]
434 [ 2nip [fortran-results>] ]
435 } 4 ncleave 4 nappend ;
437 MACRO: fortran-invoke ( return library function parameters -- )
438 { [ 2drop nip set-fortran-abi ] [ (fortran-invoke) ] } 4 ncleave ;
440 :: define-fortran-function ( return library function parameters -- )
441 function create-in dup reset-generic
442 return library function parameters return [ "void" ] unless* parse-arglist
443 [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
446 f "c-library" get scan ";" parse-tokens
447 [ "()" subseq? not ] filter define-fortran-function ;
450 scan "c-library" get scan ";" parse-tokens
451 [ "()" subseq? not ] filter define-fortran-function ;
456 [ set-fortran-abi ] bi ;