/* File: flrcompiler.P -- The Flora Compiler
**
** Author(s): Guizhen Yang
**
** Contact: flora-users@lists.sourceforge.net
**
** Copyright (C) The Research Foundation of SUNY, 1999-2001
**
** FLORA-2 is free software; you can redistribute it and/or modify it under the
** terms of the GNU Library General Public License as published by the Free
** Software Foundation; either version 2 of the License, or (at your option)
** any later version.
**
** FLORA-2 is distributed in the hope that it will be useful, but WITHOUT ANY
** WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
** FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for
** more details.
**
** You should have received a copy of the GNU Library General Public License
** along with FLORA-2; if not, write to the Free Software Foundation,
** Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
**
** $Id: flrcompiler.P,v 1.58 2003/06/18 07:01:37 kifer Exp $
**
*/
:- compiler_options([xpp_on]).
#include "flora_errors.flh"
#include "flora_terms.flh"
#include "flora_porting.flh"
#define NEWVAR newvar
#define NEWPREDICATE newpredicate
#define NEWOID FL_NEWOID_SYM
#define RULE_NUM rule_num
#define NEWOID_COUNT FL_NEWOID_PREFIX
#define TMPDIRECT tmpdirect
#define TMPOPTION tmpoption
%% ruleoid is used for numbered anonymous oid generation
:- dynamic ruleoid(_,_,_).
:- dynamic TMPDIRECT(_).
:- dynamic TMPOPTION(_).
:- index(TMPDIRECT/1,trie).
:- index(TMPOPTION/1,trie).
/****************************************************************************
utilities
****************************************************************************/
is_flrule(FLRULE(Head,Body),Head,Body).
is_flfact(FLFACT(Head),Head).
is_flquery(FLQUERY(Body),Body).
is_fldirective(FLDIRECTIVE(DirectList),DirectList).
is_fldynrule(FLDYNRULE(Head,Body),Head,Body).
is_flcommand(FLCOMMAND(C),C).
is_fltable(FLTABLE(P,A),P,A).
is_fltable(FLTABLE(M,P,A),M,P,A).
is_flopdef(FLOPDEF(P,A,O),P,A,O).
%%is_flarguments(FLARGUMENTS(F,N,Args),F,N,Args).
is_flprolog(FLPROLOG(F,N),F,N).
is_flindex(FLINDEX(A,P),A,P).
is_flequality(FLEQUALITY(A),A).
is_flcmpopt(FLCMPOPT(OptList),OptList).
%% These two are used for the build process only--want to get rid of them
is_flconjunct(FLCONJUNCT(L,R),L,R).
is_fldisjunct(FLDISJUNCT(L,R),L,R).
is_flnot(FLNOT(Goal),Goal).
is_fltnot(FLTNOT(Goal),Goal).
is_flload(FLLOAD(LoadList),LoadList).
is_flconstraint(FLCONSTRAINT(ConstrBody),ConstrBody).
%% @module
is_flworkspace(FLWORKSPACE(P,WS),P,WS).
%% @flora(module)
is_flfloralib(FLFLORALIB(P,M),P,M).
%% @prolog(M) and @prolog()
is_flplib(FLPLIB(P,M),P,M).
is_flplib(FLPLIB(P),P).
%% @prologall() and @prologall(module)
%% Make sure the coder translates P2H_PREDICATE/4 as prolog
is_flpliball(FLPLIBALL(P),P) :-
flora_define_prolog(P2H_PREDICATE,4).
is_flpliball(FLPLIBALL(P,M),P,M) :-
flora_define_prolog(P2H_PREDICATE,4).
is_flifthenelse(FLIFTHENELSE(Cond,Then,Else),Cond,Then,Else).
is_flifthen(FLIFTHEN(Cond,Then),Cond,Then).
%% Meta ~
is_fluniveqform(FLUNIVEQFORM(Left,Right),Left,Right).
%% Meta =..
is_flmetauniv(FLMETAUNIV(Left,Right),Left,Right).
%% Meta ~..
is_flmetaunivform(FLMETAUNIVFORM(Left,Right),Left,Right).
is_reifyop(FLREIFYOP(Formula),Formula).
%% Control constructs while-do, while-loop, loop-until, do-until,unless-do
is_flcontrolconstruct(FLWHILEDO(Cond,Action),FLLIBWHILEDO,Cond,Action).
is_flcontrolconstruct(FLWHILELOOP(Cond,Action),FLLIBWHILELOOP,Cond,Action).
is_flcontrolconstruct(FLDOUNTIL(Cond,Action),FLLIBDOUNTIL,Cond,Action).
is_flcontrolconstruct(FLLOOPUNTIL(Cond,Action),FLLIBLOOPUNTIL,Cond,Action).
is_flcontrolconstruct(FLUNLESSDO(Cond,Action),FLLIBUNLESSDO,Cond,Action).
is_flterm(FLTERM(Funct,Arity,Args),Funct,Arity,Args).
is_flinsert(FLINSERT(Op,List,Cond),Op,List,Cond).
is_flinsert(FLINSERT(Op,List),Op,List).
is_fldelete(FLDELETE(Op,List,Cond),Op,List,Cond).
is_fldelete(FLDELETE(Op,List),Op,List).
is_fltablerefresh(FLREFRESH(List),List).
is_flcatch(FLCATCH(Goal,Error,Handler),Goal,Error,Handler).
is_flthrow(FLTHROW(Error),Error).
is_flp2h(FLP2H(Prolog,Hilog),Prolog,Hilog).
%% Op is needed for newmodule only because of its position information
is_flnewmodule(FLNEWMODULE(Op,ModList),Op,ModList).
is_flupdaterule(FLUPDATERULE(Op,RuleList),Op,RuleList).
is_flaggregate(FLAGGREGATE(Op,V,GV,Goal),Op,V,GV,Goal).
%% Binary relationship, like : or ::
is_flbirelate(FLBIRELATE(Obj1,RelType,Obj2),Obj1,RelType,Obj2).
is_flobjspec(FLOBJSPEC(Obj,Spec),Obj,Spec).
%% Represents object reference: O.M, O..M, O!M, O!!M. RefType is ->, ->>, ...
is_flobjref(FLOBJREF(Obj,RefType,Att),Obj,RefType,Att).
%% RefType represents the arrow type: ->, *->, ->, =>>, ...
is_flfdattspec(FLFDATTSPEC(Att,RefType,Val),Att,RefType,Val).
is_flmvdattspec(FLMVDATTSPEC(Att,RefType,Val),Att,RefType,Val).
is_flincattspec(FLINCATTSPEC(Att,RefType,Val),Att,RefType,Val).
is_fltolistattspec(FLTOLISTATTSPEC(Att,RefType,Val),Att,RefType,Val).
is_flmethspec(FLMETHSPEC(Meth),Meth).
is_flimethspec(FLIMETHSPEC(IMeth),IMeth).
is_fltranspec(FLTRANSPEC(Tran),Tran).
is_flobjeql(FLOBJEQL(O1,O2),O1,O2).
is_flcut(FLCUT(I),I).
%% basic building blocks
is_flatom(FLATOM(Atom,_I),Atom).
is_flatom(FLATOM(Atom,Index),Atom,Index).
is_flnumber(FLNUMBER(Number,_I),Number).
is_flstring(FLSTRING(String,_I),String).
is_fltoken(FLTOKEN(Token,I),Token,I).
is_fltoken(FLTOKEN(Token,Num,I),Token,Num,I).
is_flvar(FLVAR(Name,Index),Name,Index).
is_fllist(FLLIST(L,T,I),L,T,I).
is_isaspecop(FL_ISA).
is_subspecop(FL_SUB).
is_fdrefop(FL_FD).
is_ifdrefop(FL_INHERIFD).
is_mvdrefop(FL_MVD).
is_imvdrefop(FL_INHERIMVD).
is_fdspecop(FL_FDARROW).
is_ifdspecop(FL_INFDARROW).
is_mvdspecop(FL_MVDARROW).
is_imvdspecop(FL_INMVDARROW).
is_fdsigspecop(FL_FDSIGARROW).
is_mvdsigspecop(FL_MVDSIGARROW).
is_mvdincspecop(FL_ALLINARROW).
is_imvdincspecop(FL_INALLINARROW).
is_mvdtolistspecop(FL_TOLISTARROW).
is_imvdtolistspecop(FL_INTOLISTARROW).
is_ifdsigspecop(FL_INFDSIGARR).
is_imvdsigspecop(FL_INMVDSIGARR).
/****************************************************************************
approximate_index(+ParserTerm,-Index)
It takes a term output from the parser and returns the main index. This
routine is called when an oid reference is compiled. Since a new variable
needs to be generated, this main index will represent the textual information
that corresponds to this new variable.
Ideally, this procedure should always succeed with a meaningful index,
since the input is a structure from the parser and corresponds to a
piece of text in the program file.
This procedure should be called for a syntax in an oid position.
****************************************************************************/
approximate_index(FLATOM(_Atom,I),I) :- !.
approximate_index(FLNUMBER(_Number,I),I) :- !.
approximate_index(FLSTRING(_String,I),I) :- !.
approximate_index(FLTOKEN(_Token,I),I) :- !.
approximate_index(FLTOKEN(_Token,_Num,I),I) :- !.
approximate_index(FLVAR(_Name,I),I) :- !.
approximate_index(FLLIST(_List,_T,I),I) :- !.
approximate_index(FLTERM(F,_A,_Args),I) :- !, approximate_index(F,I).
approximate_index(FLBIRELATE(Obj1,_Rel,_Obj2),I) :- !, approximate_index(Obj1,I).
approximate_index(FLOBJSPEC(Obj,_Spec),I) :- !, approximate_index(Obj,I).
approximate_index(FLOBJREF(Obj,_Ref,_Att),I) :- !, approximate_index(Obj,I).
approximate_index(FLAGGREGATE(Op,_V,_GV,_Goal),I) :- !, approximate_index(Op,I).
approximate_index(FLPLIB(P,_M),I) :- !, approximate_index(P,I).
approximate_index(FLPLIB(P),I) :- !, approximate_index(P,I).
approximate_index(FLFLORALIB(P,_M),I) :- !, approximate_index(P,I).
approximate_index(FLWORKSPACE(P,_WS),I) :- !, approximate_index(P,I).
approximate_index(FLINSERT(Op,_List,_Cond),I) :- !, approximate_index(Op,I).
approximate_index(FLINSERT(Op,_List),I) :- !, approximate_index(Op,I).
approximate_index(FLDELETE(Op,_List,_Cond),I) :- !, approximate_index(Op,I).
approximate_index(FLDELETE(Op,_List),I) :- !, approximate_index(Op,I).
/****************************************************************************
encoding utilities
****************************************************************************/
rule_struct(Head,Body,PRRULE(Head,Body)).
fact_struct(Head,PRFACT(Head)).
query_struct(Goal,PRQUERY(Goal)).
directive_struct(Direct,PRDIRECTIVE(Direct)).
dynrule_struct(Head,Body,HVars,BVars,PRDYNRULE(Head,Body,HVars,BVars)).
reify_struct(Formula,PRREIFY(Formula)).
command_struct(C,PRCOMMAND(C)).
table_struct(F,N,PRTABLE(F,N)).
%% We keep the import directive's support mechanism for @prolog(module)
import_struct(F,N,M,PRIMPORT(F,N,M)).
cmpopt_struct(OptList,PRCMPOPT(OptList)).
/****************************************************************************
conjunct_struct(+Goal1,+Goal2,-Code)
disjunct_struct(+Goal1,+Goal2,-Code)
not_struct(+Goal,-Code)
tnot_struct(+Goal,-Code)
****************************************************************************/
conjunct_struct(Goal1,Goal2,PRAND(Goal1,Goal2)).
disjunct_struct(Goal1,Goal2,PROR(Goal1,Goal2)).
not_struct(Goal,PRNOT(Goal)).
tnot_struct(Goal,PRTNOT(Goal)) :-
import_struct((FLORA_TNOT_PREDICATE),1,(flrnegation),ICode),
directive_struct(ICode,DCode),
report_directive(DCode).
/****************************************************************************
conjunct_code(+GoalList,-Code)
Takes a list of goals and constructs a conjunct:
prand(G1, prand(G2, G3))
Discards NULLs
If all are NULLs, returns NULL.
****************************************************************************/
conjunct_code([Goal],Goal).
conjunct_code([NULL|GList],ConjGoal) :- !, conjunct_code(GList,ConjGoal).
conjunct_code([Goal|GList],ConjGoal) :-
conjunct_code(GList,ConjGoalTail),
( ConjGoalTail == NULL ->
ConjGoal=Goal
;
conjunct_struct(Goal,ConjGoalTail,ConjGoal)
).
/****************************************************************************
encoding routines
Note: Only primitive structures (atoms, variables, numbers, strings, lists,
newoids, and cuts) encode the index to the corresponding textual
information. The compiler directives do not encode any textual
information. However, not all primitive structures have a meaningful
index, for instance, new variables that are generated for an oid
reference. In this case, an index is approximated. In some other
cases, an atom is generated to encode an internal structure. So there
is no meaningful index. Then the macro NO_INDEX is encoded as a
place holder. No textual information should be inferred from the
NO_INDEX value.
****************************************************************************/
%% basic structures
atomobj_struct(FLATOM(Atom,I),PRATOM(Atom,I)) :- !.
atomobj_struct(Atom,PRATOM(Atom,NO_INDEX)) :- atomic(Atom).
atomobj_struct(Atom,Index,PRATOM(Atom,Index)).
atomlit_struct(FLATOM(Atom,I),PRATOMLIT(Atom,I)).
numobj_struct(FLNUMBER(Number,I),PRNUMBER(Number,I)).
varobj_struct(Name,Index,PRVARIABLE(Name,Index)).
strobj_struct(FLSTRING(String,I),PRSTRING(String,I)).
newoid_struct(Oid,Index,PRNEWOID(Oid,Index)).
cut_struct(Index,PRCUT(Index)).
list_struct(List,Term,Index,PRLIST(List,Term,Index)).
list_struct(List,Term,PRLIST(List,Term,NO_INDEX)).
workspace_struct(P,WS,PRWORKSPACE(P,WS)).
newpredicate_struct(Name,N,Args,PRNEWPRED(Name,N,Args)).
thismodule_struct(PRTHISMODULE(PRTHISMODULE)).
thisstorage_struct(fdb,PRTHISFDBSTORAGE(PRTHISFDBSTORAGE)).
%% support for checking undefinedness
thisstorage_struct(fld,PRTHISFLDSTORAGE(PRTHISFLDSTORAGE)).
floralib_struct(WS,PRFLORALIB(WS)).
storage_struct(WS,PRFDBSTORAGE(WS)).
call_struct(VarName,Index,PRCALL(Var)) :- varobj_struct(VarName,Index,Var).
termlit_struct(FObj,N,ObjList,PRTERMLIT(FObj,N,ObjList)).
workspacelit_struct(P,WS,Code) :-
(is_flvar(WS,WSVarName,Index) ->
varobj_struct(WSVarName,Index,WSVarCode),
%% a call to a Flora user module
florasyslib_struct(FLLIBMODLIT,2,[P,WSVarCode],Code)
%% X@module of X@flora(module)
; is_varobj_struct(P) ->
(is_flatom(WS,WSAtom,Index) -> atomobj_struct(WSAtom,Index,WSCode)
%% ...@ _@
; is_fltoken(WS,FL_THISMODULE,_) -> thismodule_struct(WSCode)
; WSCode = WS % if system module then it is already compiled
),
%% a call to a module
florasyslib_struct(FLLIBMODLIT,2,[P,WSCode],Code)
; is_flatom(WS,WSAtom,Index) ->
atomobj_struct(WSAtom,Index,WSCode),
workspace_struct(P,WSCode,Code)
; is_fltoken(WS,FL_THISMODULE,_) ->
thismodule_struct(WSCode),
workspace_struct(P,WSCode,Code)
;
%% a Flora system module
workspace_struct(P,WS,Code)
).
workspaceobj_struct(P,WS,Object,Code) :-
(is_flvar(WS,WSVarName,Index) ->
varobj_struct(WSVarName,Index,WSVarCode),
new_varobj(Index,Object),
%% code to construct the object for foo@X in arg position,
%% i.e., p(foo@X)
florasyslib_struct(FLLIBMODOBJ,3,[P,WSVarCode,Object],Code)
; is_varobj_struct(P) ->
(is_flatom(WS,WSAtom,Index) -> atomobj_struct(WSAtom,Index,WSCode)
; is_fltoken(WS,FL_THISMODULE,_) -> thismodule_struct(WSCode)
; WSCode = WS % if system module then it is already compiled
),
new_varobj(Index,Object),
%% code to construct the object for X@... in arg position,
%% i.e., p(X@...)
florasyslib_struct(FLLIBMODOBJ,3,[P,WSCode,Object],Code)
; is_flatom(WS,WSAtom,Index) ->
atomobj_struct(WSAtom,Index,WSCode),
workspace_struct(P,WSCode,Object),
Code=NULL
; is_fltoken(WS,FL_THISMODULE,_) ->
thismodule_struct(WSCode),
workspace_struct(P,WSCode,Object),
Code=NULL
;
%% a Flora system module
Code=NULL,
workspace_struct(P,WS,Object)
).
prologterm_struct(F,N,Args,PROLOGTERM(F,N,Args)).
prologliblit_struct(PrologTerm,PROLOGLIBLIT(PrologTerm)).
%% Not all Flora system libraries encode textual information. Only
%% those for aggregates and DB updates do.
florasyslib_struct(F,N,Args,FLORASYSLIB(NO_INDEX,F,N,Args)) :- report_option(FLSYSLIB(F)).
florasyslib_struct(Index,F,N,Args,FLORASYSLIB(Index,F,N,Args)) :- report_option(FLSYSLIB(F)).
is_florasyslib_struct(FLORASYSLIB(I,F,N,Args), I,F,N,Args).
termobj_struct(FObj,N,ObjList,PRTERM(FObj,N,ObjList)).
%% catch{...,...,...}
catch_struct(Goal,Error,Handler,Code) :-
florasyslib_struct(FLLIBCATCH,3,[Goal,Error,Handler],Code).
%% throw{...}
throw_struct(Error,Code) :-
florasyslib_struct(FLLIBTHROW,1,[Error],Code).
%% p2h{...}
p2h_struct(Prolog,Hilog,Code) :-
atomobj_struct(P2H_PREDICATE,P2HCode),
prologterm_struct(P2HCode,4,[Prolog,Hilog,WRAP_HILOG,P2H_DONOT_UNIFY_VARS],Code).
insert_struct(Op,List,Cond,Code) :-
%% Index denotes the textual information for the insert
%% operator and represents the textual information for the
%% entire insert statement.
is_flatom(Op,OpAtom,Index),
insert_syslib(OpAtom,Lib),
florasyslib_struct(Index,Lib,2,[List,Cond],Code).
insert_struct(Op,List,Code) :-
%% Index denotes the textual information for the insert
%% operator and represents the textual information for the
%% entire insert statement.
is_flatom(Op,OpAtom,Index),
insert_syslib(OpAtom,Lib),
florasyslib_struct(Index,Lib,1,[List],Code).
delete_struct(Op,List,Cond,Code) :-
%% Index denotes the textual information for the delete
%% operator and represents the textual information for the
%% entire delete statement.
is_flatom(Op,OpAtom,Index),
delete_syslib(OpAtom,Lib),
florasyslib_struct(Index,Lib,2,[List,Cond],Code).
delete_struct(Op,List,Code) :-
%% Index denotes the textual information for the delete
%% operator and represents the textual information for the
%% entire delete statement.
is_flatom(Op,OpAtom,Index),
delete_syslib(OpAtom,Lib),
florasyslib_struct(Index,Lib,1,[List],Code).
table_refresh_struct(List,Code) :-
florasyslib_struct(FLLIBREFRESH,1,[List],Code).
insert_syslib(FL_INSERT,FLLIBINSERT) :- !.
insert_syslib(FL_INSERTALL,FLLIBINSERTALL) :- !.
insert_syslib(FL_BTINSERT,FLLIBBTINSERT) :- !.
insert_syslib(FL_BTINSERTALL,FLLIBBTINSERTALL) :- !.
delete_syslib(FL_DELETE,FLLIBDELETE) :- !.
delete_syslib(FL_DELETEALL,FLLIBDELETEALL) :- !.
delete_syslib(FL_ERASE,FLLIBERASE) :- !.
delete_syslib(FL_ERASEALL,FLLIBERASEALL) :- !.
delete_syslib(FL_BTDELETE,FLLIBBTDELETE) :- !.
delete_syslib(FL_BTDELETEALL,FLLIBBTDELETEALL) :- !.
delete_syslib(FL_BTERASE,FLLIBBTERASE) :- !.
delete_syslib(FL_BTERASEALL,FLLIBBTERASEALL) :- !.
updaterule_syslib(FL_INSERTRULE_A,FLLIBINSERTRULE_A) :- !.
updaterule_syslib(FL_INSERTRULE_Z,FLLIBINSERTRULE_Z) :- !.
updaterule_syslib(FL_DELETERULE_A,FLLIBDELETERULE_A) :- !.
updaterule_syslib(FL_DELETERULE_Z,FLLIBDELETERULE_Z) :- !.
updaterule_syslib(FL_DELETERULE,FLLIBDELETERULE) :- !.
aggregate_struct(Op,V,GV,B,Object,Code) :-
%% Index denotes the textual information for the aggregate
%% operator and represents the textual information for the
%% entire aggregate statement.
is_flatom(Op,OpAtom,Index),
aggregate_syslib(OpAtom,Lib),
new_varobj(Index,Object),
( GV == [] ->
florasyslib_struct(Index,Lib,3,[V,B,Object],Code)
;
florasyslib_struct(Index,Lib,4,[V,GV,B,Object],Code)
),
!.
aggregate_syslib(FL_MIN,FLLIBMIN) :- !.
aggregate_syslib(FL_MAX,FLLIBMAX) :- !.
aggregate_syslib(FL_SUM,FLLIBSUM) :- !.
aggregate_syslib(FL_AVG,FLLIBAVG) :- !.
aggregate_syslib(FL_COUNT,FLLIBCOUNT) :- !.
aggregate_syslib(FL_COLLECTSET,FLLIBCOLLECTSET) :- !.
aggregate_syslib(FL_COLLECTBAG,FLLIBCOLLECTBAG) :- !.
objexists_struct(Obj,PREXISTS(Obj)).
birelate_struct(Obj1,RelType,Obj2,Code) :-
( is_isaspecop(RelType) ->
isaspec_struct(Obj1,Obj2,Code)
;
is_subspecop(RelType),
subspec_struct(Obj1,Obj2,Code)
).
isaspec_struct(Obj1,Obj2,PRISA(Obj1,Obj2)).
subspec_struct(Obj1,Obj2,PRSUB(Obj1,Obj2)).
fdattspec_struct(Object,AttObj,RefType,ValObj,Code) :-
(
is_fdspecop(RefType) ->
fdspec_struct(Object,AttObj,ValObj,Code)
; is_ifdspecop(RefType) ->
ifdspec_struct(Object,AttObj,ValObj,Code)
).
fdspec_struct(Object,AttObj,ValObj,PRFD(Object,AttObj,ValObj)).
ifdspec_struct(Object,AttObj,ValObj,PRIFD(Object,AttObj,ValObj)).
%% This is called when someting like a.b[] is compiled.
objattdef_struct(Obj,RefType,Att,Code) :-
( is_fdrefop(RefType) ->
fddef_struct(Obj,Att,Code)
; is_ifdrefop(RefType) ->
ifddef_struct(Obj,Att,Code)
; is_mvdrefop(RefType) ->
mvddef_struct(Obj,Att,Code)
;
is_imvdrefop(RefType),
imvddef_struct(Obj,Att,Code)
).
%% This is for ->>, *->>, =>, *=>, =>>, *=>> when the attribute is defined,
%% but its value is empty set
mvdattdef_struct(Object,AttObj,RefType,Code) :-
( is_mvdspecop(RefType) ->
mvddef_struct(Object,AttObj,Code)
;
is_imvdspecop(RefType),
imvddef_struct(Object,AttObj,Code)
; is_mvdsigspecop(RefType) ->
mvdsigdef_struct(Object,AttObj,Code)
; is_imvdsigspecop(RefType) ->
imvdsigdef_struct(Object,AttObj,Code)
; is_fdsigspecop(RefType) ->
fdsigdef_struct(Object,AttObj,Code)
; is_ifdsigspecop(RefType) ->
ifdsigdef_struct(Object,AttObj,Code)
).
fddef_struct(Object,AttObj,PRFDDEF(Object,AttObj)).
ifddef_struct(Object,AttObj,PRIFDDEF(Object,AttObj)).
mvddef_struct(Object,AttObj,PRMVDDEF(Object,AttObj)).
imvddef_struct(Object,AttObj,PRIMVDDEF(Object,AttObj)).
mvdsigdef_struct(Object,AttObj,PRMVDSIGDEF(Object,AttObj)).
imvdsigdef_struct(Object,AttObj,PRIMVDSIGDEF(Object,AttObj)).
fdsigdef_struct(Object,AttObj,PRFDSIGDEF(Object,AttObj)).
ifdsigdef_struct(Object,AttObj,PRIFDSIGDEF(Object,AttObj)).
mvdattspec_struct(Object,AttObj,RefType,ValObj,Code) :-
(
is_mvdspecop(RefType) ->
mvdspec_struct(Object,AttObj,ValObj,Code)
; is_imvdspecop(RefType) ->
imvdspec_struct(Object,AttObj,ValObj,Code)
; is_mvdsigspecop(RefType) ->
mvdsigspec_struct(Object,AttObj,ValObj,Code)
; is_imvdsigspecop(RefType) ->
imvdsigspec_struct(Object,AttObj,ValObj,Code)
%% Note: => and *=> are permitted to have multiple values
%% (semantics is intersection)
; is_fdsigspecop(RefType) ->
fdsigspec_struct(Object,AttObj,ValObj,Code)
; is_ifdsigspecop(RefType) ->
ifdsigspec_struct(Object,AttObj,ValObj,Code)
).
mvdspec_struct(Object,AttObj,ValObj,PRMVD(Object,AttObj,ValObj)).
imvdspec_struct(Object,AttObj,ValObj,PRIMVD(Object,AttObj,ValObj)).
mvdsigspec_struct(Object,AttObj,ValObj,PRMVDSIG(Object,AttObj,ValObj)).
imvdsigspec_struct(Object,AttObj,ValObj,PRIMVDSIG(Object,AttObj,ValObj)).
fdsigspec_struct(Object,AttObj,ValObj,PRFDSIG(Object,AttObj,ValObj)).
ifdsigspec_struct(Object,AttObj,ValObj,PRIFDSIG(Object,AttObj,ValObj)).
%% for +>> and *+>>
incattspec_struct(Object,AttObj,RefType,ValObj,Code) :-
( is_mvdincspecop(RefType) ->
mvdincspec_struct(Object,AttObj,ValObj,Code)
;
is_imvdincspecop(RefType),
imvdincspec_struct(Object,AttObj,ValObj,Code)
).
%% +>>
mvdincspec_struct(Object,AttObj,ValObj,PRMVDINC(Object,AttObj,ValObj)).
%% *+>>
imvdincspec_struct(Object,AttObj,ValObj,PRIMVDINC(Object,AttObj,ValObj)).
%% ->->
tolistattspec_struct(Object,AttObj,RefType,ValObj,Code) :-
( is_mvdtolistspecop(RefType) ->
mvdtolistspec_struct(Object,AttObj,ValObj,Code)
;
is_imvdtolistspecop(RefType),
imvdtolistspec_struct(Object,AttObj,ValObj,Code)
).
mvdtolistspec_struct(Object,AttObj,ValObj,PRMVDTOLIST(Object,AttObj,ValObj)).
imvdtolistspec_struct(Object,AttObj,ValObj,PRIMVDTOLIST(Object,AttObj,ValObj)).
objref_struct(Obj,RefType,Att,Index,Val,Code) :-
%% Index is the approximate textual information
%% for the new variable that represents an oid.
new_varobj(Index,Val),
( is_fdrefop(RefType) ->
fdspec_struct(Obj,Att,Val,Code)
; is_ifdrefop(RefType) ->
ifdspec_struct(Obj,Att,Val,Code)
; is_mvdrefop(RefType) ->
mvdspec_struct(Obj,Att,Val,Code)
;
is_imvdrefop(RefType),
imvdspec_struct(Obj,Att,Val,Code)
).
head_objref_struct(Obj,RefType,Att,Index,Val,Code) :-
( is_fdrefop(RefType) ->
fdskolem_struct(Obj,Att,Index,Val),
fdspec_struct(Obj,Att,Val,Code)
;
is_ifdrefop(RefType),
ifdskolem_struct(Obj,Att,Index,Val),
ifdspec_struct(Obj,Att,Val,Code)
).
%% Skolem functions encode textual information.
fdskolem_struct(Obj,Att,Index,PRFDSKOLEM(Obj,Att,Index)) :- report_option(FLSKOLEM).
ifdskolem_struct(Obj,Att,Index,PRIFDSKOLEM(Obj,Att,Index)) :- report_option(FLSKOLEM).
methspec_struct(Obj,Meth,PRMETH(Obj,Meth)).
imethspec_struct(Obj,IMeth,PRIMETH(Obj,IMeth)).
transpec_struct(Obj,Tran,PRTRAN(Obj,Tran)).
objeql_struct(O1,O2,PROBJEQL(O1,O2)).
ifthenelse_struct(Cond,Then,Else,Code) :-
florasyslib_struct(FLLIBIFTHENELSE,3,[Cond,Then,Else],Code).
ifthen_struct(Cond,Then,Code) :-
florasyslib_struct(FLLIBIFTHEN,2,[Cond,Then],Code).
univeqform_struct(Left,Right,Code) :-
florasyslib_struct(FLLIBUNIVEQFORM,2,[Left,Right],Code).
%% This handles both ~.. and =..
%% These predicates are defined identically. The only difference is that
%% the LHS arg of ~.. is compiled as meta, while in =.. it is compiled as oid
metauniv_struct(Left,Right,Code) :-
florasyslib_struct(FLLIBMETAUNIV,2,[Left,Right],Code).
%% encoding for control constructs
controlconstruct_struct(CondCode,ActionCode,Wrapper,Code) :-
florasyslib_struct(Wrapper,2,[CondCode,ActionCode],Code).
constraint_struct(ConstrCode,PRCONSTRAINT(ConstrCode)).
/****************************************************************************
reset_newpredicate/0
new_predicate(-Name)
****************************************************************************/
reset_newpredicate :- flora_set_counter(NEWPREDICATE,1).
new_predicate(Name) :-
flora_increment_counter(NEWPREDICATE,1,OldVal,_NewVal),
number_codes(OldVal,OldValLst),
atom_codes(OldValAtm,OldValLst),
flora_concat_atoms([NEWPREDICATE,OldValAtm],Name).
/****************************************************************************
reset_newvar/0
new_varobj(-CompiledVarObj)
new_varobjlist(+Number,-List)
****************************************************************************/
reset_newvar :- flora_set_counter(NEWVAR,1).
new_varobj(Index,VarObj) :-
flora_increment_counter(NEWVAR,1,OldVal,_NewVal),
number_codes(OldVal,OldValLst),
atom_codes(OldValAtm,OldValLst),
flora_concat_atoms([NEWVAR,OldValAtm],Name),
varobj_struct(Name,Index,VarObj).
new_varobjlist(0,[]) :- !.
new_varobjlist(N,[VarObj|L]) :-
new_varobj(NO_INDEX,VarObj),
M is N-1,
new_varobjlist(M,L).
/****************************************************************************
reset_newoid/0
new_oidobj(+Index,-OidObject)
****************************************************************************/
reset_newoid :- flora_set_counter(NEWOID_COUNT,1).
new_oidobj(Index,OidObject) :-
flora_increment_counter(NEWOID_COUNT,1,OldVal,_NewVal),
number_codes(OldVal,OldValLst),
atom_codes(OldValAtm,OldValLst),
flora_concat_atoms([NEWOID,OldValAtm],Name),
newoid_struct(Name,Index,OidObject).
/*************************************************************************
new_oidobj(+RuleNum,+OidNumStr,+Index,-OidObject) :-
*************************************************************************/
new_oidobj(RuleNum,OidNumStr,Index,OidObject) :-
(
ruleoid(OidNumStr,_,Count)
-> Count_new is Count+1,
retract(ruleoid(OidNumStr,_,Count)),
assert(ruleoid(OidNumStr,Index,Count_new))
; assert(ruleoid(OidNumStr,Index,1))
),
number_codes(RuleNum,RuleNumLst),
atom_codes(RuleNumAtm,RuleNumLst),
flora_concat_atoms([NEWOID,RuleNumAtm,'|',OidNumStr],Name),
newoid_struct(Name,Index,OidObject).
/****************************************************************************
reset_rulenum
****************************************************************************/
reset_rulenum :- flora_set_counter(RULE_NUM,1).
/****************************************************************************
allvars(+CompilerTerm,-Vars)
collects all variables in a term (or a list of terms) into the list Vars.
allvars(+CompilerTerm,-Vars,-TailVars)
****************************************************************************/
is_atomobj_struct(PRATOM(_Atom,_I)).
is_numobj_struct(PRNUMBER(_Number,_I)).
is_varobj_struct(PRVARIABLE(_Name,_I)).
is_strobj_struct(PRSTRING(_String,_I)).
allvars(Term,Vars) :-
allvars(Term,Vs,[]),
sort(Vs,Vars).
allvars(Term,Vars,Vars) :-
(var(Term); atomic(Term)),
!.
allvars([],Vars,Vars) :- !.
allvars([H|L],Vars,TVars) :-
!,
allvars(H,Vars,LVars),
allvars(L,LVars,TVars).
allvars(Term,[Term|Vars],Vars) :-
is_varobj_struct(Term),
!.
allvars(Term,Vars,Vars) :-
( is_atomobj_struct(Term);
is_numobj_struct(Term);
is_strobj_struct(Term)
),
!.
allvars(Term,Vars,TVars) :-
Term =.. [_F|L],
allvars(L,Vars,TVars).
/****************************************************************************
error and warning messages
****************************************************************************/
compiling_error(Index,Msg,error(Index,Msg)).
compiling_warning(Index,Msg,warning(Index,Msg)).
/****************************************************************************
collect_vars(+ParserTermOrList,-Vars)
collects all occurrences of variables in a parser term (or a list of parser
terms) into the list Vars.
collect_vars(+ParserTerm,-Vars,-TailVars)
****************************************************************************/
collect_vars(ParserTermOrList,Vars) :-
collect_vars(ParserTermOrList,Vars,[]).
collect_vars(ParserTerm,Vars,Vars) :-
(var(ParserTerm); atomic(ParserTerm)),
!.
collect_vars([],Vars,Vars) :- !.
collect_vars([H|L],Vars,TVars) :-
!,
collect_vars(H,Vars,LVars),
collect_vars(L,LVars,TVars).
collect_vars(ParserTerm,[ParserTerm|Vars],Vars) :-
is_flvar(ParserTerm,_Name,_Index),
!.
collect_vars(ParserTerm,Vars,Vars) :-
( is_flatom(ParserTerm,_Atom);
is_flnumber(ParserTerm,_Number);
is_flstring(ParserTerm,_String);
is_fltoken(ParserTerm,_Token,_I);
is_fltoken(ParserTerm,_Token,_Num,_I)
),
!.
collect_vars(ParserTerm,Vars,TVars) :-
ParserTerm =.. [_F|L],
collect_vars(L,Vars,TVars).
/****************************************************************************
subtract_vars(+VarsList1,+VarsList2,-VarsList)
subtracts the VarsList2 from VarsList1, both of which contain parser term.
The result is a list of variables whose names do not appear in VarsList2.
Anonymous variables are considered as distinct names.
****************************************************************************/
subtract_vars([],_,[]) :- !.
subtract_vars([H|T1],L,[H|T2]) :-
is_flvar(H,FL_UNDERSCORE,_I),
!,
subtract_vars(T1,L,T2).
subtract_vars([H|T],L,V) :-
is_flvar(H,N,_I),
is_flvar(X,N,_J),
member(X,L),
!,
subtract_vars(T,L,V).
subtract_vars([H|T1],L,[H|T2]) :-
subtract_vars(T1,L,T2).
/****************************************************************************
collect_namevars(+ParserTerm,-QueryVars)
collects all the queryable variables (those that do not start with an
underscore) in a parser term (or a list of parser terms) into a list
of Name=Var constructs.
indexvars(+SortedNameVars,-IndexVars)
namevars(+SortedIndexVars,-QueryVars)
****************************************************************************/
collect_namevars(ParserTerm,QueryVars) :-
collect_vars(ParserTerm,NameVs),
sort(NameVs,SortedNameVs),
indexvars(SortedNameVs,IndexVs),
keysort(IndexVs,SortedIndexVs),
namevars(SortedIndexVs,QueryVars).
indexvars([],[]) :- !.
indexvars([T|L],Vars) :-
is_flvar(T,Name,I),
( flora_match_substring(FL_UNDERSCORE,Name,0) ->
indexvars(L,Vars)
;
Vars=[I-Name|Vs],
remove_dupvars(L,Name,VL),
indexvars(VL,Vs)
).
namevars([],[]) :- !.
namevars([Index-Name|L],[NV|NVs]) :-
varobj_struct(Name,Index,VCode),
atomobj_struct(Name,Index,NCode),
atomobj_struct(FL_UNIVEQ,FCode),
prologterm_struct(FCode,2,[NCode,VCode],NV),
namevars(L,NVs).
/****************************************************************************
singleton_vars(+SortedVarsList,-SingletonVars)
collects all the singleton variables in SortedVarsList into SingletonVars.
Singleton variables collected here exclude those
beginning with a underscore and the anonymous.
remove_dupvars(+SortedVarsList,+VarName,-Vars)
****************************************************************************/
singleton_vars([],[]) :- !.
singleton_vars([V|L],[V|Vs]) :-
is_flvar(V,FL_UNDERSCORE,_I),
!,
singleton_vars(L,Vs).
singleton_vars([V],[V]) :- !.
singleton_vars([V1,V2|L],Vars) :-
( is_flvar(V1,Name,_I), is_flvar(V2,Name,_J) ->
remove_dupvars(L,Name,Vs),
singleton_vars(Vs,Vars)
;
Vars=[V1|Vs],
singleton_vars([V2|L],Vs)
).
remove_dupvars([V|L],Name,Vars) :-
is_flvar(V,Name,_I),
!,
remove_dupvars(L,Name,Vars).
remove_dupvars(Vars,_Name,Vars).
/****************************************************************************
singleton_warning(+VarList,-WarnList,-WarnTail)
Warnings are not generated for variables beginning with an underscore.
****************************************************************************/
singleton_warning([],WarnList,WarnList).
singleton_warning([V|L],WarnList,WarnTail) :-
is_flvar(V,Name,I),
( flora_match_substring(FL_UNDERSCORE,Name,0) ->
singleton_warning(L,WarnList,WarnTail)
;
compiling_warning(I,SINGLETON_VAR,W),
WarnList=[W|T],
singleton_warning(L,T,WarnTail)
).
/****************************************************************************
unbound_warning(+VarList,-WarnList,-WarnTail)
Warnings are not generated for variables beginning with an underscore.
****************************************************************************/
unbound_warning([],WarnList,WarnList).
unbound_warning([V|L],WarnList,WarnTail) :-
is_flvar(V,Name,I),
( flora_match_substring(FL_UNDERSCORE,Name,0) ->
unbound_warning(L,WarnList,WarnTail)
;
compiling_warning(I,UNBOUND_VAR,W),
WarnList=[W|T],
unbound_warning(L,T,WarnTail)
).
/****************************************************************************
check_vars(+HeadTermList,+BodyTerm,-Status)
****************************************************************************/
check_vars(HeadTermList,BodyTerm,Status) :-
collect_vars(HeadTermList,HeadVars),
collect_vars(BodyTerm,BodyVars),
append(HeadVars,BodyVars,Vars),
sort(Vars,SortedVars),
singleton_vars(SortedVars,SingletonVars),
singleton_warning(SingletonVars,Status,WarnTail),
subtract_vars(HeadVars,BodyVars,UnboundVars),
unbound_warning(UnboundVars,WarnTail,[]).
/****************************************************************************
clear_directive
get_directive(-L)
report_directive(+Direct)
clear_option
get_option(-L)
report_option(+Option)
****************************************************************************/
clear_directive :- retractall(TMPDIRECT(_)).
get_directive(L) :- findall(D,TMPDIRECT(D),L).
report_directive(Direct) :- assert(TMPDIRECT(Direct)).
clear_option :- retractall(TMPOPTION(_)).
get_option(L) :- findall(O,TMPOPTION(O),L).
report_option(Option) :- assert(TMPOPTION(Option)).
/****************************************************************************
initialize_work
****************************************************************************/
initialize_work :-
reset_newvar,
clear_directive,
clear_option.
/****************************************************************************
flora_reset_compiler/0
****************************************************************************/
flora_reset_compiler :-
reset_newpredicate,
reset_rulenum,
reset_newoid.
/****************************************************************************
flora_compile(+ParserTerm,-CodeDiffList,-OptionList,-Status)
This is the top level procedure that is called to compile code.
CodeDiffList is a difference list in the form of [...|T]-T. It is for
the optimization of append.
****************************************************************************/
flora_compile(NULL,X-X,[],[]) :- !.
flora_compile(ParserTerm,CodeDiffList,OptionList,Status) :-
%% extract the rule number
flora_increment_counter(RULE_NUM,1,_,_),
initialize_work,
( is_flrule(ParserTerm,Head,Body) ->
compile_rule(Head,Body,CodeDiffList,S),
%% check whether singleton numbered anon oid exists
(ruleoid(_,_,1) -> referenced_once(S,Status); Status=S)
; is_flfact(ParserTerm,Head) ->
compile_fact(Head,CodeDiffList,S),
(ruleoid(_,_,1) -> referenced_once(S,Status); Status=S)
; is_flquery(ParserTerm,Body) ->
compile_query(Body,CodeDiffList,Status)
; is_fldirective(ParserTerm,DirectList) ->
compile_directive(DirectList,CodeDiffList,Status)
),
!,
get_option(OptionList),
retractall(ruleoid(_,_,_)).
%% This rule is for debugging.
flora_compile(_ParserTerm,[],[],[error(UNKNOWN_ERROR)]).
/***************************************************************************
referenced_once(+Status_rf,-Status)
finds singleton numbered anon oid and puts warning message in Status
***************************************************************************/
referenced_once(Status_rf,Status) :-
findall(Index,ruleoid(_,Index,1),IndexList),
singleton_oid_warning(IndexList,WarnList,[]),
append(Status_rf,WarnList,Status).
/*************************************************************************
singleton_oid_warning(+SingleOidList,-WarnList,-WarnTail)
***********************************************************************/
singleton_oid_warning([],WarnList,WarnList).
singleton_oid_warning([Index|L],WarnList,WarnTail) :-
compiling_warning(Index,SINGLETON_OID,W),
WarnList=[W|T],
singleton_oid_warning(L,T,WarnTail).
/****************************************************************************
compile_directive(+DirectList,-CodeDiffList,-Status)
compile_direct(DirectTerm,-CodeList,Status)
****************************************************************************/
compile_directive([],T-T,[]) :- !.
compile_directive([D|L],CodeList-ListTail,Status) :-
compile_direct(D,DCodeList,S),
( S == [] ->
append(DCodeList,T,CodeList),
compile_directive(L,T-ListTail,Status)
;
Status=S
).
%% Some directives imply additional code.
compile_direct(DirectTerm,[Code|ImpliedCode],[]) :-
( is_flcommand(DirectTerm,C) ->
command_struct(C,Direct),
ImpliedCode = []
; is_fltable(DirectTerm,P,A) ->
get_slash_sep_numbers(A,ATerm),
( is_flvar(P,PName,_PI) ->
flora_define_hilogtable(_,ATerm),
table_struct(_,ATerm,Direct)
;
is_flatom(P,PName,_PI),
flora_define_hilogtable(PName,ATerm),
table_struct(PName,ATerm,Direct)
),
ImpliedCode = []
),
!,
directive_struct(Direct,Code).
compile_direct(DirectTerm,[],[]) :-
is_flindex(DirectTerm,A,P),
report_option(FLINDEX(A,P)),
!.
%% Operator definition. Must also induce executable op definition,
%% to execute in the shell (restricted to "main" module)
compile_direct(DirectTerm,[Code],Status) :-
is_flopdef(DirectTerm,P,A,O),
flora_define_operator(P,A,O),
compile_exec_directive([FLOPDEF(P,A,O)],NULL,Code1,Status),
query_struct(Code1,Code),
!.
%% Operator definition. Must also induce executable args definition,
%% to execute in the shell (restricted to "main" module)
/** DEPRECATED
compile_direct(DirectTerm,[Code],Status) :-
is_flarguments(DirectTerm,P,N,A),
flora_define_arguments(P,N,A),
compile_exec_directive([FLARGUMENTS(P,N,A)],NULL,Code1,Status),
query_struct(Code1,Code),
!.
**/
compile_direct(DirectTerm,[],[]) :-
is_flprolog(DirectTerm,P,N),
flora_define_prolog(P,N),
!.
compile_direct(DirectTerm,CodeList,[]) :-
( is_flequality(DirectTerm,A) ->
( A == BASIC ->
report_option(FLEQLBASIC)
; A == FLOGIC ->
report_option(FLEQLFLOGIC)
; A == NONE ->
report_option(FLEQLNONE)
),
thismodule_struct(M)
),
florasyslib_struct(FLLIBEQUALITY,2,[A,M],CCode),
query_struct(CCode,Code),
CodeList=[Code],
!.
%% :- compiler_options
compile_direct(DirectTerm,[Code],[]) :-
is_flcmpopt(DirectTerm,OptList),
( member(XSB_SPECREPR,OptList) ->
report_option(XSB_SPECREPR)
;
true
),
cmpopt_struct(OptList,OCode),
directive_struct(OCode,Code),
!.
/****************************************************************************
compile_flatomvar(+T,-Code)
T is a variable structure, or an atom structure, or a plain atomic.
****************************************************************************/
compile_flatomvar(T,Code) :-
( is_flvar(T,TName,I) ->
varobj_struct(TName,I,Code)
;
atomobj_struct(T,Code)
).
compile_flatomvar_list([],[]) :- !.
compile_flatomvar_list([H|T],[HCode|TCode]) :-
compile_flatomvar(H,HCode),
compile_flatomvar_list(T,TCode).
/****************************************************************************
get_slash_sep_numbers(+Old,-New)
****************************************************************************/
get_slash_sep_numbers(N,M) :-
is_flnumber(N,M),
!.
get_slash_sep_numbers(FLTERM(FLATOM(FL_SLASH,_I),2,[N1,N2]),FL_SLASH(M1,M2)) :-
get_slash_sep_numbers(N1,M1),
is_flnumber(N2,M2).
/****************************************************************************
compile_fact(+Head,-CodeDiffList,-Status)
CodeDiffList is a difference list in the form of [...|T]-T. It is for
the optimization of append.
****************************************************************************/
compile_fact(Head,CodeDiffList,Status) :-
compile_head(Head,HeadCode,S),
( S == [] ->
compile_factlist(HeadCode,CodeDiffList),
check_vars(Head,[],Status)
;
Status=S
).
/****************************************************************************
compile_factlist(+Code,-CodeDifferenceList)
This procedure takes a conjucntion of atoms and splits into a
difference list.
****************************************************************************/
compile_factlist(NULL,CodeList-CodeList) :- !.
compile_factlist(ConjunctCode,CodeList-ListTail) :-
conjunct_struct(F1,F2,ConjunctCode),
!,
compile_factlist(F1,CodeList-T),
compile_factlist(F2,T-ListTail).
compile_factlist(F,[FCode|ListTail]-ListTail) :-
!,
fact_struct(F,FCode).
/****************************************************************************
compile_query(+Body,-CodeDiffList,-Status)
CodeDiffList is a difference list in the form of [...|T]-T. It is for
the optimization of append.
****************************************************************************/
compile_query(Body,CodeList-ListTail,Status) :-
compile_body(Body,BodyCode,Status),
( Status == [] ->
collect_namevars(Body,NV),
list_struct(NV,[],NVCode),
florasyslib_struct(FLLIBANSWER,2,[BodyCode,NVCode],Goal),
query_struct(Goal,QueryCode),
get_directive(DirectCodeList),
append(DirectCodeList,[QueryCode|ListTail],CodeList)
;
true
).
/****************************************************************************
compile_rule(+Head,+Body,-CodeDiffList,-Status)
CodeDiffList is a difference list in the form of [...|T]-T. It is for
the optimization of append.
****************************************************************************/
compile_rule(Head,Body,CodeList-ListTail,Status) :-
compile_head(Head,HeadCode,HS),
compile_conjunct2list(HeadCode,HeadCodeList),
( HS == [] ->
compile_body(Body,BodyCode,BS),
( BS == [] ->
get_directive(DirectCodeList),
append(DirectCodeList,T,CodeList),
compile_rulelist(HeadCodeList,BodyCode,T-ListTail),
check_vars(Head,Body,Status)
;
Status=BS
)
;
Status=HS
).
/****************************************************************************
compile_rulelist(+HeadCodeList,+BodyCode,-CodeDiffList)
HeadCodeList is a list of atoms in the rule head. BodyCode is the formula
in the rule body. This procedure splits the list of atoms in the rule
head and generates a difference list.
****************************************************************************/
compile_rulelist([H],Body,[Code|T]-T) :-
!,
%% Only a single atom appears in the rule head.
rule_struct(H,Body,Code).
compile_rulelist(HeadList,Body,[Code|CodeList]-ListTail) :-
%% Multiple atoms appear in the rule head.
%% Generate a temp rule.
allvars(HeadList,HeadVars),
length(HeadVars,N),
new_predicate(Name),
newpredicate_struct(Name,N,HeadVars,Newpredicate),
rule_struct(Newpredicate,Body,Code),
%% Split the atoms over this temp rule.
rule_difflist(HeadList,Newpredicate,CodeList-ListTail).
rule_difflist([],_B,CodeList-CodeList) :- !.
rule_difflist([H|L],B,[HC|LC]-T) :-
rule_struct(H,B,HC),
rule_difflist(L,B,LC-T).
/****************************************************************************
compile_conjunct2list(+ConjunctCode,-CodeList)
compile_conjunct2list(+ConjunctCode,-CodeList,-ListTail)
ConjunctCode may contain NULL.
****************************************************************************/
compile_conjunct2list(ConjunctCode,CodeList) :-
compile_conjunct2list(ConjunctCode,CodeList,[]).
compile_conjunct2list(NULL,CodeList,CodeList) :- !.
compile_conjunct2list(ConjunctCode,CodeList,ListTail) :-
conjunct_struct(C1,C2,ConjunctCode),
!,
compile_conjunct2list(C1,CodeList,T1),
compile_conjunct2list(C2,T1,ListTail).
compile_conjunct2list(Code,[Code|ListTail],ListTail) :- !.
/****************************************************************************
compile_head(+ParserTermList,-Code,-Status)
****************************************************************************/
compile_head([],NULL,[]) :- !.
compile_head([ParserTerm|ParserTermList],Code,Status) :-
compile_head_literal(ParserTerm,PCode,S),
( S == [] ->
compile_head(ParserTermList,PLCode,Status),
(Status == [] -> conjunct_struct(PCode,PLCode,Code); true)
;
Status=S
).
/****************************************************************************
compile_head_literal(+ParserTerm,-Code,-Status)
Code is conjucntions of atoms, which should be split into a list form later.
****************************************************************************/
compile_head_literal(ParserTerm,Code,Status) :-
( is_flterm(ParserTerm,Funct,N,Args) ->
compile_head_fltermlit(Funct,N,Args,Code,Status)
; is_flbirelate(ParserTerm,OT1,RelType,OT2) ->
compile_head_flbirelate(OT1,RelType,OT2,_Obj,Code,Status)
; is_flobjspec(ParserTerm,ObjTerm,Spec) ->
compile_head_flobjspec(ObjTerm,Spec,_Obj,Code,Status)
; is_flobjeql(ParserTerm,Obj1,Obj2) ->
compile_head_flobjeql(Obj1,Obj2,Code,Status)
; is_flworkspace(ParserTerm,P,WS) ->
compile_head_wsliteral(P,WS,Code,Status)
; is_flvar(ParserTerm,Name,Index) ->
compile_flvar(Name,Index,Code),
Status=[]
;
atomlit_struct(ParserTerm,Code),
Status=[]
).
/****************************************************************************
compile_body(+ParserTerm,-Code,-Status)
****************************************************************************/
compile_body(ParserTerm,Code,Status) :-
is_flconjunct(ParserTerm,L,R),
!,
compile_body(L,LCode,S),
( S == [] ->
compile_body(R,RCode,Status),
(Status == [] -> conjunct_struct(LCode,RCode,Code); true)
;
Status=S
).
compile_body(ParserTerm,Code,Status) :-
is_fldisjunct(ParserTerm,L,R),
!,
compile_body(L,LCode,S),
( S == [] ->
compile_body(R,RCode,Status),
(Status == [] -> disjunct_struct(LCode,RCode,Code); true)
;
Status=S
).
compile_body(ParserTerm,Code,Status) :-
is_flnot(ParserTerm,G),
!,
compile_body(G,GCode,Status),
(Status == [] -> not_struct(GCode,Code); true).
compile_body(ParserTerm,Code,Status) :-
is_fltnot(ParserTerm,G),
!,
compile_body(G,GCode,Status),
(Status == [] -> tnot_struct(GCode,Code); true).
compile_body(ParserTerm,Code,Status) :-
compile_body_literal(ParserTerm,Code,Status).
/****************************************************************************
compile_body_literal(+ParserTerm,-Code,-Status)
****************************************************************************/
compile_body_literal(ParserTerm,Code,Status) :-
( is_flterm(ParserTerm,Funct,N,Args) ->
compile_fltermlit(Funct,N,Args,OidCode,SpecCode,Status)
; is_flbirelate(ParserTerm,ObjTerm1,RelType,ObjTerm2) ->
compile_flbirelate(ObjTerm1,RelType,ObjTerm2,_Obj,OidCode,SpecCode,Status)
; is_flobjspec(ParserTerm,ObjTerm,Spec) ->
compile_flobjspec(ObjTerm,Spec,_Object,OidCode,SpecCode,Status)
; is_flload(ParserTerm,LoadList) ->
compile_flload(LoadList,SpecCode,Status),
OidCode=NULL
; is_flconstraint(ParserTerm,ConstrBody) ->
compile_body(ConstrBody,ConstrBodyCode,Status),
constraint_struct(ConstrBodyCode,SpecCode),
OidCode=NULL
; is_flworkspace(ParserTerm,P,WS) ->
compile_wsliteral(P,WS,OidCode,SpecCode,Status)
; is_flplib(ParserTerm,P) ->
compile_prologliblit(P,OidCode,SpecCode,Status)
; is_flplib(ParserTerm,P,Module) ->
compile_prologliblit(P,Module,OidCode,SpecCode,Status)
; is_flpliball(ParserTerm,P) ->
compile_prologallliblit(P,OidCode,SpecCode,Status)
; is_flpliball(ParserTerm,P,Module) ->
compile_prologallliblit(P,Module,OidCode,SpecCode,Status)
; is_flfloralib(ParserTerm,P,Module) ->
compile_floraliblit(P,Module,OidCode,SpecCode,Status)
; is_flinsert(ParserTerm,Op,List,Cond) ->
compile_flinsert(Op,List,Cond,SpecCode,Status),
OidCode=NULL
; is_flinsert(ParserTerm,Op,List) ->
compile_flinsert(Op,List,SpecCode,Status),
OidCode=NULL
; is_fldelete(ParserTerm,Op,List,Cond) ->
compile_fldelete(Op,List,Cond,SpecCode,Status),
OidCode=NULL
; is_fldelete(ParserTerm,Op,List) ->
compile_fldelete(Op,List,SpecCode,Status),
OidCode=NULL
; is_fltablerefresh(ParserTerm,List) ->
compile_flrefresh(List,SpecCode,Status),
OidCode=NULL
; is_flcatch(ParserTerm,Goal,Error,Handler) ->
compile_flcatch(Goal,Error,Handler,SpecCode,Status),
OidCode=NULL
; is_flthrow(ParserTerm,Error) ->
compile_flthrow(Error,SpecCode,Status),
OidCode=NULL
; is_flp2h(ParserTerm,Prolog,Hilog) ->
compile_flp2h(Prolog,Hilog,SpecCode,Status),
OidCode=NULL
; is_flnewmodule(ParserTerm,Op,ModList) ->
is_flatom(Op,_OpAtom,Index),
compile_flatomvar_list(ModList,Mods),
list_struct(Mods,[],ModlistCode),
florasyslib_struct(Index,FLLIBNEWMODULE,1,[ModlistCode],SpecCode),
Status=[],
OidCode=NULL
; is_flupdaterule(ParserTerm,Op,List) ->
compile_flupdaterule(Op,List,SpecCode,Status),
OidCode=NULL
; is_flifthenelse(ParserTerm,Cond,Then,Else) ->
compile_flifthenelse(Cond,Then,Else,SpecCode,Status),
OidCode=NULL
; is_flifthen(ParserTerm,Cond,Then) ->
compile_flifthen(Cond,Then,SpecCode,Status),
OidCode=NULL
; is_fluniveqform(ParserTerm,Left,Right) ->
compile_fluniveqform(Left,Right,SpecCode,Status),
OidCode=NULL
; is_flmetauniv(ParserTerm,Left,Right) ->
compile_flmetauniv(Left,Right,OidCode,SpecCode,Status)
; is_flmetaunivform(ParserTerm,Left,Right) ->
compile_flmetaunivform(Left,Right,OidCode,SpecCode,Status)
; is_flcontrolconstruct(ParserTerm,Wrapper,Cond,Action) ->
compile_flcontrolconstruct(Cond,Action,Wrapper,SpecCode,Status),
OidCode = NULL
; is_flcut(ParserTerm,I) ->
cut_struct(I,SpecCode),
OidCode=NULL,
Status=[]
; is_flatom(ParserTerm,_A) ->
atomlit_struct(ParserTerm,SpecCode) ->
OidCode=NULL,
Status=[]
; is_flvar(ParserTerm,Name,Index) ->
call_struct(Name,Index,SpecCode),
OidCode=NULL,
Status=[]
; is_flobjeql(ParserTerm,O1,O2) ->
compile_flobjeql(O1,O2,OidCode,SpecCode,Status)
; is_fldirective(ParserTerm,DirectList) ->
compile_exec_directive(DirectList,NULL,SpecCode,Status),
OidCode=NULL
),
conjunct_code([OidCode,SpecCode],Code).
/****************************************************************************
compile_flifthenelse(+Cond,+Then,+Else,-Code,-Status)
****************************************************************************/
compile_flifthenelse(Cond,Then,Else,Code,Status) :-
compile_body(Cond,CondCode,S1),
( S1 == [] ->
compile_body(Then,ThenCode,S2),
( S2 == [] ->
compile_body(Else,ElseCode,Status),
(Status == [] -> ifthenelse_struct(CondCode,ThenCode,ElseCode,Code); true)
;
Status=S2
)
;
Status=S1
).
/****************************************************************************
compile_flifthen(+Cond,+Then,-Code,-Status)
****************************************************************************/
compile_flifthen(Cond,Then,Code,Status) :-
compile_body(Cond,CondCode,S1),
( S1 == [] ->
compile_body(Then,ThenCode,Status),
(Status == [] -> ifthen_struct(CondCode,ThenCode,Code); true)
;
Status=S1
).
/****************************************************************************
compile_fluniveqform(+Left,+Right,-Code,-Status)
Compiling ~
This produces only spec code -- no oid code, because each argument
is treated as Meta, so no oid is passed utside of this term
****************************************************************************/
compile_fluniveqform(Left,Right,Code,Status) :-
compile_body(Left,LeftCode,S1),
( S1 == [] ->
compile_body(Right,RightCode,Status),
(Status == [] -> univeqform_struct(LeftCode,RightCode,Code); true)
;
Status=S1
).
/****************************************************************************
compile_flmetauniv(+Left,+Right,-OidCode,-Code,-Status)
Compiling =..
****************************************************************************/
compile_flmetauniv(Left,Right,OidCode,Code,Status) :-
%% Use pathexp translation instead of body translation, because we
%% don't want module name to be tacked on unless requested
%% LeftCode becomes bound to the OID code of Left
%% ObjCode is later conjuncted with the result
compile_pathexp(Left,LeftCode,OidCodeLeft,ObjCode,S1),
( S1 == []
-> compile_pathexp(Right,RightCode,OidCodeRight,RightObjCode,Status),
(Status == []
-> metauniv_struct(LeftCode,RightCode,UnivCode),
conjunct_code([UnivCode,ObjCode,RightObjCode],Code),
conjunct_code([OidCodeLeft,OidCodeRight],OidCode)
; true
)
;
Status=S1
).
/****************************************************************************
compile_flmetaunivform(+Left,+Right,-OidCode,-Code,-Status)
Compiling ~..
****************************************************************************/
compile_flmetaunivform(Left,Right,OidCode,Code,Status) :-
compile_body(Left,LeftCode,S1),
( S1 == []
-> compile_pathexp(Right,RightCode,OidCode,RightObjCode,Status),
(Status == []
-> metauniv_struct(LeftCode,RightCode,UnivCode),
conjunct_code([UnivCode,RightObjCode],Code)
; true
)
; Status=S1
).
/****************************************************************************
compile_flcontrolconstruct(+Cond,+Action,+Wrapper,-Code,-Status)
Handle control stmts while-do,do-until,while-loop,loop-until,unless-do
****************************************************************************/
compile_flcontrolconstruct(Cond,Action,Wrapper,Code,Status) :-
compile_body(Cond,CondCode,S1),
(S1 == []
-> compile_body(Action,ActionCode,Status),
(Status==[]
-> controlconstruct_struct(CondCode,ActionCode,Wrapper,Code)
; true
)
; Status = S1
).
/****************************************************************************
compile_pathexp(+ParserTerm,-Object,-OidCode,-Code,-Status)
Handles pathexps that are atoms, numbers, special tokens, like _#, _#123, _@,
vars, strings
****************************************************************************/
%% ParserTerm is a primitive object -- no oid code and no spec code results
compile_pathexp(ParserTerm,Object,NULL,NULL,[]) :-
( is_flatom(ParserTerm,_A) ->
atomobj_struct(ParserTerm,Object)
; is_fltoken(ParserTerm,FL_THISMODULE,_Index) ->
thismodule_struct(Object)
; is_flnumber(ParserTerm,_N) ->
numobj_struct(ParserTerm,Object)
; is_flvar(ParserTerm,Name,Index) ->
compile_flvar(Name,Index,Object)
; is_flstring(ParserTerm,_S) ->
strobj_struct(ParserTerm,Object)
),
!.
compile_pathexp(ParserTerm,Object,OidCode,Code,Status) :-
( is_flterm(ParserTerm,Funct,N,Args) ->
compile_fltermobj(Funct,N,Args,Object,OidCode,Code,Status)
; is_flbirelate(ParserTerm,ObjTerm1,RelType,ObjTerm2) ->
compile_flbirelate(ObjTerm1,RelType,ObjTerm2,Object,OidCode,Code,Status)
; is_flobjspec(ParserTerm,ObjTerm,Spec) ->
compile_flobjspec(ObjTerm,Spec,Object,OidCode,Code,Status)
; is_flobjref(ParserTerm,ObjTerm,RefType,AttTerm) ->
compile_flobjref(ObjTerm,RefType,AttTerm,Object,OidCode,Code,Status)
; is_fllist(ParserTerm,L,T,I) ->
compile_fllist(L,T,I,Object,OidCode,Code,Status)
; is_flaggregate(ParserTerm,Op,V,GV,B) ->
%% Aggregates are treated as OID, so its code would come
%% ahead of the code of the literal it occurs in
compile_flaggregate(Op,V,GV,B,Object,OidCode,Status)
; is_reifyop(ParserTerm,Formula) ->
compile_reifyop(Formula,Object,OidCode,Status),
Code=NULL
; is_flplib(ParserTerm,P) ->
compile_prologlibobj(P,Object,OidCode,Code,Status)
; is_flplib(ParserTerm,P,Module) ->
compile_prologlibobj(P,Module,Object,OidCode,Code,Status)
; is_flpliball(ParserTerm,P) ->
compile_prologalllibobj(P,Object,OidCode,Code,Status)
; is_flpliball(ParserTerm,P,Module) ->
compile_prologalllibobj(P,Module,Object,OidCode,Code,Status)
; is_flfloralib(ParserTerm,P,Module) ->
compile_floralibobj(P,Module,Object,OidCode,Code,Status)
;
is_flworkspace(ParserTerm,P,WS),
compile_wspathexp(P,WS,Object,OidCode,Code,Status)
).
/****************************************************************************
compile_pathexplist(+ParserTermList,-ObjectList,-OidCode,-Code,-Status)
****************************************************************************/
compile_pathexplist([],[],NULL,NULL,[]) :- !.
compile_pathexplist([T|L],[TObj|LObj],OidCode,Code,Status) :-
compile_pathexp(T,TObj,OidCodeHead,TCode,S),
( S == [] ->
compile_pathexplist(L,LObj,OidCodeTail,LCode,Status),
(Status == [] ->
conjunct_code([TCode,LCode],Code),
conjunct_code([OidCodeHead,OidCodeTail],OidCode)
;
true
)
;
Status=S
).
/****************************************************************************
compile_argpathexplist(+ParserTermList,+ArgTypeList,-ObjectList,-OidCode,-Code,-Status)
****************************************************************************/
compile_argpathexplist([],[],[],NULL,NULL,[]).
compile_argpathexplist([T|L],[FL_OID|ArgTypeList],[TObj|LObj],OidCode,Code,Status) :-
!,
compile_pathexp(T,TObj,OidCodeHead,TCode,S),
( S == [] ->
compile_argpathexplist(L,ArgTypeList,LObj,OidCodeTail,LCode,Status),
(Status == [] ->
conjunct_code([TCode,LCode],Code),
conjunct_code([OidCodeHead,OidCodeTail],OidCode)
; true
)
;
Status=S
).
compile_argpathexplist([T|L],[FL_BODYFORMULA|ArgTypeList],[TCode|LObj],OidCode,Code,Status) :-
!,
%% because we are compiling a meta here, the code
%% is self-contained -- no oid part will be pushed
%% to the front of the enveloping term
%%compile_body(T,TCode,S),
compile_body(T,TCode1,S),
reify_struct(TCode1,TCode),
( S == [] ->
compile_argpathexplist(L,ArgTypeList,LObj,OidCode,Code,Status)
;
Status=S
).
/****************************************************************************
compile_flload(+LoadList,-Code,-Status)
****************************************************************************/
compile_flload(LoadList,Code,Status) :-
is_fllist(LoadList,L,T,I),
%% since complex terms aren't allowed in load lists, we ignore OidCode
compile_fllist(L,T,I,ObjList,_OidCode,OCode,Status),
( Status == [] ->
thismodule_struct(Mod),
%% This is the file being compiled
(flora_compiler_environment(file,ProgramFile), !
; ProgramFile=userin
),
%% "I" is a token index
flora_nth_token(I,Token),
flora_token_text(Token,_TextStr,BLN,BCN,_ELN,_ECN),
%% Encode location of the literal [file>>mod]
%% Location is used for error checking in flrload.P to make sure
%% that loading of a file doesn't override the program
%% in which the loading statement occurs
list_struct([BLN,BCN],[],PositionCode),
florasyslib_struct(FLLIBLOAD,
4,
[ObjList,ProgramFile,Mod,PositionCode],LCode),
conjunct_code([OCode,LCode],Code)
;
true
).
/****************************************************************************
compile_flvar(+Name,+Index,-VarObject)
****************************************************************************/
compile_flvar(Name,Index,VarObject) :-
( Name == FL_UNDERSCORE ->
new_varobj(Index,VarObject)
;
varobj_struct(Name,Index,VarObject)
).
/****************************************************************************
compile_fltermobj(+FunctorTerm,+Arity,+ArgList,-Object,-OidCode,-Code,-Status)
Compile term in the OID position.
****************************************************************************/
compile_fltermobj(Funct,N,Args,Object,OidCode,Code,Status) :-
is_flatom(Funct,FAtom),
flora_argdef(FAtom,N,ArgTypes),
!,
atomobj_struct(Funct,FObj),
compile_argpathexplist(Args,ArgTypes,AObj,OidCode,Code,Status),
(Status == [] -> termobj_struct(FObj,N,AObj,Object); true).
compile_fltermobj(Funct,N,Args,Object,OidCode,Code,Status) :-
compile_pathexplist([Funct|Args],[FObj|AObj],OidCode,Code,Status),
(Status == [] -> termobj_struct(FObj,N,AObj,Object); true).
/****************************************************************************
compile_fltermlit(+FunctorTerm,+Arity,+ArgList,-OidCode,-Code,-Status)
Compile term in a predicate position in rule body.
****************************************************************************/
compile_fltermlit(Funct,N,Args,OidCode,Code,Status) :-
is_flatom(Funct,FAtom),
flora_argdef(FAtom,N,ArgTypes),
!,
atomobj_struct(Funct,FObj),
compile_argpathexplist(Args,ArgTypes,AObj,OidCode,ObjCode,Status),
( Status == [] ->
termlit_struct(FObj,N,AObj,TCode),
conjunct_code([TCode,ObjCode],Code)
;
true
).
compile_fltermlit(Funct,N,Args,OidCode,Code,Status) :-
compile_pathexplist([Funct|Args],[FObj|AObj],OidCode,ObjCode,Status),
( Status == [] ->
termlit_struct(FObj,N,AObj,TCode),
conjunct_code([TCode,ObjCode],Code)
;
true
).
/****************************************************************************
compile_fllist(+ObjTermList,+ObjTerm,+Index,-Object,-OidCode,-Code,-Status)
Index refers to '['.
Lists are like this: [a,b,c|rest]
ObjTermList refers to the list [a,b,c] and ObjTerm to rest.
****************************************************************************/
compile_fllist(ObjTermList,ObjTerm,Index,Object,OidCode,Code,Status) :-
compile_pathexplist(ObjTermList,ObjList,OidCodeList,ObjListCode,S),
( S == [] ->
( ObjTerm == [] ->
Obj=[],
OidCodeObj=NULL,
ObjCode=NULL,
Status=[]
;
compile_pathexp(ObjTerm,Obj,OidCodeObj,ObjCode,Status)
),
( Status == [] ->
list_struct(ObjList,Obj,Index,Object),
conjunct_code([ObjListCode,ObjCode],Code),
conjunct_code([OidCodeList,OidCodeObj],OidCode)
;
true
)
;
Status=S
).
/****************************************************************************
compile_flobjref(+ObjTerm,+RefType,+AttTerm,-Object,-OidCode,-Code,-Status)
Process an object reference like a.b.c
An objref can be more complex, e.g., a[f->g].b[h->>p].c[k->u]
****************************************************************************/
compile_flobjref(ObjTerm,RefType,AttTerm,Object,OidCode,Code,Status) :-
compile_pathexplist([ObjTerm,AttTerm],[Obj,Att],OidCodeList,OCode,Status),
( Status == [] ->
%% Approximate the textual information for the new variable.
approximate_index(AttTerm,Index),
objref_struct(Obj,RefType,Att,Index,Object,TCode),
Code = OCode,
conjunct_code([OidCodeList,TCode],OidCode)
;
true
).
/****************************************************************************
compile_flbirelate(+ObjTerm1,+RelType,+ObjTerm2,-Object,-Code,-Status)
Compiles binary relationships, like : or ::.
****************************************************************************/
compile_flbirelate(ObjTerm1,RelType,ObjTerm2,Obj1,OidCode,Code,Status) :-
compile_pathexplist([ObjTerm1,ObjTerm2],[Obj1,Obj2],OidCode,OCode,Status),
( Status == [] ->
birelate_struct(Obj1,RelType,Obj2,TCode),
conjunct_code([TCode,OCode],Code)
;
true
).
/****************************************************************************
compile_flobjspec(+ObjTerm,+SpecBody,-Object,-OidCode,-Code,-Status)
Code produced by this and similar predicates is divided into
OidCode and Code.
OidCode is the code needed to compute the attribute of molecule
and the oid, and the oid of the value part (in ->, ->>, etc.)
Code represents the code needed to compute the the attribute specification.
For instance, in a.b[c.d->e.f],
OidCode will represent the computation of c.d and e.d:
prand(prfd(a,b,_newvar1),prand(prfd(c,d,_newvar2),prfd(e,d,_newvar3)))
Code will represent the -> part:
prfd(_newvar1,_newvar2,_newvar3)
****************************************************************************/
compile_flobjspec(ObjTerm,SpecBody,Object,OidCode,Code,Status) :-
( SpecBody == [] ->
%% Just objref, no body. Something like a.b.c. Possibly a.b.c[]
( is_flobjref(ObjTerm,OTerm,RefType,ATerm) ->
compile_pathexplist([OTerm,ATerm],[OObj,AObj],OidCode,ObjCode,Status),
( Status == [] ->
objattdef_struct(OObj,RefType,AObj,TCode),
conjunct_code([TCode,ObjCode],Code)
;
true
)
;
%% object exist statement: a.b.c[]
compile_pathexp(ObjTerm,Object,OidCode,ObjCode,Status),
( Status == [] ->
objexists_struct(Object,ECode),
conjunct_code([ECode,ObjCode],Code)
;
true
)
)
; % oid spec plus object spec. something like a.b[c->d]
compile_pathexp(ObjTerm,Object,ObjOidCode,ObjCode,S),
( S == [] ->
compile_flspecbody(Object,SpecBody,SpecOidCode,SpecCode,Status),
(Status == [] ->
conjunct_code([ObjCode,SpecCode],Code),
conjunct_code([ObjOidCode,SpecOidCode],OidCode)
; true
)
;
Status=S
)
).
/****************************************************************************
compile_flspecbody(+Object,+SpecTerm,-OidCode,-Code,-Status)
Compile the specification part of a molecule Object[SpecTerm]
Object: describes the oid
SpecTerm: descripes the specification inside the brackets
Code: the resulting compiled code
****************************************************************************/
compile_flspecbody(Object,SpecTerm,OidCode,Code,Status) :-
is_flconjunct(SpecTerm,L,R),
!,
compile_flspecbody(Object,L,OidCode,LCode,S),
( S == [] ->
compile_flspecbody(Object,R,OidCode,RCode,Status),
(Status == [] -> conjunct_code([LCode,RCode],Code); true)
;
Status=S
).
compile_flspecbody(Object,SpecTerm,OidCode,Code,Status) :-
is_fldisjunct(SpecTerm,L,R),
!,
compile_flspecbody(Object,L,OidCode,LCode,S),
( S == [] ->
compile_flspecbody(Object,R,OidCode,RCode,Status),
(Status == [] -> disjunct_struct(LCode,RCode,Code); true)
;
Status=S
).
compile_flspecbody(Object,SpecTerm,OidCode,Code,Status) :-
is_flnot(SpecTerm,G),
!,
compile_flspecbody(Object,G,OidCode,GCode,Status),
(Status == [] ->
conjunct_code([OidCode,GCode],CombinedGCode),
not_struct(CombinedGCode,Code)
; true
).
compile_flspecbody(Object,SpecTerm,OidCode,Code,Status) :-
is_fltnot(SpecTerm,G),
!,
compile_flspecbody(Object,G,OidCode,GCode,Status),
(Status == [] ->
conjunct_code([OidCode,GCode],CombinedGCode),
tnot_struct(CombinedGCode,Code)
; true
).
%% F-molecule with attribute specification.
%% Can be O[M->V], where O,M,V can be any complex F-molecule
%% OidCodeList below gets bound to code needed to produce
%% the attribute (M) and the value (V). We conjunct this code in front of the
%% code for the molecule
%% NULL means that we don't pass OID code out, because we use it right here.
compile_flspecbody(Object,SpecTerm,NULL,Code,Status) :-
is_flfdattspec(SpecTerm,AttTerm,RefType,ValTerm),
!,
compile_pathexplist([AttTerm,ValTerm],[AttObj,ValObj],OidCode,OCode,Status),
( Status == [] ->
fdattspec_struct(Object,AttObj,RefType,ValObj,SCode),
%% SCode: code to produce object reference, attribute, and value
%% OCode: code for the pure attribute spec of the object
%% OidCode: code to produce the attribute and the value
conjunct_code([OidCode,SCode,OCode],Code)
;
true
).
%% Same for ->>
%% No OidCode is passed outside: we consume it here
compile_flspecbody(Object,SpecTerm,NULL,Code,Status) :-
is_flmvdattspec(SpecTerm,AttTerm,RefType,ValTermList),
!,
compile_pathexp(AttTerm,AttObj,AOidCode,ACode,S),
( S == [] ->
( ValTermList == [] ->
mvdattdef_struct(Object,AttObj,RefType,SCode),
conjunct_code([AOidCode,ACode,SCode],Code),
Status=[]
;
%% An mvd spec can have several terms in the value set
%% (represented by ValTermList). This compiles such
%% a spec into a conjunction.
compile_mvdattspec(Object,AttObj,RefType,ValTermList,VOidCode,SCode,Status),
%% ACode: Code to produce attribute
%% SCode: code to produce pure attr specs and
%% the objects that represents the values
(Status == [] ->
conjunct_code([AOidCode,VOidCode,ACode,SCode],Code)
;
true
)
)
;
Status=S
).
%% +>>, *+>>
compile_flspecbody(Object,SpecTerm,NULL,Code,Status) :-
is_flincattspec(SpecTerm,AttTerm,RefType,ValTerm),
!,
compile_pathexplist([AttTerm,ValTerm],[AttObj,ValObj],OidCode,OCode,Status),
( Status == [] ->
incattspec_struct(Object,AttObj,RefType,ValObj,SCode),
conjunct_code([OidCode,SCode,OCode],Code)
;
true
).
%% same for ->->
compile_flspecbody(Object,SpecTerm,NULL,Code,Status) :-
is_fltolistattspec(SpecTerm,AttTerm,RefType,ValTerm),
!,
compile_pathexplist([AttTerm,ValTerm],[AttObj,ValObj],OidCode,OCode,Status),
( Status == [] ->
tolistattspec_struct(Object,AttObj,RefType,ValObj,SCode),
%% Fold OidCode in front of the molecule
conjunct_code([OidCode,SCode,OCode],Code)
;
true
).
%% for O[BoolMeth]
compile_flspecbody(Object,SpecTerm,NULL,Code,Status) :-
is_flmethspec(SpecTerm,MethTerm),
!,
compile_pathexp(MethTerm,MethObj,OidCode,MCode,Status),
( Status == [] ->
methspec_struct(Object,MethObj,SCode),
%% Fold OidCode in front of the molecule
conjunct_code([OidCode,MCode,SCode],Code)
;
true
).
%% for O[*BoolMeth]
compile_flspecbody(Object,SpecTerm,NULL,Code,Status) :-
is_flimethspec(SpecTerm,IMethTerm),
!,
compile_pathexp(IMethTerm,IMethObj,OidCode,IMCode,Status),
( Status == [] ->
imethspec_struct(Object,IMethObj,SCode),
%% Fold OidCode in front of the molecule
conjunct_code([OidCode,IMCode,SCode],Code)
;
true
).
%% O[#M]
compile_flspecbody(Object,SpecTerm,NULL,Code,Status) :-
is_fltranspec(SpecTerm,TranTerm),
!,
compile_pathexp(TranTerm,TranObj,OidCode,TCode,Status),
( Status == [] ->
transpec_struct(Object,TranObj,SCode),
conjunct_code([OidCode,TCode,SCode],Code)
;
true
).
/****************************************************************************
compile_mvdattspec(+Object,+AttObj,+RefType,+ValTermList,-OidCode,-Code,-Status)
Arg 4 is a list representing the value set of the attribute.
This predicate compiles such a spec into a conjunction.
Each conjunct corresponds to each member of the value set.
Assumes that AttObj is already an oid
****************************************************************************/
compile_mvdattspec(Object,AttObj,RefType,[T],OidCode,Code,Status) :-
!,
compile_pathexp(T,TObj,OidCode,TCode,Status),
( Status == [] ->
mvdattspec_struct(Object,AttObj,RefType,TObj,SCode),
conjunct_code([SCode,TCode],Code)
;
true
).
compile_mvdattspec(Object,AttObj,RefType,[T|L],OidCode,Code,Status) :-
!,
compile_mvdattspec(Object,AttObj,RefType,[T],OidCodeHead,TCode,S),
( S == [] ->
compile_mvdattspec(Object,AttObj,RefType,L,OidCodeTail,LCode,Status),
(Status == [] ->
conjunct_code([TCode,LCode],Code),
conjunct_code([OidCodeHead,OidCodeTail],OidCode)
;
true
)
;
Status=S
).
/****************************************************************************
compile_flaggregate(+Op,+Var,+GVars,+BodyTerm,-Object,-Code,-Status)
****************************************************************************/
compile_flaggregate(Op,Var,GVars,BodyTerm,Object,Code,Status) :-
compile_body(BodyTerm,BCode,S),
( S == [] ->
check_aggregate(Var,GVars,BodyTerm,Status),
( Status == [] ->
compile_pathexplist([Var|GVars],[VarCode|GVarsCode],NULL,NULL,[]),
list_struct(GVarsCode,[],GVarsListCode),
aggregate_struct(Op,VarCode,GVarsListCode,BCode,Object,Code)
;
true
)
;
Status=S
).
/****************************************************************************
check_aggregate(+Var,+GroupVars,+BodyTerm,-Status)
check_repeatedvar(+Vars,-Status,-TailStatus)
allgvar_notin(+SortedVars,-Status,-TailStatus)
****************************************************************************/
check_aggregate(Var,GVars,BodyTerm,Status) :-
is_flvar(Var,VarName,VarIndex),
%% Check if the aggregate variable is anonymous.
( VarName == FL_UNDERSCORE ->
compiling_error(VarIndex,ERROR_AVAR,M1),
Status=[M1|S1]
;
Status=S1
),
%% Check if any grouping variable is anonymous.
check_gvar(GVars,S1,S2),
%% Check if the aggregate variable is also used for grouping.
( VarName \= FL_UNDERSCORE, is_flvar(U,VarName,_Iu), member(U,GVars) ->
compiling_error(VarIndex,AVAR_ASGVAR,M2),
S2=[M2|S3]
;
S3=S2
),
%% Check if there are any repeated grouping variables.
sort(GVars,SVars),
check_repeatedvar(SVars,S3,S4),
collect_vars(BodyTerm,BVars),
%% Check if aggregate variable is used in the aggregate body.
( (VarName == FL_UNDERSCORE; is_flvar(W,VarName,_Iw), member(W,BVars)) ->
S5=S4
;
compiling_error(VarIndex,AVAR_NOTIN,M5),
S4=[M5|S5]
),
%% Check if all grouping variables are used in the aggregate body.
( subtract_vars(GVars,BVars,L), L \== [] ->
sort(L,SL),
allgvar_notin(SL,S5,[])
;
S5=[]
).
check_gvar([],S,S) :- !.
check_gvar([H|L],Status,TS) :-
( is_flvar(H,FL_UNDERSCORE,HIndex) ->
compiling_error(HIndex,ERROR_GVAR,M),
Status=[M|S],
check_gvar(L,S,TS)
;
check_gvar(L,Status,TS)
).
check_repeatedvar([],S,S) :- !.
check_repeatedvar([H|L],Status,TS) :-
is_flvar(H,FL_UNDERSCORE,_I),
!,
check_repeatedvar(L,Status,TS).
check_repeatedvar([_H],S,S) :- !.
check_repeatedvar([H1,H2|T],Status,TS) :-
( is_flvar(H1,Name,_I1), is_flvar(H2,Name,I2) ->
compiling_error(I2,REPEATED_GVAR,Msg),
Status=[Msg|S],
check_repeatedvar([H1|T],S,TS)
;
check_repeatedvar([H2|T],Status,TS)
).
allgvar_notin([],S,S) :- !.
allgvar_notin([H|L],Status,TS) :-
is_flvar(H,FL_UNDERSCORE,_I),
!,
allgvar_notin(L,Status,TS).
allgvar_notin([H|T],[Msg|S],TS) :-
is_flvar(H,Name,Index),
compiling_error(Index,GVAR_NOTIN,Msg),
remove_dupvars(T,Name,L),
allgvar_notin(L,S,TS).
/****************************************************************************
compile_flobjeql(+Obj1,+Obj2,-OidCode,-Code,-Status)
****************************************************************************/
compile_flobjeql(Obj1,Obj2,OidCode,Code,Status) :-
compile_pathexplist([Obj1,Obj2],[O1,O2],OidCode,OCode,Status),
( Status == [] ->
objeql_struct(O1,O2,OECode),
conjunct_code([OCode,OECode],Code)
;
true
).
/****************************************************************************
compile_head_fltermobj(+FunctorTerm,+Arity,+ArgList,-Object,-Code,-Status)
****************************************************************************/
compile_head_fltermobj(Funct,N,Args,Object,Code,Status) :-
is_flatom(Funct,FAtom),
flora_argdef(FAtom,N,ArgTypes),
!,
atomobj_struct(Funct,FObj),
compile_head_argpathexplist(Args,ArgTypes,AObj,Code,Status),
(Status == [] -> termobj_struct(FObj,N,AObj,Object); true).
compile_head_fltermobj(Funct,N,Args,Object,Code,Status) :-
compile_head_pathexplist([Funct|Args],[FObj|AObj],Code,Status),
(Status == [] -> termobj_struct(FObj,N,AObj,Object); true).
/****************************************************************************
compile_head_fltermlit(+FunctorTerm,+Arity,+ArgList,-Code,-Status)
Compile a term in a rule head in a predicate position.
****************************************************************************/
compile_head_fltermlit(Funct,N,Args,Code,Status) :-
is_flatom(Funct,FAtom),
flora_argdef(FAtom,N,ArgTypes),
!,
atomobj_struct(Funct,FObj),
compile_head_argpathexplist(Args,ArgTypes,AObj,ObjCode,Status),
( Status == [] ->
termlit_struct(FObj,N,AObj,TObj),
conjunct_struct(ObjCode,TObj,Code)
;
true
).
compile_head_fltermlit(Funct,N,Args,Code,Status) :-
compile_head_pathexplist([Funct|Args],[FObj|AObj],ObjCode,Status),
( Status == [] ->
termlit_struct(FObj,N,AObj,TObj),
conjunct_struct(ObjCode,TObj,Code)
;
true
).
/****************************************************************************
compile_head_fllist(+ObjTermList,+ObjTerm,+Index,-Object,-Code,-Status)
Index refers to '['.
****************************************************************************/
compile_head_fllist(ObjTermList,ObjTerm,Index,Object,Code,Status) :-
compile_head_pathexplist(ObjTermList,ObjList,ObjListCode,S),
( S == [] ->
( ObjTerm == [] ->
Obj=[],
ObjCode=NULL,
Status=[]
;
compile_head_pathexp(ObjTerm,Obj,ObjCode,Status)
),
( Status == [] ->
list_struct(ObjList,Obj,Index,Object),
conjunct_struct(ObjListCode,ObjCode,Code)
;
true
)
;
Status=S
).
/****************************************************************************
compile_head_argpathexplist(+ParserTermList,+ArgTypeList,-ObjectList,-Code,-Status)
****************************************************************************/
compile_head_argpathexplist([],[],[],NULL,[]).
compile_head_argpathexplist([T|L],[FL_OID|ArgTypeList],[TObj|LObj],Code,Status) :-
!,
compile_head_pathexp(T,TObj,TCode,S),
( S == [] ->
compile_head_argpathexplist(L,ArgTypeList,LObj,LCode,Status),
(Status == [] -> conjunct_struct(TCode,LCode,Code); true)
;
Status=S
).
compile_head_argpathexplist([T|L],[FL_BODYFORMULA|ArgTypeList],[TCode|LObj],Code,Status) :-
!,
%%compile_body(T,TCode,S),
compile_body(T,TCode1,S),
reify_struct(TCode1,TCode),
( S == [] ->
compile_head_argpathexplist(L,ArgTypeList,LObj,Code,Status)
;
Status=S
).
/****************************************************************************
compile_head_pathexplist(+ParserTermList,-ObjectList,-Code,-Status)
****************************************************************************/
compile_head_pathexplist([],[],NULL,[]) :- !.
compile_head_pathexplist([T|L],[TObj|LObj],Code,Status) :-
compile_head_pathexp(T,TObj,TCode,S),
( S == [] ->
compile_head_pathexplist(L,LObj,LCode,Status),
(Status == [] -> conjunct_struct(TCode,LCode,Code); true)
;
Status=S
).
/****************************************************************************
compile_head_pathexp(+ParserTerm,-Object,-Code,-Status)
Note: It is for skolemization.
****************************************************************************/
compile_head_pathexp(ParserTerm,Object,NULL,[]) :-
( is_flatom(ParserTerm,_A) ->
atomobj_struct(ParserTerm,Object)
; is_flnumber(ParserTerm,_N) ->
numobj_struct(ParserTerm,Object)
; is_flvar(ParserTerm,Name,Index) ->
compile_flvar(Name,Index,Object)
; is_flstring(ParserTerm,_S) ->
strobj_struct(ParserTerm,Object)
; is_fltoken(ParserTerm,Token,Index) ->
compile_head_fltoken(Token,Index,Object)
; is_fltoken(ParserTerm,Token,Num,Index) ->
compile_head_fltoken(Token,Num,Index,Object)
),
!.
compile_head_pathexp(ParserTerm,Object,Code,Status) :-
( is_flbirelate(ParserTerm,OT1,RelType,OT2) ->
compile_head_flbirelate(OT1,RelType,OT2,Object,Code,Status)
; is_flobjspec(ParserTerm,ObjTerm,Spec) ->
compile_head_flobjspec(ObjTerm,Spec,Object,Code,Status)
; is_flobjref(ParserTerm,ObjTerm,RefType,AttTerm) ->
compile_head_flobjref(ObjTerm,RefType,AttTerm,Object,Code,Status)
; is_reifyop(ParserTerm,Formula) ->
%% Code: code to get Object
compile_reifyop(Formula,Object,Code,Status)
; is_flterm(ParserTerm,Funct,N,Args) ->
compile_head_fltermobj(Funct,N,Args,Object,Code,Status)
; is_fllist(ParserTerm,L,T,I) ->
compile_head_fllist(L,T,I,Object,Code,Status)
;
is_flworkspace(ParserTerm,P,WS),
compile_head_wspathexp(P,WS,Object,Code,Status)
).
/****************************************************************************
compile_head_fltoken(+Token,+Index,-Object)
Handles _#, _#123, _@, atoms
****************************************************************************/
compile_head_fltoken(Token,Index,Object) :-
( Token == FL_NEWOID ->
new_oidobj(Index,Object)
; Token == FL_THISMODULE ->
thismodule_struct(Object)
;
atomobj_struct(Token,Index,Object)
).
/****************************************************************************
compile_head_fltoken(+Token,+Num,+Index,-Object)
****************************************************************************/
compile_head_fltoken(Token,Num,Index,Object) :-
( Token == FL_NEWOID ->
flora_get_counter(RULE_NUM, Rule_num),
new_oidobj(Rule_num,Num,Index,Object)
;
atomobj_struct(Token,Index,Object)
).
/****************************************************************************
compile_head_flobjref(+ObjT,+RefType,+AttT,-Object,-Code,-Status)
****************************************************************************/
compile_head_flobjref(ObjTerm,RefType,AttTerm,Object,Code,Status) :-
compile_head_pathexplist([ObjTerm,AttTerm],[Obj,Att],OACode,Status),
( Status == [] ->
%% Approximate the textual information for the new variable.
approximate_index(AttTerm,Index),
head_objref_struct(Obj,RefType,Att,Index,Object,TCode),
conjunct_struct(OACode,TCode,Code)
;
true
).
/****************************************************************************
compile_head_flbirelate(+OT1,+RelType,+OT2,-Object,-Code,-Status)
****************************************************************************/
compile_head_flbirelate(ObjTerm1,RelType,ObjTerm2,Obj1,Code,Status) :-
compile_head_pathexplist([ObjTerm1,ObjTerm2],[Obj1,Obj2],OCode,Status),
( Status == [] ->
birelate_struct(Obj1,RelType,Obj2,TCode),
conjunct_struct(OCode,TCode,Code)
;
true
).
/****************************************************************************
compile_head_flobjspec(+ObjTerm,+SpecBody,-Object,-Code,-Status)
****************************************************************************/
compile_head_flobjspec(ObjTerm,SpecBody,Object,Code,Status) :-
( SpecBody == [] ->
( is_flobjref(ObjTerm,OTerm,RefType,ATerm) ->
compile_head_flobjref(OTerm,RefType,ATerm,Object,Code,Status)
;
compile_head_pathexp(ObjTerm,Object,ObjCode,Status),
( Status == [] ->
objexists_struct(Object,ECode),
conjunct_struct(ObjCode,ECode,Code)
;
true
)
)
;
compile_head_pathexp(ObjTerm,Object,ObjCode,S),
( S == [] ->
compile_head_flspecbody(Object,SpecBody,SCode,Status),
(Status == [] -> conjunct_struct(ObjCode,SCode,Code); true)
;
Status=S
)
).
/****************************************************************************
compile_head_flspecbody(+Object,+SpecTerm,-Code,-Status)
compile_head_mvdattspec(+Object,+AttObj,+RefType,+VL,-Code,-Status)
****************************************************************************/
compile_head_flspecbody(Object,SpecTerm,Code,Status) :-
is_flconjunct(SpecTerm,L,R),
!,
compile_head_flspecbody(Object,L,LCode,S),
( S == [] ->
compile_head_flspecbody(Object,R,RCode,Status),
(Status == [] -> conjunct_struct(LCode,RCode,Code); true)
;
Status=S
).
compile_head_flspecbody(Object,SpecTerm,Code,Status) :-
is_flfdattspec(SpecTerm,AttTerm,RefType,ValTerm),
!,
compile_head_pathexplist([AttTerm,ValTerm],[AttObj,ValObj],VACode,Status),
( Status == [] ->
fdattspec_struct(Object,AttObj,RefType,ValObj,SCode),
conjunct_struct(VACode,SCode,Code)
;
true
).
compile_head_flspecbody(Object,SpecTerm,Code,Status) :-
is_flmvdattspec(SpecTerm,AttTerm,RefType,VL),
!,
compile_head_pathexp(AttTerm,AObj,ACode,S),
( S == [] ->
( VL == [] ->
mvdattdef_struct(Object,AObj,RefType,SCode),
conjunct_struct(ACode,SCode,Code),
Status=[]
;
compile_head_mvdattspec(Object,AObj,RefType,VL,VCode,Status),
(Status == [] -> conjunct_struct(ACode,VCode,Code); true)
)
;
Status=S
).
compile_head_flspecbody(Object,SpecTerm,Code,Status) :-
is_flmethspec(SpecTerm,MethTerm),
!,
compile_head_pathexp(MethTerm,MethObj,MCode,Status),
( Status == [] ->
methspec_struct(Object,MethObj,SCode),
conjunct_struct(MCode,SCode,Code)
;
true
).
compile_head_flspecbody(Object,SpecTerm,Code,Status) :-
is_flimethspec(SpecTerm,IMethTerm),
!,
compile_head_pathexp(IMethTerm,IMethObj,IMCode,Status),
( Status == [] ->
imethspec_struct(Object,IMethObj,SCode),
conjunct_struct(IMCode,SCode,Code)
;
true
).
compile_head_flspecbody(Object,SpecTerm,Code,Status) :-
is_fltranspec(SpecTerm,TranTerm),
!,
compile_head_pathexp(TranTerm,TranObj,TCode,Status),
( Status == [] ->
transpec_struct(Object,TranObj,SCode),
conjunct_struct(TCode,SCode,Code)
;
true
).
compile_head_mvdattspec(_Object,_AttObj,_RefType,[],NULL,[]) :- !.
compile_head_mvdattspec(Object,AttObj,RefType,[T|L],Code,Status) :-
!,
compile_head_pathexp(T,TObj,TCode,S),
( S == [] ->
compile_head_mvdattspec(Object,AttObj,RefType,L,LCode,Status),
( Status == [] ->
mvdattspec_struct(Object,AttObj,RefType,TObj,SCode),
conjunct_struct(LCode,SCode,LSCode),
conjunct_struct(TCode,LSCode,Code)
;
true
)
;
Status=S
).
/****************************************************************************
compile_head_flobjeql(+Obj1,+Obj2,-Code,-Status)
X :=: Y found in a rule head
****************************************************************************/
compile_head_flobjeql(Obj1,Obj2,Code,Status) :-
compile_head_pathexplist([Obj1,Obj2],[O1,O2],OCode,Status),
( Status == [] ->
objeql_struct(O1,O2,OECode),
conjunct_struct(OCode,OECode,Code),
report_option(FLOBJEQLDEF)
;
true
).
/****************************************************************************
compile_floraliblit(+ParserTerm,+Workspace,-Code,-Status)
This procedure compiles a literal that is associated with a Flora system
module specification.
****************************************************************************/
compile_floraliblit(ParserTerm,WS,OidCode,Code,Status) :-
%% Flora system modules are like normal users modules except that
%% users cannot load into those areas.
is_flatom(WS,WSName,Index),
report_option(FLSYSMOD(WSName)),
atomobj_struct(WSName,Index,WSNameCode),
floralib_struct(WSNameCode,WSCode),
compile_wsliteral(ParserTerm,WSCode,OidCode,Code,Status).
/****************************************************************************
compile_wsliteral(+ParserTerm,+Workspace,-OidCode,-Code,-Status)
****************************************************************************/
compile_wsliteral(ParserTerm,WS,OidCode,WSCode,Status) :-
( is_flterm(ParserTerm,Funct,N,Args) ->
compile_wstermlit(Funct,N,Args,WS,OidCode,WSCode,Status)
; is_flvar(ParserTerm,VarName,Index) ->
compile_flvar(VarName,Index,VarCode),
workspacelit_struct(VarCode,WS,WSCode),
OidCode = NULL,
Status = []
; is_flbirelate(ParserTerm,ObjTerm1,RelType,ObjTerm2) ->
compile_wsflbirelate(ObjTerm1,RelType,ObjTerm2,WS,_Obj,OidCode,WSCode,Status)
; is_flobjspec(ParserTerm,ObjTerm,Spec) ->
compile_wsflobjspec(ObjTerm,Spec,WS,_Obj,OidCode,WSCode,Status)
; is_flobjeql(ParserTerm,O1,O2) ->
compile_wsflobjeql(O1,O2,WS,OidCode,WSCode,Status)
; is_fldirective(ParserTerm,DirectList) ->
compile_exec_directive(DirectList,WS,WSCode,Status),
OidCode=NULL
;
atomlit_struct(ParserTerm,Code),
workspacelit_struct(Code,WS,WSCode),
OidCode=NULL,
Status=[]
).
/****************************************************************************
compile_floralibobj(+ParserTerm,+Workspace,-Object,-OidCode,-Code,-Status)
****************************************************************************/
compile_floralibobj(ParserTerm,WS,Object,OidCode,Code,Status) :-
is_flatom(WS,WSName,Index),
report_option(FLSYSMOD(WSName)),
atomobj_struct(WSName,Index,WSNameCode),
floralib_struct(WSNameCode,WSCode),
compile_wspathexp(ParserTerm,WSCode,Object,OidCode,Code,Status).
/****************************************************************************
compile_wspathexp(+ParserTerm,+Workspace,-Object,-OidCode,-Code,-Status)
****************************************************************************/
compile_wspathexp(ParserTerm,WS,Object,OidCode,Code,Status) :-
( %% pred(Term@...)
%% Note: We have have to create code to compute X@.... We put this
%% code in OidCode so that it would precede the code for pred(...)
atomlit_struct(ParserTerm,A) ->
workspaceobj_struct(A,WS,Object,OidCode),
Code=NULL,
Status=[]
; is_flterm(ParserTerm,Funct,N,Args) ->
compile_wstermobj(Funct,N,Args,WS,Object,OidCode,Code,Status)
; is_flbirelate(ParserTerm,ObjTerm1,RelType,ObjTerm2) ->
compile_wsflbirelate(ObjTerm1,RelType,ObjTerm2,WS,Object,OidCode,Code,Status)
; is_flobjspec(ParserTerm,ObjTerm,Spec) ->
compile_wsflobjspec(ObjTerm,Spec,WS,Object,OidCode,Code,Status)
%% pred(X@...)
%% Note: We have have to create code to compute X@..., so we put
%% this code in OidCode so that it would precede the code for pred(...)
; is_flvar(ParserTerm,VarName,VarIndex) ->
compile_flvar(VarName,VarIndex,VarCode),
workspaceobj_struct(VarCode,WS,Object,OidCode),
Code=NULL,
Status = []
;
is_flobjref(ParserTerm,ObjTerm,RefType,AttTerm),
compile_wsflobjref(ObjTerm,RefType,AttTerm,WS,Object,OidCode,Code,Status)
).
/****************************************************************************
compile_wsflpathexplist(+ParserTermList,+Workspace,-ObjectList,-OidCode,-Code,-Status)
****************************************************************************/
compile_wsflpathexplist([],_WS,[],NULL,NULL,[]).
compile_wsflpathexplist([T|L],WS,[TObj|LObj],OidCode,Code,Status) :-
compile_wsflpathexp(T,WS,TObj,OidCodeHead,TCode,S),
( S == [] ->
compile_wsflpathexplist(L,WS,LObj,OidCodeTail,LCode,Status),
(Status == [] ->
conjunct_code([TCode,LCode],Code),
conjunct_code([OidCodeHead,OidCodeTail],OidCode)
; true
)
;
Status=S
).
/****************************************************************************
compile_wsflargpathexplist(+ParserTermList,+ArgTypeList,+WS,-ObjectList,-OidCode,-Code,-Status)
****************************************************************************/
compile_wsflargpathexplist([],[],_WS,[],NULL,NULL,[]) :- !.
compile_wsflargpathexplist([T|L],[FL_OID|ArgTypeList],WS,[TObj|LObj],OidCode,Code,Status) :-
!,
compile_wsflpathexp(T,WS,TObj,OidCodeHead,TCode,S),
( S == [] ->
compile_wsflargpathexplist(L,ArgTypeList,WS,LObj,OidCodeTail,LCode,Status),
(Status == [] ->
conjunct_code([TCode,LCode],Code),
conjunct_code([OidCodeHead,OidCodeTail],OidCode)
; true
)
;
Status=S
).
compile_wsflargpathexplist([T|L],[FL_BODYFORMULA|ArgTypeList],WS,[TCode|LObj],OidCode,Code,Status) :-
!,
%% workspace not distributive over nested "meta"
%%compile_body(T,TCode,S),
compile_body(T,TCode1,S),
reify_struct(TCode1,TCode),
( S == [] ->
compile_wsflargpathexplist(L,ArgTypeList,WS,LObj,OidCode,Code,Status)
;
Status=S
).
/****************************************************************************
compile_wsflpathexp(+ParserTerm,+Workspace,-Object,-OidCode,-Code,-Status)
Note: The difference between compile_wsflpathexp and compile_wspathexp
is that compile_wsflpathexp applies workspace only to F-Logic
constructs.
****************************************************************************/
compile_wsflpathexp(ParserTerm,WS,Object,OidCode,Code,Status) :-
( is_flobjref(ParserTerm,ObjTerm,RefType,AttTerm) ->
compile_wsflobjref(ObjTerm,RefType,AttTerm,WS,Object,OidCode,Code,Status)
; is_flobjspec(ParserTerm,ObjTerm,Spec) ->
compile_wsflobjspec(ObjTerm,Spec,WS,Object,OidCode,Code,Status)
; is_flbirelate(ParserTerm,ObjTerm1,RelType,ObjTerm2) ->
compile_wsflbirelate(ObjTerm1,RelType,ObjTerm2,WS,Object,OidCode,Code,Status)
; is_flterm(ParserTerm,Funct,N,Args) ->
compile_wsfltermobj(Funct,N,Args,WS,Object,OidCode,Code,Status)
; is_fllist(ParserTerm,L,T,I) ->
compile_wsfllist(L,T,I,WS,Object,OidCode,Code,Status)
; is_flworkspace(ParserTerm,P,NestedWS) ->
compile_wspathexp(P,NestedWS,Object,OidCode,Code,Status)
;
%% workspace not distributive over nested aggregates
compile_pathexp(ParserTerm,Object,OidCode,Code,Status)
).
/****************************************************************************
compile_wstermobj(+FunctorTerm,+Arity,+ArgList,+Workspace,-Object,-OidCode,-Code,-Status)
****************************************************************************/
compile_wstermobj(Funct,N,Args,WS,Object,OidCode,Code,Status) :-
is_flatom(Funct,FAtom),
flora_argdef(FAtom,N,ArgTypes),
!,
atomobj_struct(Funct,FObj),
compile_wsflargpathexplist(Args,ArgTypes,WS,AObj,OidCode,TCode,Status),
( Status == [] ->
termlit_struct(FObj,N,AObj,O),
workspaceobj_struct(O,WS,Object,WCode),
conjunct_code([TCode,WCode],Code)
;
true
).
compile_wstermobj(Funct,N,Args,WS,Object,OidCode,Code,Status) :-
compile_wsflpathexplist([Funct|Args],WS,[FObj|AObj],OidCode,TCode,Status),
( Status == [] ->
termlit_struct(FObj,N,AObj,O),
workspaceobj_struct(O,WS,Object,WCode),
conjunct_code([TCode,WCode],Code)
;
true
).
/****************************************************************************
compile_wsfltermobj(+FunctorTerm,+Arity,+ArgList,+Workspace,-Object,-OidCode,-Code,-Status)
Note: The difference between compile_wsfltermobj and compile_wstermobj
is that compile_wsfltermobj applies workspace only to F-Logic
constructs.
****************************************************************************/
compile_wsfltermobj(Funct,N,Args,WS,Object,OidCode,Code,Status) :-
is_flatom(Funct,FAtom),
flora_argdef(FAtom,N,ArgTypes),
!,
atomobj_struct(Funct,FObj),
compile_wsflargpathexplist(Args,ArgTypes,WS,AObj,OidCode,Code,Status),
(Status == [] -> termobj_struct(FObj,N,AObj,Object); true).
compile_wsfltermobj(Funct,N,Args,WS,Object,OidCode,Code,Status) :-
compile_wsflpathexplist([Funct|Args],WS,[FObj|AObj],OidCode,Code,Status),
(Status == [] -> termobj_struct(FObj,N,AObj,Object); true).
/****************************************************************************
compile_wstermlit(+FunctorTerm,+Arity,+ArgList,+Workspace,-OidCode,-Code,-Status)
****************************************************************************/
compile_wstermlit(Funct,N,Args,WS,OidCode,Code,Status) :-
is_flatom(Funct,FAtom),
flora_argdef(FAtom,N,ArgTypes),
!,
atomobj_struct(Funct,FObj),
compile_wsflargpathexplist(Args,ArgTypes,WS,AObj,OidCode,ObjCode,Status),
( Status == [] ->
termlit_struct(FObj,N,AObj,TCode),
workspacelit_struct(TCode,WS,WSCode),
conjunct_code([WSCode,ObjCode],Code)
;
true
).
compile_wstermlit(Funct,N,Args,WS,OidCode,Code,Status) :-
compile_wsflpathexplist([Funct|Args],WS,[FObj|AObj],OidCode,ObjCode,Status),
( Status == [] ->
termlit_struct(FObj,N,AObj,TCode),
workspacelit_struct(TCode,WS,WSCode),
conjunct_code([WSCode,ObjCode],Code)
;
true
).
/****************************************************************************
compile_wsfllist(+ObjTermList,+ObjTerm,+Index,+WS,-Object,-OidCode,-Code,-Status)
Lists are like this: [a,b,c|rest]
ObjTermList refers to the list [a,b,c] and ObjTerm to rest.
****************************************************************************/
compile_wsfllist(ObjTermList,ObjTerm,Index,WS,Object,OidCode,Code,Status) :-
compile_wsflpathexplist(ObjTermList,WS,ObjList,OidCodeList,ObjListCode,S),
( S == [] ->
( ObjTerm == [] ->
Obj=[],
ObjCode=NULL,
Status=[]
;
compile_wsflpathexp(ObjTerm,WS,Obj,OidCodeObj,ObjCode,Status)
),
( Status == [] ->
list_struct(ObjList,Obj,Index,Object),
conjunct_code([ObjListCode,ObjCode],Code),
conjunct_code([OidCodeList,OidCodeObj],OidCode)
;
true
)
;
Status=S
).
/****************************************************************************
compile_wsflobjref(+ObjTerm,+RefType,+AttTerm,+Workspace,-Object,-OidCode,-Code,-Status)
Process an object reference like a.b.c@module
An objref can be more complex, e.g., a[f->g].b[h->>p].c[k->u]@module
****************************************************************************/
compile_wsflobjref(ObjTerm,RefType,AttTerm,WS,Object,OidCode,Code,Status) :-
compile_wsflpathexplist([ObjTerm,AttTerm],WS,[Obj,Att],OidCodeList,OACode,Status),
( Status == [] ->
%% Approximate the textual information for the new variable.
approximate_index(AttTerm,Index),
objref_struct(Obj,RefType,Att,Index,Object,TCode),
workspacelit_struct(TCode,WS,WTCode),
Code = OACode,
conjunct_code([OidCodeList,WTCode],OidCode)
;
true
).
/****************************************************************************
compile_wsflbirelate(+ObjTerm1,+RelType,+ObjTerm2,+Workdpace,-Object,-OidCode,-Code,-Status)
****************************************************************************/
compile_wsflbirelate(ObjTerm1,RelType,ObjTerm2,WS,Obj1,OidCode,Code,Status) :-
compile_wsflpathexplist([ObjTerm1,ObjTerm2],WS,[Obj1,Obj2],OidCode,OCode,Status),
( Status == [] ->
birelate_struct(Obj1,RelType,Obj2,TCode),
workspacelit_struct(TCode,WS,WTCode),
conjunct_code([WTCode,OCode],Code)
;
true
).
/****************************************************************************
compile_wsflobjspec(+ObjTerm,+SpecBody,+Workspace,-Object,-OidCode,-Code,-Status)
Code produced by this and similar predicates is divided into
OidCode and Code.
OidCode is the code needed to compute the attribute of molecule
and the oid, and the oid of the value part (in ->, ->>, etc.)
Code represents the code needed to compute the the attribute specification.
For instance, in a.b[c.d->e.f],
OidCode will represent the computation of c.d and e.d:
prand(prfd(a,b,_newvar1),prand(prfd(c,d,_newvar2),prfd(e,d,_newvar3)))
Code will represent the -> part:
prfd(_newvar1,_newvar2,_newvar3)
****************************************************************************/
compile_wsflobjspec(ObjTerm,SpecBody,WS,Object,OidCode,Code,Status) :-
( SpecBody == [] ->
( is_flobjref(ObjTerm,OTerm,RefType,ATerm) ->
compile_wsflpathexplist([OTerm,ATerm],WS,[OObj,AObj],OidCode,ObjCode,Status),
( Status == [] ->
objattdef_struct(OObj,RefType,AObj,TCode),
workspacelit_struct(TCode,WS,WTCode),
conjunct_code([WTCode,ObjCode],Code)
;
true
)
;
%% object exists test: a.b.c[]@module
compile_wsflpathexp(ObjTerm,WS,Object,OidCode,ObjCode,Status),
( Status == [] ->
objexists_struct(Object,ECode),
workspacelit_struct(ECode,WS,WSECode),
conjunct_code([WSECode,ObjCode],Code)
;
true
)
)
; % oid spec plus object spec. something like a.b[c->d]@module
compile_wsflpathexp(ObjTerm,WS,Object,ObjOidCode,ObjCode,S),
( S == [] ->
compile_wsflspecbody(Object,SpecBody,WS,SpecOidCode,SpecCode,Status),
(Status == [] ->
conjunct_code([ObjCode,SpecCode],Code),
conjunct_code([ObjOidCode,SpecOidCode],OidCode)
;
true
)
;
Status=S
)
).
/****************************************************************************
compile_wsflspecbody(+Object,+SpecTerm,+Workspace,-OidCode,-Code,-Status)
****************************************************************************/
compile_wsflspecbody(Object,SpecTerm,WS,OidCode,Code,Status) :-
is_flconjunct(SpecTerm,L,R),
!,
compile_wsflspecbody(Object,L,WS,OidCode,LCode,S),
( S == [] ->
compile_wsflspecbody(Object,R,WS,OidCode,RCode,Status),
(Status == [] -> conjunct_code([LCode,RCode],Code); true)
;
Status=S
).
compile_wsflspecbody(Object,SpecTerm,WS,OidCode,Code,Status) :-
is_fldisjunct(SpecTerm,L,R),
!,
compile_wsflspecbody(Object,L,WS,OidCode,LCode,S),
( S == [] ->
compile_wsflspecbody(Object,R,WS,OidCode,RCode,Status),
(Status == [] -> disjunct_struct(LCode,RCode,Code); true)
;
Status=S
).
compile_wsflspecbody(Object,SpecTerm,WS,OidCode,Code,Status) :-
is_flnot(SpecTerm,G),
!,
compile_wsflspecbody(Object,G,WS,OidCode,GCode,Status),
(Status == [] ->
conjunct_code([OidCode,GCode],CombinedGCode),
not_struct(CombinedGCode,Code)
; true
).
compile_wsflspecbody(Object,SpecTerm,WS,OidCode,Code,Status) :-
is_fltnot(SpecTerm,G),
!,
compile_wsflspecbody(Object,G,WS,OidCode,GCode,Status),
(Status == [] ->
conjunct_code([OidCode,GCode],CombinedGCode),
tnot_struct(CombinedGCode,Code)
; true
).
%% OidCodeList below gets bound to code needed to produce
%% the attribute (M) and the value (V). We conjunct this code in front of the
%% code for the molecule
%% NULL means tht we don't pass OID code out, because we use it right here.
compile_wsflspecbody(Object,SpecTerm,WS,NULL,Code,Status) :-
is_flfdattspec(SpecTerm,AttTerm,RefType,ValTerm),
!,
compile_wsflpathexplist([AttTerm,ValTerm],WS,[AttObj,ValObj],OidCode,OCode,Status),
( Status == [] ->
fdattspec_struct(Object,AttObj,RefType,ValObj,SCode),
workspacelit_struct(SCode,WS,WSCode),
%% WSCode: code to produce object reference, attribute, and value
%% OCode: code for the pure attribute spec of the object
%% OidCode: code to produce the attribute and the value
conjunct_code([OidCode,WSCode,OCode],Code)
;
true
).
%% No OidCode is passed outside: we consume it here
compile_wsflspecbody(Object,SpecTerm,WS,NULL,Code,Status) :-
is_flmvdattspec(SpecTerm,AttTerm,RefType,ValTermList),
!,
compile_wsflpathexp(AttTerm,WS,AttObj,AOidCode,ACode,S),
( S == [] ->
( ValTermList == [] ->
mvdattdef_struct(Object,AttObj,RefType,SCode),
workspacelit_struct(SCode,WS,WSCode),
%% Fold OidCode in front of molecule
conjunct_code([AOidCode,ACode,WSCode],Code),
Status=[]
;
compile_wsmvdattspec(Object,AttObj,RefType,ValTermList,WS,VOidCode,WSCode,Status),
(Status == [] ->
%% ACode: Code to produce attribute
%% WSCode: code to produce pure attr specs and
%% the objects that represents the values
conjunct_code([AOidCode,VOidCode,ACode,WSCode],Code)
; true
)
)
;
Status=S
).
%% +>>, *+>>@module
%% NULL means: consume OidCode for attr and val here -- don't pass up the chain
compile_wsflspecbody(Object,SpecTerm,WS,NULL,Code,Status) :-
is_flincattspec(SpecTerm,AttTerm,RefType,ValTerm),
!,
compile_wsflpathexplist([AttTerm,ValTerm],WS,[AttObj,ValObj],OidCode,OCode,Status),
( Status == [] ->
incattspec_struct(Object,AttObj,RefType,ValObj,SCode),
workspacelit_struct(SCode,WS,WSCode),
%% Fold OidCode in front of molecule
conjunct_code([OidCode,WSCode,OCode],Code)
;
true
).
%% same for ->->@module
%% NULL means: consume OidCode for attr and val here -- don't pass up the chain
compile_wsflspecbody(Object,SpecTerm,WS,NULL,Code,Status) :-
is_fltolistattspec(SpecTerm,AttTerm,RefType,ValTerm),
!,
compile_wsflpathexplist([AttTerm,ValTerm],WS,[AttObj,ValObj],OidCode,OCode,Status),
( Status == [] ->
tolistattspec_struct(Object,AttObj,RefType,ValObj,SCode),
workspacelit_struct(SCode,WS,WSCode),
conjunct_code([OidCode,WSCode,OCode],Code)
;
true
).
%% for O[BoolMeth]@module
%% NULL means: consume OidCode for attr and val here -- don't pass up the chain
compile_wsflspecbody(Object,SpecTerm,WS,NULL,Code,Status) :-
is_flmethspec(SpecTerm,MethTerm),
!,
compile_wsflpathexp(MethTerm,WS,MethObj,OidCode,MCode,Status),
( Status == [] ->
methspec_struct(Object,MethObj,SCode),
workspacelit_struct(SCode,WS,WSCode),
conjunct_code([OidCode,MCode,WSCode],Code)
;
true
).
%% for O[*BoolMeth]@module
%% NULL means: consume OidCode for attr and val here -- don't pass up the chain
compile_wsflspecbody(Object,SpecTerm,WS,NULL,Code,Status) :-
is_flimethspec(SpecTerm,IMethTerm),
!,
compile_wsflpathexp(IMethTerm,WS,IMethObj,OidCode,IMCode,Status),
( Status == [] ->
imethspec_struct(Object,IMethObj,SCode),
workspacelit_struct(SCode,WS,WSCode),
%% Fold OidCode in front of molecule
conjunct_code([OidCode,IMCode,WSCode],Code)
;
true
).
%% O[#M]@module
compile_wsflspecbody(Object,SpecTerm,WS,NULL,Code,Status) :-
is_fltranspec(SpecTerm,TranTerm),
!,
compile_wsflpathexp(TranTerm,WS,TranObj,OidCode,TCode,Status),
( Status == [] ->
transpec_struct(Object,TranObj,SCode),
workspacelit_struct(SCode,WS,WSCode),
conjunct_code([OidCode,TCode,WSCode],Code)
;
true
).
/****************************************************************************
compile_wsmvdattspec(+Object,+AttObj,+RefType,+ValTermList,+Workspace,-OidCode,-Code,-Status)
Compiles ->>, *->>, etc., when they have one or more value terms
****************************************************************************/
compile_wsmvdattspec(Object,AttObj,RefType,[T],WS,OidCode,Code,Status) :-
!,
compile_wsflpathexp(T,WS,TObj,OidCode,TCode,Status),
( Status == [] ->
mvdattspec_struct(Object,AttObj,RefType,TObj,SCode),
workspacelit_struct(SCode,WS,WSCode),
conjunct_code([WSCode,TCode],Code)
;
true
).
compile_wsmvdattspec(Object,AttObj,RefType,[T|L],WS,OidCode,Code,Status) :-
!,
compile_wsmvdattspec(Object,AttObj,RefType,[T],WS,OidCodeHead,WTCode,S),
( S == [] ->
compile_wsmvdattspec(Object,AttObj,RefType,L,WS,OidCodeTail,WLCode,Status),
(Status == [] ->
conjunct_code([WTCode,WLCode],Code),
conjunct_code([OidCodeHead,OidCodeTail],OidCode)
; true
)
;
Status=S
).
/****************************************************************************
compile_wsflobjeql(+Obj1,+Obj2,+Workspace,-OidCode,-Code,-Status)
****************************************************************************/
compile_wsflobjeql(Obj1,Obj2,WS,OidCode,Code,Status) :-
compile_wsflpathexplist([Obj1,Obj2],WS,[O1,O2],OidCode,OCode,Status),
( Status == [] ->
objeql_struct(O1,O2,OECode),
workspacelit_struct(OECode,WS,WSCode),
conjunct_code([OCode,WSCode],Code)
;
true
).
/****************************************************************************
compile_reifyop(+Formula,-Object,-Status)
Compiling ${...}
****************************************************************************/
compile_reifyop(Formula,Object,OidCode,Status) :-
compile_body(Formula,Object1,Status),
(is_florasyslib_struct(Object1, Index,FLLIBMODLIT,_N,Args)
%% It is compiled into a LIBMODLIT/2: replace with LIBMODOBJ
->
new_varobj(Index,Object),
append(Args,[Object],NewArgs),
florasyslib_struct(FLLIBMODOBJ,3,NewArgs,OidCode)
;
reify_struct(Object1,Object), OidCode = NULL
).
/****************************************************************************
compile_prologliblit(+ParserTerm,-OidCode,-Code,-Status)
Compiles Prolog library call @prolog()
****************************************************************************/
compile_prologliblit(ParserTerm,OidCode,Code,Status) :-
( is_flterm(ParserTerm,Funct,N,Args) ->
compile_prlgterm(Funct,N,Args,TCode,OidCode,ACode,Status),
(Status == [] -> conjunct_code([ACode,TCode],Code); true)
;
atomobj_struct(ParserTerm,FObj),
N=0,
prologterm_struct(FObj,0,[],Code),
OidCode=NULL,
Status=[]
),
!.
/****************************************************************************
compile_prologliblit(+ParserTerm,+Module,-OidCode,-Code,-Status)
Compiles Prolog library call @prolog(module)
****************************************************************************/
compile_prologliblit(ParserTerm,Module,OidCode,Code,Status) :-
( is_flterm(ParserTerm,Funct,N,Args) ->
is_flatom(Funct,FAtom),
compile_prlgterm(Funct,N,Args,TCode,OidCode,ACode,Status)
;
is_flatom(ParserTerm,FAtom),
atomobj_struct(ParserTerm,FObj),
N=0,
prologterm_struct(FObj,0,[],TCode),
ACode=NULL,
OidCode=NULL,
Status=[]
),
( Status == [] ->
%% build a special structure for the coder
prologliblit_struct(TCode,PCode),
conjunct_code([ACode,PCode],Code),
%% generate an import statement for the corresponding XSB predicate
is_flatom(Module,MName),
import_struct(FAtom,N,MName,ICode),
directive_struct(ICode,DCode),
report_directive(DCode)
;
true
),
!.
/****************************************************************************
compile_prologallliblit(+ParserTerm,-OidCode,-Code,-Status)
Compiles Prolog library call @prologall()
****************************************************************************/
compile_prologallliblit(ParserTerm,OidCode,Code,Status) :-
compile_prologliblit(ParserTerm,OidCode,PrelimCode,Status),
( % here PrelimCode is bound and we decompose it
conjunct_struct(ACode,PrelimTermCode,PrelimCode), !
; PrelimCode = PrelimTermCode, ACode=NULL
),
%% Here PrelimTermCode is bound and we decompose it
prologterm_struct(FunctCode,N,ArgsCode,PrelimTermCode),
new_varobjlist(N,NewVarList),
generate_convert_to_prolog_code(ArgsCode,NewVarList,ToPrologCode),
prologterm_struct(FunctCode,N,NewVarList,TermCode),
generate_convert_from_prolog_code(ArgsCode,NewVarList,FromPrologCode),
conjunct_code([ACode,ToPrologCode,TermCode,FromPrologCode],Code).
/****************************************************************************
compile_prologallliblit(+ParserTerm,+Module,-OidCode,-Code,-Status)
Compiles Prolog library call @prologall(module)
****************************************************************************/
compile_prologallliblit(ParserTerm,Module,OidCode,Code,Status) :-
compile_prologliblit(ParserTerm,Module,OidCode,PrelimCode,Status),
( % here PrelimCode is bound and we decompose it
conjunct_struct(ACode,PrelimTermLitCode,PrelimCode), !
; PrelimCode = PrelimTermLitCode, ACode=NULL
),
%% PrelimTermLitCode is bound and we decompose it
prologliblit_struct(PrelimTermCode,PrelimTermLitCode),
%% PrelimTermCode is bound and we decompose it
prologterm_struct(FunctCode,N,ArgsCode,PrelimTermCode),
new_varobjlist(N,NewVarList),
generate_convert_to_prolog_code(ArgsCode,NewVarList,ToPrologCode),
prologterm_struct(FunctCode,N,NewVarList,TermCode),
prologliblit_struct(TermCode,TermLitCode),
generate_convert_from_prolog_code(ArgsCode,NewVarList,FromPrologCode),
conjunct_code([ACode,ToPrologCode,TermLitCode,FromPrologCode],Code).
/****************************************************************************
compile_prologlibobj(+ParserTerm,-Object,-OidCode,-Code,-Status)
Compiles Prolog library call @prolog() in the arguments position
E.g., f(member(X,[a])@prolog())
This feature might be userful for meta-programming.
****************************************************************************/
compile_prologlibobj(ParserTerm,Object,OidCode,Code,Status) :-
( is_flterm(ParserTerm,Funct,N,Args) ->
compile_prlgterm(Funct,N,Args,Object,OidCode,Code,Status)
;
atomobj_struct(ParserTerm,FObj),
N=0,
prologterm_struct(FObj,0,[],Object),
Code=NULL,
OidCode=NULL,
Status=[]
),
!.
/****************************************************************************
compile_prologlibobj(+ParserTerm,+Module,-Object,-OidCode,-Code,-Status)
Compiles Prolog library call @prolog(module) in the arguments position
****************************************************************************/
compile_prologlibobj(ParserTerm,Module,Object,OidCode,Code,Status) :-
( is_flterm(ParserTerm,Funct,N,Args) ->
is_flatom(Funct,FAtom),
compile_prlgterm(Funct,N,Args,Object,OidCode,Code,Status)
;
is_flatom(ParserTerm,FAtom),
atomobj_struct(ParserTerm,FObj),
N=0,
prologterm_struct(FObj,0,[],Object),
Code=NULL,
OidCode=NULL,
Status=[]
),
!,
( Status == [] ->
%% generate an import statement for the corresponding XSB predicate
is_flatom(Module,MName),
import_struct(FAtom,N,MName,ICode),
directive_struct(ICode,DCode),
report_directive(DCode)
;
true
),
!.
/****************************************************************************
compile_prologalllibobj(+ParserTerm,-Object,-OidCode,-Code,-Status)
Compiles @prologall() in argument position, e.g., foo(f(...)@prologall()
***************************************************************************/
compile_prologalllibobj(ParserTerm,Object,OidCode,Code,Status) :-
compile_prologlibobj(ParserTerm,PrelimObject,PrelimOidCode,PrelimCode,Status),
%% PrelimObject is bound and we decompose it
prologterm_struct(FunctCode,N,ArgsCode,PrelimObject),
new_varobjlist(N,NewVarList),
generate_convert_to_prolog_code(ArgsCode,NewVarList,ToPrologCode),
prologterm_struct(FunctCode,N,NewVarList,Object),
generate_convert_from_prolog_code(ArgsCode,NewVarList,FromPrologCode),
conjunct_code([ToPrologCode,PrelimOidCode],OidCode),
conjunct_code([FromPrologCode,PrelimCode],Code).
/****************************************************************************
compile_prologalllibobj(+ParserTerm,+Module,-Object,-OidCode,-Code,-Status)
Compiles @prologall(module) in argument position,
e.g., foo(f(...)@prologall(module)
***************************************************************************/
compile_prologalllibobj(ParserTerm,Module,Object,OidCode,Code,Status) :-
compile_prologlibobj(ParserTerm,Module,PrelimObject,PrelimOidCode,PrelimCode,Status),
%% PrelimObject is bound and we decompose it
prologterm_struct(FunctCode,N,ArgsCode,PrelimObject),
new_varobjlist(N,NewVarList),
generate_convert_to_prolog_code(ArgsCode,NewVarList,ToPrologCode),
prologterm_struct(FunctCode,N,NewVarList,Object),
generate_convert_from_prolog_code(ArgsCode,NewVarList,FromPrologCode),
conjunct_code([ToPrologCode,PrelimOidCode],OidCode),
conjunct_code([PrelimCode,FromPrologCode],Code).
/****************************************************************************
compile_prlgterm(+FunctTerm,+Arity,+ArgList,-Object,-OidCode,-Code,-Status)
****************************************************************************/
compile_prlgterm(Funct,N,Args,Object,OidCode,Code,Status) :-
is_flatom(Funct,FAtom),
atomobj_struct(Funct,FObj),
prologterm_struct(FObj,N,AObj,Object),
( flora_argdef(FAtom,N,ArgTypes) ->
compile_argpathexplist(Args,ArgTypes,AObj,OidCode,Code,Status)
;
compile_pathexplist(Args,AObj,OidCode,Code,Status)
),
!.
/*************************************************************************
generate_convert_to_prolog_code(+AObjList,+VarList,-Code)
*************************************************************************/
generate_convert_to_prolog_code([],_,NULL).
generate_convert_to_prolog_code([AObjH|AObjT],[VarH|VarT],Code) :-
atomobj_struct(P2H_PREDICATE,FlP2H),
%% P2H_DONOT_UNIFY_VARS - do not unify when both args are vars
termlit_struct(FlP2H,4,[VarH,AObjH,WRAP_HILOG,P2H_DONOT_UNIFY_VARS],CodeH),
generate_convert_to_prolog_code(AObjT,VarT,CodeT),
conjunct_code([CodeH,CodeT],Code).
/*************************************************************************
generate_convert_from_prolog_code(+AObjList,+VarList,-Code)
*************************************************************************/
generate_convert_from_prolog_code([],_,NULL).
generate_convert_from_prolog_code([AObjH|AObjT],[VarH|VarT],Code) :-
atomobj_struct(P2H_PREDICATE,FlP2H),
%% P2H_UNIFY_VARS - unify when both args are vars
termlit_struct(FlP2H,4,[VarH,AObjH,WRAP_HILOG,P2H_UNIFY_VARS],CodeH),
generate_convert_from_prolog_code(AObjT,VarT,CodeT),
conjunct_code([CodeH,CodeT],Code).
/****************************************************************************
compile_head_wspathexp(+ParserTerm,+Workspace,-Object,-Code,-Status)
This procedure is called from compile_head_pathexp/4 and
compile_head_wsflpathexp/5 when a workspace is explicitly specified.
****************************************************************************/
compile_head_wspathexp(ParserTerm,WS,Object,Code,Status) :-
( atomlit_struct(ParserTerm,A) ->
workspaceobj_struct(A,WS,Object,Code),
Status=[]
; is_flterm(ParserTerm,Funct,N,Args) ->
compile_head_wstermobj(Funct,N,Args,WS,Object,Code,Status)
; is_flbirelate(ParserTerm,ObjTerm1,RelType,ObjTerm2) ->
compile_head_wsflbirelate(ObjTerm1,RelType,ObjTerm2,WS,Object,Code,Status)
; is_flobjspec(ParserTerm,ObjTerm,Spec) ->
compile_head_wsflobjspec(ObjTerm,Spec,WS,Object,Code,Status)
;
is_flobjref(ParserTerm,ObjTerm,RefType,AttTerm),
compile_head_wsflobjref(ObjTerm,RefType,AttTerm,WS,Object,Code,Status)
).
/****************************************************************************
compile_head_wsliteral(+ParserTerm,+Workspace,-Code,-Status)
****************************************************************************/
compile_head_wsliteral(ParserTerm,WS,Code,Status) :-
( is_flterm(ParserTerm,Funct,N,Args) ->
compile_head_wstermlit(Funct,N,Args,WS,Code,Status)
; is_flbirelate(ParserTerm,ObjTerm1,RelType,ObjTerm2) ->
compile_head_wsflbirelate(ObjTerm1,RelType,ObjTerm2,WS,_Obj,Code,Status)
; is_flobjspec(ParserTerm,ObjTerm,Spec) ->
compile_head_wsflobjspec(ObjTerm,Spec,WS,_Obj,Code,Status)
; is_flobjeql(ParserTerm,O1,O2) ->
compile_head_wsflobjeql(O1,O2,WS,Code,Status)
; is_flvar(ParserTerm,VarName,Index) ->
compile_flvar(VarName,Index,VarCode),
workspacelit_struct(VarCode,WS,Code),
Status=[]
;
atomlit_struct(ParserTerm,ACode),
workspacelit_struct(ACode,WS,Code),
Status=[]
).
/****************************************************************************
compile_head_wsflargpathexplist(+ParserTermList,+ArgTypeList,+WS,
-ObjectList,-Code,-Status)
****************************************************************************/
compile_head_wsflargpathexplist([],[],_WS,[],NULL,[]) :- !.
compile_head_wsflargpathexplist([T|L],[FL_OID|ArgTypeList],WS,
[TObj|LObj],Code,Status) :-
!,
compile_head_wsflpathexp(T,WS,TObj,TCode,S),
( S == [] ->
compile_head_wsflargpathexplist(L,ArgTypeList,WS,LObj,LCode,Status),
(Status == [] -> conjunct_struct(TCode,LCode,Code); true)
;
Status=S
).
compile_head_wsflargpathexplist([T|L],[FL_BODYFORMULA|ArgTypeList],WS,
[TCode|LObj],Code,Status) :-
!,
%% workspace not distributive over nested `meta' argument spec
%%compile_body(T,TCode,S),
compile_body(T,TCode1,S),
reify_struct(TCode1,TCode),
( S == [] ->
compile_head_wsflargpathexplist(L,ArgTypeList,WS,LObj,Code,Status)
;
Status=S
).
/****************************************************************************
compile_head_wsflpathexplist(+ParserTermList,+WS,-ObjectList,-Code,-Status)
****************************************************************************/
compile_head_wsflpathexplist([],_WS,[],NULL,[]) :- !.
compile_head_wsflpathexplist([T|L],WS,[TObj|LObj],Code,Status) :-
compile_head_wsflpathexp(T,WS,TObj,TCode,S),
( S == [] ->
compile_head_wsflpathexplist(L,WS,LObj,LCode,Status),
(Status == [] -> conjunct_struct(TCode,LCode,Code); true)
;
Status=S
).
/****************************************************************************
compile_head_wsflpathexp(+ParserTerm,+WS,-Object,-Code,-Status)
Note: The difference between compile_head_wsflpathexp and compile_head_wspathexp
is that compile_head_wsflpathexp applies workspace only to F-Logic
constructs.
****************************************************************************/
compile_head_wsflpathexp(ParserTerm,WS,Object,Code,Status) :-
( is_flbirelate(ParserTerm,OT1,RelType,OT2) ->
compile_head_wsflbirelate(OT1,RelType,OT2,WS,Object,Code,Status)
; is_flobjspec(ParserTerm,ObjTerm,Spec) ->
compile_head_wsflobjspec(ObjTerm,Spec,WS,Object,Code,Status)
; is_flobjref(ParserTerm,ObjTerm,RefType,AttTerm) ->
compile_head_wsflobjref(ObjTerm,RefType,AttTerm,WS,Object,Code,Status)
; is_flterm(ParserTerm,Funct,N,Args) ->
compile_head_wsfltermobj(Funct,N,Args,WS,Object,Code,Status)
; is_fllist(ParserTerm,L,T,I) ->
compile_head_wsfllist(L,T,I,WS,Object,Code,Status)
; is_flworkspace(ParserTerm,P,NestedWS) ->
compile_head_wspathexp(P,NestedWS,Object,Code,Status)
;
compile_head_pathexp(ParserTerm,Object,Code,Status)
).
/****************************************************************************
compile_head_wstermobj(+FunctorTerm,+Arity,+ArgList,+WS,-Object,-Code,-Status)
****************************************************************************/
compile_head_wstermobj(_Funct,_N,_Args,WS,_Object,_Code,Status) :-
is_flvar(WS,_Name,VarIndex),
!,
%% Workspace in the rule head is not bound at compile time. Currently
%% this will generate an error. However, this might be solved by moving
%% the code that generates the workspace predicate to the body
%% of the rule.
compiling_error(VarIndex,VARWSINHEAD,Status).
compile_head_wstermobj(Funct,N,Args,WS,Object,Code,Status) :-
is_flatom(Funct,FAtom),
flora_argdef(FAtom,N,ArgTypes),
!,
atomobj_struct(Funct,FObj),
compile_head_wsflargpathexplist(Args,ArgTypes,WS,AObj,Code,Status),
( Status == [] ->
termlit_struct(FObj,N,AObj,O),
%% WCode should be NULL here since it is already checked
%% by the rule that the workspace is not a variable.
workspaceobj_struct(O,WS,Object,_WCodeIsNULL)
;
true
).
compile_head_wstermobj(Funct,N,Args,WS,Object,Code,Status) :-
compile_head_wsflpathexplist([Funct|Args],WS,[FObj|AObj],Code,Status),
( Status == [] ->
termlit_struct(FObj,N,AObj,O),
%% WCode should be NULL here since it is already checked by the rule
%% that the workspace is not a variable.
workspaceobj_struct(O,WS,Object,_WCodeIsNULL)
;
true
).
/****************************************************************************
compile_head_wsfltermobj(+FunctorTerm,+Arity,+ArgList,+WS,-Object,-Code,-Status)
Note: The difference between compile_head_wsflpathexp
and compile_head_wspathexp
is that compile_head_wsflpathexp applies workspace only to F-Logic
constructs.
****************************************************************************/
compile_head_wsfltermobj(Funct,N,Args,WS,Object,Code,Status) :-
is_flatom(Funct,FAtom),
flora_argdef(FAtom,N,ArgTypes),
!,
atomobj_struct(Funct,FObj),
compile_head_wsflargpathexplist(Args,ArgTypes,WS,AObj,Code,Status),
(Status == [] -> termobj_struct(FObj,N,AObj,Object); true).
compile_head_wsfltermobj(Funct,N,Args,WS,Object,Code,Status) :-
compile_head_wsflpathexplist([Funct|Args],WS,[FObj|AObj],Code,Status),
(Status == [] -> termobj_struct(FObj,N,AObj,Object); true).
/****************************************************************************
compile_head_wstermlit(+FunctorTerm,+Arity,+ArgList,+WS,-Code,-Status)
****************************************************************************/
compile_head_wstermlit(Funct,N,Args,WS,Code,Status) :-
is_flatom(Funct,FAtom),
flora_argdef(FAtom,N,ArgTypes),
!,
atomobj_struct(Funct,FObj),
compile_head_wsflargpathexplist(Args,ArgTypes,WS,AObj,ObjCode,Status),
( Status == [] ->
termlit_struct(FObj,N,AObj,TCode),
workspacelit_struct(TCode,WS,WSCode),
conjunct_struct(ObjCode,WSCode,Code)
;
true
).
compile_head_wstermlit(Funct,N,Args,WS,Code,Status) :-
compile_head_wsflpathexplist([Funct|Args],WS,[FObj|AObj],ObjCode,Status),
( Status == [] ->
termlit_struct(FObj,N,AObj,TObj),
workspacelit_struct(TObj,WS,WSTObj),
conjunct_struct(ObjCode,WSTObj,Code)
;
true
).
/****************************************************************************
compile_head_wsfllist(+ObjTermList,+ObjTerm,+Index,+WS,-Object,-Code,-Status)
****************************************************************************/
compile_head_wsfllist(ObjTermList,ObjTerm,Index,WS,Object,Code,Status) :-
compile_head_wsflpathexplist(ObjTermList,WS,ObjList,ObjListCode,S),
( S == [] ->
( ObjTerm == [] ->
Obj=[],
ObjCode=NULL,
Status=[]
;
compile_head_wsflpathexp(ObjTerm,WS,Obj,ObjCode,Status)
),
( Status == [] ->
list_struct(ObjList,Obj,Index,Object),
conjunct_struct(ObjListCode,ObjCode,Code)
;
true
)
;
Status=S
).
/****************************************************************************
compile_head_wsflobjref(+ObjT,+RefType,+AttT,+WS,-Object,-Code,-Status)
****************************************************************************/
compile_head_wsflobjref(ObjTerm,RefType,AttTerm,WS,Object,Code,Status) :-
compile_head_wsflpathexplist([ObjTerm,AttTerm],WS,[Obj,Att],OACode,Status),
( Status == [] ->
%% Approximate the textual information for the new variable.
approximate_index(AttTerm,Index),
head_objref_struct(Obj,RefType,Att,Index,Object,TCode),
workspacelit_struct(TCode,WS,WTCode),
conjunct_struct(OACode,WTCode,Code)
;
true
).
/****************************************************************************
compile_head_wsflbirelate(+OT1,+RelType,+OT2,+WS,-Object,-Code,-Status)
****************************************************************************/
compile_head_wsflbirelate(ObjTerm1,RelType,ObjTerm2,WS,Obj1,Code,Status) :-
compile_head_wsflpathexplist([ObjTerm1,ObjTerm2],WS,[Obj1,Obj2],OCode,Status),
( Status == [] ->
birelate_struct(Obj1,RelType,Obj2,TCode),
workspacelit_struct(TCode,WS,WTCode),
conjunct_struct(OCode,WTCode,Code)
;
true
).
/****************************************************************************
compile_head_wsflobjspec(+ObjTerm,+SpecBody,+WS,-Object,-Code,-Status)
****************************************************************************/
compile_head_wsflobjspec(ObjTerm,SpecBody,WS,Object,Code,Status) :-
( SpecBody == [] ->
( is_flobjref(ObjTerm,OTerm,RefType,ATerm) ->
compile_head_wsflobjref(OTerm,RefType,ATerm,WS,Object,Code,Status)
;
compile_head_wsflpathexp(ObjTerm,WS,Object,ObjCode,Status),
( Status == [] ->
objexists_struct(Object,ECode),
workspacelit_struct(ECode,WS,WSECode),
conjunct_struct(ObjCode,WSECode,Code)
;
true
)
)
;
compile_head_wsflpathexp(ObjTerm,WS,Object,ObjCode,S),
( S == [] ->
compile_head_wsflspecbody(Object,SpecBody,WS,SCode,Status),
(Status == [] -> conjunct_struct(ObjCode,SCode,Code); true)
;
Status=S
)
).
/****************************************************************************
compile_head_wsflspecbody(+Object,+SpecTerm,+WS,-Code,-Status)
compile_head_wsmvdattspec(+Object,+AttObj,+RefType,+VL,+WS,-Code,-Status)
****************************************************************************/
compile_head_wsflspecbody(Object,SpecTerm,WS,Code,Status) :-
is_flconjunct(SpecTerm,L,R),
!,
compile_head_wsflspecbody(Object,L,WS,LCode,S),
( S == [] ->
compile_head_wsflspecbody(Object,R,WS,RCode,Status),
(Status == [] -> conjunct_struct(LCode,RCode,Code); true)
;
Status=S
).
compile_head_wsflspecbody(Object,SpecTerm,WS,Code,Status) :-
is_flfdattspec(SpecTerm,AttTerm,RefType,ValTerm),
!,
compile_head_wsflpathexplist([AttTerm,ValTerm],WS,[AttObj,ValObj],VACode,Status),
( Status == [] ->
fdattspec_struct(Object,AttObj,RefType,ValObj,SCode),
workspacelit_struct(SCode,WS,WSSCode),
conjunct_struct(VACode,WSSCode,Code)
;
true
).
compile_head_wsflspecbody(Object,SpecTerm,WS,Code,Status) :-
is_flmvdattspec(SpecTerm,AttTerm,RefType,VL),
!,
compile_head_wsflpathexp(AttTerm,WS,AObj,ACode,S),
( S == [] ->
( VL == [] ->
mvdattdef_struct(Object,AObj,RefType,SCode),
workspacelit_struct(SCode,WS,WSSCode),
conjunct_struct(ACode,WSSCode,Code),
Status=[]
;
compile_head_wsmvdattspec(Object,AObj,RefType,VL,WS,VCode,Status),
(Status == [] -> conjunct_struct(ACode,VCode,Code); true)
)
;
Status=S
).
compile_head_wsflspecbody(Object,SpecTerm,WS,Code,Status) :-
is_flmethspec(SpecTerm,MethTerm),
!,
compile_head_wsflpathexp(MethTerm,WS,MethObj,MCode,Status),
( Status == [] ->
methspec_struct(Object,MethObj,SCode),
workspacelit_struct(SCode,WS,WSSCode),
conjunct_struct(MCode,WSSCode,Code)
;
true
).
compile_head_wsflspecbody(Object,SpecTerm,WS,Code,Status) :-
is_flimethspec(SpecTerm,IMethTerm),
!,
compile_head_wsflpathexp(IMethTerm,WS,IMethObj,IMCode,Status),
( Status == [] ->
imethspec_struct(Object,IMethObj,SCode),
workspacelit_struct(SCode,WS,WSSCode),
conjunct_struct(IMCode,WSSCode,Code)
;
true
).
compile_head_wsflspecbody(Object,SpecTerm,WS,Code,Status) :-
is_fltranspec(SpecTerm,TranTerm),
!,
compile_head_wsflpathexp(TranTerm,WS,TranObj,TCode,Status),
( Status == [] ->
transpec_struct(Object,TranObj,SCode),
workspacelit_struct(SCode,WS,WSSCode),
conjunct_struct(TCode,WSSCode,Code)
;
true
).
compile_head_wsmvdattspec(_Object,_AttObj,_RefType,[],_WS,NULL,[]) :- !.
compile_head_wsmvdattspec(Object,AttObj,RefType,[T|L],WS,Code,Status) :-
!,
compile_head_wsflpathexp(T,WS,TObj,TCode,S),
( S == [] ->
mvdattspec_struct(Object,AttObj,RefType,TObj,SCode),
workspacelit_struct(SCode,WS,WSSCode),
conjunct_struct(TCode,WSSCode,TSCode),
compile_head_wsmvdattspec(Object,AttObj,RefType,L,WS,LCode,Status),
(Status == [] -> conjunct_struct(TSCode,LCode,Code); true)
;
Status=S
).
/****************************************************************************
compile_head_wsflobjeql(+Obj1,+Obj2,+Workspace,-Code,-Status)
****************************************************************************/
compile_head_wsflobjeql(Obj1,Obj2,WS,Code,Status) :-
compile_head_wsflpathexplist([Obj1,Obj2],WS,[O1,O2],OCode,Status),
( Status == [] ->
objeql_struct(O1,O2,OECode),
workspacelit_struct(OECode,WS,WSCode),
conjunct_struct(OCode,WSCode,Code)
;
true
).
/****************************************************************************
compile_flinsert(+Op,+List,+Cond,-Code,-Status)
****************************************************************************/
compile_flinsert(Op,List,Cond,Code,Status) :-
compile_flinsert_literals(List,CodeList,S),
( S == [] ->
compile_body(Cond,CondCode,Status),
( Status == [] ->
list_struct(CodeList,[],ListCode),
insert_struct(Op,ListCode,CondCode,Code)
;
true
)
;
Status=S
).
/****************************************************************************
compile_flinsert(+Op,+List,-Code,Status)
****************************************************************************/
compile_flinsert(Op,List,Code,Status) :-
compile_flinsert_literals(List,CodeList,Status),
( Status == [] ->
list_struct(CodeList,[],ListCode),
insert_struct(Op,ListCode,Code)
;
true
).
/****************************************************************************
compile_flinsert_literals(+List,-DBCodeList,-Status)
****************************************************************************/
compile_flinsert_literals(List,DBCodeList,Status) :-
compile_flinsert_list(List,Code,Status),
compile_conjunct2list(Code,CodeList),
(Status == [] -> compile_dbupdate_list(CodeList,DBCodeList); true).
/****************************************************************************
compile_flinsert_list(+List,-Code,-Status)
Code is the conjunctions of atoms to be inserted.
****************************************************************************/
compile_flinsert_list([],NULL,[]) :- !.
compile_flinsert_list([H|T],Code,Status) :-
is_flvar(H,VarName,Index),
!,
compile_flvar(VarName,Index,VarCode),
compile_flinsert_list(T,TCode,Status),
conjunct_struct(VarCode,TCode,Code).
compile_flinsert_list([H|T],Code,Status) :-
%% Call compile_head_literal because path expressions should
%% be skolemized.
compile_head_literal(H,HCode,S),
( S == [] ->
compile_flinsert_list(T,TCode,Status),
(Status == [] -> conjunct_struct(HCode,TCode,Code); true)
;
Status=S
).
/****************************************************************************
compile_fldelete(+Op,+List,+Cond,-Code,-Status)
for delete operations with a condition.
****************************************************************************/
compile_fldelete(Op,List,Cond,Code,Status) :-
compile_fldelete_literals(List,CodeList,S),
( S == [] ->
compile_body(Cond,CondCode,Status),
( Status == [] ->
list_struct(CodeList,[],ListCode),
delete_struct(Op,ListCode,CondCode,Code)
;
true
)
;
Status=S
).
/****************************************************************************
compile_fldelete(+Op,+List,-Code,-Status)
for delete operations without a condition.
****************************************************************************/
compile_fldelete(Op,List,Code,Status) :-
compile_fldelete_literals(List,CodeList,Status),
( Status == [] ->
list_struct(CodeList,[],ListCode),
delete_struct(Op,ListCode,Code)
;
true
).
/****************************************************************************
compile_fldelete_literals(+List,-DBCodeList,-Status)
****************************************************************************/
compile_fldelete_literals(List,DBCodeList,Status) :-
compile_fldelete_list(List,CodeList,Status),
(Status == [] -> compile_dbupdate_list(CodeList,DBCodeList); true).
/****************************************************************************
compile_fldelete_list(+List,-CodeList,-Status)
****************************************************************************/
compile_fldelete_list([],[],[]) :- !.
compile_fldelete_list([H|T],[VarCode|TCodeList],Status) :-
is_flvar(H,VarName,Index),
!,
compile_flvar(VarName,Index,VarCode),
compile_fldelete_list(T,TCodeList,Status).
compile_fldelete_list([H|T],CodeList,Status) :-
%% When delete list contains an object equality definition, the compiler
%% will prepare to load the basic equality trailer, unless it is
%% overridden by an explicity directive.
is_flobjeql(H,O1,O2),
!,
compile_flobjeql(O1,O2,OidCode,SpecCode,S),
conjunct_code([OidCode,SpecCode],HCode),
report_option(FLOBJEQLDEF),
( S == [] ->
compile_conjunct2list(HCode,HCodeList),
compile_fldelete_list(T,TCodeList,Status),
(Status == [] -> append(HCodeList,TCodeList,CodeList); true)
;
Status=S
).
compile_fldelete_list([H|T],CodeList,Status) :-
%% Call compile_body_literal because path expressions should be
%% compiled into queries.
compile_body_literal(H,HCode,S),
( S == [] ->
compile_conjunct2list(HCode,HCodeList),
compile_fldelete_list(T,TCodeList,Status),
(Status == [] -> append(HCodeList,TCodeList,CodeList); true)
;
Status=S
).
/****************************************************************************
compile_dbupdate_list(+CodeList,-DBCodeList)
This predicate processes the list of literals in a DB update. For each
literal, it tries to add the name of the storage trie for the module.
Note: a DB update can only update a Flora user module or itself. If a
Flora system module allows update, it must provide an update interface.
****************************************************************************/
compile_dbupdate_list([],[]) :- !.
compile_dbupdate_list([C|CL],[C|DBCodeList]) :-
( is_varobj_struct(C)
; is_florasyslib_struct(C,_,_,_,_)
),
!,
compile_dbupdate_list(CL,DBCodeList).
compile_dbupdate_list([C|CL],[DBCode|DBCodeList]) :-
( workspace_struct(_P,WS,C) ->
%% The name of the module is known.
storage_struct(WS,SCode)
;
thisstorage_struct(fdb,SCode),
thismodule_struct(WS)
),
atomobj_struct(FLSYSDBUPDATE,FCode),
prologterm_struct(FCode,3,[C,SCode,WS],DBCode),
compile_dbupdate_list(CL,DBCodeList).
/****************************************************************************
compile_flupdatetrule(+Op,+List,-Code,Status)
****************************************************************************/
compile_flupdaterule(Op,List,Code,Status) :-
is_flatom(Op,OpAtom,Index),
compile_fldynrule_list(List,CodeList,Status),
( Status == [] ->
list_struct(CodeList,[],ListCode),
updaterule_syslib(OpAtom,InsertruleLib),
florasyslib_struct(Index,InsertruleLib,1,[ListCode],Code)
;
true
).
compile_fldynrule_list([],[],[]) :- !.
compile_fldynrule_list([H|L],[HCode|LCode],Status) :-
is_fldynrule(H,Head,Body),
compile_head(Head,HeadCode,HS),
collect_namevars(Head,HeadVars),
list_struct(HeadVars,[],HVL),
compile_conjunct2list(HeadCode,HeadCodeListPre),
remove_empty_list(HeadCodeListPre,HeadCodeList),
( HS == [] ->
compile_body(Body,BodyCode,BS),
( BS == [] ->
collect_namevars(Body,BodyVars),
list_struct(BodyVars,[],BVL),
list_struct(HeadCodeList,[],HCL),
dynrule_struct(HCL,BodyCode,HVL,BVL,HCode),
compile_fldynrule_list(L,LCode,Status)
;
Status=BS
)
;
Status=HS
).
remove_empty_list([],[]) :- !.
remove_empty_list([[]|L],NL) :-
!,
remove_empty_list(L,NL).
remove_empty_list([H|L],[H|NL]) :-
remove_empty_list(L,NL).
/****************************************************************************
Table maintenance predicates
refresh{...} removes the corresponding calls from Prolog tables.
****************************************************************************/
compile_flrefresh(List,Code,Status) :-
compile_fldelete_list(List,CodeList,Status),
( Status == [] ->
list_struct(CodeList,[],ListCode),
table_refresh_struct(ListCode,Code)
;
true
).
/****************************************************************************
Error handling
catch{Goal,Err,Handler}
****************************************************************************/
compile_flcatch(Goal,Err,Handler,Code,Status) :-
compile_body(Goal,GoalCode,GoalStatus),
( GoalStatus == [] ->
compile_pathexp(Err,ErrCode,_OidCode,_ObjSpec,ErrStatus),
( ErrStatus == [] ->
compile_body(Handler,HandlerCode,Status),
( Status == [] ->
catch_struct(GoalCode,ErrCode,HandlerCode,Code)
; true
)
; Status = ErrStatus
)
; Status = GoalStatus
).
/****************************************************************************
throw{Err}
****************************************************************************/
compile_flthrow(Err,Code,Status) :-
compile_pathexp(Err,ErrCode,_OidCode,_ObjSpec,Status),
( Status == [] ->
throw_struct(ErrCode,Code)
; true
).
/****************************************************************************
p2h{Prolog,Hilog}
****************************************************************************/
compile_flp2h(Prolog,Hilog,Code,Status) :-
compile_pathexp(Prolog,PCode,_POidCode,_PObjSpec,PStatus),
( PStatus == [] ->
compile_pathexp(Hilog,HCode,_HOidCode,_HObjSpec,Status),
(Status == [] ->
p2h_struct(PCode,HCode,Code)
; true
)
; Status = PStatus
).
/****************************************************************************
compile_exec_directive(+DirectList,+WS,-Code,-Status)
compile_execdirect_list(+DirectList,+WS,-DirectCodeList)
****************************************************************************/
compile_exec_directive(DirectList,WS,Code,[]) :-
compile_execdirect_list(DirectList,WS,DirectCodeList),
conjunct_code(DirectCodeList,Code).
compile_execdirect_list([],_,[]) :- !.
compile_execdirect_list([D|L],WS,[DCode|LCode]) :-
compile_execdirect(D,WS,DCode),
compile_execdirect_list(L,WS,LCode).
/****************************************************************************
compile_execdirect(+Direct,-Code)
****************************************************************************/
compile_execdirect(DirectTerm,_WS,Code) :-
( (is_fltable(DirectTerm,P,A),thismodule_struct(MCode),!;
is_fltable(DirectTerm,M,P,A),compile_flatomvar(M,MCode)) ->
compile_flatomvar(P,PCode),
( is_flterm(A,Funct,N,Args) ->
compile_fltermobj(Funct,N,Args,NCode,_OidCode,_RCode,_Status)
;
numobj_struct(A,NCode)
),
florasyslib_struct(FLLIBSHDIRECT,4,[FL_TABLE,MCode,PCode,NCode],Code)
),
!.
compile_execdirect(DirectTerm,WS,Code) :-
(WS == NULL -> thismodule_struct(Mod)
; compile_flatomvar(WS,Mod)
),
( is_flopdef(DirectTerm,Precedence,Associativity,Op) ->
florasyslib_struct(FLLIBSHDIRECT,5,[FL_OP,Mod,Precedence,Associativity,Op],Code)
/** DEPRECATED
; is_flarguments(DirectTerm,Funct,Arity,Args) ->
list_struct(Args,[],ArgsCode),
florasyslib_struct(FLLIBSHDIRECT,5,[FL_ARGUMENTS,Mod,Funct,Arity,ArgsCode],Code)
**/
; is_flequality(DirectTerm,T) ->
compile_flatomvar(T,TObj),
florasyslib_struct(FLLIBEQUALITY,2,[TObj,Mod],Code)
; is_flindex(DirectTerm,A,P) ->
(numobj_struct(A,ACode);is_flvar(A,AN,AI),varobj_struct(AN,AI,ACode)),
(numobj_struct(P,PCode); is_flvar(P,PN,PI),varobj_struct(PN,PI,PCode)),
florasyslib_struct(FLLIBSHDIRECT,4,[FL_INDEX,Mod,ACode,PCode],Code)
),
!.
syntax highlighted by Code2HTML, v. 0.9.1