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