# <![CDATA[
# KEHOME/src/pplist.icn
# Oct/18/2005
# Feb/25/2007 "in"
# pplist functions
# pplist ::=
# SYMBOL("pplist",[pp,... ])
# SYMBOL("ppnull",[])
# pp ::= SYMBOL("pp",[prep,nvobject])
# nvobject ::= SYMBOL("nvobject",nvlist)
# nvlist ::= [nv,...]
# nv ::=
# SYMBOL("nv",[name,"=",value])
# SYMBOL("nvnull",name)
record PPOBJECT (
ppat, # nvobject action context
ppout, # nvobject action products
ppof, # nvobject action domains
ppwith, # nvobject action characteristics
ppod, # nvobject action direct objects
ppfrom, # nvobject action initial characteristics
ppto, # nvobject action final characteristics
ppin # object list|array|relation
)
# methods
# new_ppobject(pplist)
# find_ppobject()
# get_ppobject()
# ppobject_update(ppobj,pplist)
# ppobject_arglist()
# ppobject_unparse()
# ppobject_writes()
# ppobject_copy()
# get_product()
# put_product()
# new_pplist()
# new_pp()
# get_pp()
# put_pp()
# delete_pp()
# is_ppnull()
# SYMBOL
procedure new_pplist(pp_list)
#============================
return SYMBOL("pplist",pp_list)
end
# SYMBOL
procedure new_pp(prep,nvobject)
#==============================
return SYMBOL("pp",[prep,nvobject])
end
# any
procedure get_product(x)
#=======================
# get product from out list
local y
static ierror
initial {
ierror := "Internal ERROR: get_product: "
}
case type(x) of {
default: {
writes_type_all(x,ierror||"not PPOBJECT: x")
fail
}
"PPOBJECT": {
y := get(x.ppout)
}
} # end case type()
return y
end
# PPOBJECT
procedure put_product(x,product)
#===============================
# put product in out list
local y
static ierror
initial {
ierror := "Internal ERROR: put_product: "
}
y := x
case type(x) of {
default: {
writes_type_all(x,ierror||"not PPOBJECT: x")
fail
}
"PPOBJECT": {
put(y.ppout,product)
}
} # end case type()
return y
end
procedure ppobject_writes(fd,x,fsep,tail)
#========================================
local At,Out,Of,With,Od,From,To,In
/fsep := ""
/tail := ""
At := x.ppat
Out := x.ppout
Of := x.ppof
With := x.ppwith
Od := x.ppod
From := x.ppfrom
To := x.ppto
In := x.ppin
writes(fd,"PPOBJECT(",fsep)
writes_any(fd,At); writes(fd,",",fsep)
writes_any(fd,Of); writes(fd,",",fsep)
writes_any(fd,With); writes(fd,",",fsep)
writes_any(fd,Out); writes(fd,",",fsep)
writes_any(fd,Od); writes(fd,",",fsep)
writes_any(fd,From); writes(fd,",",fsep)
writes_any(fd,To); writes(fd,",",fsep)
writes_any(fd,In)
writes(fd,fsep,")",tail)
end
# string
procedure ppobject_unparse(x,first,prefix,suffix,last)
#=====================================================
# output ::=
# first
# prefix pp suffix
# ...
# last
local t,uline
local line,At,Out,Of,With,Od,From,To,In
static info,ierror,lsep,psep
initial {
info := "INFO: ppobject_unparse: "
ierror := "Internal ERROR: ppobject_unparse: "
lsep := ","
psep := " "
}
/first := "[\n"
/prefix := repl(" ",4)
/suffix := "\n"
/last := prefix||"]\n"
case t := type(x) of {
"PPOBJECT": { }
default: {
writes_type(myerr,x,ierror||"unexpected type: x")
writes_type(mylog,x,ierror||"unexpected type: x")
return "(UNEXPECTED PPOBJECT)"
}
}
At := x.ppat
Out := x.ppout
Of := x.ppof
With := x.ppwith
Od := x.ppod
From := x.ppfrom
To := x.ppto
In := x.ppin
line := [first]
if *At > 0 then
put(line,PHRASE([prefix,"at",At,suffix]))
if *Out > 0 then
put(line,PHRASE([prefix,"out",Out,suffix]))
if *Of > 0 then
put(line,PHRASE([prefix,"of",Of,suffix]))
if *With > 0 then
put(line,PHRASE([prefix,"with",With,suffix]))
if *Od > 0 then
put(line,PHRASE([prefix,"od",Od,suffix]))
if *From > 0 then
put(line,PHRASE([prefix,"from",From,suffix]))
if *To > 0 then
put(line,PHRASE([prefix,"to",To,suffix]))
if *In > 0 then
put(line,PHRASE([prefix,"in",In,suffix]))
put(line,last)
uline := unparse(line,lsep,psep)
return uline
end
# list
procedure ppobject_arglist(x)
#============================
# called by set_role() in role.icn
# set up for do_method() with formattype = proposition
# important to maintain this order
local t
local arglist,At,Out,Of,With,Od,From,To,In
local uarglist,uAt,uOut,uOf,uWith,uOd,uFrom,uTo,uIn
local uaritylist
static info,ierror
initial {
info := "INFO: ppobject_arglist: "
ierror := "Internal ERROR: ppobject_arglist: "
}
if DEBUG=="PPLIST" then {
#writes_type_all(x,info||"input x")
#ppobject_writes(mybug,x,"\n","\n")
uarglist := []
uaritylist := []
}
arglist := []
case t := type(x) of {
"PPOBJECT": { }
default: {
writes_type(myerr,x,ierror||"unexpected type: x")
writes_type(mylog,x,ierror||"unexpected type: x")
return arglist
}
}
At := x.ppat
Out := x.ppout
Of := x.ppof
With := x.ppwith
Od := x.ppod
From := x.ppfrom
To := x.ppto
In := x.ppin
if DEBUG=="PPLIST" then {
uAt := list_unparse(At)
uOut := list_unparse(Out)
uOf := list_unparse(Of)
uWith := list_unparse(With)
uOd := list_unparse(Od)
uFrom := list_unparse(From)
uTo := list_unparse(To)
uIn := list_unparse(In)
writes_type_all(uAt, info||"uAt")
writes_type_all(uOut, info||"uOut")
writes_type_all(uOf, info||"uOf")
writes_type_all(uWith,info||"uWith")
writes_type_all(uOd, info||"uOd")
writes_type_all(uFrom,info||"uFrom")
writes_type_all(uTo, info||"uTo")
writes_type_all(uIn, info||"uIn")
}
if *At > 0 then
put(arglist,At)
if *Out > 0 then
put(arglist,Out)
if *Of > 0 then
put(arglist,Of)
if *With > 0 then
put(arglist,With)
if *Od > 0 then
put(arglist,Od)
if *From > 0 then
put(arglist,From)
if *To > 0 then
put(arglist,To)
if *In > 0 then
put(arglist,In)
if DEBUG=="PPLIST" then {
#if *At > 0 then {
put(uarglist,[uAt])
put(uaritylist,*uAt)
#}
#if *Out > 0 then {
put(uarglist,[uOut])
put(uaritylist,*uOut)
#}
#if *Of > 0 then {
put(uarglist,[uOf])
put(uaritylist,*uOf)
#}
#if *With > 0 then {
put(uarglist,[uWith])
put(uaritylist,*uWith)
#}
#if *Od > 0 then {
put(uarglist,[uOd])
put(uaritylist,*uOd)
#}
#if *From > 0 then {
put(uarglist,[uFrom])
put(uaritylist,*uFrom)
#}
#if *To > 0 then {
put(uarglist,[uTo])
put(uaritylist,*uTo)
#if *In > 0 then {
put(uarglist,[uIn])
put(uaritylist,*uIn)
#}
#writes_type_all(arglist,info||"output arglist")
writes_type_all(uarglist,info||"output uarglist")
writes_type_all(uaritylist,info||"output uaritylist")
}
return arglist
end
# PPOBJECT
procedure find_ppobject(x)
#=========================
# called by do_production() in statement.icn
# option := "nv" | "nov"
local y,z,zz
static info,warning,ierror
initial {
info := "INFO: find_ppobject: "
warning := "WARNING: find_ppobject: "
ierror := "Internal ERROR: find_ppobject: "
}
y := &null
case type(x) of {
default: {
writes_type_all(x,ierror||"unexpected type: x")
fail
}
("list"|"set"): {
every z := !x do
if zz := find_ppobject(z) then
return zz
}
"PPOBJECT": { y := x }
"SYMBOL": { y := find_ppobject(x.svalue) }
} # end case type()
return y
end
# PPOBJECT
procedure get_ppobject(pplist,option)
#====================================
# called by command() in command.icn # (,"nov")
# called by do_definition() in definition.icn # (,"nv")
# called by pplist2fmtlist() in pplist.icn # (,"nov")
# option := "nv" | "nov"
local t,st,ppobj
local atphrase,ofphrase,withphrase,outphrase,
odphrase,fromphrase,tophrase,inphrase
local context,part,product,arglist,infile,outfile
static info,warning,ierror
initial {
info := "INFO: get_ppobject: "
warning := "WARNING: get_ppobject: "
ierror := "Internal ERROR: get_ppobject: "
}
/option := "nov"
if DEBUG==("PPLIST"|"NV") then {
writes_type(mybug,pplist,info||"input pplist")
writes_type(mylog,pplist,info||"input pplist")
}
ppobj := new_ppobject([])
case t := type(pplist) of {
default: {
writes_type(myerr,pplist,ierror||"unexpected type pplist")
writes_type(myerr,pplist,ierror||"unexpected type pplist")
return ppobj
}
"null": {
if DEBUG=="NULL" then {
writes_type(mybug,pplist,ierror||"unexpected null pplist")
writes_type(mylog,pplist,ierror||"unexpected null pplist")
}
return ppobj
}
"SYMBOL": {
case st := pplist.stype of {
"pplist": { }
"ppnull": {
if DEBUG=="NULL" then {
writes_type(mybug,pplist,warning||"unexpected null pplist")
writes_type(mylog,pplist,warning||"unexpected null pplist")
}
return ppobj
}
default: {
writes_type(myerr,pplist,ierror||"unexpected stype pplist")
writes_type(myerr,pplist,ierror||"unexpected stype pplist")
return ppobj
}
} # end case st
}
"PPOBJECT": { return pplist }
"list": { }
}
# separate pp
#========================================================#
ppobj := new_ppobject(pplist)
#========================================================#
if DEBUG=="NV" then {
writes_type(mylog,ppobj,info||"output nv ppobj")
}
case option of {
default: { }
"nv": { } # preserve nvphrase
"nov": {
# get_string(): nvlist => novlist
#================================#
ppobj := ppobj2nov(ppobj)
if DEBUG==("NV"|"PP"|"PPLIST") then {
writes_type(mylog,ppobj,info||"output nov ppobj")
}
} # end "nov"
} # end case option
return ppobj
end
# PPOBJECT
procedure ppobject_update(old,pplist)
#======================================
local new
new := new_ppobject(pplist)
if *new.ppat = 0 then new.ppat := old.ppat
if *new.ppout = 0 then new.ppout := old.ppout
if *new.ppof = 0 then new.ppof := old.ppof
if *new.ppwith = 0 then new.ppwith := old.ppwith
if *new.ppod = 0 then new.ppod := old.ppod
if *new.ppfrom = 0 then new.ppfrom := old.ppfrom
if *new.ppto = 0 then new.ppto := old.ppto
if *new.ppin = 0 then new.ppin := old.ppin
return new
end
# PPOBJECT
procedure new_ppobject(pplist)
#=============================
local ppobj,atphrase,outphrase,ofphrase,withphrase,
odphrase,fromphrase,tophrase,inphrase
ppobj := PPOBJECT()
atphrase := get_pp("at", pplist) | SYMBOL("null",[])
outphrase := get_pp("out", pplist) | SYMBOL("null",[])
ofphrase := get_pp("of", pplist) | SYMBOL("null",[])
withphrase := get_pp("with",pplist) | SYMBOL("null",[])
odphrase := get_pp("od", pplist) | SYMBOL("null",[])
fromphrase := get_pp("from",pplist) | SYMBOL("null",[])
tophrase := get_pp("to", pplist) | SYMBOL("null",[])
inphrase := get_pp("in", pplist) | SYMBOL("null",[])
atphrase := delete_separator(atphrase )
outphrase := delete_separator(outphrase )
ofphrase := delete_separator(ofphrase )
withphrase := delete_separator(withphrase )
odphrase := delete_separator(odphrase )
fromphrase := delete_separator(fromphrase )
tophrase := delete_separator(tophrase )
inphrase := delete_separator(inphrase )
ppobj.ppat := atphrase.svalue[2] | [] # nvlist stv
ppobj.ppout := outphrase.svalue[2] | [] # nvlist
ppobj.ppof := ofphrase.svalue[2] | [] # nvlist
ppobj.ppwith := withphrase.svalue[2] | [] # nvlist
ppobj.ppod := odphrase.svalue[2] | [] # nvlist
ppobj.ppfrom := fromphrase.svalue[2] | [] # nvlist
ppobj.ppto := tophrase.svalue[2] | [] # nvlist
ppobj.ppin := inphrase.svalue[2] | [] # nvlist
return ppobj
end
# PPOBJECT
procedure ppobj2nov(ppobj)
#=========================
# convert NVPHRASE to nov list
local new
new := PPOBJECT()
new.ppat := nv2nov(ppobj.ppat)
new.ppout := nv2nov(ppobj.ppout)
new.ppof := nv2nov(ppobj.ppof)
new.ppwith := nv2nov(ppobj.ppwith)
new.ppod := nv2nov(ppobj.ppod)
new.ppfrom := nv2nov(ppobj.ppfrom)
new.ppto := nv2nov(ppobj.ppto)
new.ppin := nv2nov(ppobj.ppin)
return new
end
#----------------------------------------#
# prepphrase
procedure get_pp(prep,pplist)
#============================
# get prepphrase for specified prep
local t,svalue,foundprep,foundpp,pp,p
local pinfo,pierror
static info,ierror
initial {
info := "INFO: get_pp("
ierror := "Internal ERROR: get_pp("
}
pinfo := info||prep||"): "
pierror := ierror||prep||"): "
#DEBUG := "PPLIST"
if DEBUG=="PPLIST" then {
writes_type_all(pplist,pinfo||"looking for "||prep||" in pplist")
}
case t := type(pplist) of {
"SYMBOL": {
case pplist.stype of {
default: {
writes_type_all(pplist,pierror||"unexpected stype pplist")
fail
}
"null": { fail }
"ppnull": { fail }
"pplist": { svalue := pplist.svalue }
} # end case stype
}
"list": { svalue := pplist }
"null": {
if DEBUG==("NULL"|"PPLIST") then {
writes_type_all(pplist,pierror||"null pplist")
}
fail
}
default: {
writes_type_all(pplist,pierror||"unexpected type pplist")
fail
}
} # end case type()
if DEBUG=="PPLIST" then {
writes_type_all(svalue,pinfo||"looking for "||prep||" in svalue")
}
foundprep := "no"
foundpp := []
every pp := !svalue do {
case type(pp) of {
"SYMBOL": {
if pp.stype ~== "pp" then
writes_type_all(pp,pierror||"unexpected type pp")
}
default: {
writes_type_all(pp,pierror||"unexpected type pp")
}
} # end case type(pp)
if DEBUG=="PPLIST" then {
writes_type_all(pp,pinfo||"pp")
}
p := pp.svalue[1]
if DEBUG=="PPLIST" then {
writes_type_all(p,pinfo||"p")
}
if type(p)=="list" then {
p := !p
}
if p == prep then {
foundprep := "yes"
foundpp := pp
} else {
# continue
} # end if p
} # end every pp
if foundprep=="yes" then {
if DEBUG=="PPLIST" then {
writes_type_all(foundpp,pinfo||"returning foundpp")
}
return foundpp
} else {
fail
}
end
# SYMBOL
procedure put_pp(pplist,pp)
#==========================
local svalue
svalue := pplist.svalue
svalue |||:= pp
pplist := SYMBOL("pplist",svalue)
return pplist
end
# SYMBOL
procedure delete_pp(prep,pplist)
#===============================
# delete prepphrase for specified prep
local t,svalue,foundprep,foundpp,pp,p
static info,ierror,error
initial {
info := "INFO: delete_pp: "
ierror := "Internal ERROR: delete_pp: "
error := "ERROR: delete_pp: "
}
#DEBUG := "PPLIST"
if DEBUG=="PPLIST" then {
writes_type(mylog,pplist,info||"looking for "||prep||" in pplist")
}
case t := type(pplist) of {
"SYMBOL": {
if pplist.stype ~== "pplist" then
writes_type(myerr,pplist,ierror||"unexpected type pplist")
svalue := pplist.svalue
}
"list": { svalue := pplist }
default: {
writes_type(myerr,pplist,error||"unexpected type pplist")
fail
}
} # end case type()
if DEBUG=="PPLIST" then {
writes_type(mylog,svalue,info||"looking for "||prep||" in svalue")
}
foundprep := "no"
foundpp := []
every pp := !svalue do {
case type(pp) of {
"SYMBOL": {
if pp.stype ~== "pp" then
writes_type(mylog,pp,ierror||"unexpected type pp")
}
default: {
writes_type(mylog,pp,ierror||"unexpected type pp")
}
}
if DEBUG=="PPLIST" then {
writes_type(mylog,pp,info||"pp")
}
p := pp.svalue[1]
if DEBUG=="PPLIST" then {
writes_type(mylog,p,info||"p")
}
if type(p)=="list" then {
p := !p
}
if p == prep then {
foundprep := "yes"
} else {
foundpp := put(foundpp,pp)
} # end if p
} # end while pp
if DEBUG=="PPLIST" then {
if foundprep=="yes" then {
writes_type(mylog,prep,info||"deleted")
} else {
writes_type(mylog,prep,info||"not found")
}
}
foundpp := SYMBOL("pplist",foundpp)
return foundpp
end
procedure pp2arg(pplist)
#=======================
# make arglist to match old format
# pp ::= SYMBOL("pp",["od",nvlist])
# arglist := nvlist, but convert nv SYMBOLs
local arglist,odpp,nvlist,nv
static info,warning,ierror
initial {
info := "INFO: pp2arg: "
warning := "WARNING: pp2arg: "
ierror := "Internal ERROR: pp2arg: "
}
writes_type(mylog,pplist,info||"pplist")
arglist := []
if odpp := get_pp("od",pplist) then {
nvlist := odpp.svalue[2]
every nv := !nvlist do {
# NOTE: sometimes nv SYMBOL gets converted
# e.g.: by get_string() or unparse()
case type(nv) of {
"SYMBOL": { # as expected
case nv.stype of {
"nv": { arglist |||:= nv.svalue } # [name,op,value]
"nvnull": { arglist |||:= [nv.svalue] } # [name]
}
} # end case "SYMBOL"
"list": { # unexpected, but recover
writes_type(mylog,nv,warning||"unexpected type nv")
arglist |||:= nv
}
default: { # unexpected, give up
writes_type(mylog,nv,ierror||"unexpected type nv")
fail
}
} # end case type(nv)
} # end every nv
} else {
# empty arglist
}
writes_type(mylog,arglist,info||"arglist")
return arglist
end
#------------------------------------------------------------#
procedure pplist2fmtlist(pplist)
#===============================
# convert pplist to fmtlist
# called from format2list() in role.icn
# called from do_method() in method.icn
local AtOfWithOutOdFromToIn,x,y,z
static info
initial {
info := "INFO: pplist2fmtlist: "
}
AtOfWithOutOdFromToIn := get_ppobject(pplist) # pplist.icn
y := []
every x := !AtOfWithOutOdFromToIn do {
case *x of {
0: { }
default: {
if DEBUG=="FORMAT" then {
writes_type(mybug,x,info||"x")
writes_type(mylog,x,info||"x")
}
y |||:= x
}
} # end case *x
} # end every x
# convert nest to list
z := []
every x := !y do {
put(z,x[1])
} # end every x
if DEBUG=="FORMAT" then {
writes_type(mybug,z,info||"z")
writes_type(mylog,z,info||"z")
}
return z
end
#------------------------------------------------------------#
# list
procedure is_ppnull(pplist)
#==========================
# check for different forms of empty pplist
# return empty list for success
static ierror,utype,ustype
initial {
ierror := "Internal ERROR: is_ppnull: "
utype := ierror||"unexpected type pplist"
ustype := ierror||"unexpected stype pplist"
}
case type(pplist) of {
default: {
writes_type(myerr,pplist,utype)
writes_type(mylog,pplist,utype)
fail
}
"null": { return [] }
"SYMBOL": {
case pplist.stype of {
default: {
writes_type(myerr,pplist,ustype)
writes_type(mylog,pplist,ustype)
fail
}
"null": { return [] }
"ppnull": { return [] }
"pplist": {
if *pplist.svalue = 0 then
return []
else
fail
}
} # end case stype
} # end "SYMBOL"
"list": {
if *pplist = 0 then
return []
else
fail
} # end "list"
} # end case type()
end
#--------------------------------------#
# PPOBJECT
procedure copy_ppobject(x)
#=========================
local new
new := new_ppobject([])
new.ppat := copy_list(x.ppat)
new.ppout := copy_list(x.ppout)
new.ppof := copy_list(x.ppof)
new.ppwith := copy_list(x.ppwith)
new.ppod := copy_list(x.ppod)
new.ppfrom := copy_list(x.ppfrom)
new.ppto := copy_list(x.ppto)
new.ppin := copy_list(x.ppin)
return new
end
# ]]>