# # KEHOME/parser/pplist.icn # Richard H. McCullough Oct/18/2005 Jul/20/2009 Sep/27/2014 Feb/15/2015 link unparse link deepcopy # pplist ::= # SYMBOL("pplist",[pp,... ]) record PPHRASE( pp_list # [prep,object] ) record PPOBJECT ( ppat, # csnvlist action context ppof, # csnvlist action domains ppwith, # csnvlist action characteristics ppod, # csnvlist action direct objects ppfrom, # csnvlist action initial characteristics ppto, # csnvlist action final characteristics ppin, # csnvlist list|array|relation ppout # csnvlist action products ) # procedures #=========== # copy_ppobject(x) # use deepcopy() # delete_pp(prep,pplist) # find_ppobject(x) # get_pp(prep,pplist) # use deepcopy() # get_ppobject(pplist,option) # get_product(x) # is_ppnull(pplist) # new_pp(prep,nvlist) # new_pplist(pp_list) # new_ppobject(pplist) # pp_list(x) # pp_object(x) # pp_prep(x) # pp2arg(pplist) # pplist2fmtlist(pplist) # ppobj2nov(ppobj) # ppobject_arglist(x) # ppobject_unparse(x,first,prefix,suffix,last) # ppobject_update(old,pplist) # ppobject_writes(fd,x,fsep,tail) # put_pp(pplist,pp) # put_product(pplist,product) # SYMBOL procedure new_pplist(x) #====================== local t,y static prog,b,colon,yyprefix initial { prog := "new_pp: " b := " " colon := ":" } yyprefix := yylineno||colon||yywordno||b||KFORMAT||b||prog case t := type(x) of { default: { write(&errout,yyprefix,"unexpected input type (",t, ") x = (",showparse(x),")"); fail } "PPHRASE": { y := [x] } "list": { y := PHRASE(x) } } # end case t return SYMBOL("pplist",y) end # PPHRASE procedure new_pp(prep,csnvlist) #============================== local t,x,y,pp static prog,b,colon,yyprefix initial { prog := "new_pp: " b := " " colon := ":" } yyprefix := yylineno||colon||yywordno||b||KFORMAT||b||prog x := unparse(prep) case t := type(csnvlist) of { default: { write(&errout,yyprefix,"unexpected input type (",t,")") } "NVPHRASE": { y := csnvlist } "PHRASE": { y := csnvlist } "CSV": { y := csnvlist } "string": { y := PHRASE(csnvlist) } "integer": { y := PHRASE(csnvlist) } "real": { y := PHRASE(csnvlist) } } # end case t pp := PPHRASE([x,y]) if yydebug = 1 then write(mylog,yyprefix,"pp = (",showparse(pp),")") return pp end # list procedure pp_list(x) #=================== local t,y static prog,b,colon,yyprefix initial { prog := "pp_list: " b := " " colon := ":" } yyprefix := yylineno||colon||yywordno||b||KFORMAT||b||prog case t := type(x) of { default: { write(mylog,yyprefix,"unexpected input type (",t,") x = (",showparse(x),")"); y := [] } "PPHRASE": { y := x.pp_list } } return y end # string procedure pp_prep(x) #=================== local t,y static prog,b,colon,yyprefix initial { prog := "pp_prep: " b := " " colon := ":" } yyprefix := yylineno||colon||yywordno||b||KFORMAT||b||prog case t := type(x) of { default: { write(mylog,yyprefix,"unexpected input type (",t,") x = (",showparse(x),")"); y := "" } "PPHRASE": { y := x.pp_list[1] } } return unparse(y) end # CSV or [] procedure pp_object(x) #===================== local t,y static prog,b,colon,yyprefix initial { prog := "pp_object: " b := " " colon := ":" } yyprefix := yylineno||colon||yywordno||b||KFORMAT||b||prog case t := type(x) of { default: { write(mylog,yyprefix,"unexpected input type (",t,") x = (",showparse(x),")"); y := [] } "PPHRASE": { y := x.pp_list[2] } } # end case return y end # string procedure get_product(x) #======================= # get product from x local t,y static prog,b,colon,yyprefix initial { prog := "get_product: " b := " " colon := ":" } yyprefix := yylineno||colon||yywordno||b||KFORMAT||b||prog case t := type(x) of { default: { write(&errout,yyprefix,"unexpected input type (",t,") x = (",showparse(x),")"); y := [] } "PPHRASE": { y := unparse(pp_object(x)) } "PPOBJECT": { y := unparse(x.ppout) } "SYMBOL": { y := unparse(pp_object(get_pp("out",x))) } } if DEBUG == "PRODUCT" then write(mylog,yyprefix,"x = (",showparse(x),") y = (",showparse(y),")") return y end # pplist or PPOBJECT procedure put_product(x,product) #=============================== # put product in x # product ::= string | PHRASE # x ::= pplist | PPOBJECT local t,st,outpp,newx static prog,b,colon,yyprefix static info,ierror initial { prog := "put_product: " b := " " colon := ":" info := "INFO: "||prog ierror := "Internal ERROR: "||prog } yyprefix := yylineno||colon||yywordno||b||KFORMAT||b||prog case t := type(product) of { default: { write(&errout,yyprefix,"unexpected input type (",t,") product = (",showparse(product),")"); return x } ("string"|"integer"|"real"): { outpp := PPHRASE(["out",product]) } "PPHRASE": { outpp := PPHRASE(["out",product]) } "list": { outpp := PPHRASE(["out",product]) } } # end case t case t := type(x) of { default: { write(&errout,yyprefix,"unexpected input type (",t,") x = (",showparse(x),")"); return x } "list": { newx := x newx |||:= [outpp] } "SYMBOL": { case st := x.stype of { default: { write(&errout,yyprefix,"unexpected input stype (",st,") x = (",showparse(x),")"); return x } "pplist": { } } # end case st newx := SYMBOL("pplist",x.svalue ||| [outpp]) } "PPOBJECT": { newx := x newx.ppout |||:= [pp_object(outpp)] } } # end case t if DEBUG == "PRODUCT" then write(&output,yyprefix,"x = (",showparse(x),") product = (",showparse(product),") newx = (",showparse(newx),")") return deepcopy(newx) 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 prog static info,warning,ierror initial { prog := "pp2arg: " info := "INFO: "||prog warning := "WARNING: "||prog ierror := "Internal ERROR: "||prog } write_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 write_type(mylog,nv,warning||"unexpected type nv") arglist |||:= nv } default: { # unexpected, give up write_type(mylog,nv,ierror||"unexpected type nv") fail } } # end case type(nv) } # end every nv } else { # empty arglist } write_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 prog static info initial { prog := "pplist2fmtlist: " info := "INFO: "||prog } AtOfWithOutOdFromToIn := get_ppobject(pplist) # pplist.icn y := [] every x := !AtOfWithOutOdFromToIn do { case *x of { 0: { } default: { if DEBUG=="FORMAT" then { write_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 { write_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 prog static ierror,utype,ustype initial { prog := "is_ppnull: " ierror := "Internal ERROR: "||prog utype := ierror||"unexpected type pplist" ustype := ierror||"unexpected stype pplist" } case type(pplist) of { default: { write_type(&errout,pplist,utype) write_type(mylog,pplist,utype) fail } "null": { return [] } "SYMBOL": { case pplist.stype of { default: { write_type(&errout,pplist,ustype) write_type(mylog,pplist,ustype) fail } "null": { return [] } "ppnull": { return [] } ("pplist"|"pp"): { 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) #========================= return deepcopy(x) end # pp or [] procedure get_pp(prep,pplist) #============================ # pplist ::= SYMBOL("pplist",[pp,...]) local t,st,pp,found static prog,b,colon,yyprefix initial { prog := "get_pp: " b := " " colon := ":" } yyprefix := yylineno||colon||yywordno||b||KFORMAT||b||prog prep := unparse(prep) if DEBUG == "PPLIST" then write(mylog,yyprefix,"prep = (",image(prep),") pplist = (",showparse(pplist),")") if ((t := type(pplist)) == "SYMBOL") & ((st := pplist.stype) == "pplist") then { # continue below } else { write(mylog,yyprefix,"unexpected input type (",t,") or stype (",image(st),") pplist = (",showparse(pplist),")") return [] } # end if every pp := ! pplist.svalue do { if prep == unparse(pp_prep(pp)) then { if DEBUG == "PPLIST" then write(mylog,yyprefix,"pp = (",showparse(pp),")") return deepcopy(pp) } } # end every pp return [] end # procedure # SYMBOL procedure put_pp(pplist,pp) #========================== local t,st,tpp local newsv,newpplist static prog,b,colon,yyprefix initial { prog := "put_pp: " b := " " colon := ":" } yyprefix := yylineno||colon||yywordno||b||KFORMAT||b||prog if ((t := type(pplist)) == "SYMBOL") & ((st := pplist.stype) == "pplist") & ((tpp := type(pp)) == "PPHRASE") then { # continue below } else { write(&errout,yyprefix,"unexpected input type: ", "t = ", image(t)," st = ",image(st),") tpp = (",image(tpp),")") return pplist } # end if newsv := pplist.svalue put(newsv,pp) newpplist := SYMBOL("pplist",newsv) return newpplist end # SYMBOL procedure delete_pp(prep,pplist) #=============================== # delete prepphrase for specified prep local t,st,pp local newsv,newpplist static prog,b,colon,yyprefix static info,ierror,error initial { prog := "delete_pp: " b := " " colon := ":" info := "INFO: "||prog ierror := "Internal ERROR: "||prog error := "ERROR: "||prog } yyprefix := yylineno||colon||yywordno||b||KFORMAT||b||prog if DEBUG=="PPLIST" then { write(mylog,yyprefix,"looking for ",prep," in pplist = (",showparse(pplist),")") } prep := unparse(prep) if ((t := type(pplist)) == "SYMBOL") & ((st := pplist.stype) == "pplist") then { newsv := [] every pp := !pplist.svalue do { if prep ~== pp_prep(pp) then put(newsv,pp) } # end every pp } else { write(&errout,yyprefix,"unexpected input type: ", "t = ", t," st = ",st, " tpp = ",")") fail } # end if newpplist := SYMBOL("pplist",newsv) return newpplist end # PPOBJECT or [] procedure get_ppobject(pplist) #============================= # called by command() in command.icn # called by do_definition() in definition.icn # called by pplist2fmtlist() in pplist.icn local t,st static prog,b,colon,yyprefix static info,warning,ierror initial { prog := "get_ppobject: " b := " " colon := ":" info := "INFO: "||prog warning := "WARNING: " ierror := "Internal ERROR: "||prog } yyprefix := yylineno||colon||yywordno||b||KFORMAT||b||prog if DEBUG==("PPLIST"|"NV") then { write(mylog,yyprefix,"input pplist = (",showparse(pplist),")") } case t := type(pplist) of { default: { write(mylog,yyprefix,"unexpected input type (",t,") pplist = (",showparse(pplist),")"); return [] } "list": { if *pplist = 0 then return [] } "SYMBOL": { if *pplist.svalue = 0 then return []} } # end case t case st := pplist.stype of { default: { write(&errout,yyprefix,"unexpected input stype (",st,") pplist = (",showparse(pplist),")"); return [] } "pplist": { } } # end case st return new_ppobject(pplist) end # PPOBJECT procedure new_ppobject(pplist) #============================= local ppobj,atphrase,outphrase,ofphrase,withphrase, odphrase,fromphrase,tophrase,inphrase static prog,b,c,colon,yyprefix static info initial { prog := "new_ppobject: " b := " " c := "," colon := ":" info := "INFO: "||prog } yyprefix := yylineno||colon||yywordno||b||KFORMAT||b||prog ppobj := PPOBJECT() atphrase := get_pp("at", pplist) # context ofphrase := get_pp("of", pplist) # part withphrase := get_pp("with",pplist) # modifier odphrase := get_pp("od", pplist) # direct object fromphrase := get_pp("from",pplist) # initial state tophrase := get_pp("to", pplist) # final state inphrase := get_pp("in", pplist) # array outphrase := get_pp("out", pplist) # output if DEBUG == ("PP"|"PPLIST") then { write(mylog,yyprefix,"atphrase = (", showparse(atphrase), "") write(mylog,yyprefix,"ofphrase = (", showparse(ofphrase), "") write(mylog,yyprefix,"withphrase = (",showparse(withphrase),"") write(mylog,yyprefix,"odphrase = (", showparse(odphrase), "") write(mylog,yyprefix,"fromphrase = (",showparse(fromphrase),"") write(mylog,yyprefix,"tophrase = (", showparse(tophrase), "") write(mylog,yyprefix,"inphrase = (", showparse(inphrase), "") write(mylog,yyprefix,"outphrase = (", showparse(outphrase), "") } ppobj.ppat := pp_object(atphrase) ppobj.ppof := pp_object(ofphrase) ppobj.ppwith := pp_object(withphrase) ppobj.ppod := pp_object(odphrase) ppobj.ppfrom := pp_object(fromphrase) ppobj.ppto := pp_object(tophrase) ppobj.ppin := pp_object(inphrase) ppobj.ppout := pp_object(outphrase) return ppobj end # PPOBJECT procedure ppobj2nov(ppobj) #========================= # convert NVPHRASE to nov list local new new := PPOBJECT() new.ppat := nv2nov(ppobj.ppat) 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) new.ppout := nv2nov(ppobj.ppout) return new end procedure ppobject_writes(fd,x,fsep,tail) #======================================== local At,Out,Of,With,Od,From,To,In static c initial c := "," /fd := &output /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) write(fd,unparse(At)); writes(fd,c,fsep) write(fd,unparse(Of)); writes(fd,c,fsep) write(fd,unparse(With)); writes(fd,c,fsep) write(fd,unparse(Out)); writes(fd,c,fsep) write(fd,unparse(Od)); writes(fd,c,fsep) write(fd,unparse(From)); writes(fd,c,fsep) write(fd,unparse(To)); writes(fd,c,fsep) write(fd,unparse(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 prog,b,c,colon,yyprefix static info,ierror,lsep,psep initial { prog := "ppobject_unparse: " b := " " c := "," colon := ":" info := "INFO: "||prog ierror := "Internal ERROR: "||prog lsep := c psep := b } /first := "[\n" /prefix := repl(" ",4) /suffix := "\n" /last := prefix||"]\n" yyprefix := yylineno||colon||yywordno||b||KFORMAT||b||prog case t := type(x) of { "PPOBJECT": { } default: { write(&errout,yyprefix,"unexpected input type ("||t||")") write(mylog, yyprefix,"unexpected input type ("||t||")") return "(UNEXPECTED PPOBJECT)" } } # end case At := unparse(x.ppat,lsep) Of := unparse(x.ppof,lsep) With := unparse(x.ppwith,lsep) Od := unparse(x.ppod,lsep) From := unparse(x.ppfrom,lsep) To := unparse(x.ppto,lsep) In := unparse(x.ppin,lsep) Out := unparse(x.ppout,lsep) line := [first] if *At > 0 then put(line,PHRASE([prefix,"at",At,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])) if *Out > 0 then put(line,PHRASE([prefix,"out",Out,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 prog,b,colon,yyprefix static info,ierror initial { prog := "ppobject_arglist: " b := " " colon := ":" info := "INFO: "||prog ierror := "Internal ERROR: "||prog } yyprefix := yylineno||colon||yywordno||b||KFORMAT||b||prog if DEBUG=="PPLIST" then { write(mylog,yyprefix,"x = (",showparse(x),")") uarglist := [] uaritylist := [] } arglist := [] case t := type(x) of { default: { write(&errout,yyprefix,"unexpected input type (",t,")") fail } "PPOBJECT": { } "list": { if (*x = 1) & (type(x[1]) == "PPOBJECT") then { write(mylog,yyprefix,"warning: ","unexpected input type (",t,")") x := x[1] } else { write(&errout,yyprefix,"unexpected input type (",t,")") fail } } } # end case t At := x.ppat Of := x.ppof With := x.ppwith Od := x.ppod From := x.ppfrom To := x.ppto In := x.ppin Out := x.ppout if DEBUG=="PPLIST" then { uAt := list_unparse(At) uOf := list_unparse(Of) uWith := list_unparse(With) uOd := list_unparse(Od) uFrom := list_unparse(From) uTo := list_unparse(To) uIn := list_unparse(In) uOut := list_unparse(Out) write(mylog,yyprefix,"uAt = (", showparse(uAt),")") write(mylog,yyprefix,"uOf = (", showparse(uOf),")") write(mylog,yyprefix,"uWith = (",showparse(uWith),")") write(mylog,yyprefix,"uOd = (", showparse(uOd),")") write(mylog,yyprefix,"uFrom = (",showparse(uFrom),")") write(mylog,yyprefix,"uTo = (", showparse(uTo),")") write(mylog,yyprefix,"uIn = (", showparse(uIn),")") write(mylog,yyprefix,"uOut = (", showparse(uOut),")") } if *At > 0 then put(arglist,At) 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 *Out > 0 then put(arglist,Out) if DEBUG=="PPLIST" then { #if *At > 0 then { put(uarglist,[uAt]) put(uaritylist,*uAt) #} #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) #} #if *Out > 0 then { put(uarglist,[uOut]) put(uaritylist,*uOut) #} write(mylog,yyprefix,"output arglist = (", showparse(arglist),")") write(mylog,yyprefix,"output uarglist = (", showparse(uarglist),")") write(mylog,yyprefix,"output uaritylist = (",showparse(uaritylist),")") } return arglist end # PPOBJECT procedure find_ppobject(x) #========================= # called by do_production() in statement.icn # option := "nv" | "nov" local t,y,z,zz static prog,b,colon,yyprefix static info,warning,ierror initial { prog := "find_ppobject: " b := " " colon := ":" info := "INFO: "||prog warning := "WARNING: "||prog ierror := "Internal ERROR: "||prog } yyprefix := yylineno||colon||yywordno||b||KFORMAT||b||prog y := &null case t := type(x) of { default: { write(&errout,yyprefix,"unexpected input type ("||t||")") 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 ppobject_update(old,pplist) #====================================== local new new := new_ppobject(pplist) if *new.ppat = 0 then new.ppat := old.ppat 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 if *new.ppout = 0 then new.ppout := old.ppout return new end #