34
35:- module(foreign_generator,
36 [generate_library/5,
37 collect_prop/4,
38 gen_foreign_library/3]). 39
40:- use_module(library(apply)). 41:- use_module(library(filesex)). 42:- use_module(library(assertions)). 43:- use_module(library(atomics_atom)). 44:- use_module(library(codegen)). 45:- use_module(library(call_ref)). 46:- use_module(library(camel_snake)). 47:- use_module(library(extend_args)). 48:- use_module(library(extra_messages)). 49:- use_module(library(foldil)). 50:- use_module(library(foreign/foreign_props)). 51:- use_module(library(key_value)). 52:- use_module(library(lists)). 53:- use_module(library(metaprops)). 54:- use_module(library(neck)). 55:- use_module(library(nmember)). 56:- use_module(library(process)). 57:- use_module(library(readutil)). 58:- use_module(library(solution_sequences)). 59:- use_module(library(substitute)). 60:- use_module(library(terms)). 61:- use_module(library(thread)). 62:- use_module(library(transpose)). 63:- use_module(library(pairs)). 64:- use_module(library(occurs)). 65:- init_expansors. 66
67:- multifile
68 foreign_dependency/2,
69 gen_foreign_library/3,
70 use_foreign_source/2,
71 use_foreign_header/2,
72 include_foreign_dir/2,
73 library_foreign_dir/2,
74 extra_compiler_opts/2,
75 link_foreign_library/2,
76 pkg_foreign_config/2. 77
78:- discontiguous
79 match_type//6,
80 implement_type_unifier//3. 81
82:- dynamic
83 foreign_dependency/2,
84 gen_foreign_library/3,
85 use_foreign_source/2,
86 use_foreign_header/2,
87 include_foreign_dir/2,
88 extra_compiler_opts/2,
89 link_foreign_library/2,
90 pkg_foreign_config/2. 91
92:- table bind_type_names/2 as private. 93
95
96foreign_dependency(M, HAlias) :- use_foreign_header(M, HAlias).
97foreign_dependency(_, library('foreign/foreign_interface.h')).
98foreign_dependency(_, library('foreign/foreign_swipl.h')).
99
100command_to_atom(Command, Args, Atom) :-
101 process_create(path(Command), Args, [stdout(pipe(Out))]),
102 read_stream_to_codes(Out, String),
103 atom_string(Atom, String).
104
105language_command(for, M, path(gfortran), ValueL, ValueT) :-
106 command_to_atom(swipl, ['--dump-runtime-variables'], Atom),
107 atomic_list_concat(AtomL, ';\n', Atom),
108 findall(Value,
109 ( ( member(NameValue, AtomL),
110 member(NameEq, ['PLCFLAGS="', 'PLLDFLAGS="']),
111 atomics_atom([NameEq, Values, '"'], NameValue)
112 ; extra_compiler_opts(M, Values)
113 ),
114 atomic_args(Values, ValueL1),
115 member(Value, ValueL1)
116 ),
117 ValueL, ValueT).
118language_command(c, M, path('swipl-ld'), ValueL, ValueT) :-
119 findall(COpt, ( COpt = '-shared'
120 ; ( extra_compiler_opts(M, COpts)
121 ; pkg_foreign_config(M, Package),
122 command_to_atom('pkg-config', ['--cflags', Package], COpt1),
123 atom_concat(COpts, '\n', COpt1)
124 ),
125 atomic_args(COpts, COptL1),
126 member(COpt, COptL1)
127 ), ValueL, ValueT).
128
129intermediate_obj(M, DirSO, OptL, LibL, Source, Object) -->
130 { file_name_extension(Base, Ext, Source),
131 file_base_name(Base, Name),
132 ( Ext = for,
133 memberchk(gfortran, LibL)
134 ->true
135 ; Ext = c
136 ),
137 intermediate_obj_cmd(Ext, Name, M, DirSO, OptL, Source, Object, Command)
138 },
139 !,
140 ( {is_newer(Object, Source)}
141 ->[]
142 ; [Ext-Command]
143 ).
144intermediate_obj(_, _, _, _, Source, Source) --> [].
145
146intermediate_obj_cmd(Ext, Name, M, DirSO, OptL, Source, Object, Compiler-Args) :-
147 148 atomic_list_concat([Name, '_', Ext], NameFor),
149 file_name_extension(NameFor, o, NameO),
150 directory_file_path(DirSO, NameO, Object),
151 append([OptL, ['-c', Source, '-o', Object]], FOptL),
152 language_command(Ext, M, Compiler, Args, FOptL).
153
154generate_library(M, AliasSO, AliasSOPl, InitL, File) :-
155 absolute_file_name(AliasSO, FileSO, [file_type(executable),
156 relative_to(File)]),
157 findall(FSource, ( ( use_foreign_source(M, FAlias)
158 ; FAlias = library('foreign/foreign_interface.c')
159 ; FAlias = library('foreign/foreign_swipl.c')
160 ),
161 absolute_file_name(FAlias, FSource,
162 [extensions(['.c', '']),
163 access(read),
164 relative_to(File)])
165 ), FSourceL),
166 ( forall(( Dep = File
167 ; member(Alias, [library(foreign/foreign_generator),
168 library(foreign/foreign_props),
169 library(foreign/foreign_interface)
170 ]),
171 absolute_file_name(Alias, Dep, [file_type(prolog),
172 access(read),
173 relative_to(File)])),
174 is_newer(FileSO, Dep))
175 ->print_message(informational,
176 format("Skipping generation of ~w interface: is up to date", [File])),
177 compile_library(M, FileSO, File, FSourceL)
178 ; do_generate_library(M, FileSO, File, InitL),
179 do_generate_wrapper(M, AliasSO, AliasSOPl, File),
180 do_compile_library(M, FileSO, File, FSourceL)
181 ).
182
183compile_library(M, FileSO, File, FSourceL) :-
184 intf_file(FileSO, IntfFile),
185 ( forall(( member(Dep, [IntfFile|FSourceL])
186 ; foreign_dependency(M, HAlias),
187 absolute_file_name(HAlias, Dep,
188 [extensions(['.h','']),
189 access(read),
190 relative_to(File)])
191 ),
192 is_newer(FileSO, Dep))
193 ->print_message(informational,
194 format("Skipping compilation of ~w: is up to date", [FileSO]))
195 ; do_compile_library(M, FileSO, File, FSourceL, IntfFile)
196 ).
197
200max_fli_args(10 ).
201
202do_generate_wrapper(M, AliasSO, AliasSOPl, File) :-
203 max_fli_args(MaxFLIArgs),
204 findall(F/A, ( current_foreign_prop(Head, M, _, _, Glob),
205 arg(1, Glob, Opts),
206 \+ ( nmember(lang(Lang), Opts),
207 lang(Lang)
208 ),
209 \+ ( predicate_property(M:Head, number_of_clauses(X)),
210 X>0
211 ),
212 functor(Head, F, A)
213 ), IntfPIU),
214 sort(IntfPIU, IntfPIL),
215 atom_concat(M, '$impl', IModule),
216 absolute_file_name(AliasSOPl, FileSOPl, [file_type(prolog),
217 relative_to(File)]),
218 save_to_file(FileSOPl,
219 phrase(( add_autogen_note(M),
220 [(:- module(IModule, IntfPIL))],
221 generate_aux_clauses(M),
222 [ "",
223 (:- use_foreign_library(AliasSO)),
224 225 (:- initialization(( shlib:current_library(AliasSO, _, F1, IModule, _),
226 open_shared_object(F1, _, [global])), now))
227 ],
228 findall((Head :- Body),
229 ( member(F/A, IntfPIL),
230 A > MaxFLIArgs,
231 atomic_list_concat(['__aux_pfa_', F, '_', A], NF),
232 functor(Head, F, A),
233 Body =.. [NF, Head]
234 ))
235 ))).
236
237atomic_args(String, ArgL) :-
238 atomic_list_concat(ArgL1, ' ', String),
239 subtract(ArgL1, [''], ArgL).
240
241do_generate_library(M, FileSO, File, InitL) :-
242 file_name_extension(BaseFile, _, FileSO),
243 generate_foreign_interface(M, File, InitL, BaseFile).
244
245dir_intf(File, DirIntf) :-
246 absolute_file_name(library(foreign/foreign_interface),
247 IntfPl,
248 [file_type(prolog), access(read), relative_to(File)]),
249 directory_file_path(DirIntf, _, IntfPl).
250
251intf_file(FileSO, IntfFile) :-
252 file_name_extension(BaseFile, _, FileSO),
253 atom_concat(BaseFile, '_intf.c', IntfFile).
254
255do_compile_library(M, FileSO, File, FSourceL) :-
256 intf_file(FileSO, IntfFile),
257 do_compile_library(M, FileSO, File, FSourceL, IntfFile).
258
259do_compile_library(M, FileSO, File, FSourceL, IntfFile) :-
260 dir_intf(File, DirIntf),
261 directory_file_path(DirSO, _, FileSO),
262 findall(IDir, ( ( Dir = DirSO
263 ; Dir = DirIntf
264 ; include_foreign_dir(M, DAlias),
265 absolute_file_name(DAlias, Dir, [file_type(directory),
266 relative_to(File)])
267 ),
268 atom_concat('-I', Dir, IDir)
269 ), IDirL),
270 CommonOptL = ['-fPIC'|IDirL],
271 foldl(intermediate_obj(M, DirSO, CommonOptL, LibL), [IntfFile|FSourceL], FTargetL, ExtCommands, []),
272 once(append(LibL, [], _)),
273 findall(COpt, ( COpt = '-shared'
274 ; ( extra_compiler_opts(M, COpts)
275 ; pkg_foreign_config(M, Package),
276 command_to_atom('pkg-config', ['--cflags', Package], COpt1),
277 atom_concat(COpts, '\n', COpt1)
278 ),
279 atomic_args(COpts, COptL1),
280 member(COpt, COptL1)
281 ), COptL),
282 findall(CLib, ( ( link_foreign_library(M, Lib)
283 ; member(Lib, LibL)
284 ),
285 atom_concat('-l', Lib, CLib)
286 ; pkg_foreign_config(M, Package),
287 command_to_atom('pkg-config', ['--libs', Package], CLib1),
288 atom_concat(CLibs, '\n', CLib1),
289 atomic_args(CLibs, CLibL1),
290 member(CLib, CLibL1)
291 ), CLibL, ['-o', FileSO]),
292 findall(LDir, ( library_foreign_dir(M, DAlias),
293 absolute_file_name(DAlias, Dir, [file_type(directory),
294 relative_to(File)]),
295 atom_concat('-L', Dir, LDir)
296 ),
297 LDirL),
298 append([COptL, CommonOptL, LDirL, FTargetL, CLibL], FArgsL),
299 keysort(ExtCommands, Sorted),
300 group_pairs_by_key(Sorted, Grouped),
301 concurrent_maplist(compile_1, Grouped),
302 compile_2(path('swipl-ld')-FArgsL).
303
304compile_1(Ext-Commands) :- compile_1(Ext, Commands).
305
309compile_1(for, Commands) :- maplist(compile_2, Commands).
310compile_1(c, Commands) :- concurrent_maplist(compile_2, Commands).
311
312compile_2(Command-ArgL) :-
313 process_create(Command, ArgL, [stdout(pipe(Out)),
314 stderr(pipe(Err))]),
315 read_string(Err, _, SErr),
316 read_string(Out, _, SOut),
317 close(Err),
318 command_to_string(Command, ArgL, CommandS),
319 catch(call_cleanup(
320 close(Out),
321 ( SOut = "",
322 SErr = ""
323 ->print_message(informational, format("~s", [CommandS]))
324 ; print_message(warning, format("~s~s~nCommand: ~s", [SOut, SErr, CommandS]))
325 )),
326 Error,
327 print_message(error, Error)).
328
329command_to_string(Command, ArgL, CommandS) :-
330 ( Command = path(RCommand)
331 ->true
332 ; RCommand = Command
333 ),
334 atomic_list_concat([RCommand|ArgL], ' ', CommandS).
335
336generate_foreign_interface(Module, FilePl, IntL, BaseFile) :-
337 abolish_module_tables(foreign_generator),
338 atom_concat(BaseFile, '_impl', BaseFileImpl),
339 file_name_extension(BaseFileImpl, h, FileImpl_h),
340 atom_concat(BaseFile, '_intf', BaseFileIntf),
341 file_name_extension(BaseFileIntf, h, FileIntf_h),
342 file_name_extension(BaseFileIntf, c, FileIntf_c),
343 directory_file_path(_, Base, BaseFile),
344 save_to_file(FileImpl_h, generate_foreign_impl_h(Module)),
345 save_to_file(FileIntf_h, generate_foreign_intf_h(Module, FileImpl_h)),
346 save_to_file(FileIntf_c, generate_foreign_c(Module, Base, IntL, FilePl, FileIntf_h)).
347
348c_var_name(Arg, "_c_"+Arg).
349
350generate_foreign_intf_h(Module, FileImpl_h) -->
351 add_autogen_note(Module),
352 ["#ifndef __"+Module+"_INTF_H",
353 "#define __"+Module+"_INTF_H",
354 "",
355 "",
356 "#include <foreign_swipl.h>",
357 "#include \""+FileImpl_h+"\"",
358 "",
359 "extern module_t __"+Module+"_impl;"],
360 findall_tp(Module, type_props_nf(gett), declare_type(gett)),
361 findall_tp(Module, type_props_nf(unif), declare_type(unif)),
362 findall("extern "+Decl+";",
363 ( current_foreign_prop(Head, _, Module, _, _, _, _, Dict, FuncName, _, BindName, _, Type),
364 apply_dict(Head, Dict),
365 declare_intf_head(Type, FuncName, BindName, Head, Decl)
366 )),
367 ["",
368 "#endif /* __"+Module+"_INTF_H */"].
369
370declare_intf_head(foreign(Opts, _), _, BindName, _, Decl) :-
371 once(( nmember(lang(Lang), Opts),
372 lang(Lang)
373 )),
374 declare_intf_fimp_head(BindName, Decl).
375declare_intf_head(foreign(Opts, _), FuncName, _, Head, Decl) :-
376 once(nmember(lang(native), Opts)),
377 declare_intf_head(FuncName, Head, Decl).
378declare_intf_head(Type, _, BindName, Head, Decl) :-
379 \+ ( Type = foreign(Opts, _),
380 nmember(lang(Lang), Opts),
381 lang(Lang)
382 ),
383 declare_intf_head(BindName, Head, Decl).
384
385declare_intf_fimp_head(BindName, "predicate_t "+BindName+"").
386
387generate_foreign_impl_h(Module) -->
388 add_autogen_note(Module),
389 ["#ifndef __"+Module+"_IMPL_H",
390 "#define __"+Module+"_IMPL_H",
391 "",
392 "#include <foreign_interface.h>"],
393 findall_tp(Module, type_props_nf(decl), declare_struct),
394 declare_foreign_bind(Module),
395 ["#endif /* __"+Module+"_IMPL_H */"].
396
397add_autogen_note(Module) -->
398 ["/* NOTE: File generated automatically from "+Module+" */",
399 ""].
400
401generate_foreign_c(Module, Base, InitL, FilePl, FileIntf_h) -->
402 add_autogen_note(Module),
403 findall("#include \""+File_h+"\"",
404 ( use_foreign_header(Module, HAlias),
405 absolute_file_name(HAlias, File_h, [extensions(['.h', '']),
406 access(read),
407 relative_to(FilePl)])
408 )),
409 ["#include \""+FileIntf_h+"\"",
410 "",
411 "module_t __"+Module+";",
412 "module_t __"+Module+"_impl;"
413 ],
414 findall_tp(Module, type_props_nft(gett), implement_type_getter),
415 findall_tp(Module, type_props_nft(unif), implement_type_unifier),
416 generate_foreign_register(Module, Base, InitL),
417 generate_foreign_intf(Module).
418
419generate_foreign_register(Module, Base, InitL) -->
420 ["install_t install_"+Base+"() {",
421 " __system_dict_create =PL_predicate(\"dict_create\", 3, \"system\");",
422 " __system_get_dict =PL_predicate(\"get_dict\", 3, \"system\");",
423 " __system_put_dict =PL_predicate(\"put_dict\", 4, \"system\");",
424 " __foreign_generator_call_idx=PL_predicate(\"call_idx\", 2, \"foreign_generator\");",
425 " __foreign_generator_idx_call=PL_predicate(\"idx_call\", 2, \"foreign_generator\");",
426 " __"+Module+" =PL_new_module(PL_new_atom(\""+Module+"\"));",
427 " __"+Module+"_impl=PL_new_module(PL_new_atom(\""+Module+"$impl\"));"],
428 findall_tp(Module, type_props_nf([gett, unif]), define_aux_variables),
429 findall(Line,
430 ( current_foreign_prop(_, M, Module, _, _, _, _, _, _, PredName, BindName, Arity, Type),
431 write_register_sentence(Type, M, Module, PredName, Arity, BindName, Line))),
432 foldl(generate_init, InitL),
433 ["} /* install_"+Base+" */",
434 ""].
435
436generate_init(Init) --> [" "+Init+"();"].
437
438write_register_sentence(foreign(Opts, _), M, _, PredName, Arity, BindName, Line) :-
439 nmember(lang(Lang), Opts),
440 lang(Lang),
441 !,
442 write_init_import_binding(M, PredName, Arity, BindName, Line).
443write_register_sentence(_, M, CM, PredName, Arity, BindName, Line) :-
444 write_register_foreign_native(M, CM, PredName, Arity, BindName, Line).
445
446write_register_foreign_native(M, CM, PredName, Arity, BindName, L) :-
447 max_fli_args(MaxFLIArgs),
448 ( M == CM
449 ->L1=" PL_register_foreign("
450 ; L1=" PL_register_foreign_in_module(\""+M+"\","
451 ),
452 ( Arity =< MaxFLIArgs
453 ->L = L1+"\""+PredName+"\", "+Arity+", "+BindName+", 0);"
454 ; L = L1+"\"__aux_pfa_"+PredName+"_"+Arity+"\", 1, __aux_pfa_"+BindName+"_"+Arity+", 0);"
455 ).
456
457write_init_import_binding(M, PN, A, BN,
458 " "+BN+" = PL_predicate(\""+PN+"\", "+A+", \""+M+"\");").
459
460:- meta_predicate findall_tp(+,4,5,?,?). 461
462findall_tp(Module, TypeProps, Call) -->
463 findall(List,
464 ( call(TypeProps, Module, TypePropLDictL, Pos, _Asr),
465 maplist(apply_dict_tp, TypePropLDictL),
466 phrase(type_components(Module, TypePropLDictL, Call, Pos), List)
467 )).
468
469apply_dict_tp(_-TypePropLDictL) :- maplist(apply_dict_tp_2, TypePropLDictL).
470
471apply_dict_tp_2(t(Type, PropL, GlobL, Dict)) :- apply_dict(Type-PropL-GlobL, Dict).
472
473auto_generated_types(M, GlobL, p(Type, PropL, Dict), t(Type, PropS, GlobL, Dict)) -->
474 { get_type_name(Type, Name),
475 foldl(match_unknown_type(M, Name), PropL, PropTypeL1, []),
476 foldl(cleanup_redundant(Type, PropL), PropTypeL1, PropTypeL, []),
477 substitute_values(PropTypeL, PropL, PropS)
478 },
479 foldl(add_dict(Dict), PropTypeL).
480
481cleanup_redundant(Type, PropL, Prop=SubType) -->
482 ( { functor(Type, _, A),
483 arg(A, Type, Arg),
484 functor(SubType, _, SA),
485 arg(SA, SubType, SubArg),
486 Arg==SubArg,
487 PropL==[Prop]
488 }
489 ->[]
490 ; [Prop=SubType]
491 ).
492
493add_dict(Dict, Prop=Type) --> [Type-[t(Type, [Prop], [], Dict)]].
494
495match_unknown_type(M, Name, Prop) --> match_type(Prop, M, unknown, Name, _, _), !.
496
497is_type(CM, Head) :-
498 once(( prop_asr(Head, CM, check, prop, _, _, Asr),
499 once(prop_asr(glob, type(_), _, Asr))
500 )).
501
502type_props(M, TypePropLDictL, Pos, Asr) :-
503 type_props(M, _, TypePropLDictL, Pos, Asr).
504
505type_props(M, Type, TypePropLDictL, Pos, Asr) :-
506 type_props1(M, Type, TDict, Pos, Asr),
507 type_props2(M, Type, TDict, TypePropLDictL, Asr).
508
509type_props2(M, Type, TDict, TypePropLDictL, Asr) :-
510 collect_prop(Asr, M, comp, TPropL),
511 collect_prop(Asr, M, glob, TGlobL),
512 ( TPropL \= []
513 ->TypePropLDictL1 = [p(Type, TPropL, TDict)]
514 ; bind_type_names(M:Type, TypePropLDictL1)
515 ->true
516 ; TypePropLDictL1 = [p(Type, [], TDict)]
517 ),
518 phrase(foldl(auto_generated_types(M, TGlobL), TypePropLDictL1, TypePropLDictL2),
519 TypePropLDictL3, [Type-TypePropLDictL2]),
520 maplist(resolve_special_terms, TypePropLDictL3, TypePropLDictL).
521
522resolve_special_term(V, V) :- var(V).
523resolve_special_term([], nil).
524resolve_special_term([H|T], edge(H, T)).
525resolve_special_term(T, T).
526
527resolve_special_terms(Type1-TypePropLDictL1, Type-TypePropLDictL) :-
528 resolve_special_arg(Type1, Type),
529 maplist(resolve_special_term2, TypePropLDictL1, TypePropLDictL).
530
531resolve_special_arg(Type1, Type) :-
532 Type1 =.. List1,
533 once(append(Left, [Last1], List1)),
534 once(resolve_special_term(Last1, Last)),
535 append(Left, [Last], List),
536 Type =.. List.
537
538resolve_special_term2(t(Type1, PropL, GlobL, Dict), t(Type, PropL, GlobL, Dict)) :- resolve_special_arg(Type1, Type).
539
540type_props1(CM, Head, Dict, Pos, Asr) :-
541 542 asr_head_prop(Asr, CM, Head, check, prop, Dict, _, Pos),
543 544 is_type(CM, Head).
545
546type_props_nf(Opts1, Module, TypePropLDictL, Pos, Asr) :-
547 type_props_nf(Opts1, Module, _, TypePropLDictL, Pos, Asr).
548
549type_props_nf(Opts1, Module, Type, TypePropLDictL, Pos, Asr) :-
550 type_props(Module, Type, TypePropLDictL, Pos, Asr),
551 once(( normalize_ftgen(Glob1, tgen(Opts2, _)),
552 prop_asr(glob, Glob1, _, Asr),
553 nmember(Opt, Opts1),
554 nmember(Opt, Opts2)
555 )),
556 \+ ( normalize_ftype(Glob, NType),
557 prop_asr(glob, Glob, _, Asr),
558 arg(1, NType, Opts),
559 \+ ( nmember(lang(Lang), Opts),
560 lang(Lang)
561 )).
562
563type_props_nft(Opt, Module, TypePropLDictL, Pos, Asr) :-
564 type_props_nf(Opt, Module, Type, TypePropLDictL, Pos, Asr),
565 566 567 \+ type_is_tdef(Module, Type, _, _).
568
569define_aux_variables(dict_ini(_, Name, M, _), _, _) -->
570 !,
571 [" __rtcwarn((__"+M+"_aux_keyid_index_"+Name+"=PL_pred(PL_new_functor(PL_new_atom(\"__aux_keyid_index_"+Name+"\"), 2), __"+M+"_impl))!=NULL);"].
572define_aux_variables(dict_key_value(_, _, _, _), _, _) --> !, {fail}.
573define_aux_variables(_, _, _) --> [].
574
575implement_type_getter_ini(PName, CName, Spec, Name) -->
576 { ( memberchk(Spec, [array(_, _), setof(_, _, _, _)])
577 ->Decl = Name
578 ; Decl = Name+"*"
579 )
580 },
581 ["int FI_get_"+Name+"(root_t __root, term_t "+PName+", "+Decl+" "+CName+") {"].
582
583c_get_argument_getter(Spec, CNameArg, PNameArg, GetArg) :-
584 c_get_argument(Spec, in, CNameArg, PNameArg, GetArg).
585
586implement_type_getter_union_ini_join(SubType, Spec, Term, Name, UType) -->
587 { term_pcname(Term, Name, PName, CName),
588 cname_utype(SubType, CName, UType1),
589 ( \+ref_type(Spec)
590 ->UType = "*"+UType1
591 ; UType = UType1
592 ),
593 get_type_name(Term, Func),
594 '$current_source_module'(CM)
595 },
596 implement_type_getter_ini(PName, CName, Spec, Name),
597 [" term_t __args = PL_new_term_refs(2);",
598 " int __utype;",
599 " __rtcheck(PL_unify_term(__args, PL_FUNCTOR_CHARS, \""+Func+"\", 1, PL_TERM, "+PName+"));",
600 " __rtcheck(__rtctype(PL_call_predicate(__"+CM+", PL_Q_NORMAL,",
601 " __foreign_generator_call_idx, __args),",
602 " __args, "+Name+"));",
603 " __rtcheck(PL_get_integer(__args + 1, &__utype));",
604 " "+UType+"=__utype;"
605 ].
606
607implement_type_getter_union_ini(union, Spec, Term, Name) -->
608 implement_type_getter_union_ini_join(union, Spec, Term, Name, UType),
609 [" switch ("+UType+") {"].
610implement_type_getter_union_ini(cdef, _, _, _) --> [].
611implement_type_getter_union_ini(struct, _, _, _) --> [].
612implement_type_getter_union_ini(enum, Spec, Term, Name) -->
613 implement_type_getter_union_ini_join(enum, Spec, Term, Name, _).
614
615implement_type_getter_union_end(union) -->
616 [" default:",
617 " return FALSE;",
618 " };"],
619 implement_type_end.
620implement_type_getter_union_end(cdef ) --> [].
621implement_type_getter_union_end(struct) --> [].
622implement_type_getter_union_end(enum ) --> implement_type_end.
623
624enum_elem(Name, Term, Name+"_"+Suff) :- enum_suff(Term, Suff).
625
626enum_suff(Term, Elem) :- get_type_name(Term, Elem).
627
628implement_type_getter(union_ini(SubType, Spec, _), Term, Name) -->
629 implement_type_getter_union_ini(SubType, Spec, Term, Name).
630implement_type_getter(union_end(SubType, _), _, _) -->
631 implement_type_getter_union_end(SubType).
632implement_type_getter(func_ini(SubType, Spec), Term, Name) -->
633 ( {SubType = union}
634 ->{enum_elem(Name, Term, Elem)},
635 [" case "+Elem+":",
636 " {"]
637 ; {func_pcname(Name, PName, CName)},
638 implement_type_getter_ini(PName, CName, Spec, Name)
639 ).
640implement_type_getter(func_rec(SubType, N, Term, Name), Spec, Arg) -->
641 { SubType = union
642 ->enum_suff(Term, Suff),
643 line_atom(Suff, TName),
644 format(atom(CRecordName), "~w.~w", [TName, Arg]),
645 format(atom(TNameArg), "~w_~w", [TName, Arg]),
646 camel_snake(PRecordName, TNameArg),
647 Indent = " "
648 ; CRecordName = Arg,
649 camel_snake(PRecordName, Arg),
650 Indent = " "
651 },
652 { func_pcname(Name, PName, CName),
653 ( memberchk(Spec, [setof(_, _, _, _)])
654 ->CRef=""
655 ; CRef="&"
656 ),
657 CNameArg=CRef+CName+"->"+CRecordName+"",
658 PNameArg=PName+"_"+PRecordName
659 },
660 ( {SubType = union_type}
661 ->{c_get_argument_getter(Spec, CNameArg, PName, GetArg)}
662 ; [Indent+"term_t "+PNameArg+"=PL_new_term_ref();",
663 Indent+"__rtcheck(PL_get_arg("+N+","+PName+","+PNameArg+"));"],
664 {c_get_argument_getter(Spec, CNameArg, PNameArg, GetArg)}
665 ),
666 [Indent+GetArg+";"].
667implement_type_getter(func_end(SubType, _), _, _) -->
668 ( {SubType = union}
669 ->[" break;",
670 " }"]
671 ; implement_type_end
672 ).
673implement_type_getter(atomic(SubType, Name), Spec, Term) -->
674 {enum_elem(Name, Term, Elem)},
675 ( {SubType = union}
676 ->{ func_pcname(Name, PName, CName1),
677 enum_suff(Term, Suff),
678 CName = CName1+"->"+Suff,
679 Indent = " "
680 },
681 [" case "+Elem+":"]
682 ; { func_pcname(Name, PName, CName),
683 Indent = " "
684 },
685 implement_type_getter_ini(PName, CName, Spec, Name)
686 ),
687 {c_get_argument_getter(Spec, CName, PName, GetArg)},
688 [Indent+GetArg+";"],
689 ( {SubType = union}
690 ->[Indent+"break;"]
691 ; implement_type_end
692 ).
693implement_type_getter(dict_ini(SubType, Name, M, _), Spec, Term) -->
694 ( {SubType = union}
695 ->{enum_elem(Name, Term, Elem)},
696 [" case "+Elem+":",
697 " {"]
698 ; ["predicate_t __"+M+"_aux_keyid_index_"+Name+";"],
699 {term_pcname(Term, Name, PName, CName)},
701 implement_type_getter_dict_ini(M, PName, CName, Spec, Name)
702 )
702.
703implement_type_getter(dict_key_value(Dict, _, N, _), Key, Value) -->
704 {key_value_from_dict(Dict, N, Key, Value)}.
705implement_type_getter(dict_rec(SubType, _, Term, N, Name), Spec, Arg) -->
706 { ( SubType = union
707 ->enum_suff(Term, Suff),
708 format(atom(CRecordName), "~w.~w", [Suff, Arg]),
709 Indent = " "
710 ; CRecordName = Arg,
711 Indent = " "
712 ),
713 term_pcname(Term, Name, PName, CName),
714 CNameArg = "&"+CName+"->"+CRecordName,
715 c_get_argument_getter(Spec, CNameArg, PName, GetArg)
716 },
717 [Indent+" case "+N+": "+GetArg+"; break;"].
718implement_type_getter(dict_end(SubType, _, _), _, _) -->
719 [" }"],
720 ( {SubType = union}
721 ->[" break;",
722 " }"]
723 ; implement_type_end
724 ).
725
726implement_type_getter_dict_ini(Module, PName, CName, Spec, Name) -->
727 {ctype_decl(Spec, Decl)},
728 ["static int get_pair_"+Name+"(root_t __root, term_t __keyid, term_t "+PName+", "+Decl+"* "+CName+");",
729 ""],
730 implement_type_getter_ini(PName, CName, Spec, Name),
731 [" memset("+CName+", 0, sizeof("+Decl+"));",
732 " FI_get_dict_t("+Name+", "+PName+", "+CName+");"
733 ],
734 implement_type_end,
735 ["static int get_pair_"+Name+"(root_t __root, term_t __keyid, term_t "+PName+", "+Decl+"* "+CName+") {",
736 " int __index;",
737 " FI_get_keyid_index(__"+Module+"_aux_keyid_index_"+Name
738 +", __keyid, __index);",
739 " switch (__index) {"].
740
741implement_type_end -->
742 [" return TRUE;",
743 "}",
744 ""].
745
746term_pcname(Term, NameL, Name) :-
747 ( compound(Term)
748 ->get_type_name(Term, Func)
749 ; Func = Term
750 ),
751 ( valid_csym(Func)
752 ->Name = Func
753 ; Name = NameL
754 ).
755
756term_pcname(Term, NameL, PName, CName) :-
757 term_pcname(Term, NameL, Name),
758 func_pcname(Name, PName, CName).
759
760func_pcname(NameL, PName, CName) :-
761 ( is_list(NameL)
762 ->atomic_list_concat(NameL, Name)
763 ; Name = NameL
764 ),
765 camel_snake(PName, Name),
766 c_var_name(Name, CName).
767
768type_char(Type, Char) :- char_type(Char, Type).
769
770valid_csym(Func) :-
771 atom_codes(Func, Codes),
772 maplist(type_char(csym), Codes).
773
774implement_type_unifier(atomic(SubType, Name), Spec, Term) -->
775 {enum_elem(Name, Term, Elem)},
776 ( {SubType = union}
777 ->{ func_pcname(Name, PName, CName1),
778 enum_suff(Term, Suff),
779 CName = CName1+"->"+Suff,
780 Indent = " "
781 },
782 [" case "+Elem+":"]
783 ; { func_pcname(Name, PName, CName),
784 Indent = " "
785 },
786 implement_type_unifier_ini(PName, CName, Name, Spec)
787 ),
788 { ( SubType = union
789 ->Mode = inout
790 ; Mode = out
791 ),
792 c_set_argument(Spec, Mode, CName, PName, SetArg)
793 },
794 [Indent+SetArg+";"],
795 ( {SubType = union}
796 ->[Indent+"break;"]
797 ; implement_type_end
798 ).
799implement_type_unifier(union_ini(SubType, Spec, _), Term, Name) -->
800 implement_type_unifier_union_ini(SubType, Spec, Term, Name).
801
802cname_utype(union, CName, CName+"->utype").
803cname_utype(enum, CName, CName).
804
805implement_type_unifier_union_ini_join(SubType, Spec, Term, Name, UType) -->
806 { term_pcname(Term, Name, PName, CName),
807 cname_utype(SubType, CName, UType),
808 get_type_name(Term, Func),
809 '$current_source_module'(CM)
810 },
811 implement_type_unifier_ini(PName, CName, Name, Spec),
812 [" term_t __args = PL_new_term_refs(2);",
813 " __rtcheck(PL_put_integer(__args, "+UType+"));",
814 " __rtcheck(PL_unify_term(__args + 1, PL_FUNCTOR_CHARS, \""+Func+"\", 1, PL_TERM, "+PName+"));",
815 " __rtcheck(__rtctype(PL_call_predicate(__"+CM+", PL_Q_NORMAL,",
816 " __foreign_generator_idx_call, __args),",
817 " __args, "+Name+"));"
818 ].
819
820implement_type_unifier_union_ini(union, Spec, Term, Name) -->
821 implement_type_unifier_union_ini_join(union, Spec, Term, Name, UType),
822 [" switch ("+UType+") {"].
823implement_type_unifier_union_ini(enum, Spec, Term, Name) -->
824 implement_type_unifier_union_ini_join(enum, Spec, Term, Name, _).
825implement_type_unifier_union_ini(cdef, _, _, _) --> [].
826implement_type_unifier_union_ini(struct, _, _, _) --> [].
827
828implement_type_unifier(union_end(SubType, _), _, _) -->
829 implement_type_unifier_union_end(SubType).
830
831implement_type_unifier_union_end(union) -->
832 [" default:",
833 " return FALSE;",
834 " };"],
835 implement_type_end.
836implement_type_unifier_union_end(cdef ) --> [].
837implement_type_unifier_union_end(struct) --> [].
838implement_type_unifier_union_end(enum ) --> implement_type_end.
839
840implement_type_unifier(func_ini(SubType, Spec), Term, Name) -->
841 {func_pcname(Name, PName, CName)},
842 ( {SubType = union}
843 ->{enum_elem(Name, Term, Elem)},
844 [" case "+Elem+":",
845 " {"]
846 ; implement_type_unifier_ini(PName, CName, Name, Spec),
847 {functor(Term, Func, Arity)},
848 [" __rtcheck(PL_unify_functor("+PName+", PL_new_functor(PL_new_atom(\""+Func+"\"), "+Arity+")));"]
849 ).
850implement_type_unifier(func_rec(SubType, N, Term, Name), Spec, Arg) -->
851 {type_unifiers_elem_names(SubType, Term, Name, Arg, Indent, PName, CNameArg, PNameArg)},
852 ( {SubType = union_type}
853 ->{c_set_argument(Spec, out, CNameArg, PName, SetArg)}
854 ; [Indent+"term_t "+PNameArg+"=PL_new_term_ref();",
855 Indent+"__rtcheck(PL_unify_arg("+N+","+PName+","+PNameArg+"));"],
856 {c_set_argument(Spec, out, CNameArg, PNameArg, SetArg)}
857 ),
858 [Indent+SetArg+";"].
859
860type_unifiers_elem_names(SubType, Term, Name, Arg, Indent, PName, CNameArg, PNameArg) :-
861 func_pcname(Name, PName, CName),
862 ( SubType = union
863 ->enum_suff(Term, Suff),
864 line_atom(Suff, TName),
865 format(atom(CRecordName), "~w.~w", [TName, Arg]),
866 format(atom(TNameArg), "~w_~w", [TName, Arg]),
867 camel_snake(PRecordName, TNameArg),
868 Indent = " "
869 ; CRecordName = Arg,
870 camel_snake(PRecordName, Arg),
871 ( SubType = union_type
872 ->Indent = " "
873 ; Indent = " "
874 )
875 ),
876 CNameArg = CName+"->"+CRecordName,
877 PNameArg = PName+"_"+PRecordName.
878
879implement_type_unifier(func_end(SubType, _), _, _) -->
880 ( {SubType = union}
881 ->[" break;",
882 " }"]
883 ; implement_type_end
884 ).
885implement_type_unifier(dict_ini(SubType, Name, _, _), Spec, Term) -->
886 ( {SubType = union}
887 ->{enum_elem(Name, Term, Elem)},
888 [" case "+Elem+":",
889 " {"]
890 ; {func_pcname(Term, PName, CName)},
891 implement_type_unifier_ini(PName, CName, Name, Spec)
892 ),
893 [" term_t __desc=PL_new_term_ref();",
894 " term_t __tail=PL_copy_term_ref(__desc);"].
895implement_type_unifier(dict_key_value(Dict, _, N, _), Key, Value) -->
896 {key_value_from_dict(Dict, N, Key, Value)}. 897implement_type_unifier(dict_rec(SubType, _, Term, _N, NameL), Spec, Arg) -->
898 {term_pcname(Term, NameL, Name)},
899 {type_unifiers_elem_names(SubType, Term, Name, Arg, Indent, _, CNameArg, PNameArg)},
900 ( {spec_pointer(Spec)}
901 ->with_wrapper(
902 Indent+"if("+CNameArg+") {",
903 type_unifiers_elem_dict_settle(Spec, Arg, Indent+" ", CNameArg, PNameArg),
904 Indent+"}")
905 ; type_unifiers_elem_dict_settle(Spec, Arg, Indent, CNameArg, PNameArg)
906 ).
907
908type_unifiers_elem_dict_settle(Spec, Arg, Indent, CNameArg, PNameArg) -->
909 [Indent+"term_t "+PNameArg+"=PL_new_term_ref();"],
910 [Indent+"FI_put_desc(__tail, \""+Arg+"\", "+PNameArg+");"],
911 {c_set_argument(Spec, out, CNameArg, PNameArg, SetArg)},
912 [Indent+SetArg+";"].
913
914with_wrapper(Ini, Goal, End) -->
915 [Ini],
916 call(Goal),
917 [End].
918
919implement_type_unifier(dict_end(SubType, _, Tag), _, Term) -->
920 {func_pcname(Term, PName, _)},
921 [" __rtcheck(PL_unify_nil(__tail));",
922 " FI_dict_create("+PName+", \""+Tag+"\", __desc);"],
923 ( {SubType = union}
924 ->[" break;",
925 " }"]
926 ; implement_type_end
927 ).
928
929spec_pointer(chrs(_)).
930spec_pointer(string(_)).
931spec_pointer(ptr(_)).
932spec_pointer(ntype(_, pointer)).
933spec_pointer(list(_)).
934spec_pointer(tdef(_, Spec)) :- spec_pointer(Spec).
936
937implement_type_unifier_ini(PName, CName, Name, Spec) -->
938 { ( \+ref_type(Spec)
939 ->DRef = ""
940 ; DRef = "*"
941 ),
942 ctype_suff(Spec, Suff)
943 },
944 ["int FI_unify_"+Name+"(term_t "+PName+", "+Name+DRef+" const "+CName+Suff+") {"].
945
946apply_name(Name=Value) :-
947 camel_snake(Name, Arg),
948 ignore(Value=Arg).
949
950apply_dict(Head, Dict) :-
951 maplist(apply_name, Dict),
952 term_variables(Head, Vars),
953 fg_numbervars(Vars, 1, Dict).
954
955fg_numbervars([], _, _).
956fg_numbervars([V|Vs], N, Dict) :-
957 format(atom(T), "var_~d", [N]),
958 succ(N, N1),
959 ( memberchk(_=T, Dict)
960 ->fg_numbervars([V|Vs], N1, Dict)
961 ; V=T,
962 fg_numbervars(Vs, N1, Dict)
963 ).
964
965bind_type_names(MType, TypeMPropLDictL) :-
966 predicate_property(MType, interpreted),
967 strip_module(MType, _, Type),
968 findall(p(Type, MPropL, Dict),
969 bind_tn_clause(MType, MPropL, Dict),
970 TypeMPropLDictL).
971
972:- meta_predicate
973 bind_tn_clause(0, -, -). 974
975bind_tn_clause(MType, MPropL, Dict) :-
976 strip_module(MType, M, Type),
977 catch(clause(MType, Body, Ref), _, fail),
978 ( clause_property(Ref, file(File)),
979 clause_property(Ref, line_count(Line)),
980 get_dictionary(Type :- Body, File, Line, M, Dict)
981 ->true
982 ; Dict = []
983 ),
984 clause_property(Ref, module(CM)),
985 sequence_list(Body, PropL, []),
986 maplist(cond_qualify_with(CM), PropL, MPropL).
987
988ds_union_ini(SubType, Name, TPDL1) -->
989 { TPDL1 = [TPD1|_],
990 TPD1 = t(Type1, _, _, _),
991 Type1 =.. Args1,
992 append(Left, [_], Args1),
993 append(Left, ["NUM"], ArgsN),
994 TypeN =.. ArgsN,
995 TPDN = t(TypeN, _, _, _),
996 append(TPDL1, [TPDN], TPDL),
997 !
998 },
999 foldil(ds_union_ini_1(SubType, Name), 0, TPDL).
1000
1001ds_union_ini_1(SubType, Name, Idx, t(Type, _, _, _)) -->
1002 { functor(Type, _, N),
1003 arg(N, Type, Term),
1004 ( SubType = enum
1005 ->format(codes(Codes), "~w", [Term]),
1006 sanitize_csym(Codes, [], CName, []),
1007 atom_codes(TName, CName),
1008 Elem = Name+"_"+TName
1009 ; enum_elem(Name, Term, Elem)
1010 )
1011 },
1012 [" "+Elem+" = "+Idx+","].
1013
1014sanitize_csym([], _ ) --> [].
1015sanitize_csym([C|L], S1) -->
1016 ( {type_char(csym, C)}
1017 ->S1,
1018 [C],
1019 {S = []}
1020 ; [],
1021 {S = [0'_|S1]}
1022 ),
1023 sanitize_csym(L, S).
1024
1025declare_struct_union_ini(union, Spec, TPDL, Name) -->
1026 ["typedef enum {"],
1027 ds_union_ini(union, Name, TPDL),
1028 ["} "+Name+"_utype;"],
1029 {ctype_ini(Spec, Decl)},
1030 [Decl+" {",
1031 " "+Name+"_utype utype;",
1032 " union {"
1033 ].
1034declare_struct_union_ini(cdef, _, _, _) --> [].
1035declare_struct_union_ini(struct, _, _, _) --> [].
1036declare_struct_union_ini(enum, Spec, TPDL, Name) -->
1037 {ctype_ini(Spec, CIni)},
1038 [CIni+" {"],
1039 ds_union_ini(enum, Name, TPDL),
1040 {ctype_end(Spec, CEnd)},
1041 ["}"+CEnd+";"].
1042
1043declare_struct_union_end(union, Spec) -->
1044 {ctype_end(Spec, CEnd)},
1045 [" };",
1046 "}"+CEnd+";"
1047 ].
1048declare_struct_union_end(cdef, _) --> [].
1049declare_struct_union_end(struct, _) --> [].
1050declare_struct_union_end(enum, _) --> [].
1051
1052ctype_decl_suff(array(Spec, Dim)) -->
1053 !,
1054 "[", acodes(Dim), "]", ctype_decl_suff(Spec).
1055ctype_decl_suff(setof(_, _, _, Dim)) -->
1056 !,
1057 ( {Dim = 1}
1058 ->""
1059 ; "[", acodes(Dim), "]"
1060 ).
1061ctype_decl_suff(_) --> "".
1062
1063ctype_decl_suff(Spec, Suff) :-
1064 ctype_decl_suff(Spec, Codes, []),
1065 atom_codes(Suff, Codes).
1066
1067declare_getset_macros(setof(_, _, _, Dim), Name) -->
1068 !,
1069 {c_dim_mult(Dim, Mult)},
1070 ["#define FI_empty_"+Name+"(__set) FI_empty_set_"+Mult+"(__set, "+Dim+")"],
1071 ["#define FI_chk_element_"+Name+"(__elem, __set) FI_chk_element_"+Mult+"(__elem, __set)"],
1072 ["#define FI_add_element_"+Name+"(__elem, __set) FI_add_element_"+Mult+"(__elem, __set)"],
1073 ["#define FI_del_element_"+Name+"(__elem, __set) FI_del_element_"+Mult+"(__elem, __set)"],
1074 ["#define FI_xor_element_"+Name+"(__elem, __set) FI_xor_element_"+Mult+"(__elem, __set)"].
1075declare_getset_macros(_, _) --> "".
1076
1077declare_struct(union_ini(SubType, Spec, TPDL), _, Name) -->
1078 declare_struct_union_ini(SubType, Spec, TPDL, Name).
1079declare_struct(union_end(SubType, Spec), _, _) -->
1080 declare_struct_union_end(SubType, Spec).
1081declare_struct(atomic(SubType, Name), Spec, Term) -->
1082 { ctype_decl(Spec, Decl),
1083 ctype_decl_suff(Spec, Suff)
1084 },
1085 ( {SubType = union}
1086 ->{get_type_name(Term, TName)},
1087 [" "+Decl+" "+TName+Suff+";"]
1088 ; ["typedef "+Decl+" "+Name+Suff+";"],
1089 declare_getset_macros(Spec, Name)
1090 ).
1091declare_struct(func_ini(SubType, Spec), Term, _) -->
1092 ( {SubType = union,
1093 atom(Term)
1094 }
1095 ->[]
1096 ; ( {SubType = union}
1097 ->{Decl = " struct"}
1098 ; {ctype_ini(Spec, Decl)}
1099 ),
1100 [Decl+" {"]
1101 ).
1102declare_struct(func_end(SubType, Spec), Term, _) -->
1103 ( {SubType = union,
1104 atom(Term)
1105 }
1106 ->[]
1107 ; ( {SubType = union}
1108 ->{enum_suff(Term, TName)},
1109 [" } "+TName+";"]
1110 ; {ctype_end(Spec, Decl)},
1111 ["}"+Decl+";"]
1112 )
1113 ).
1114declare_struct(func_rec(_, _, _, _), Spec, Name) -->
1115 { ctype_decl(Spec, Decl),
1116 ctype_suff(Spec, Suff)
1117 },
1118 [" "+Decl+" "+Name+Suff+";"].
1120declare_struct(dict_ini(_, _, _, _), Spec, _) -->
1121 {ctype_ini(Spec, Decl)},
1122 ["",
1123 Decl+" {"].
1124declare_struct(dict_key_value(Dict, Desc, N, _), Key, Value) -->
1125 {key_value_from_desc(Dict, Desc, N, Key, Value)}.
1126declare_struct(dict_rec(_, _, _, _, _), Spec, Name) -->
1127 { ctype_decl(Spec, Decl),
1128 ctype_suff(Spec, Suff)
1129 },
1130 [" "+Decl+" "+Name+Suff+";"].
1131declare_struct(dict_end(_, _, _), Spec, _) -->
1132 {ctype_end(Spec, Decl)},
1133 ["}"+Decl+";"].
1134
1135declare_type_union_ini(union, Opt, Name, Spec) --> declare_type(Opt, Name, Spec).
1136declare_type_union_ini(enum, Opt, Name, Spec) --> declare_type(Opt, Name, Spec).
1137declare_type_union_ini(cdef, _, _, _) --> [].
1138declare_type_union_ini(struct, _, _, _) --> [].
1139
1140declare_type(Opt, Data, Type, Name) --> declare_type_(Data, Opt, Type, Name).
1141
1143declare_type_(atomic(SubType, Name), Opt, Spec, _) -->
1144 ( {SubType = union}
1145 ->[]
1146 ; declare_type(Opt, Name, Spec)
1147 ).
1148declare_type_(union_ini(SubType, Spec, _), Opt, _, Name) -->
1149 declare_type_union_ini(SubType, Opt, Name, Spec).
1150declare_type_(union_end(_, _), _, _, _) --> [].
1151declare_type_(func_ini(SubType, Spec), Opt, _, Name) -->
1152 ( {SubType = union}
1153 ->[]
1154 ; declare_type(Opt, Name, Spec)
1155 ).
1156declare_type_(func_end(_, _), _, _, _) --> [].
1157declare_type_(func_rec(_, _, _, _), _, _, _) --> [].
1158declare_type_(dict_ini(_, Name, M, _), _, _, _) -->
1159 ["predicate_t __"+M+"_aux_keyid_index_"+Name+";"].
1160declare_type_(dict_end(_, _, _), _, _, _) --> [].
1161declare_type_(dict_rec(_, _, _, _, _), _, _, _) --> [].
1162
1163declare_type(gett, Name, Spec) -->
1164 ( {member(Spec, [ntype(_, Type), tdef(Type, _)])}
1165 ->["#define FI_get_"+Name+"(__root, __term, __value) FI_get_"+Type+"(__root, __term, __value)"]
1166 ; { ( memberchk(Spec, [array(_, _), setof(_, _, _, _)])
1167 ->Decl = Name
1168 ; Decl = Name+"*"
1169 )
1170 },
1171 ["int FI_get_"+Name+"(root_t __root, term_t, "+Decl+");"]
1172 ).
1173declare_type(unif, Name, Spec) -->
1174 ( {member(Spec, [ntype(_, Type), tdef(Type, _)])}
1175 ->["#define FI_unify_"+Name+"(__term, __value) FI_unify_"+Type+"(__term, __value)"]
1176 ; { ( \+ref_type(Spec)
1177 ->DRef = Name
1178 ; DRef = Name+"*"
1179 )
1180 },
1181 ["int FI_unify_"+Name+"(term_t, "+DRef+" const);"]
1182 ).
1183
1184generate_aux_clauses(Module) -->
1185 findall_tp(Module, type_props, generate_aux_clauses).
1186
1189generate_aux_clauses(dict_ini(_, Name, _, _), _, _) -->
1190 !,
1191 {atom_concat('__aux_keyid_index_', Name, F)},
1192 [(:- public F/2)].
1193generate_aux_clauses(dict_key_value(Dict, _, N, _), Key, Value) -->
1194 !,
1195 {key_value_from_dict(Dict, N, Key, Value)}.
1196generate_aux_clauses(dict_rec(_, _, _, N, Name), _, Key) -->
1197 !,
1198 { atom_concat('__aux_keyid_index_', Name, F),
1199 Pred =.. [F, Key, N]
1200 },
1201 [(Pred :- true)].
1202generate_aux_clauses(_, _, _) --> [].
1203
1204:- multifile
1205 prolog:message//1. 1206
1207prolog:message(ignored_type(Name, Arg)) -->
1208 ["~w->~w ignored"-[Name, Arg]].
1209
1210prolog:message(failed_binding(TypeComponents)) -->
1211 ["~w failed"-[TypeComponents]].
1212
1213:- meta_predicate type_components(+,+,5,+,?,?). 1214
1215type_components(M, TypePropLDictL, Call, Loc) -->
1216 foldl(type_components_1(M, Call, Loc), TypePropLDictL).
1217
1218fix_reserved_name(if, '_if').
1219
1220get_type_name(Type, Name) :-
1221 functor(Type, Name1, _),
1222 ( fix_reserved_name(Name1, Name)
1223 ->true
1224 ; Name = Name1
1225 ).
1226
1227type_components_1(M, Call, Loc, Type-TypePropLDictL) -->
1228 { get_type_name(Type, Name),
1229 ( TypePropLDictL = [t(_, [], _, _)]
1230 ->SubType = cdef,
1231 Spec = cdef(Name)
1232 ; forall(member(t(Type, PropL, _, _), TypePropLDictL), PropL = [])
1233 ->SubType = enum,
1234 length(TypePropLDictL, N),
1235 Spec = enum(Name, N)
1236 ; Spec = struct(Name),
1237 ( TypePropLDictL = [_, _|_]
1238 ->SubType = union,
1239 ISpec = struct(Name)
1240 ; SubType = struct,
1241 ISpec = Spec
1242 )
1243 )
1244 },
1245 { nb_setval('$recursive', fail),
1246 nb_setval('$type_name', Name)
1247 },
1248 [UnionIni],
1249 foldl(type_components_one(M, SubType, ISpec, Name, Call, Loc), TypePropLDictL),
1250 {phrase(call(Call, union_ini(SubType, Spec, TypePropLDictL), Type, Name), UnionIni)},
1251 call(Call, union_end(SubType, Spec), Type, Name),
1252 { nb_setval('$recursive', fail),
1253 nb_setval('$type_name', $$$$)
1254 }.
1255
1256type_components_one(M, SubType, TSpec, Name, Call, Loc, t(Type, PropL, _, _)) -->
1257 { functor(Type, _, Arity),
1258 arg(Arity, Type, Term)
1259 },
1260 ( { PropL = [],
1261 SubType \= union
1262 }
1263 ->[]
1264 ; { compound(Term)
1265 ; atom(Term),
1266 SubType = union
1267 }
1268 ->[FuncIni],
1269 ( {compound(Term)}
1270 ->findall(Lines,
1271 ( arg(N, Term, Arg),
1272 phrase(( { member(Prop, PropL),
1273 match_known_type(Prop, M, Name, Spec, Arg)
1274 },
1275 call(Call, func_rec(SubType, N, Term, Name), Spec, Arg)
1276 ->[]
1277 ; {print_message(
1278 warning,
1279 at_location(Loc, ignored_type(func(Name), Arg)))}
1280 ), Lines)
1281 ))
1282 ; { atom(Term),
1283 SubType = union,
1284 PropL = [Prop]
1285 }
1286 ->( { match_known_type(Prop, M, Name, Spec, Arg)
1287 },
1288 call(Call, func_rec(union_type, 1, Term, Name), Spec, Arg)
1289 ->[]
1290 ; {print_message(
1291 warning,
1292 at_location(Loc, ignored_type(func(Name), _)))}
1293 )
1294 ; []
1295 ),
1296 {phrase(call(Call, func_ini(SubType, TSpec), Term, Name), FuncIni)},
1297 call(Call, func_end(SubType, TSpec), Term, Name)
1298 ; { select(dict_t(Desc, Term), PropL, PropL1)
1299 ; select(dict_t(Tag, Desc, Term), PropL, PropL1)
1300 ; select(dict_join_t(Tag, Type1, Type2, Term), PropL, PropL1),
1301 join_dict_types(Type1, M, Type2, M, Tag, Desc)
1302 ; select(dict_extend_t(Term, Type, Tag, Desc2), PropL, PropL1),
1303 join_type_desc(M:Type, Tag, Desc2, Desc)
1304 }
1305 ->{ is_dict(Desc, Tag)
1306 ->Dict=Desc
1307 ; dict_create(Dict, Tag, Desc)
1308 },
1309 {ignore(Tag = Name)},
1310 call(Call, dict_ini(SubType, Name, M, Dict), TSpec, Term),
1311 findall(Lines,
1312 phrase(( call(Call, dict_key_value(Dict, Desc, N, Name), Arg, Value),
1313 ( { fetch_kv_prop_arg(Arg, M, Value, PropL1, Prop),
1314 match_known_type(Prop, M, Name, Spec, Arg)
1315 },
1316 call(Call, dict_rec(SubType, M, Term, N, Name), Spec, Arg)
1317 ->[]
1318 ; {print_message(
1319 warning,
1320 at_location(Loc, ignored_type(dict(Name), Arg)))}
1321 )), Lines)),
1322 call(Call, dict_end(SubType, M, Tag), TSpec, Term)
1323 ; { member(Prop, PropL),
1324 match_known_type(Prop, M, Name, Spec, Term)
1325 }
1326 ->call(Call, atomic(SubType, Name), Spec, Term)
1327 ),
1328 !.
1329type_components_one(M, ST, TS, N, G, Loc, T) -->
1330 {print_message(
1331 error,
1332 at_location(
1333 Loc,
1334 failed_binding(type_components_one(M, ST, TS, N, G, Loc, T))))}.
1335
1336key_value_from_dict(Dict, N, Key, Value) :-
1337 S = s(0),
1338 Value=Dict.Key,
1339 S = s(N),
1340 succ(N, N2),
1341 nb_setarg(1, S, N2).
1342
1343key_value_from_list(Desc, N, Key, Value) :-
1344 nth0(N, Desc, KeyValue),
1345 key_value(KeyValue, Key, Value).
1346
1347key_value_from_desc(_, Desc, N, Key, Value) :-
1348 is_list(Desc), !,
1349 key_value_from_list(Desc, N, Key, Value).
1350key_value_from_desc(Dict, _, N, Key, Value) :-
1351 key_value_from_dict(Dict, N, Key, Value).
1352
1353fetch_kv_prop_arg(Key, CM, Value, PropL, M:Prop) :-
1354 ( member(MProp, PropL),
1355 strip_module(CM:MProp, M, Prop),
1356 functor(Prop, _, N),
1357 arg(N, Prop, Key)
1358 ; extend_args(Value, [Key], Prop),
1359 M=CM
1360 ).
1361
1362declare_intf_head(PCN, Head, "foreign_t __aux_pfa_"+PCN+"_"+N+"(term_t __args)") :-
1363 max_fli_args(MaxFLIArgs),
1364 functor(Head, _, N),
1365 N > MaxFLIArgs,
1366 !.
1367declare_intf_head(PCN, Head, "foreign_t "+PCN+"("+TxtL/", "+")") :-
1368 findall("term_t "+Arg,
1369 ( compound(Head),
1370 arg(_, Head, Arg)
1371 ), TxtL).
1372
1373declare_foreign_bind(CM) -->
1374 findall(Line+";",
1375 ( read_foreign_properties(Head, M, CM, Comp, Call, Succ, Glob, Bind, Type),
1376 \+ ( Type = foreign(Opts, _),
1377 nmember(lang(native), Opts)
1378 ),
1379 declare_impl_head(Type, Head, M, CM, Comp, Call, Succ, Glob, Bind, Line)
1380 )).
1381
1382declare_impl_head(foreign(Opts, _), Head, _, _, _, _, _, _, Bind, IntfHead) :-
1383 nmember(lang(native), Opts),
1384 !,
1385 Bind = (FN/_ as _/_ + _),
1386 declare_intf_head(FN, Head, IntfHead).
1387declare_impl_head(_, Head, M, CM, Comp, Call, Succ, Glob, (CN/_ as _ + _), Type+FHD) :-
1388 nonvar(CN),
1389 ( member(RS, [returns_state(_), type(_)]),
1390 memberchk(RS, Glob)
1391 ->Type = "int ", 1392 CHead = Head
1393 ; member(returns(Var, _), Glob)
1394 ->bind_argument(Head, M, CM, Comp, Call, Succ, Glob, Var, Spec, Mode),
1395 ctype_arg_decl(Spec, Mode, Decl),
1396 Type = Decl+" ",
1397 Head =.. [F|Args],
1398 once(select(Var, Args, CArgs)),
1399 CHead =.. [F|CArgs]
1400 ; Type = "void ",
1401 CHead = Head
1402 ),
1403 declare_foreign_head(CHead, M, CM, Comp, Call, Succ, Glob, CN, FHD),
1404 !.
1405
1406declare_foreign_head(Head, M, CM, Comp, Call, Succ, Glob, CN, CN+"("+ArgL/", "+")") :-
1407 phrase(( ( {memberchk(memory_root(_), Glob)}
1408 ->["root_t __root"]
1409 ; []
1410 ),
1411 findall(
1412 Line,
1413 distinct(
1414 Key,
1415 ( compound(Head),
1416 arg(_, Head, Arg),
1417 bind_argument(Head, M, CM, Comp, Call, Succ, Glob, Arg, Spec, Mode),
1418 curr_arg_decl(Arg, Spec, Mode, Key, Line)
1419 )))
1420 ), ArgL).
1421
(array(Spec, Dim), Key, Line) :-
1423 ( \+ integer(Dim),
1424 curr_arg_decl(Dim, ntype(size_t, size_t), in, Key, Line)
1425 ; extra_arg_decl(Spec, Key, Line)
1426 ).
1427
1428curr_arg_decl(_, Spec, Mode, Key, Line) :-
1429 memberchk(Mode, [in, inout]),
1430 extra_arg_decl(Spec, Key, Line).
1431curr_arg_decl(Arg, Spec, Mode, Arg, Decl+" "+Arg+Suff) :-
1432 ctype_barg_decl(Spec, Mode, Decl),
1433 ctype_barg_suff(Spec, Suff).
1434
1435ctype_barg_decl(Spec, Mode, Decl) :-
1436 ctype_barg_decl(Spec, Mode, Codes, []),
1437 atom_codes(Decl, Codes).
1438
1439ctype_barg_suff(Spec, Suff) :-
1440 ctype_suff(Spec, Codes, []),
1441 atom_codes(Suff, Codes).
1442
1443ctype_barg_decl(Spec, Mode) -->
1444 ctype_arg_decl(Spec, Mode),
1445 ({ Mode = in,
1446 \+ ref_type(Spec)
1447 ; Spec = array(_, _)
1448 } -> []
1449 ; "*"
1450 ),
1451 ( {Mode = in} 1452 ->" const"
1453 ; []
1454 ).
1455
1456ctype_arg_decl(setof(Name, _, _, _), Mode) -->
1457 !,
1458 acodes(Name),
1459 ({member(Mode, [in, out])} -> [] ; "*").
1460ctype_arg_decl(Spec, Mode) -->
1461 ctype_decl(Spec),
1462 ({is_ref(Spec, Mode)} -> [] ; "*").
1463
1464ctype_arg_decl(Spec, Mode, Decl) :-
1465 ctype_arg_decl(Spec, Mode, Codes, []),
1466 atom_codes(Decl, Codes).
1467
1468ctype_suff(array(Spec, Dim), CDim) --> !, "[", call(CDim, Dim), "]", ctype_suff(Spec, CDim).
1469ctype_suff(_, _) --> "".
1470
1471ctype_suff(Spec) --> ctype_suff(Spec, acodes).
1472
1473is_ref(term, _) :- !.
1474is_ref(list(_), _) :- !. 1475is_ref(ptr(_), _) :- !. 1476is_ref(chrs(_), _) :- !.
1477is_ref(string(_), _) :- !.
1478is_ref(array(_, _), _) :- !.
1479is_ref(_, in).
1480is_ref(_, out).
1484
1486ref_type(struct(_)).
1487ref_type(tdef(_, Spec)) :- ref_type(Spec).
1488
1489ctype_ini(struct(CType)) --> \+ {nb_current('$recursive', true)}, !, "typedef struct ", acodes(CType).
1491ctype_ini(struct(CType)) --> "typedef struct __", acodes(CType), " ", acodes(CType), ";\n",
1492 "struct __", acodes(CType).
1493ctype_ini(enum(_, _)) --> "typedef enum".
1494ctype_ini(cdef(_)) --> "".
1495
1496ctype_end(struct(CType)) --> \+ {nb_current('$recursive', true)}, !, " ", acodes(CType).
1497ctype_end(struct(_)) --> "".
1498ctype_end(enum(CType, _)) --> " ", acodes(CType).
1499ctype_end(cdef(CType)) --> " ", acodes(CType).
1500
1501ctype_decl(struct(CType)) --> acodes(CType).
1502ctype_decl(list(Spec)) --> ctype_decl(Spec), "*".
1503ctype_decl(array(Spec, _)) --> ctype_decl(Spec).
1504ctype_decl(ptr(Spec)) --> ctype_decl(Spec), "*".
1505ctype_decl(chrs(CType)) --> acodes(CType).
1506ctype_decl(string(CType)) --> acodes(CType).
1507ctype_decl(enum(CType, _)) --> acodes(CType).
1508ctype_decl(term) --> "term_t".
1509ctype_decl(tdef(CType, _)) --> acodes(CType).
1510ctype_decl(setof(_, CType, _, _)) --> acodes(CType).
1511ctype_decl(cdef(CType)) --> acodes(CType).
1512ctype_decl(ntype(CType, _)) --> acodes(CType).
1513
1514ctype_ini(Spec, Decl) :- phrase(ctype_ini(Spec), Codes), atom_codes(Decl, Codes).
1515ctype_end(Spec, Decl) :- phrase(ctype_end(Spec), Codes), atom_codes(Decl, Codes).
1516
1517ctype_decl(Spec, Decl) :-
1518 ctype_decl(Spec, Codes, []),
1519 atom_codes(Decl, Codes).
1520
1521ctype_suff(Spec, Suff) :-
1522 ctype_suff(Spec, Codes, []),
1523 atom_codes(Suff, Codes).
1524
1525acodes(Atom, List, Tail) :-
1526 atom_codes(Atom, Codes),
1527 append(Codes, Tail, List).
1528
1529cond_qualify_with(CM, MProp1, MProp) :-
1530 strip_module(CM:MProp1, M, Prop),
1531 ( CM = M
1532 ->MProp = Prop
1533 ; MProp = M:Prop
1534 ).
1535
1536:- meta_predicate collect(?,^,-). 1537collect(Tmpl, Goal, List) :-
1538 (bagof(Tmpl, Goal, List) *-> true ; List = []).
1539
1540collect_props(Asr, CM, CompL, CallL, SuccL, GlobL) :-
1541 maplist(collect_prop(Asr, CM),
1542 [comp, call, succ, glob],
1543 [CompL, CallL, SuccL, GlobL]).
1544
1545collect_prop(Asr, CM, Part, PropL) :-
1546 collect(MProp,
1547 (M, Prop, From)^( curr_prop_asr(Part, M:Prop, From, Asr),
1548 ( M \= CM
1549 ->MProp = M:Prop
1550 ; MProp = Prop
1551 )
1552 ), PropL).
1553
1554assertion_db(Asr, Head, M, CM, Status, Type, Comp, Call, Succ, Glob, Dict) :-
1555 asr_head_prop(Asr, HM, Head, Status, Type, Dict, CM, _Loc),
1556 predicate_property(HM:Head, implementation_module(M)),
1557 collect_props(Asr, CM, Comp, Call, Succ, Glob).
1558
1559current_foreign_prop(Head, Module, Context, CompL, CallL, SuccL, GlobL,
1560 DictL, FuncName, PredName, BindName, Arity, NKeyProp) :-
1561 current_foreign_prop(Head, Module, Type, Context, NKeyProp),
1562 findall(Head-[MComp, MCall, MSucc, MGlob, Dict],
1563 ( assertion_db(_, Head, Module, CM, check, Type, Comp, Call, Succ, Glob, Dict),
1564 maplist(maplist(cond_qualify_with(CM)),
1565 [ Comp, Call, Succ, Glob],
1566 [MComp, MCall, MSucc, MGlob])
1567 ), KPropLL),
1568 maplist(=(Head-_), KPropLL),
1569 pairs_values(KPropLL, PropLL),
1570 transpose(PropLL, PropTL),
1571 maplist(append, PropTL, [CompU, CallU, SuccU, GlobU, DictL]),
1572 maplist(sort, [CompU, CallU, SuccU, GlobU], [CompL, CallL, SuccL, GlobL]),
1573 functor(Head, PredName, Arity),
1574 ( member(FGlob, GlobL),
1575 normalize_ftype(FGlob, foreign(FuncSpecs, _)),
1576 nmember(FuncSpec, FuncSpecs),
1577 resolve_name(FuncSpec, PredName, FuncName)
1578 ->true
1579 ; true
1580 ),
1581 ( ( member(NGlob, GlobL),
1582 normalize_ftype(NGlob, native(BindSpecs, _)),
1583 nmember(BindSpec, BindSpecs),
1584 Name = PredName
1585 ; nonvar(FuncName),
1586 BindSpec = prefix(pl_),
1587 Name = FuncName
1588 ),
1589 resolve_name(BindSpec, Name, BindName)
1590 ->true
1591 ).
1592
1593current_foreign_prop(Head, Module, Type, Context, NKeyProp) :-
1594 asr_head_prop(Asr, HM, Head, check, Type, _, Context, _),
1595 memberchk(Type, [pred, prop]),
1596 predicate_property(HM:Head, implementation_module(Module)),
1597 once(( normalize_ftype(KeyProp, NKeyProp),
1598 prop_asr(glob, KeyProp, _, Asr)
1599 )).
1600
1601resolve_name(BindName, _, BindName) :- atom(BindName), !.
1602resolve_name(name(BindName), _, BindName).
1603resolve_name(prefix(Prefix), PredName, BindName) :- atom_concat(Prefix, PredName, BindName).
1604resolve_name(suffix(Suffix), PredName, BindName) :- atom_concat(PredName, Suffix, BindName).
1605
1606read_foreign_properties(Head, M, CM, Comp, Call, Succ, Glob, CN/A as PN/BN + CheckMode, T) :-
1607 current_foreign_prop(Head, M, CM, Comp, Call, Succ, Glob, Dict, CN, PN, BN, A, T),
1608 ( memberchk(type(_), Glob)
1609 ->CheckMode=(type)
1610 ; CheckMode=pred
1611 ),
1612 apply_dict(Head, Dict).
1613
1614generate_foreign_intf(CM) -->
1615 findall(Lines,
1616 ( read_foreign_properties(Head, M, CM, Comp, Call, Succ, Glob, Bind, Type),
1617 declare_impl_head(Type, Head, M, CM, Comp, Call, Succ, Glob, Bind, ImplHead),
1618 phrase(declare_intf_impl(Type, Head, M, CM, Comp, Call, Succ, Glob, Bind, ImplHead),
1619 Lines))).
1620
1621declare_intf_impl(foreign(Opts, _), Head, M, Module, Comp, Call, Succ, Glob, Bind, ImplHead) -->
1622 { nmember(lang(Lang), Opts),
1623 lang(Lang)
1624 },
1625 !,
1626 declare_fimp_impl(Lang, Head, M, Module, Comp, Call, Succ, Glob, Bind, ImplHead).
1627declare_intf_impl(_, Head, M, Module, Comp, Call, Succ, Glob, Bind, ImplHead) -->
1628 declare_forg_impl(Head, M, Module, Comp, Call, Succ, Glob, Bind, ImplHead).
1629
1630declare_fimp_impl(prolog, Head, M, CM, Comp, Call, Succ, Glob, Bind, ImplHead) -->
1631 { Bind = (_/A as PN/BN + _),
1632 declare_intf_fimp_head(BN, BNHead)
1633 },
1634 [BNHead+"=NULL;"],
1635 [ImplHead+" {",
1636 " term_t "+BN+"_args = PL_new_term_refs("+A+");"],
1637 ( {memberchk(parent(Var, _), Glob)}
1638 ->[" __leaf_t *__root = LF_ROOT(LF_PTR(FI_array_ptr("+Var+")));"]
1639 ; []
1640 ),
1641 bind_outs_arguments(Head, M, CM, Comp, Call, Succ, Glob, Bind),
1642 ["} /* "+PN/A+" */",
1643 ""].
1644declare_fimp_impl(native, Head, _, CM, _, _, _, Glob, Bind, ImplHead) -->
1645 { Bind = (FN/A as _/BN + _),
1646 declare_intf_fimp_head(BN, BNHead)
1647 },
1648 [BNHead+"=NULL;"],
1649 [ImplHead+" {",
1650 " term_t "+BN+"_args = PL_new_term_refs("+A+");"],
1651 findall([" __rtcheck(PL_unify_arg("+Idx+","+BN+"_args,"+Arg+"));"], arg(Idx, Head, Arg)),
1652 bind_call_predicate(CM, Glob, BN),
1653 ["} /* "+FN/A+" */",
1654 ""].
1655
1656bind_call_predicate(CM, Glob, BN) -->
1657 {CallPred = "PL_call_predicate(__"+CM+", PL_Q_NORMAL, "+BN+", "+BN+"_args)"},
1658 ( { member(RS, [returns_state(_), type(_)]),
1659 memberchk(RS, Glob)
1660 }
1661 ->[" int __result = "+CallPred+";"]
1662 ; [" __rtcwarn("+CallPred+");"]
1663 ).
1664
1665declare_forg_impl(Head, M, Module, Comp, Call, Succ, Glob, Bind, _ImplHead) -->
1666 { max_fli_args(MaxFLIArgs),
1667 neck,
1668 Bind = (PI as _/PCN + CheckMode),
1669 declare_intf_head(PCN, Head, PCNH)
1670 },
1671 [PCNH+" {"],
1672 ( { functor(Head, _, Arity),
1673 Arity > MaxFLIArgs
1674 }
1675 ->findall([" term_t "+Arg+" = PL_new_term_ref();",
1676 " __rtcheck(PL_get_arg("+N+", __args, "+Arg+"));"],
1677 arg(N, Head, Arg))
1678 ; []
1679 ),
1680 1681 findall(" if(PL_is_variable("+Arg+")) return TRUE;",
1682 ( CheckMode==(type),
1683 arg(_, Head, Arg)
1684 )),
1685 [" __mkroot(__root);"],
1686 bind_arguments(Head, M, Module, Comp, Call, Succ, Glob, Bind, Return),
1687 [" __delroot(__root);",
1688 " return "+Return+";",
1689 "} /* "+PI+" */",
1690 ""].
1691
1692enum_name(enum(Name, _), Name).
1693
1694c_get_argument(T, M, C, A, L) :- c_argument(T, get, M, C, A, L).
1695
1696c_set_argument(T, M, C, A, L) :- c_argument(T, set, M, C, A, L).
1697
1698c_argument(list(S), G, M, C, A, L) :- c_argument_rec(G, M, list, S, C, A, L).
1699c_argument(array(S, D), G, _, C, A, L) :- c_argument_array(G, S, D, C, A, L).
1700c_argument(ptr(S), G, M, C, A, L) :- c_argument_rec(G, M, ptr, S, C, A, L).
1701c_argument(struct(T), G, M, C, A, L) :- c_argument_type(G, M, T, C, A, L).
1702c_argument(enum(T, _), G, M, C, A, L) :- c_argument_one(G, M, T, C, A, L).
1703c_argument(cdef(T), G, M, C, A, L) :- c_argument_one(G, M, T, C, A, L).
1704c_argument(ntype(_, T), G, M, C, A, L) :- c_argument_one(G, M, T, C, A, L).
1705c_argument(chrs(_), G, M, C, A, L) :- c_argument_chrs(G, M, C, A, L).
1706c_argument(string(_), G, M, C, A, L) :- c_argument_string(G, M, C, A, L).
1707c_argument(tdef(T, _), G, M, C, A, L) :- c_argument_one(G, M, T, C, A, L).
1708c_argument(setof(_, _, S, D), G, M, C, A, L) :- c_argument_setof(G, M, S, D, C, A, L).
1709c_argument(term, G, _, C, A, L) :- c_argument_term(G, C, A, L).
1710
1711getset_smode(get, in).
1712getset_smode(set, out).
1713
1714getset_unify(get, get).
1715getset_unify(set, unify).
1716
1717c_argument_rec(GetSet, Mode, Type, Spec, CArg, Arg, L) :-
1718 Arg_ = Arg+"_",
1719 c_var_name(Arg_, CArg_),
1720 getset_smode(GetSet, SMode),
1721 getset_unify(GetSet, Unify),
1722 c_argument(Spec, GetSet, SMode, CArg_, Arg_, L1),
1723 c_argument_rec_2(GetSet, Unify, Mode, Type, CArg, Arg, L1, L).
1724
1725c_argument_rec_2(get, Unify, Mode, Type, CArg, Arg, L1, "FI_"+Unify+"_"+Mode+"_"+Type+"("+L1+", "+Arg+", "+CArg+")").
1726c_argument_rec_2(set, Unify, _, Type, CArg, Arg, L1, "FI_"+Unify+"_" +Type+"("+L1+", "+Arg+", "+CArg+")").
1727
1728c_argument_array(GetSet, Spec, Dim, CArg, Arg, "FI_"+Unify+"_array("+L+", "+CDim+", "+Arg+")") :-
1729 Arg_ = Arg+"_",
1730 c_var_name(Arg_, CArg_),
1731 c_dim(Dim, CDim),
1732 getset_smode(GetSet, SMode),
1733 getset_unify(GetSet, Unify),
1734 c_argument(Spec, GetSet, SMode, CArg+"["+CArg_+"]", Arg_, L).
1735
1736c_argument_type(G, M, T, C, A, L) :-
1737 getset_unify(G, U),
1738 c_argument_type_2(M, U, T, C, A, L).
1739
1740c_argument_type_2(in, Unify, Type, CArg, Arg, "__rtc_FI_"+Unify+"("+Type+", "+Arg+", "+CArg+")").
1741c_argument_type_2(out, Unify, Type, CArg, Arg, "__rtc_FI_"+Unify+"("+Type+", "+Arg+", &"+CArg+")").
1742c_argument_type_2(inout, Unify, Type, CArg, Arg, "FI_"+Unify+"_inout_type("+Type+", "+Arg+", "+CArg+")").
1743
1744c_argument_one(G, M, T, C, A, L) :-
1745 getset_unify(G, U),
1746 c_argument_one_2(M, U, T, C, A, L).
1747
1748c_argument_one_2(in, Unify, Type, CArg, Arg, "__rtc_FI_"+Unify+"("+Type+", "+Arg+", "+CArg+")").
1749c_argument_one_2(out, Unify, Type, CArg, Arg, "__rtc_FI_"+Unify+"("+Type+", "+Arg+", "+CArg+")").
1750c_argument_one_2(inout, Unify, Type, CArg, Arg, "FI_"+Unify+"_inout("+Type+", "+Arg+", "+CArg+")").
1751
1752c_argument_chrs(G, M, C, A, L) :-
1753 getset_unify(G, U),
1754 c_argument_chrs_2(M, U, C, A, L).
1755
1756c_argument_chrs_2(in, Unify, CArg, Arg, "__rtc_FI_"+Unify+"(chrs, "+Arg+", "+CArg+")").
1757c_argument_chrs_2(out, Unify, CArg, Arg, "__rtc_FI_"+Unify+"(chrs, "+Arg+", "+CArg+")").
1758c_argument_chrs_2(inout, Unify, CArg, Arg, "FI_"+Unify+"_inout_chrs(" +Arg+", "+CArg+")").
1759
1760c_argument_string(G, M, C, A, L) :-
1761 getset_unify(G, U),
1762 c_argument_string_2(M, U, C, A, L).
1763
1764c_argument_string_2(in, Unify, CArg, Arg, "__rtc_FI_"+Unify+"(string, "+Arg+", "+CArg+")").
1765c_argument_string_2(out, Unify, CArg, Arg, "__rtc_FI_"+Unify+"(string, "+Arg+", "+CArg+")").
1766c_argument_string_2(inout, Unify, CArg, Arg, "FI_"+Unify+"_inout_string(" +Arg+", "+CArg+")").
1767
1768c_argument_setof(GetSet, Mode, Spec, Dim, CArg, Arg, "FI_"+Unify+"_"+Mode+"_setof("+L+", "+Type+", "+Mult+", "+Dim+", "+Name+", "+Arg+", "+CArg+")") :-
1769 Arg_ = Arg+"_",
1770 c_var_name(Arg_, CArg_),
1771 ctype_decl(Spec, Type),
1772 enum_name(Spec, Name),
1773 c_dim_mult(Dim, Mult),
1774 getset_unify(GetSet, Unify),
1775 getset_smode(GetSet, SMode),
1776 c_argument(Spec, GetSet, SMode, CArg_, Arg_, L).
1777
1778c_argument_term(get, C, A, "*"+C+"=PL_copy_term_ref("+A+")").
1779c_argument_term(set, C, A, "__rtcheck(PL_unify("+A+", "+C+"))").
1780
1781c_dim_mult(1, single) :- !.
1782c_dim_mult(_, vector).
1783
1784c_dim(Dim) --> {integer(Dim)}, !, acodes(Dim).
1785c_dim(Dim) --> "_c_", acodes(Dim).
1786
1787c_dim(Dim, CDim) :-
1788 c_dim(Dim, Codes, []),
1789 atom_codes(CDim, Codes).
1790
1791ctype_c_suff(Spec) --> ctype_suff(Spec, c_dim).
1792
1793ctype_c_suff(Spec, Suff) :-
1794 ctype_c_suff(Spec, Codes, []),
1795 atom_codes(Suff, Codes).
1796
(array(Spec, Dim), Head, Arg, Key, Line) :-
1798 ( \+ integer(Dim),
1799 curr_bind_line(dim(Arg), Head, Dim, ntype(size_t, size_t), in, Key, Line)
1800 ; extra_var_def(Spec, Head, Arg+"_"+Dim, Key, Line)
1801 ).
1802
1803curr_bind_line(arg, Head, Arg, Spec, Mode, Key, Line) :-
1804 memberchk(Mode, [in, inout]),
1805 extra_var_def(Spec, Head, Arg, Key, Line).
1806curr_bind_line(_, _, Arg, Spec, Mode, dec(Arg), Line) :-
1807 ctype_arg_decl(Spec, Mode, Decl),
1808 c_var_name(Arg, CArg),
1809 ( Spec = term
1810 ->DN=" "+CArg+"=PL_new_term_ref();"
1811 ; ctype_c_suff(Spec, CSuff),
1812 DN=" "+CArg+CSuff+";"
1813 ),
1814 Line = " "+Decl+DN.
1815curr_bind_line(arg, _, Arg, Spec, Mode, def(Arg), Line) :-
1816 memberchk(Mode, [in, inout]),
1817 c_var_name(Arg, CArg1),
1818 ( member(Spec, [setof(_, _, _, _)])
1819 ->CArg = CArg1
1820 ; CArg = "&"+CArg1
1821 ),
1822 c_get_argument(Spec, Mode, CArg, Arg, GetArg),
1823 Line = [" "+GetArg+";"].
1824curr_bind_line(dim(Arg), Head, Dim, _, _, def(CDim1), LineL) :-
1825 \+ arg(_, Head, Dim),
1826 c_var_name(Dim, CDim1),
1827 CDim = "&"+CDim1,
1828 Line = " FI_get_dim("+Arg+", "+CDim+");",
1829 ( arg(_, Head, Arg)
1830 ->LineL = [Line]
1831 ; Arg = Arg2+"_"+_,
1832 LineL = [" term_t "+Arg+"=PL_new_term_ref();",
1833 " __rtcheck(PL_get_arg(1, "+Arg2+", "+Arg+"));",
1834 Line]
1835 ).
1836
1837bind_arguments(Head, M, CM, Comp, Call, Succ, Glob, Bind, Return) -->
1838 ( {compound(Head)}
1839 ->findall(Line,
1840 distinct(
1841 Key, 1842 ( arg(_, Head, Arg),
1843 bind_argument(Head, M, CM, Comp, Call, Succ, Glob, Arg, Spec, Mode),
1844 curr_bind_line(arg, Head, Arg, Spec, Mode, Key, Line)
1845 )
1846 ))
1847 ; []
1848 ),
1849 {generate_foreign_call(Bind-Head, M, CM, Comp, Call, Succ, Glob, Return, ForeignCall)},
1850 [ForeignCall],
1851 ( {compound(Head)}
1852 ->findall(" "+SetArg+";",
1853 ( arg(_, Head, Arg),
1854 bind_argument(Head, M, CM, Comp, Call, Succ, Glob, Arg, Spec, Mode),
1855 memberchk(Mode, [out, inout]),
1856 c_var_name(Arg, CArg),
1857 c_set_argument(Spec, Mode, CArg, Arg, SetArg)
1858 ))
1859 ; []
1860 ).
1861
1862invert_mode(in, out).
1863invert_mode(out, in).
1864invert_mode(inout, inout).
1865
1866bind_outs_arguments(Head, M, CM, Comp, Call, Succ, Glob, (_ as _/BN +_)) -->
1867 findall(" "+Decl+Line,
1868 ( memberchk(returns(Arg, _), Glob)
1869 ->bind_argument(Head, M, CM, Comp, Call, Succ, Glob, Arg, Spec, Mode),
1870 memberchk(Mode, [out, inout]),
1871 ctype_arg_decl(Spec, Mode, Decl),
1872 ( Spec = term
1873 ->Line=" "+Arg+"=PL_new_term_ref();"
1874 ; Line=" "+Arg+";"
1875 )
1876 )),
1877 ( {compound(Head)}
1878 ->findall([" term_t "+PArg+"="+BN+"_args + "+Idx1+";",
1879 " "+SetArg+";"],
1880 ( arg(Idx, Head, Arg),
1881 succ(Idx1, Idx),
1882 bind_argument(Head, M, CM, Comp, Call, Succ, Glob, Arg, Spec, Mode),
1883 memberchk(Mode, [in, inout]),
1884 ( Mode = in,
1885 Spec \= struct(_)
1886 ->CArg = Arg
1887 ; CArg = "*"+Arg
1888 ),
1889 PArg = "_p_"+Arg,
1890 invert_mode(Mode, InvM),
1891 c_set_argument(Spec, InvM, CArg, PArg, SetArg)
1892 ))
1893 ; []
1894 ),
1895 bind_call_predicate(CM, Glob, BN),
1896 ( {compound(Head)}
1897 ->findall(Line,
1898 ( arg(Idx, Head, Arg),
1899 succ(Idx1, Idx),
1900 bind_argument(Head, M, CM, Comp, Call, Succ, Glob, Arg, Spec, Mode),
1901 memberchk(Mode, [out, inout]),
1902 invert_mode(Mode, InvM),
1903 ( memberchk(returns(Arg, _), Glob)
1904 ->CArg = "&"+Arg
1905 ; CArg = Arg
1906 ),
1907 PArg = "_p_"+Arg,
1908 c_get_argument(Spec, InvM, CArg, PArg, SetArg),
1909 ( Mode = out,
1910 Line = " term_t "+PArg+"="+BN+"_args + "+Idx1+";"
1911 ; Line = " "+SetArg+";"
1912 )
1913 )),
1914 ( { memberchk(returns(Arg, _), Glob)
1915 ; memberchk(returns_state(_), Glob),
1916 Arg = "__result"
1917 }
1918 ->[" return "+Arg+";"]
1919 ; []
1920 )
1921 ; []
1922 ).
1923
1924generate_foreign_call((CN/_A as _ + _)-Head1, M, CM, Comp, Call, Succ, Glob, Return,
1925 " "+HLine+CN+"("+MR+LineL/", "+");") :-
1926 ( member(RS, [returns_state(_), type(_)]),
1927 memberchk(RS, Glob)
1928 ->HLine="foreign_t __result=",
1929 Head = Head1,
1930 Return = "__result"
1931 ; ( member(returns(Var, _), Glob)
1932 ->c_var_name(Var, CVar),
1933 HLine=CVar+"=",
1934 Head1 =.. [F|Args],
1935 once(select(Var, Args, CArgs)),
1936 Head =.. [F|CArgs]
1937 ; Head = Head1,
1938 HLine=""
1939 ),
1940 ( member(no_exception, Glob)
1941 ->Return = "TRUE"
1942 ; Return = "!PL_exception(0)"
1943 )
1944 ),
1945 ( memberchk(memory_root(_), Glob)
1946 ->MR="__root, "
1947 ; MR=""
1948 ),
1949 findall(Line,
1950 distinct(Key,
1951 ( compound(Head),
1952 arg(_, Head, Arg),
1953 bind_argument(Head, M, CM, Comp, Call, Succ, Glob, Arg, Spec, Mode),
1954 curr_arg_call(Arg, Spec, Mode, Key-Line)
1955 )
1956 ), LineL).
1957
(array(Spec, Dim), KeyLine) :-
1959 ( \+ integer(Dim),
1960 curr_arg_call(Dim, ntype(size_t, size_t), in, KeyLine)
1961 ; extra_arg_call(Spec, KeyLine)
1962 ).
1963
1964curr_arg_call(_, Spec, Mode, KeyLine) :-
1965 memberchk(Mode, [in, inout]),
1966 extra_arg_call(Spec, KeyLine).
1967curr_arg_call(Arg, Spec, Mode, Arg-(Deref+CArg)) :-
1968 c_var_name(Arg, CArg),
1969 ( ( Mode = in,
1970 \+ ref_type(Spec)
1971 ; Spec = array(_, _)
1972 )
1973 ->Deref = ""
1974 ; Deref = "&"
1975 ).
1976
1977:- use_module(library(sequence_list)). 1978:- use_module(library(prolog_clause), []). 1979
1980get_dictionary(Term, File, Line, M, Dict) :-
1981 ( prolog_clause:read_term_at_line(File, Line, M, RawTerm1, _TermPos, Dict),
1982 ( RawTerm1 \= (_ :- _)
1983 ->RawTerm = (RawTerm1 :- true)
1984 ; RawTerm1 = RawTerm
1985 ),
1986 subsumes(RawTerm, Term) -> true
1987 ; Dict = []
1988 ).
1989
1990match_known_type(Prop, M, Name, Spec, Arg) :-
1991 match_type(Prop, M, known, Name, Spec, Arg, _, _),
1992 ( nb_current('$type_name', TName),
1993 sub_term(TName, Spec)
1994 ->nb_setval('$recursive', true)
1995 ; true
1996 ).
1997
1998match_type(M:Prop, _, K, Name, Spec, Arg) -->
1999 ( match_type(Prop, M, K, Name, Spec, Arg)
2000 ->[]
2001 ).
2002match_type(dict_t(Desc, A), _, _, Name, Spec, A) -->
2003 {is_dict(Desc, Tag)},
2004 !,
2005 match_known_type_dict(dict_t(Desc, A), Tag, A, Name, Spec).
2006match_type(dict_t(Tag, Desc, A), _, _, Name, Spec, A) -->
2007 {dict_create(_, Tag, Desc)},
2008 !,
2009 match_known_type_dict(dict_t(Tag, Desc, A), Tag, A, Name, Spec).
2010match_type(Prop, M, K, N, Spec, A) -->
2011 match_type_k(K, Prop, M, N, Spec, A).
2012
2013match_type_k(known, Prop, M, N, Spec, A) --> match_known_type(Prop, M, N, Spec, A).
2014match_type_k(unknown, _, _, _, _, _) --> [].
2015
2016match_known_type_type(Type, A, M, N, MSpec, A) -->
2017 {extend_args(Type, [A], Prop)},
2018 match_type(Prop, M, known, N, MSpec, A).
2019
2020match_known_array([], T, A, M, N, MSpec, A) -->
2021 match_known_type_type(T, A, M, N, MSpec, A).
2022match_known_array([D|L], T, A, M, N, array(Spec, D), A) -->
2023 match_known_array(L, T, E, M, N, Spec, E).
2024
2025match_known_type(atm(A), _, _, chrs('char*'), A) --> [].
2026match_known_type(atom(A), _, _, chrs('char*'), A) --> [].
2027match_known_type(str(A), _, _, string('char*'), A) --> [].
2028match_known_type(string(A), _, _, string('char*'), A) --> [].
2029match_known_type(ptr(A), _, _, ntype('void*', pointer), A) --> [].
2030match_known_type(long(A), _, _, ntype(long, long), A) --> [].
2031match_known_type(int(A), _, _, ntype(int, integer), A) --> [].
2032match_known_type(int64(A), _, _, ntype(int64_t, int64), A) --> [].
2033match_known_type(nnegint(A), _, _, ntype('unsigned int', integer), A) --> [].
2034match_known_type(integer(A), _, _, ntype(int, integer), A) --> [].
2035match_known_type(character_code(A), _, _, ntype(char, char_code), A) --> [].
2036match_known_type(char(A), _, _, ntype(char, char), A) --> [].
2037match_known_type(num(A), _, _, ntype(double, float), A) --> [].
2038match_known_type(size_t(A), _, _, ntype(size_t, size_t), A) --> [].
2039match_known_type(float_t(A), _, _, ntype(float, float_t), A) --> [].
2040match_known_type(number(A), _, _, ntype(double, float), A) --> [].
2041match_known_type(term(A), _, _, term, A) --> [].
2042match_known_type(type(Type, A), M, N, MSpec, A) -->
2043 {nonvar(Type)},
2044 match_known_type_type(Type, A, M, N, MSpec, A).
2045match_known_type(array(Type, DimL, A), M, N, MSpec, A) -->
2046 {nonvar(Type)},
2047 match_known_array(DimL, Type, A, M, N, MSpec, A),
2048 !.
2049match_known_type(MType, M, N, MSpec, A) -->
2050 { member(MType-MSpec, [ptr( Type, A)-ptr( Spec),
2051 list(Type, A)-list(Spec)])
2052 },
2053 neck,
2054 {nonvar(Type)},
2055 match_known_type_type(Type, E, M, N, Spec, E),
2056 !.
2057match_known_type(Type, M, _, tdef(Name, Spec), A) -->
2058 { type_is_tdef(M, Type, Spec, A),
2059 get_type_name(Type, Name)
2060 },
2061 !.
2062match_known_type(setof(Type, A), M, N, Spec, A) -->
2063 { nonvar(Type),
2064 extend_args(Type, [E], Prop)
2065 },
2066 match_type(Prop, M, known, N, PSpec, E),
2067 { ( PSpec = tdef(EName, ESpec)
2068 ->true
2069 ; ESpec = PSpec,
2070 EName = TName
2071 ),
2072 ( ESpec = enum(_, C),
2073 ( ( C =< 16
2074 ->TName = short
2075 ; C =< 32
2076 ->TName = int
2077 ; C =< 64
2078 ->TName = long
2079 )
2080 ->Dim = 1
2081 ; current_prolog_flag(address_bits, AB),
2082 ( AB >= 64
2083 ->TName = '__int128',
2084 ElemSize = 128
2085 ; TName = long,
2086 ElemSize = AB
2087 ),
2088 Dim is (C+ElemSize-1)//ElemSize
2089 )
2090 ->Spec = setof(N, EName, ESpec, Dim)
2091 ; Spec = list(PSpec)
2092 )
2093 }.
2094match_known_type(Type, M, _, Spec, A) -->
2095 { compound(Type),
2096 functor(Type, Name, Arity),
2097 arg(Arity, Type, A),
2098 functor(Head, Name, Arity),
2099 2100 2101 type_props(M, HeadTypePropLDictL, _, _)
2102 },
2103 ( { HeadTypePropLDictL = [Head-[t(Head2, [], _, _)]],
2104 Head == Head2
2105 }
2106 ->{Spec=cdef(Name)}
2107 ; { HeadTypePropLDictL = [Head-TypePropLDictL],
2108 forall(member(t(Head, PropL, _, _), TypePropLDictL), PropL = [])
2109 }
2110 ->{ length(TypePropLDictL, N),
2111 Spec=enum(Name, N)
2112 }
2113 ; { member(_-TypePropLDictL, HeadTypePropLDictL),
2114 member(t(Head, PropL, _, _), TypePropLDictL),
2115 PropL \= []
2116 }
2117 ->( { PropL = [setof(EType, A)],
2118 nonvar(EType)
2119 }
2120 ->match_known_type(setof(EType, A), M, Name, Spec, A)
2121 ; {Spec=struct(Name)}
2122 )
2123 ),
2124 !.
2125
2126match_known_type_dict(Prop, Tag, A, Name, struct(TypeName)) -->
2127 { atomic_list_concat([Name, '_', Tag], TypeName),
2128 Type =.. [TypeName, A]
2129 },
2130 [Prop=Type].
2131
2132type_is_tdef(M, Type, Spec, A) :-
2133 compound(Type),
2134 functor(Type, TName, Arity),
2135 arg(Arity, Type, A),
2136 functor(Head, TName, Arity),
2137 type_props1(M, Head, _, _, Asr),
2138 \+ curr_prop_asr(comp, _, _, Asr),
2139 bind_type_names(M:Head, TypeMPropLDictL),
2140 TypeMPropLDictL = [p(Head, [Prop], _)],
2141 \+ member(Prop, [dict_t(_, _), dict_t(_, _, _), setof(_, _)]),
2142 arg(Arity, Head, A),
2143 functor(Prop, _, PA),
2144 arg(PA, Prop, B),
2145 A==B,
2146 match_known_type(Prop, M, TName, Spec, A),
2147 !.
2148
2149bind_argument(Head, M, CM, CompL, CallL, SuccL, GlobL, Arg, Spec, Mode) :-
2150 get_type_name(Head, Name),
2151 ( member(Comp, CompL),
2152 once(match_known_type(Comp, CM, Name, Spec, Arg1)),
2153 Arg1 == Arg
2154 ->true
2155 ; true
2156 ),
2157 ( member(Call, CallL),
2158 once(match_known_type(Call, CM, Name, Spec, Arg1)),
2159 Arg1 == Arg
2160 ->Mode = in
2161 ; true
2162 ),
2163 ( member(Succ, SuccL),
2164 once(match_known_type(Succ, CM, Name, Spec, Arg1)),
2165 Arg1 == Arg
2166 ->Mode = out
2167 ; true
2168 ),
2169 ( memberchk(type(_), GlobL),
2170 once(match_known_type(Head, M, Name, Spec, Arg1)),
2171 Arg1 == Arg
2172 ->Mode = in
2173 ; true
2174 ),
2175 ignore(Mode = inout),
2176 ignore(Spec = term).
2177
2178:- public call_idx/2. 2179:- meta_predicate call_idx(0, -). 2180call_idx(Call, Idx) :-
2181 findall(Ref, once(call_ref(Call, Ref)), [Ref]), 2182 nth_clause(_, Idx1, Ref),
2183 succ(Idx, Idx1).
2184
2185:- public idx_call/2. 2186:- meta_predicate idx_call(+, 0). 2187idx_call(Idx1, Call) :-
2188 succ(Idx1, Idx),
2189 nth_clause(Call, Idx, Ref),
2190 clause(Call, _, Ref)