15:- module(soops, []). 16:- set_module(class(library)). 17:- include('./header'). 18
19:- multifile(soops:struct_opv/3). 20:- discontiguous soops:struct_opv/3. 21:- dynamic((soops:struct_opv/3)). 22:- multifile(soops:struct_opv/4). 23:- discontiguous soops:struct_opv/4. 24:- dynamic((soops:struct_opv/4)). 25
26:- multifile(xlisting_config:xlisting_always/1). 27:- dynamic(xlisting_config:xlisting_always/1). 28
29xlisting_config:xlisting_always(G):- G=soops:_, current_predicate(_,G),
30 predicate_property(G,dynamic),
31 \+ predicate_property(G,imported_from(_)).
32
33new_cl_fixnum(Init,Obj):-
34 create_object(claz_fixnum,[Init],Obj),!.
35
37f_make_instance([Name|Slots],Obj):- always(create_object(Name,Slots,Obj)).
38
39create_struct(X,Y):-create_object(X,Y).
40create_struct(X,Y,Z):-create_object(X,Y,Z).
46
47create_object([Name|Slots],Obj):- !,create_object(Name,Slots,Obj).
48create_object(TypeARGS,Obj):- compound(TypeARGS),!,compound_name_arguments(TypeARGS,Kind,ARGS),
49 create_object(Kind,ARGS,Obj),!.
50create_object(Kind,Obj):- create_object(Kind,[],Obj),!.
51create_object(Kind,Attrs,Obj):- new_unnamed_opv(Kind,Attrs,Obj).
52
53new_unnamed_opv(Kind,Attrs,Obj):-
54 gensym('znst_',ZName),
55 new_partly_named_opv(Kind,ZName,Attrs,Obj).
56
57new_named_opv(SKind,Name,Attrs,Obj):-
58 new_partly_named_opv(SKind,Name,Attrs,Obj).
67
68new_partly_named_opv(SKind,Name,Attrs,Obj):-
69 new_partly_named_opv_pt1(SKind,Name,Attrs,Obj,Kind),
70 new_init_instance_pt2(SKind,Name,Attrs,Obj,Kind).
71
72new_partly_named_opv_pt1(SKind,Name,_Attrs,Obj,Kind):-
73 always((
74 (var(Kind)->find_class(SKind,Kind);true),
75 claz_to_symbol(Kind,Type),
76 (var(Obj)->create_object_instance(Kind,Type,Name,Obj);add_opv_new(Obj,type_of,Type))
77 )).
78
79
80is_dict_type(claz_pathname,
81 pathname{pathname_host:[],pathname_device:[],pathname_directory:[],pathname_name:[],pathname_type:[],pathname_version:[],debug_name:[],ref:[]}).
82
83
84
85guess_ref_name(Obj,Ref):- ((get_dict(ref,Obj,Ref0),(Ref0==[]->(guess_ref_name0(Obj,Ref),nb_set_dict(ref,Obj,Ref));Ref0=Ref))),!.
86guess_ref_name(Obj,Ref):- guess_ref_name0(Obj,Ref).
87guess_ref_name0(Obj,Ref):- get_opv(Obj,ref,Ref).
88guess_ref_name0(Obj,Ref):-
89 type_or_class_nameof(Obj,Kind),
90 get_opv(Obj,debug_name,Name),
91 instance_prefix(Kind,Pre),!,atomic_list_concat([Pre,Name],'_',PName),
92 prologcase_name(PName,Ref).
93guess_ref_name0(_Obj,Ref):- gensym('sdfZZZZZZZZsdfsdf_',Ref).
94
95
96create_object_instance(Kind,Type,Name,Obj):-
97 (is_dict_type(Type,Blank);is_dict_type(Kind,Blank)),!,
98 copy_term(Blank,Obj),
99 to_prolog_string_anyways(Name,SName),
100 add_opv_new(Obj,type_of,Type),
101 set_opv(Obj,debug_name,SName),
102 instance_prefix(Kind,Pre),!,atomic_list_concat([ref,Pre,Name],'_',PName),
103 prologcase_name(PName,Ref),
104 nb_set_dict(ref,Obj,Ref).
105
106
107create_object_instance(Kind,Type,Name,Obj):- sanity(atom(Name)),
108 instance_prefix(Kind,Pre),!,atomic_list_concat([Pre,Name],'_',PName),
109 prologcase_name(PName,Obj),to_prolog_string_anyways(Name,SName),
110 add_opv_new(Obj,type_of,Type),
111 set_opv(Obj,debug_name,SName).
112
113
114
115new_init_instance_pt2(_SKind,_Name,Attrs,Obj,Kind):-
116 must_det_l((
117 init_instance_slots(Kind,1,Obj,Attrs),
118 call_init_slot_props(Kind,Obj))).
119
120call_init_slot_props(Kind,Obj):- get_opv_iiii(Obj,sys_initialized,Kind),!.
121call_init_slot_props(Kind,Obj):- add_opv_new_iiii(Obj,sys_initialized,Kind),
122 must_det_l((
123 forall(get_kind_supers(Kind,Sup),call_init_slot_props(Sup,Obj)),
124 ensure_opv_type_inited(Kind),
125 forall(get_struct_opv(Kind,sys_initform,Value,ZLOT),
126 ( get_opv_iii(Kind,Obj,ZLOT,_)-> true ;
127 (f_eval(Value,Result),set_opv(Obj,ZLOT,Result)))))).
128
129
130when_must(True,Then):- True->always(Then);true.
131
132init_instance_slots(Kind,_Ord,Obj,PProps):-always(init_instance_kv(Kind,Obj,PProps)),!.
134
135
136init_slot_props_iv(_,_N,_Obj,[]):-!.
137init_slot_props_iv(Kind,N,Obj,[Value|Props]):-
138 add_i_opv(Kind,Obj,N,Value), N2 is N + 1,
139 init_instance_kv(Kind,N2,Obj,Props).
140
141add_i_opv(Kind,Obj,N,Value):-
142 always((get_struct_opv(Kind,sys_location,N,ZLOT),
143 get_struct_opv(Kind,name,Key,ZLOT),
144 add_opv(Obj,Key,Value))).
145
146f_sys_pf_set_slot_value(Obj,Key,Value,Value):- get_object_slot_name(Obj,Key,ZLOT),!, set_opv(Obj,ZLOT,Value).
147f_slot_exists_p(Obj,Slot,Value):- t_or_nil(get_opv(Obj,Slot,_),Value).
148
149f_slot_value(Obj,Slot,Value):- always(get_opv(Obj,Slot,Value)).
150
151f_class_slot_value(Kind,Obj,Slot,Value):- get_kind_object_slot_value(Kind,Obj,Slot,Value).
152f_sys_set_class_slot_value(Kind,Obj,Slot,Value,Value):- set_kind_object_slot_value(Kind,Obj,Slot,Value).
153
154get_kind_object_slot_value(Kind,Obj,Key,Value):-
155 always(( (nonvar(Kind),get_kind_or_supers_slot_name(Kind,Key,SlotName))
156 ->always((get_opv(Obj,SlotName,Value)));
157 always(((get_object_slot_name(Obj,Key,SlotName), get_opv(Obj,SlotName,Value)))))),!.
158
159set_kind_object_slot_value(Kind,Obj,Key,Value):-
160 always(( (nonvar(Kind),get_kind_or_supers_slot_name(Kind,Key,SlotName))
161 ->always((set_opv(Obj,SlotName,Value)));
162 always(((get_object_slot_name(Obj,Key,SlotName), set_opv(Obj,SlotName,Value)))))),!.
163
164
165get_object_slot_name(Obj,Key,SlotName):-
166 type_or_class_nameof(Obj,Kind),!,
167 get_kind_or_supers_slot_name(Kind,Key,SlotName).
168
169get_kind_or_supers_slot_name(Kind,Key,SlotName):-
170 ((ground(Kind+Key) -> once(get_kind_or_supers_slot_name_now(Kind,Key,SlotName)); get_kind_or_supers_slot_name_now(Kind,Key,SlotName)) *-> true;
171 get_kind_slot_name(Kind,Key,SlotName)).
172
173get_kind_or_supers_slot_name_now(Kind,Key,SlotName):-
174 no_repeats(SlotName,always(((get_kind_supers(Kind,Sup),get_kind_slot_name(Sup,Key,SlotName))))),!.
175
176get_kind_supers(Kind,Sup):- find_class(Kind,KSup), get_kind_supers3(KSup,[],Sup).
177
178get_kind_supers3(Kind,ExceptFor,_Sup):- member(Kind,ExceptFor),!,fail.
179get_kind_supers3(Kind,_,Kind).
180get_kind_supers3(Kind,ExceptFor,Sup):-
181 get_super_class(Kind,Sup),
182 get_kind_supers3(Sup,[Kind|ExceptFor],SupSup),
183 SupSup \== claz_null,
184 SupSup \== claz_t.
185
186get_super_class(Kind,Sup):- get_struct_opv(Kind,type,Type),find_class(Type,Sup)->Sup\==Kind.
187get_super_class(Kind,Sup):- get_struct_opv(Kind,include,Sup).
188get_super_class(Kind,Sup):- get_struct_opv(Kind,sys_class_precedence_list,List),!,e_member(Sup,List).
189
190
191get_kind_slot_name(Kind,Key,SlotName):- find_class(Kind,KSup),!,quietly(always(get_slot_name0(KSup,Key,USlotName))),
192 un_kw(USlotName,SlotName).
193
194get_slot_name0(Kind,SlotName,ZLOT):- var(SlotName),!,get_struct_opv_i(Kind,_,_,SlotName),ZLOT=SlotName.
195get_slot_name0(Kind,SlotName,ZLOT):- get_struct_opv_i(Kind,_,_,SlotName),ZLOT=SlotName,!.
196get_slot_name0(Kind,Key,SlotName):- builtin_slot(Kind,Key),!,Key=SlotName.
202get_slot_name0(Kind,Key,SlotName):- sys_hash_table_index_vector==Key,!,dmsg(get_slot_name0(Kind,Key,SlotName)),break.
203get_slot_name0(Kind,SlotName,ZLOT):- get_struct_opv_i(Kind,initarg, Name, ZLOT),same_symbol_names(SlotName,Name),!.
204get_slot_name0(Kind,SlotName,ZLOT):- get_struct_opv_i(Kind,name, Name, ZLOT),same_symbol_names(SlotName,Name),!.
205get_slot_name0(Kind,SlotName,ZLOT):- get_struct_opv_i(Kind,_,OneOf,ZLOT),notrace(e_member(SlotName,OneOf)),!.
206get_slot_name0(Kind,SlotName,ZLOT):- get_struct_opv_i(Super,_,OneOf,ZLOT),notrace(e_member(SlotName,OneOf)),!,
207 dmsg(always(get_slot_name0(Super->Kind,SlotName,ZLOT))).
208get_slot_name0(_,A,A).
209
210same_symbol_names(S1,S2):- pl_symbol_name(S1,N1),pl_symbol_name(S2,N2),!,N1=N2.
211
221
222e_member(E,L):- is_list(L),!,member(E,L).
223e_member(E,E).
224
225slot_is_vertical_items(type).
226slot_is_vertical_items(sys_initialized).
227slot_is_vertical_items(kw_include).
228
230init_instance_kv(_,_,[]).
232init_instance_kv(Kind,Obj,[[Key|LList]|Props]):- slot_is_vertical_items(Key),!,
233 always((((LList=[List],is_list(List));LList=List),
234 get_kind_slot_name(Kind,Key,SlotName),
235 maplist(add_opv_new(Obj,SlotName),List))),
236 init_instance_kv(Kind,Obj,Props).
238init_instance_kv(Kind,Obj,[KV|Props]):- compound(KV),get_kv(KV,Key,Value),!,
239 show_call_trace(set_kind_object_slot_value(Kind,Obj,Key,Value)),
240 init_instance_kv(Kind,Obj,Props).
242init_instance_kv(Kind,Obj,[Key,Value|Props]):-
243 nop(always(is_keywordp(Key))),
244 set_kind_object_slot_value(Kind,Obj,Key,Value),!,
245 init_instance_kv(Kind,Obj,Props).
246
268
269type_slot_number(Kind,Key,Ordinal):-
270 get_kind_slot_name(Kind,Key,ZLOT),
271 get_struct_opv(Kind,sys_location,Ordinal,ZLOT).
272
273
282
283(wl:init_args(0,defstruct)).
284(wl:init_args(0,make_instance)).
285(wl:init_args(0,defclass)).
286
287
288foc_class(Name,Kind):- find_class(Name,Kind),Kind\==[],!.
289foc_class(Name,Kind):- 290 new_named_opv(claz_structure_class,Name,[],Kind),!.
291
292find_class(Name,Claz):- atom(Name),atom_concat_or_rtrace('claz_',_,Name),!,Claz=Name.
293find_class(Name,Claz):- soops:struct_opv(Claz,class_name,Name),!.
294find_class(Name,Claz):- atom(Name),atom_concat_or_rtrace('claz_',Name,Claz).
296
297
298f_find_class(Name,_Opts,Claz):- always(is_symbolp(Name)),
299 once((find_class(Name,Claz),claz_to_symbol(Claz,Sym),Name==Sym,always(is_classp(Claz)))).
300f_find_class(_,_,[]).
301
302is_classp(C):-f_type_of(C,T),is_class_classp(T),!.
303is_classp(C):-atom(C),atom_concat_or_rtrace('claz_',_,C).
304
305
306is_class_classp(standard_class).
307is_class_classp(built_in_class).
308is_class_classp(structure_class).
309is_class_classp(class).
310
311sf_defstruct(_ReplEnv,[[Name,KeyWords]|Slots],Name):- !, always(define_struct(Name,KeyWords,Slots,_Kind)).
312sf_defstruct(_ReplEnv,[[Name|KeyWords]|Slots],Name):- !, always(define_struct(Name,KeyWords,Slots,_Kind)).
313sf_defstruct(_ReplEnv,[Name|Slots],Name):- always(define_struct(Name,[],Slots,_Kind)).
314
315sf_defclass(_ReplEnv,[Name,Supers,Slots|KwInfo],Kind):- !, always(define_class(Name,[[kw_include,Supers]|KwInfo],Slots,Kind)).
316
317
318define_class(Name,KeyWords,SlotsIn,Kind):-
319 (var(Kind) -> (( new_named_opv(claz_standard_class,Name,[],Kind)));true),
320 define_kind(defclass,Name,KeyWords,SlotsIn,Kind),
321 ensure_metaobject(Kind,_),
322 ensure_prototype(Kind,_).
323
324
325is_prop_class_alloc(Type,SlotName,Where):- 326 freeze(Type,find_class(Type,Kind)),
327 get_struct_opv_i(Kind,allocation,kw_class,ZLOT),
328 get_kind_slot_name(Kind,SlotName,ZLOT0),ZLOT0=ZLOT,
329 ensure_metaobject(Kind,Where).
330
332ensure_prototype(Kind,Instance):- get_struct_opv(Kind,prototype,Instance),!.
333ensure_prototype(Kind,Instance):- make_proto_instance(Kind,Instance),assert_struct_opv(Kind,prototype,Instance).
334
335make_proto_instance(Kind,Obj):-
336 new_partly_named_opv_pt1(_SKind,znst_prototypical_0,[],Obj,Kind).
337
338ensure_metaobject(Kind,Instance):- get_struct_opv(Kind,metaobject,Instance),!.
339ensure_metaobject(Kind,Instance):- make_metaobject_instance(Kind,Instance),assert_struct_opv(Kind,metaobject,Instance).
340
341make_metaobject_instance(Kind,Obj):-
342 new_partly_named_opv_pt1(Kind,znst_metaobject_0,[],Obj,_Kind).
343
344
345
346define_struct(Name,KeyWords,SlotsIn,Kind):-
347 (var(Kind) -> (( new_named_opv(claz_structure_class,Name,[],Kind)));true),
348 define_kind(defstruct,Name,KeyWords,SlotsIn,Kind).
349
350is_structure_classp(T):- get_opv(T,type_of,TT),!,TT=structure_class.
351
352
353define_kind(DefType,Name,KeyWords,SlotsIn,Kind):-
354 always((
355 (DefType == defstruct-> KindKind = structure_class ; KindKind = standard_class ),
356 assert_struct_opv(Kind,class_name,Name),
357 358 359 maybe_get_docs('class',Name,SlotsIn,Slots,Code),
360 always(Code),
361 add_class_keywords(Kind,KeyWords),
362 init_instance_kv(KindKind,Kind,KeyWords),
363 get_struct_offset(Kind,Offset),
364 NOffset is Offset +1,
365 (memberchk(kw_named,KeyWords) ->
366 add_class_slots(DefType,Kind,NOffset,[[class_name,Name]|Slots]);
367 add_class_slots(DefType,Kind,NOffset,Slots)),
368 generate_missing_claz_functions(KindKind,Kind))).
369
370get_struct_offset(Kind,W):- get_struct_opv(Kind,sys_structure_class_initial_offset,W).
371get_struct_offset(_,0).
372
373generate_missing_claz_functions(_KindKind,Kind):-
374 always(( claz_to_symbol(Kind,Name),
375 to_prolog_string_anyways(Name,SName),
376 377 show_call_trace(make_default_constructor(Kind,Code)),
378 always(Code),
379 show_call_trace(maybe_add_kw_function(Kind,SName,"-P",kw_predicate, [obj],( eq('type-of'(obj),quote(Name))))),
380 381 struct_opv_else(Kind,sys_structure_class_conc_name,ConcatName,(string_concat(SName,"-",ConcatName))),
382
383 forall(get_struct_opv(Kind,name,SlotName,ZLOT),
384 (intern_slot_name('',ConcatName,SlotName,ConcSlotName),
385 add_slot_accessor_functions(Kind,ConcSlotName,ZLOT))),
386 forall(get_struct_opv(Kind,kw_reader,Accessor,ZLOT),
387 add_slot_accessor_functions(Kind,Accessor,ZLOT)),
388 forall(get_struct_opv(Kind,kw_accessor,Accessor,ZLOT),
389 add_slot_accessor_functions(Kind,Accessor,ZLOT)))).
390
392always_ignore(G):- always(ignore(G)).
393
394
400make_default_constructor(Kind,Code):-
401 always((
402 claz_to_symbol(Kind,Name),to_prolog_string_anyways(Name,SName),
403 atom_concat_or_rtrace("MAKE-",SName,FnName),
404 force_symbol_package(Name,Package),
405 (package_not_for_slots(Package)->f_intern(FnName,[],FnSym);f_intern(FnName,Package,FnSym)),
406 foc_operator(_,_,kw_function,FnSym,3,Function),
407 Head=..[Function,List,Obj],
408 Body=..[f_make_instance,[Kind|List],Obj],
409 Code = (assert_lsp(FnSym,wl:init_args(0,FnSym)),
410 assert_lsp(FnSym,wl:init_args(0,Function)),
411 412 set_opv(FnSym,symbol_function,Function),
413 assert_lsp(Name,(user:Head:-Body))))).
414
415
416
417
418maybe_add_get_set_functions(Kind,ZLOT):-
419 get_struct_opv(Kind,kw_accessor,Accessor,ZLOT),!,
420 add_slot_accessor_functions(Kind,Accessor,ZLOT),
421 add_slot_accessor_functions(Kind,ZLOT,ZLOT).
422maybe_add_get_set_functions(Kind,ZLOT):-
423 Accessor = ZLOT,
424 assert_struct_opv4(Kind,kw_accessor,Accessor,ZLOT),
425 add_slot_accessor_functions(Kind,Accessor,ZLOT).
426
427add_slot_accessor_functions(Kind,Accessor,ZLOT):-
428 add_slot_getter_function(Kind,Accessor,ZLOT),
429 (\+ get_struct_opv(Kind,read_only,t,ZLOT) ->
430 add_slot_setter_function(Kind,Accessor,ZLOT) ; true).
431
432
433add_slot_getter_function(Kind,Accessor,ZLOT):-
434 maybe_add_function(Accessor,[object],['class-slot-value',Kind,object,[quote,ZLOT]],Added1),
435 (Added1\==[]-> push_struct_opv(Kind,readers,Added1,ZLOT) ; true).
436
437add_slot_setter_function(Kind,Accessor,ZLOT):-
438 SETTER = [setf,Accessor],
439 maybe_add_function(SETTER,[object,value],['set-class-slot-value',Kind,object,[quote,ZLOT],value],Added1),
440 (Added1\==[]-> push_struct_opv(Kind,writers,Added1,ZLOT) ; true).
441
442
443member_element_list(kw_writer,writers).
444member_element_list(kw_reader,readers).
445
446f_clos_class_direct_superclasses(C,SL):-findall(S,struct_opv(C,kw_include,S),SL).
447
448f_clos_class_precedence_list(C,SL):- struct_opv(C,super_priority,SL),!.
449f_clos_class_precedence_list(C,SL):- f_clos_class_direct_superclasses(C,List1),maplist(f_clos_class_direct_superclasses,List1,List2),
450 append(List1,List2,List3),list_to_set(List3,SL).
451
452
454classof:attr_unify_hook(A,B):- trace,wdmsg(classof:attr_unify_hook(A,B)),lisp_dump_break. 455
456
457maybe_add_kw_function(Kind,L,R,Key,ArgList,LispBody):-
458 (get_struct_opv(Kind,Key, FnName) -> true; atom_concat_or_rtrace(L,R,FnName)),
459 maybe_add_function(FnName,ArgList,LispBody,_).
460
461maybe_add_function(FnName,ArgList,LispBody,R):-
462 ((atom(FnName),reader_intern_symbols(FnName,Sym),is_implemented(Sym))->R=Sym;
463 ((R=Result,as_sexp(LispBody,SLispBody),
464 reader_intern_symbols([defun,FnName,ArgList,[progn,SLispBody]],LispInterned),
465 ((lisp_compile(Result,LispInterned,PrologCode),
466 cmpout(PrologCode),
467 always(PrologCode)))))).
468
469
470struct_opv_else(Kind,Key,Value,Else):-
471 (get_struct_opv(Kind,Key,Value)->true;
472 (Else,assert_struct_opv(Kind,Key,Value))).
473
474
475
476add_class_keywords(_Struct,[]):-!.
477add_class_keywords(Kind,[Key|KeyWords]):- Key = kw_named,!,
478 assert_struct_kw(Kind, Key, t),
479 add_class_keywords(Kind,KeyWords).
480add_class_keywords(Kind,[[Key,Value]|KeyWords]):- atom(Key), !,
481 assert_struct_kw(Kind, Key, Value),
482 add_class_keywords(Kind,KeyWords).
483add_class_keywords(Kind,[[Key|Value]|KeyWords]):- atom(Key), !,
484 assert_struct_kw(Kind, Key, Value),
485 add_class_keywords(Kind,KeyWords).
486add_class_keywords(Kind,[Key,Value|KeyWords]):-
487 assert_struct_kw(Kind, Key, Value),
488 add_class_keywords(Kind,KeyWords).
489
490assert_struct_kw(Kind, Key, Value):-
491 ignore(( \+ is_keywordp(Key) , dbginfo(warn(assert_struct_kw(Kind, Key, Value))))),
492 assert_struct_opv(Kind, Key, Value).
493
494assert_struct_opv(Obj,Key,Value):-
495 get_object_slot_name(Obj,Key,SlotName),
496 show_call_trace(assertz_new(soops:struct_opv(Obj, SlotName, Value))).
497
499
500assert_struct_opv4(Obj, UKey, Value,Info):-
501 un_kw(UKey,Key),
502 show_call_trace(assertz_new(soops:struct_opv(Obj, Key, Value,Info))).
503
504update_struct_opv4(Obj, UKey, Value,Info):-
505 un_kw(UKey,Key),
506 ignore(retract(soops:struct_opv(Obj, Key, _,Info))),
507 show_call_trace(assertz_new(soops:struct_opv(Obj, Key, Value,Info))).
508
509get_struct_opv(Obj, UKey, Value):- un_kw(UKey,Key), soops:struct_opv(Obj , Key, Value).
510get_struct_opv(Kind, UKey, Value, Slot):- un_kw(UKey,Key),soops:struct_opv(Kind, Key, Value, Slot).
511
512get_struct_opv_i(Kind, Key, Value, Slot):- soops:struct_opv(Kind, Key, Value, Slot).
513
514
515push_struct_opv(Kind,Prop,Item,ZLOT):-
516 (get_struct_opv(Kind,Prop,List,ZLOT) ->
517 (member(Item,List) -> true ; update_struct_opv4(Kind,Prop,[Item|List],ZLOT));
518 assert_struct_opv4(Kind,Prop,[Item],ZLOT)).
519
520
521
522force_symbol_package(Symbol,Package):- atom(Symbol),f_symbol_package(Symbol,Package),!.
523force_symbol_package(_Symbol,[]).
524
525gen_slot_name(Prefix,Type,Key,ZLOT):-
526 always((
527 Type=..[Kind|Params],
528 claz_to_symbol(Kind,Sym),
529 intern_slot_name(Prefix,Sym,Key,SlotInfo2),
530 ZLOT=..[SlotInfo2|Params])).
531
532intern_slot_name(Prefix,Type,Key,SlotInfo2):-
533 notrace((to_prolog_string_anyways(Type,ClassName),force_symbol_package(Type,Pack1),
534 to_prolog_string_anyways(Key,KeyName),force_symbol_package(Key,Pack2),
535 choose_package(Pack1,Pack2,Package),
536 537 (atom_concat_or_rtrace(_,'-',ClassName)->ClassNameDash=ClassName;atom_concat_or_rtrace(ClassName,'-',ClassNameDash)),
538 atomics_to_string([Prefix,ClassNameDash,KeyName],String))),
539 string_upper(String,StringUC),
540 f_intern(StringUC,Package,SlotInfo2),!.
541
542
543package_not_for_slots([]).
544package_not_for_slots(pkg_cl).
545package_not_for_slots(pkg_kw).
546
547choose_package(_,Pack2,Pack2):- \+ package_not_for_slots(Pack2),!.
548choose_package(Pack1,_,Pack1):- \+ package_not_for_slots(Pack1),!.
549choose_package(_,_,pkg_sys).
550
563un_kw(In,Out):- notrace((un_kw0(In,Mid), un_classdirect(Mid,Out))).
564
565un_kw0(In,Out):- atom_concat_or_rtrace(kw_,Out,In),!.
566un_kw0(In,Out):- atom_concat_or_rtrace(sys_,Out,In),!.
567un_kw0(Prop,Prop).
568un_classdirect(In,Out):- atom_concat_or_rtrace(class_direct_,Mid,In),!,un_classdirect(Mid,Out).
569un_classdirect(In,Out):- atom_concat_or_rtrace(structure_,Mid,In),!,un_classdirect(Mid,Out).
570un_classdirect(In,Out):- atom_concat_or_rtrace(class_,Mid,In),!,un_classdirect(Mid,Out).
571un_classdirect(In,Out):- atom_concat_or_rtrace(standard_,Mid,In),!,un_classdirect(Mid,Out).
572un_classdirect(In,Out):- atom_concat_or_rtrace(object_,Mid,In),!,un_classdirect(Mid,Out).
573un_classdirect(In,Out):- atom_concat_or_rtrace(slot_definition_,Out,In),!.
574un_classdirect(Prop,Prop).
575
577personal_props(debug_name).
578personal_props(ref).
579personal_props(sys_initialized).
580
581
582wl:init_args(x,sys_get_iprops).
583wl:interned_eval('`sys:get-iprops').
584f_sys_get_iprops(Obj,Result):- nonvar(Obj),findall([Prop|Value],get_opv_i(Obj,Prop,Value),ResultL),list_to_set(ResultL,Result).
585wl:init_args(x,sys_get_opv).
586wl:interned_eval('`sys:get-opv').
587f_sys_get_opv(Obj,Prop,Value):- get_opv(Obj,Prop,Value).
588wl:init_args(x,sys_set_opv).
589wl:interned_eval('`sys:set-opv').
590f_sys_set_opv(Obj,Prop,Value,R):- set_opv(Obj,Prop,Value),R=Obj.
591
592f_sys_to_pvs(X,[float|XX]):- notrace(catch(XX is (1.0 * X),_,fail)),!.
593f_sys_to_pvs(X,XX):- findall([P|V],((get_opv_i(X,P,V),\+ personal_props(P))),List),
594 List\==[],sort(List,XX),!.
595f_sys_to_pvs(X,[str|XX]):- format(string(S),'~w',[X]),string_upper(S,XX),!.
596
597
598
599 \
616
617is_refp(Value):- atom(Value),notrace(nb_current(Value,_)),!.
618is_objp(Value):- compound(Value),functor(Value,'$OBJ',2).
620
621
622ref:attr_unify_hook(Same,Var):- get_attr(Var,ref,SameO)->Same==SameO;var(Var).
623
624get_opv(Obj,Prop,Values):- no_repeats((Obj-Prop),get_opv_i(Obj,Prop,Values)).
625
626get_kind_ref(KindObj,Kind,Obj):- var(KindObj),!,Obj=KindObj,Kind=_.
627get_kind_ref(KindObj,Kind,Obj):- compound_deref(KindObj,Real),!,get_kind_ref(Real,Kind,Obj).
628get_kind_ref('$OBJ'(Kind,_,Obj),Kind,Obj):- !.
629get_kind_ref('$OBJ'(Kind,Obj),Kind,Obj):- !.
630get_kind_ref(Obj,Kind,Obj):- type_or_class_nameof(Obj,Kind),!.
631
632compound_deref(C,_):- \+ compound(C),!,fail.
633compound_deref('$OBJ'(claz_reference,B),B):- atom(B).
634
635
637get_opv_i(Obj,Prop,Value):- attvar(Obj),!,nonvar(Prop),get_attr(Obj,Prop,Value).
638get_opv_i(Sym,Prop,Value):- atom(Sym),is_keywordp(Sym),!,get_type_default(keyword,Sym,Prop,Value).
639get_opv_i(KindObj,Prop,Value):- get_kind_ref(KindObj,Kind,Obj),get_opv_ii(Kind,Obj,Prop,Value).
640
641get_opv_ii(_Kind,Obj,Prop,Value):- quietly(get_opv_iiii(Obj,Prop,Value)).
642get_opv_ii(Kind,Obj,Prop,Type):- type_of == Prop,!,(i_type(Obj,Type)->true;Kind=Type).
643get_opv_ii(symbol,Obj,Prop,Value):- nonvar(Obj),wl:quietly((symbol_has_prop_getter(Obj,Prop,Getter),call(Getter,Obj,Prop,Value))).
644
645get_opv_ii(Kind,Obj,Prop,Values):-
646 kind_attribute_pred(Kind,Prop,Pred),
647 modulize(call(Pred,Obj,Value),OPred),
648 predicate_property(OPred,dynamic),
649 findall(Value,OPred,Values).
650get_opv_ii(_Kind,Obj,Prop,Value):- get_opv_iiii(Obj,Prop,Value).
651get_opv_ii(_Kind,_,Prop,_):- var(Prop),!,fail.
652get_opv_ii(_Kind,_,Prop,_):- not_shareble_prop(Prop),!,fail.
653get_opv_ii(Kind,Obj,Prop,Value):- nonvar(Kind),get_kind_or_supers_slot_name(Kind,Prop,Where)->Prop\==Where,!, get_opv_iiii(Obj,Where,Value).
654get_opv_ii(Kind,Obj,Prop,Value):- notrace(is_prop_class_alloc(Kind,Prop,Where))->Where\==Obj,!,get_opv_iiii(Where,Prop,Value).
655
656
657get_opv_iii(symbol,Obj,Prop,Value):- nonvar(Obj),wl:symbol_has_prop_getter(Obj,Prop,Getter),call(Getter,Obj,Prop,Value).
658get_opv_iii(_Kind,Obj,Prop,Value):- get_opv_iiii(Obj,Prop,Value).
659
660get_opv_iiii_dict(Type,_Obj,type_of,Type).
661get_opv_iiii_dict(_,Obj,Prop,Value):-
662 ((get_dict(Prop,Obj,Value)-> true;((guess_ref_name(Obj,Ref),get_opv_iiii(Ref,Prop,Value))))).
663
664get_opv_iiii(Obj,Prop,Value):- is_dict(Obj,Type),!,get_opv_iiii_dict(Type,Obj,Prop,Value).
665get_opv_iiii(Obj,Key,Value):- atom(Obj),atom(Key),!,get_opv_iiiii(Obj,Key,Value),!.
666get_opv_iiii(Obj,Key,Value):- get_opv_iiiii(Obj,Key,Value).
667
674
676
677get_opv_iiiii_ref(Obj,Prop,Value):- atom(Obj),nb_current(Obj,Ref),!,nb_current_value(Ref,Prop,Value).
678get_opv_iiiii_ref(Ref,Prop,Value):- (var(Ref)->attvar(Ref);true),nb_current_value(Ref,Prop,Value).
679
680get_opv_iiiii(Obj,Prop,Value):- (get_opv_iiiii_ref(Obj,Prop,Value)*->true;soops:o_p_v(Obj,Prop,Value)).
682get_opv_iiiii(Obj,Prop,Value):- soops:struct_opv(Obj,Prop,Value).
683
684not_shareble_prop(Prop):-notrace((nonvar(Prop),not_shareble_prop0(Prop))).
685not_shareble_prop0(type_of).
686not_shareble_prop0(symbol_value).
687not_shareble_prop0(conc_name).
688not_shareble_prop0(sys_structure_class_conc_name).
689
690
691get_type_default(keyword,Name,symbol_name,Out):- atom(Name), string_concat(kw_,Str,Name),string_upper(Str,Out).
692get_type_default(keyword,_,symbol_package,pkg_kw).
693get_type_default(keyword,_,defined_as,defconstant).
694get_type_default(keyword,_,type_of,keyword).
695get_type_default(Kind,Obj,Prop,Value):- is_prop_class_alloc(Kind,Prop,Where),Obj\==Where,get_opv_iii(Kind,Where,Prop,Value).
696
699
700
701set_ref_object(Ref,Obj):- always(atom(Ref)),quietly(nb_setval(Ref,Obj)),!.
702release_ref_object(Ref):- dbginfo(release_ref_object(Ref)),sanity(atom(Ref)),quietly(nb_setval(Ref,[])),!.
703has_ref_object(Ref,Obj):- atom(Ref),nb_current(Ref,Obj),Obj\==[].
704
705get_ref_object(Ref,Obj):- has_ref_object(Ref,Obj),!.
706get_ref_object(Ref,Obj):- sanity(atom(Ref)),
707 708 709 nb_put_attr(Object0,ref,Ref),
710 always(nb_setval(Ref,Object0)),
711 always(nb_current(Ref,Obj)),!.
712
725
726
727type_prop_prefix(Class,Prefix):- get_opv(Class,sys_structure_class_conc_name,Prefix),!.
728type_prop_prefix(Class,Prefix):- claz_to_symbol(Class,Prefix),!.
729
731
732
733instance_prefix(I,Obj):- instance_prefix0(I,Obj),!.
734instance_prefix(I,Obj):- instance_prefix1(I,Obj), \+ instance_prefix0(I,Obj).
735
736instance_prefix0(claz_structure_class, claz_).
737instance_prefix0(claz_structure_object, claz_).
738instance_prefix0(claz_standard_class, claz_).
739instance_prefix0(claz_package, pkg_).
740instance_prefix0(claz_keyword, kw_).
741
742instance_prefix1(Kind, Prefix):- claz_to_symbol(Kind, Prefix).
743
744f_class_name(C,S):- claz_to_symbol(C,S).
745
746claz_to_symbol(C,S):- claz_to_symbol0(C,S)*->true;claz_to_symbol1(C,S).
747
748claz_to_symbol0(C,S):- get_struct_opv(C,class_name,S).
750claz_to_symbol0(claz_symbol,symbol).
751claz_to_symbol0(claz_package,package).
752claz_to_symbol0(claz_number,number).
753claz_to_symbol0(C,S):- get_struct_opv(C,type,S).
754
755
756claz_to_symbol1(Class,Sym):-atom(Class),atom_concat_or_rtrace('claz_',Sym,Class).
757claz_to_symbol1(Class,Sym):-Class=Sym.
758
759
760
761
762builtin_slot(Kind,Prop):-notrace((nonvar(Prop),builtin_slot0(Kind,Prop))).
763builtin_slot0(_,type_of).
764builtin_slot0(_,sys_initialized).
765builtin_slot0(_,debug_name).
766builtin_slot0(claz_package,_).
767builtin_slot0(claz_standard_class,_).
768builtin_slot0(claz_t,_).
775builtin_slot0(_,symbol_name).
776builtin_slot0(_,symbol_package).
777builtin_slot0(_,symbol_value).
778builtin_slot0(_,symbol_function).
779builtin_slot0(_,symbol_macro).
780builtin_slot0(_,symbol_plist).
782
783
784
785
786
787
788
789add_opv_maybe(Obj,Prop,_):- get_opv_i(Obj,Prop,_),!.
790add_opv_maybe(Obj,Prop,Value):- add_opv_new(Obj,Prop,Value),!.
791
792update_opv(Obj,Prop,Value):- set_opv(Obj,Prop,Value).
793set_opv(Obj,Prop,Value):-
794 795
796 add_opv_new(Obj,Prop,Value).
797
798
799add_opv(Obj,Prop,Value):- add_opv_new(Obj,Prop,Value),!.
800add_opv_new_iii(Obj,Prop,Value):- add_opv_new(Obj,Prop,Value),!.
801
802add_opv_new(Obj,Prop,V):- ( \+ atomic(V)),is_stringp(V),to_prolog_string_if_needed(V,V0),!,show_call_trace(add_opv_new(Obj,Prop,V0)).
805add_opv_new(Obj,Prop,V):- notrace(is_list(Obj)), wdmsg(add_opv_new(Obj,Prop,V)), break.
806add_opv_new(Obj,Prop,Value):- always(type_or_class_nameof(Obj,Kind)),!, add_opv_new_ii(Kind,Obj,Prop,Value),!.
807
808
809add_opv_new_ii(Kind,Obj,Prop,Value):-
810 get_opv_ii(Kind,Obj,Prop,OldValue),Value==OldValue,!.
811add_opv_new_ii(Kind,Obj,Prop,Value):- (is_prop_class_alloc(Kind,Prop,Where) -> Obj\==Where), !,add_opv_new(Where,Prop,Value).
812add_opv_new_ii(claz_symbol,Obj,Prop,Value):- nonvar(Obj), forall(wl:symbol_has_prop_setter(Obj,Prop,Setter),once(call(Setter,Obj,Prop,Value))),fail.
813add_opv_new_ii(Kind,Obj,Prop,Val):-
814 once((kind_attribute_pred(Kind,Prop,Pred),
815 modulize(call(Pred,Obj,Val),OPred),
816 predicate_property(OPred,dynamic),
817 to_removal(OPred,RPred),
818 retractall(RPred),
819 show_call_trace(assert_lsp(OPred)))),fail.
820add_opv_new_ii(Kind,Obj,Prop,Value):- builtin_slot(Kind,Prop),!,add_opv_new_iiii(Obj,Prop,Value).
821add_opv_new_ii(Kind, Obj,Prop,Value):- get_kind_or_supers_slot_name(Kind,Prop,Where) -> Where\==Prop,!, add_opv_new(Obj,Where,Value).
822add_opv_new_ii(_Kind,Obj,Prop,Value):- add_opv_new_iiii(Obj,Prop,Value), nop(ensure_maybe_backed(Obj,Prop,Value,_Value)).
824
825to_removal(M:OPred,M:RPred):- !,copy_term(OPred,RPred),functor(RPred,_,A),nb_setarg(A,RPred,_).
826to_removal(OPred,RPred):- copy_term(OPred,RPred),functor(RPred,_,A),nb_setarg(A,RPred,_).
827
828
829
831
832ensure_maybe_backed(Obj,_Prop,ValueM,Value):-
833 ((\+ atom(Obj));(current_prolog_flag(wamcl_gvars,false);(current_prolog_flag(wamcl_init_level,N),N<3))),!,
834 Value=ValueM,
835 sanity(same_term(Value,ValueM)).
836
837ensure_maybe_backed(Obj,Prop,ValueM,Value):-
838 current_prolog_flag(wamcl_gvars,true),
839 always(get_ref_object(Obj,RefObj)),
840 ((nb_current_value(RefObj,Prop,Value),same_term(Value,ValueM)) -> true ;
841 (Value=ValueM,sanity(same_term(Value,ValueM)),nb_put_attr(RefObj,Prop,Value))).
842
843
844add_opv_new_iiii(Obj,type_of,Type):- is_dict(Obj),!,nb_setarg(1,Obj,Type).
846add_opv_new_iiii(Ref,u_daft_point_z,_Value):- Ref\==u_daft_point_znst_metaobject_0,!,break.
848add_opv_new_iiii(Obj,Prop,Value):- is_dict(Obj),!,always(((get_dict(Prop,Obj,_)->nb_set_dict(Prop,Obj,Value);
849 ((guess_ref_name(Obj,Ref),add_opv_new_iiii(Ref,Prop,Value)))))).
850add_opv_new_iiii(Ref,Prop,Value):-current_prolog_flag(wamcl_gvars,true),!, always(get_ref_object(Ref,Obj)),!,
851 852 (always(nb_put_attr(Obj,Prop,Value))).
853add_opv_new_iiii(Obj,Prop,Value):- 854 ((atom(Obj),(atom_concat_or_rtrace(sys_,_,Obj);atom_concat_or_rtrace(os_,_,Obj);true))->true;dmsg(assert_lsp(o_p_v(Obj,Prop,Value)))),
855 assert_lsp_opv(Obj,Prop,Value).
856
857assert_lsp_opv(Obj,Prop,Value):- Prop==symbol_value,
858 retractall(soops:o_p_v(Obj,Prop,_)),
859 assert_lsp(Obj,soops:o_p_v(Obj,Prop,Value)).
860assert_lsp_opv(Obj,Prop,Value):-
861 assert_lsp(Obj,soops:o_p_v(Obj,Prop,Value)).
862
864delete_opvalues(Obj,Prop):-
865 always(\+ is_list(Obj);Obj==[]),
866 type_or_class_nameof(Obj,Kind),
867 ignore(forall(retract(soops:o_p_v(Obj,Prop,_)),true)),
868 ignore((
869 kind_attribute_pred(Kind,Prop,Pred),
870 modulize(call(Pred,Obj,_),OPred),predicate_property(OPred,dynamic),
871 forall(clause(OPred,true,Ref),erase(Ref)))).
872
874
875
876delete_obj(Obj):-
877 obj_properties(Obj,Props),!,
878 maplist(delete_opvalues(Obj),Props).
879delete_obj(Obj):-
880 always(\+ is_list(Obj);Obj==[]),
881 ignore(forall(retract(soops:o_p_v(Obj,_,_)),true)).
882
883
884obj_properties(Obj,Props):-
885 findall(Prop,get_opv_i(Obj,Prop,_),Props).
886
887modulize(call(Pred,Obj,Val),OPred):- IPred=..[Pred,Obj,Val],!,modulize(IPred,OPred).
888modulize(O:Pred,O:Pred):-!.
889modulize(Pred,M:Pred):-predicate_property(Pred,imported_from(M)),!.
890modulize(Pred,M:Pred):-predicate_property(Pred,module(M)),!.
891modulize(Pred,Pred).
892
893
894wl:symbol_has_prop_set_get(sys_xx_global_env_var_xx,claz_environment, set_global_env, global_env).
895wl:symbol_has_prop_set_get(sys_xx_env_var_xx,claz_environment, set_current_env, current_env).
896
897wl:symbol_has_prop_getter(Sym,symbol_value,prolog_direct(Getter/1)):- wl:symbol_has_prop_set_get(Sym,_,_Setter,Getter).
898wl:symbol_has_prop_setter(Sym,symbol_value,prolog_direct(Setter/1)):- wl:symbol_has_prop_set_get(Sym,_,Setter,_Getter).
901
902prolog_direct(Pred/1,_Obj,_Prop,Value):- call(Pred,Value).
903prolog_direct(Pred/2,Obj,_Prop,Value):- call(Pred,Obj,Value).
904prolog_direct(Pred/3,Obj,Prop,Value):- call(Pred,Obj,Prop,Value).
905
906
907:- dynamic(cache:is_kind_innited/1). 908
909ensure_opv_type_inited(Kind):- cache:is_kind_innited(Kind),!.
910ensure_opv_type_inited(Kind):-
911 asserta(cache:is_kind_innited(Kind)),!,
912 get_deftype(Kind,DefType),
913 findall(Slot,soops:struct_opv(Kind,name,Slot,_),Slots),add_class_slots(DefType,Kind,1,Slots).
914
915get_deftype(Kind,DefType):- (is_structure_classp(Kind) -> DefType=defstruct; DefType=defclass).
916
917add_class_slots(DefType,Kind,N,[Slot|Slots]):- !,
918 always((add_slot_def(DefType,N,Kind,Slot),N1 is N + 1,
919 add_class_slots(DefType,Kind,N1,Slots))).
920add_class_slots(_DefType,_Type,_N,[]).
921
922list_oddp(Keys):- always(length(Keys,Len)), is_oddp(Len).
923
924add_slot_def(_DefType,N,Kind,Prop):- atom(Prop),!,add_slot_def_props(N,Kind,Prop,[]).
925
926add_slot_def(defstruct,N,Kind,[Prop,Default|Keys]):-
927 add_slot_def_props(N,Kind,Prop,[sys_initform,Default|Keys]).
928
929add_slot_def(_Defclass,N,Kind,[Prop,Default|Keys]):- \+ list_oddp(Keys),
930 add_slot_def_props(N,Kind,Prop,[Default|Keys]).
931add_slot_def(_DefType,N,Kind,[Prop|Keys]):- add_slot_def_props(N,Kind,Prop,Keys).
932
933add_slot_def_props(N,Kind,SlotSym,MoreInfo):-
934 always((gen_slot_name('',Kind,SlotSym,ZLOT),
935 assert_struct_opv4(Kind,name,SlotSym,ZLOT),
936 to_prolog_string_anyways(SlotSym,SName),
937
938 create_keyword(SName,KW),
939 assert_struct_opv4(Kind,initargs,[KW],ZLOT),
940
946 947 948 949
950 951 952 ignore((nonvar(N),(assert_struct_opv4(Kind,sys_slot_definition_location,N,ZLOT)))),
953 ignore((kind_attribute_pred(Kind,SlotSym,Pred),assert_struct_opv4(Kind,kw_accessor_predicate,Pred,ZLOT))),
954 add_slot_more_info(SlotSym,Kind,ZLOT,MoreInfo))).
955
956is_slot_name(KW):- \+ is_list(KW).
957
958add_slot_more_info(_SlotKW,_Kind,_SlotInfo,[]):-!.
959add_slot_more_info(_SlotKW,_Kind,_SlotInfo,[[]]):-!.
960add_slot_more_info(SlotName,Kind,ZLOT,[KW,Value|MoreInfo]):- is_slot_name(KW),
961 assert_slot_prop(SlotName,Kind,KW,Value,ZLOT),!,
962 add_slot_more_info(SlotName,Kind,ZLOT,MoreInfo).
963
964add_slot_more_info(SlotName,Kind,ZLOT,[[Default,KW,Value]]):- is_slot_name(KW),
965 assert_slot_prop(SlotName,Kind,sys_initform,Default,ZLOT),!,
966 assert_slot_prop(SlotName,Kind,KW,Value,ZLOT),!.
967
968
969add_slot_more_info(SlotName,Kind,ZLOT,[[KW,Value]|MoreInfo]):- is_slot_name(KW),
970 assert_slot_prop(SlotName,Kind,KW,Value,ZLOT),!,
971 add_slot_more_info(SlotName,Kind,ZLOT,MoreInfo).
972
973add_slot_more_info(SlotName,Kind,ZLOT,[[Value]]):-
974 assert_slot_prop(SlotName,Kind,sys_initform,Value,ZLOT),!.
975
976assert_slot_prop(_SlotName,Kind,KW,Value,ZLOT):-
977 atom_concat_or_rtrace('kw_',Base,KW),atom_concat_or_rtrace('sys_',Base,Prop),!,
978 assert_struct_opv4(Kind,Prop,Value,ZLOT).
979assert_slot_prop(_SlotName,Kind,Prop,Value,ZLOT):-
980 981 assert_struct_opv4(Kind,Prop,Value,ZLOT).
982
983
984
985prop_to_name(X,S):-string(X),!,X=S.
986prop_to_name(Prop,Upper):- to_prolog_string_if_needed(Prop,F),!,prop_to_name(F,Upper).
987prop_to_name(Prop,Upper):- to_prolog_string_anyways(Prop,Upper),!.
988prop_to_name(Prop,Upper):- claz_to_symbol(Prop,Key),
989 atomic_list_concat(List,'_',Key),atomic_list_concat(List,'-',Lower),string_upper(Lower,Upper).
990
991get_opv_else(Obj,Prop,Value,Else):- get_opv(Obj,Prop,Value)*->true;Else.
992
993
994:- dynamic(wl:type_attribute_pred_dyn/3). 995
997decl_mapped_opv(Kind,Maps):- is_list(Maps),!,maplist(decl_mapped_opv(Kind),Maps).
998decl_mapped_opv(Kind,Prop=Pred):-
999 assertz(wl:interned_eval(call(assert_lsp(wl:type_attribute_pred_dyn(Kind,Prop,Pred))))),
1000 nop(modulize(call(Pred,Obj,Val),OPred)),
1001 nop(assertz(wl:interned_eval(call(forall(OPred,add_opv_new(Obj,Prop,Val)))))),
1002 nop(assert_lsp((OPred:- (is_kind(Obj,Kind),(fail->!;true),get_opv(Obj,Prop,Val))))).
1003
1004is_kind(O,_K):- nonvar(O).
1005
1006kind_attribute_pred(Kind,Prop,Pred):- wl:type_attribute_pred_dyn(Kind,Prop,Pred).
1007
1008
1011
1012
1013
1014
1015
1016
1017:- discontiguous soops:struct_opv/3. 1018:- discontiguous soops:struct_opv/4. 1019:- dynamic((soops:struct_opv/3)). 1020:- dynamic((soops:struct_opv/4)). 1021:- multifile((soops:struct_opv/3)). 1022:- multifile((soops:struct_opv/4)). 1023:- soops:ensure_loaded('ci.data'). 1024cleanup_mop:-
1025 ignore((get_struct_opv(X,kw_include,claz_object),get_struct_opv(X,kw_include,Y),Y\==claz_object,show_call_trace(retract(soops:struct_opv(X,kw_include,claz_object))),fail)),
1026 ignore((get_struct_opv(X,kw_include,claz_t),get_struct_opv(X,kw_include,Y),Y\==claz_t,show_call_trace(retract(soops:struct_opv(X,kw_include,claz_t))),fail)).
1027
1028save_mop:- cleanup_mop,tell('ci3.data'),
1029 forall(member(Assert,[struct_opv(_,P,_),struct_opv(_,P,_,_)]),
1030 forall(soops:Assert,
1031 ignore((P\==slot1,P\==has_slots,format('~q.~n',[Assert]))))), told.
1032:- style_check(-discontiguous). 1033
1034make_soops_old:- cleanup_mop,tell('si2.data'),
1035 forall(member(Assert,[o_p_v(_,_,_)]),
1036 forall(clause(soops:Assert,true),
1037 ignore((P\==slot1,P\==has_slots,format('~q.~n',[Assert]))))), told.
1038
1039cleanup_opv0:-
1040 doall(retract(soops:o_p_v(Obj,compile_as,kw_function))),
1041 doall((
1042 get_opv_iiii(Obj,compile_as,kw_special),
1043 get_opv_iiii(Obj,function,Was),
1044 atom_concat_or_rtrace('m',Was,WillBe),
1045 assert_if_new(soops:o_p_v(Obj,symbol_function,WillBe)),
1046 retract(soops:o_p_v(Obj,function,Was)),
1047 retract(soops:o_p_v(Obj,compile_as,kw_special)),
1048 doall(retract(soops:o_p_v(Obj,compile_as,kw_special))))).
1049
1050cleanup_opv:-
1051 doall((
1052 get_opv_iiii(Was,type_of,macro),
1053 atom_concat_or_rtrace('m',Was,WillBe),
1054 assert_if_new(soops:o_p_v(WillBe,type_of,macro)),
1055 doall(retract(soops:o_p_v(Was,type_of,macro))))).
1056
1057
1058
1059save_syms:-
1060 make_soops_old,
1061 save_soops,
1062 save_pi.
1063
1064save_soops:-
1065 tell('si3.data'),
1066 forall(get_opv_iiii(Obj,Prop,Value),
1067 once(write_o_p_v(Obj,Prop,Value))),
1068 told.
1069
1070write_o_p_v(_,_,Value):- var(Value).
1071write_o_p_v(_,extra_info_proclaimed,[]).
1072write_o_p_v(_,extra_info_deftype,[]).
1073write_o_p_v(_,extra_info,[]).
1074write_o_p_v(Obj,doc_deftype,[String,Def]):-write_o_p_v(Obj,doc_deftype,String),write_o_p_v(Obj,result_deftype,Def).
1075write_o_p_v(_,ref,_).
1076write_o_p_v(Obj,extra_info(_),List):-!,maplist(write_o_p_t(Obj),List).
1077write_o_p_v(Obj,result_type(ecl2),WAS):- get_opv_iiii(Obj,result_type(sbcl),WAS).
1078write_o_p_v(Obj,lambda_list(ecl2),WAS):- get_opv_iiii(Obj,lambda_list(sbcl),WAS).
1079write_o_p_v(Obj,result_type(ecl2),number):- write_o_p_v(Obj,result_type(sbcl),sys_irrational).
1080
1081write_o_p_v(Obj,lambda_list(sbcl),WAS):- write_o_p_v(Obj,lambda_list,WAS).
1082write_o_p_v(Obj,result_type(sbcl),WAS):- write_o_p_v(Obj,result_type,WAS).
1083
1084write_o_p_v(Obj,Prop,Value):- format('~q.~n',[o_p_v(Obj,Prop,Value)]).
1085write_o_p_t(Obj,Prop):- format('~q.~n',[o_p_v(Obj,Prop,t)]).
1086
1087:- multifile o_p_v/3. 1088:- dynamic o_p_v/3. 1089:- multifile c_p_v/3. 1090:- dynamic c_p_v/3. 1091
1092load_si:-
1093 open('si.data',read,Stream),
1094 repeat,
1095 read_term(Stream,Value,[]),
1096 (Value==end_of_file->!;
1097 (load_si_value(Value),fail)).
1098load_si_value(Value):- assert_lsp(Value).
1099
1100process_si:-
1101 ensure_loaded(packages),
1102 doall((
1103 clause(soops:o_p_v(X,Y,Z),true,Ref),
1104 process_si(soops:o_p_v(X,Y,Z)),
1105 erase(Ref))).
1106
1108process_si(soops:o_p_v(X,Y,Z)):- X\==[], set_opv(X,Y,Z).
1109
1110:- if(true). 1111:- soops:ensure_loaded('si.data'). 1112:- else. 1113:- load_si. 1114:- endif. 1115
1118
1119:- fixup_exports.