moduleLanguage.Egison.CorewhereimportLanguage.Egison.NumericalimportLanguage.Egison.ParserimportLanguage.Egison.PrimitivesimportLanguage.Egison.TypesimportLanguage.Egison.VariablesimportLanguage.Egison.MacroimportControl.Monad.ErrorimportData.ArrayimportqualifiedData.MapimportqualifiedSystem.Exit()importSystem.Directory(doesFileExist)importSystem.IOimportData.IORefimportData.VersionimportPaths_egisonegisonVersion::StringegisonVersion=showVersionversion-- |A utility function to display the egison console bannershowBanner::IO()showBanner=doputStrLn$"Egison Version "++egisonVersion++" (c) 2011-2012 Satoshi Egi"putStrLn$"http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/"putStrLn$"Welcome to Egison Interpreter!"-- |A utility function to display the egison console byebye messageshowByebyeMessage::IO()showByebyeMessage=doputStrLn$"Leaving Egison."putStrLn$"Byebye. See you again! (^^)/"-- |Load standard libraries into the given environmentloadLibraries::Env->IO()loadLibrariesenv=do-- Load standard library_<-evalStringenv$"(load \"lib/core/base.egi\")"_<-evalStringenv$"(load \"lib/core/number.egi\")"_<-evalStringenv$"(load \"lib/core/collection.egi\")"_<-evalStringenv$"(load \"lib/core/array.egi\")"return()-- |A utility function to escape backslashes in the given stringescapeBackslashes::String->StringescapeBackslashess=foldrstep[]swherestepxxs|x=='\\'='\\':'\\':xs|otherwise=x:xsevalString::Env->String->IOStringevalStringenvstr=runIOThrowsREPL$(liftThrows$readTopExprstr)>>=evalTopExprenvevalMain::Env->[String]->IOThrowsErrorEgisonValevalMainenvargs=doletmainExpr=VarExpr"main"[]main<-cEval1$ClosureenvmainExprmainRef<-liftIO$newIORefmainletargvExpr=CollectionExpr$map(ElementExpr.StringExpr)argsargv<-cEval1$ClosureenvargvExprargvRef<-liftIO$newIORefargvworldRef<-liftIO$newIORef$Value$World[]argsRef<-liftIO$newIORef$Intermidiate$ITuple$[IElementworldRef,IElementargvRef]ret<-cApply1mainRefargsRefcEvalret-- |Evaluate egison top expression that has already been loaded into haskellevalTopExpr::Env->TopExpr->IOThrowsErrorStringevalTopExprenv(Testexpr)=liftMshow$evalenvexprevalTopExprenv(Definenameexpr)=doclr<-liftIO$makeClosureenvexprdefineVarenv(name,[])clrreturnnameevalTopExprenv(Executeargs)=doevalMainenvargsreturn""evalTopExprenv(LoadFilefilename)=doresult<-liftIO$doesFileExistfilenameifresultthendo(liftIO$readFilefilename)>>=loadenvreturn$filename++" loaded."elsethrowError$Default$"File does not exist: "++filenameevalTopExprenv(Loadlibname)=dofilename<-liftIO(getDataFileNamelibname)result<-liftIO$doesFileExistfilenameifresultthendo(liftIO$readFilefilename)>>=loadenvreturn$filename++" loaded."elsethrowError$Default$"Library does not exist: "++libnameload::Env->String->IOThrowsError()loadenvstr=doexprs<-liftThrows$readTopExprListstrmapM(evalTopExprenv)exprsreturn()-- |Evaluate egison expression that has already been loaded into haskelleval::Env->EgisonExpr->IOThrowsErrorEgisonValevalenvexpr=doobj<-cEval1(Closureenvexpr)caseobjofValueval->returnvalIntermidiateiVal->iEvaliVal_->throwError$Default$"eval: cannot reach here!: "++showobjiEval::IntermidiateVal->IOThrowsErrorEgisonValiEval(IInductiveDataconsargRefs)=doargs<-mapMcRefEvalargRefsreturn$InductiveDataconsargsiEval(ICollectioninnerRefs)=dovals<-innerRefsEvalinnerRefsreturn$CollectionvalsiEval(ITupleinnerRefs)=doinnerVals<-innerRefsEvalinnerRefsreturn$TupleinnerValsinnerRefsEval::[InnerValRef]->IOThrowsError[EgisonVal]innerRefsEval[]=return[]innerRefsEval((IElementobjRef):rest)=doval<-cRefEvalobjRefvals<-innerRefsEvalrestreturn(val:vals)innerRefsEval((ISubCollectionsubObjRef):rest)=dosubVal<-cRefEvalsubObjRefcasesubValofCollectionvals->doretRest<-innerRefsEvalrestreturn$vals++retRest_->throwError$Default"innerRefsEval: not collection for subcollection"cRefEval::ObjectRef->IOThrowsErrorEgisonValcRefEvalobjRef=doobj<-liftIO$readIORefobjRefval<-cEvalobjliftIO$writeIORefobjRef$ValuevalreturnvalcRefEval1::ObjectRef->IOThrowsErrorObjectcRefEval1objRef=doobj<-liftIO$readIORefobjRefcaseobjofClosure__->doobj2<-cEval1objliftIO$writeIORefobjRefobj2returnobj2_->returnobjcEval::Object->IOThrowsErrorEgisonValcEval(Closureenvexpr)=evalenvexprcEval(Valueval)=returnvalcEval(IntermidiateiVal)=iEvaliValcEval(Loop_____)=throwError$Default"cEval: cannot reach here: loop object cannot be evaluated"cEval1::Object->IOThrowsErrorObjectcEval1(Closure_(BoolExprcontents))=return$Value(Boolcontents)cEval1(Closure_(CharExprcontents))=return$Value(Charcontents)cEval1(Closure_(StringExprcontents))=return$Value(Stringcontents)cEval1(Closure_(NumberExprcontents))=return$Value(Numbercontents)cEval1(Closure_(FloatExprcontents))=return$Value(Floatcontents)cEval1(Closure_SomethingExpr)=return$ValueSomethingcEval1(Closureenv(VarExprnamenumExprs))=donumVals<-mapM(evalenv)numExprsnums<-mapM(\nVal->casenValofNumbernum->returnnum_->throwError$Default"cEval1: cannot reach here!")numValsobjRef<-getVarenv(name,nums)obj<-cRefEval1objRefcaseobjof-- for Macro expansionLoop_____->expandLoopenvobj_->returnobjcEval1(Closure_(InductiveDataExprcons[]))=doreturn$Value$InductiveDatacons[]cEval1(Closureenv(InductiveDataExprconsargExprs))=doargs<-liftIO$mapM(makeClosureenv)argExprsreturn$Intermidiate$IInductiveDataconsargscEval1(Closure_(TupleExpr[]))=doreturn$Value$Tuple[]cEval1(Closureenv(TupleExprinnerExprs))=doinnerRefs<-liftIO$mapM(makeInnerValRefenv)innerExprsobjRefs<-innerRefsToObjRefsinnerRefscaseobjRefsof[objRef]->cRefEval1objRef_->return$Intermidiate$ITupleinnerRefscEval1(Closureenv(CollectionExprinnerExprs))=doinnerRefs<-liftIO$mapM(makeInnerValRefenv)innerExprsreturn$Intermidiate$ICollectioninnerRefscEval1(Closureenv(ArrayExprinnerArrayExprs))=doletdimension=calcDimensioninnerArrayExprsletsize=calcSizeinnerArrayExprselemExprs<-liftThrows$calcElemExprsinnerArrayExprsvals<-mapM(evalenv)elemExprsreturn$Value$Arraydimensionsize$listArray(1,(fromIntegral(lengthvals)))valswherecalcDimensionaExprs=helper1aExprswherehelpern[]=nhelpern((AElementExpr_):_)=nhelpern((AInnerArrayExprinner):_)=helper(n+1)innercalcSizeaExprs=helper[]aExprswherehelperns[]=ns++[0]helpernsaExprs2@((AElementExpr_):_)=ns++[(fromIntegral(lengthaExprs2))]helpernsaExprs2@((AInnerArrayExprinner):_)=helper(ns++[(fromIntegral(lengthaExprs2))])innercalcElemExprs[]=return[]calcElemExprsaExprs@((AElementExpr_):_)=mapM(\aExpr->caseaExprofAElementExprexpr->returnexpr_->throwError$Default"type error in array")aExprscalcElemExprsaExprs@((AInnerArrayExpr_):_)=liftMconcat$mapM(\aExpr->caseaExprofAInnerArrayExpraExprs2->calcElemExprsaExprs2_->throwError$Default"type error in array")aExprscEval1(Closure_WildCardExpr)=return$ValueWildCardcEval1(Closureenv(PatVarExprnamenumExprs))=donumVals<-mapM(evalenv)numExprsnums<-mapM(\nVal->casenValofNumbernum->returnnum_->throwError$Default"cEval1: cannot reach here!")numValsreturn$Value$PatVarnamenumscEval1(Closureenv(ValuePatExprexpr))=doobjRef<-liftIO$makeClosureenvexprreturn$Value$ValuePatobjRefcEval1(Closureenv(PredPatExprpredExprargExprs))=dopredObjRef<-liftIO$makeClosureenvpredExprargObjRefs<-liftIO$mapM(makeClosureenv)argExprsreturn$Value$PredPatpredObjRefargObjRefscEval1(Closureenv(CutPatExprpatExpr))=dopatObjRef<-liftIO$makeClosureenvpatExprreturn$Value$CutPatpatObjRefcEval1(Closureenv(NotPatExprpatExpr))=dopatObjRef<-liftIO$makeClosureenvpatExprreturn$Value$NotPatpatObjRefcEval1(Closureenv(OrPatExprpatExprs))=dopatObjRefs<-liftIO$mapM(makeClosureenv)patExprsreturn$Value$OrPatpatObjRefscEval1(Closureenv(AndPatExprpatExprs))=dopatObjRefs<-liftIO$mapM(makeClosureenv)patExprsreturn$Value$AndPatpatObjRefscEval1(Closureenv(FuncExprargsbody))=doreturn$Value$FuncargsbodyenvcEval1(Closure_(MacroExprargsbody))=doreturn$Value$MacroargsbodycEval1(Closureenv(IfExprcondExprexpr1expr2))=doobj<-cEval1$ClosureenvcondExprcaseobjofValue(BoolTrue)->cEval1$Closureenvexpr1Value(BoolFalse)->cEval1$Closureenvexpr2_->throwError$Default"if: condition is not bool value"cEval1(Closureenv(LetExprbindingsbody))=donewEnv<-extendLetenvbindingscEval1(ClosurenewEnvbody)cEval1(Closureenv(LetRecExprbindingsbody))=donewEnv<-liftIO$extendLetRecenvbindingscEval1$ClosurenewEnvbodycEval1(Closureenv(DoExpr[]body))=docEval1$ClosureenvbodycEval1(Closureenv(DoExpr(binding:bindings)body))=donewEnv<-extendLetenv[binding]cEval1$ClosurenewEnv$DoExprbindingsbodycEval1(Closureenv(TypeExprdestructInfoExpr))=dodestructInfo<-liftIO$makeDestructInfodestructInfoExprreturn$Value$TypedestructInfowheremakeDestructInfo[]=return[]makeDestructInfo((pppat,typExpr,pmcs):rest)=dotypObjRef<-liftIO$makeClosureenvtypExprletepmcs=map(\(ppat,body)->(env,ppat,body))pmcsretRest<-makeDestructInforestreturn((pppat,typObjRef,epmcs):retRest)cEval1(Closureenv(MatchAllExprtgtExprtypExpr(patExpr,body)))=dopatObjRef<-liftIO$makeClosureenvpatExprtgtObjRef<-liftIO$makeClosureenvtgtExprtypObjRef<-liftIO$makeClosureenvtypExprmatchs<-patternMatchMAll[(MState[][(MAtom(PClosure[]patObjRef)tgtObjReftypObjRef)])]rets<-mapM(\match->donewEnv<-liftIO$extendEnvenvmatchobjRef<-liftIO$newIORef(ClosurenewEnvbody)returnobjRef)matchsreturn$Intermidiate$ICollection$mapIElementretscEval1(Closureenv(MatchExprtgtExprtypExprmcs))=dotgtObjRef<-liftIO$makeClosureenvtgtExprtypObjRef<-liftIO$makeClosureenvtypExprmcLooptgtObjReftypObjRefmcswheremcLoop__[]=throwError$Default"end of match clauses"mcLooptgtObjReftypObjRef((patExpr,body):rest)=dopatObjRef<-liftIO$makeClosureenvpatExprmatchs<-patternMatchMOne[(MState[][(MAtom(PClosure[]patObjRef)tgtObjReftypObjRef)])]casematchsof[]->mcLooptgtObjReftypObjRefrest[match]->donewEnv<-liftIO$extendEnvenvmatchcEval1(ClosurenewEnvbody)_->throwError$Default"cEval1.mcLoop: cannot reach here"cEval1(Closureenv(LoopExprloopVarindexVarrangeExprloopExprtailExpr))=dorangeObjRef<-liftIO$makeClosureenvrangeExprletloopObj=LooploopVarindexVarrangeObjRefloopExprtailExprexpandLoopenvloopObjcEval1(Closureenv(GenerateArrayExprfnExprrangeExpr))=dofnObjRef<-liftIO$makeClosureenvfnExprrangeVal<-evalenvrangeExprms<-liftThrows$mapMunpackNum$tupleToListrangeValletd=fromIntegral$lengthmsletis=map(\iss->(Value.Tuple)$mapNumberiss)$indexListmsisRefs<-liftIO$mapMnewIORefisvals<-mapM(cApplyfnObjRef)isRefsreturn$Value$Arraydms$listArray(1,(fromIntegral(lengthvals)))valscEval1(Closureenv(ApplyExpropExprargExpr))=doop<-cEval1(ClosureenvopExpr)caseopofValue(IOFuncfn)->doarg<-evalenvargExprval<-fn(tupleToListarg)return$ValuevalValue(PrimitiveFuncfn)->doarg<-evalenvargExprval<-liftThrows$fn(tupleToListarg)return$ValuevalValue(FuncfArgsbodycEnv)->doframe<-liftIO(makeClosureenvargExpr)>>=makeFramefArgsnewEnv<-liftIO$extendEnvcEnvframecEval1(ClosurenewEnvbody)Value(MacromArgsbody)->doargExprs<-liftThrows$tupleExprToExprListargExprnewBody<-expandMacro(Data.Map.fromList(zipmArgsargExprs))bodyliftIO$putStrLn$showExprnewBodycEval1(ClosureenvnewBody)_->throwError$Default"not function"cEval1val=doreturnvalcApply::ObjectRef->ObjectRef->IOThrowsErrorEgisonValcApplyfnObjRefargObjRef=dofnObj<-cRefEval1fnObjRefcasefnObjofValue(IOFuncfn)->doarg<-cRefEvalargObjRefval<-fn(tupleToListarg)return$valValue(PrimitiveFuncfn)->doarg<-cRefEvalargObjRefval<-liftThrows$fn(tupleToListarg)return$valValue(FuncfArgsbodycEnv)->doframe<-makeFramefArgsargObjRefnewEnv<-liftIO$extendEnvcEnvframecEval(ClosurenewEnvbody)_->throwError$Default"cApply1 not function"cApply1::ObjectRef->ObjectRef->IOThrowsErrorObjectcApply1fnObjRefargObjRef=dofnObj<-cRefEval1fnObjRefcasefnObjofValue(IOFuncfn)->doarg<-cRefEvalargObjRefval<-fn(tupleToListarg)return$ValuevalValue(PrimitiveFuncfn)->doarg<-cRefEvalargObjRefval<-liftThrows$fn(tupleToListarg)return$ValuevalValue(FuncfArgsbodycEnv)->doframe<-makeFramefArgsargObjRefnewEnv<-liftIO$extendEnvcEnvframecEval1(ClosurenewEnvbody)_->throwError$Default"cApply1: not function"expandLoop::Env->Object->IOThrowsErrorObjectexpandLoopenv(LooploopVarindexVarrangeObjRefloopExprtailExpr)=docRefEval1rangeObjRefb<-isEmptyCollectionrangeObjRefifbthencEval1$ClosureenvtailExprelsedo(carObjRef,cdrObjRef)<-consDestructrangeObjRefloopObjRef<-liftIO$newIORef$LooploopVarindexVarcdrObjRefloopExprtailExprnewEnv<-liftIO$extendEnvenv[((loopVar,[]),loopObjRef),((indexVar,[]),carObjRef)]cEval1$ClosurenewEnvloopExprexpandLoop_obj=throwError$Default$"expandLoop: cannot reach here: "++showobj-- |Extend given environment by binding a series of values to a new environment for let.extendLet::Env-- ^ Environment ->[(Args,EgisonExpr)]-- ^ Extensions to the environment->IOThrowsErrorEnv-- ^ Extended environmentextendLetenvabindings=dobingingList<-liftMconcat$mapM(\(args,expr)->doobjRef<-liftIO$makeClosureenvexprhelperargsobjRef)abindingsliftIO$extendEnvenvbingingListwherehelper(AVarname)objRef=return[((name,[]),objRef)]helper(ATupleargss)objRef=doobj<-cRefEval1objRefcaseobjofIntermidiate(ITupleinnerRefs)->doobjRefs<-innerValRefsToObjRefsinnerRefsliftMconcat$mapM(\(args,objRef3)->helperargsobjRef3)$zipargssobjRefsValue(Tuplevals)->doobjRefs<-liftIO$mapM(newIORef.Value)valsliftMconcat$mapM(\(args,objRef3)->helperargsobjRef3)$zipargssobjRefs_->liftMconcat$mapM(\(args,objRef3)->helperargsobjRef3)$zipargss[objRef]makeFrame::Args->ObjectRef->IOThrowsError[(Var,ObjectRef)]makeFrame(AVarname)objRef=return$[((name,[]),objRef)]makeFrame(ATuple[])_=return$[]makeFrame(ATuple[fArg])objRef=makeFramefArgobjRefmakeFrame(ATuplefArgs)objRef=doobj<-cRefEval1objRefcaseobjofIntermidiate(ITupleinnerRefs)->doobjRefs<-innerValRefsToObjRefsinnerRefsframes<-mapM(\(fArg,objRef3)->makeFramefArgobjRef3)$zipfArgsobjRefsreturn$concatframesValue(Tuplevals)->doobjRefs<-liftIO$mapM(newIORef.Value)valsframes<-mapM(\(fArg,objRef3)->makeFramefArgobjRef3)$zipfArgsobjRefsreturn$concatframes_->throwError$Default"makeFrame: not tuple"tupleExprToExprList::EgisonExpr->ThrowsError[EgisonExpr]tupleExprToExprList(TupleExprinnerExprs)=innerExprsToExprListinnerExprstupleExprToExprListexpr=return[expr]innerExprsToExprList::[InnerExpr]->ThrowsError[EgisonExpr]innerExprsToExprList[]=return[]innerExprsToExprList((ElementExprexpr):rest)=doretRest<-innerExprsToExprListrestreturn(expr:retRest)innerExprsToExprList((SubCollectionExpr_):_)=throwError$Default"innerExprsToExprList: subcollection is not supported"innerValRefsToObjRefs::[InnerValRef]->IOThrowsError[ObjectRef]innerValRefsToObjRefs[]=return[]innerValRefsToObjRefs(innerRef:rest)=dorestRet<-innerValRefsToObjRefsrestcaseinnerRefofIElementobjRef->return$objRef:restRetISubCollectionobjRef->doobj2<-cRefEval1objRefcaseobj2ofIntermidiate(ICollectioninnerRefs)->doobjRefs<-innerValRefsToObjRefsinnerRefsreturn$objRefs++restRetValue(Collectionvals)->doobjRefs<-liftIO$mapMnewIORef$mapValuevalsreturn$objRefs++restRet_->throwError$Default"innerValRefsToObjRefs: not collection"patternMatch::MatchFlag->[MState]->IOThrowsError[FrameList]patternMatch_[]=return[]patternMatchMAll((MStateframe[]):rest)=doframes<-patternMatchMAllrestreturn(frame:frames)patternMatchMOne((MStateframe[]):_)=doreturn[frame]patternMatchflag((MStateframe((MAtom(PClosurebfpatObjRef)tgtObjReftypObjRef):atoms)):states)=dopatObj<-liftIO$readIORefpatObjRefcasepatObjofClosureenvexpr->donewEnv<-liftIO$extendEnvenvbfpatObj2<-cEval1$ClosurenewEnvexprpatObjRef2<-liftIO$newIORefpatObj2patternMatchflag((MStateframe((MAtom(PClosure[]patObjRef2)tgtObjReftypObjRef):atoms)):states)ValueWildCard->patternMatchflag((MStateframeatoms):states)Value(PatVarnamenums)->dotypObj<-cRefEval1typObjRefcasetypObjofValue(TypedeconsInfo)->doindRet<-inductiveMatchdeconsInfopatObjReftgtObjRefcaseindRetof(inTypObjRefs,inPatObjRefs,inTgtObjRefss)->dopatternMatchflag((map(\inTgtObjRefs->(MStateframe((map(\(pat,inTgtObjRef,inTypObjRef)->(MAtom(PClosurebfpat)inTgtObjRefinTypObjRef))(zip3inPatObjRefsinTgtObjRefsinTypObjRefs))++atoms)))inTgtObjRefss)++states)ValueSomething->patternMatchflag$(MState(((name,nums),tgtObjRef):frame)(map(\(MAtom(PClosurebf2pat2)tgt2typ2)->(MAtom(PClosure(((name,nums),tgtObjRef):bf2)pat2)tgt2typ2))atoms)):states_->throwError$Default"patternMatch: second argument of match expressions must be type"Value(ValuePat_)->do-- same with Inductive PatterntypObj<-cRefEval1typObjRefcasetypObjofValue(TypedeconsInfo)->doindRet<-inductiveMatchdeconsInfopatObjReftgtObjRefcaseindRetof(inTypObjRefs,inPatObjRefs,inTgtObjRefss)->dopatternMatchflag((map(\inTgtObjRefs->(MStateframe((map(\(pat,inTgtObjRef,inTypObjRef)->(MAtom(PClosurebfpat)inTgtObjRefinTypObjRef))(zip3inPatObjRefsinTgtObjRefsinTypObjRefs))++atoms)))inTgtObjRefss)++states)ValueSomething->throwError$Default"patternMatch: Only pattern variable can be pattern matched with Something"_->throwError$Default"patternMatch: second argument of match expressions must be type"Value(InductiveData__)->do-- same with ValuePattypObj<-cRefEval1typObjRefcasetypObjofValue(TypedeconsInfo)->doindRet<-inductiveMatchdeconsInfopatObjReftgtObjRefcaseindRetof(inTypObjRefs,inPatObjRefs,inTgtObjRefss)->dopatternMatchflag((map(\inTgtObjRefs->(MStateframe((map(\(pat,inTgtObjRef,inTypObjRef)->(MAtom(PClosurebfpat)inTgtObjRefinTypObjRef))(zip3inPatObjRefsinTgtObjRefsinTypObjRefs))++atoms)))inTgtObjRefss)++states)ValueSomething->throwError$Default"patternMatch: Only pattern variable can be pattern matched with Something"_->throwError$Default"patternMatch: second argument of match expressions must be type"Intermidiate(IInductiveData__)->do-- same with ValuePattypObj<-cRefEval1typObjRefcasetypObjofValue(TypedeconsInfo)->doindRet<-inductiveMatchdeconsInfopatObjReftgtObjRefcaseindRetof(inTypObjRefs,inPatObjRefs,inTgtObjRefss)->dopatternMatchflag((map(\inTgtObjRefs->(MStateframe((map(\(pat,inTgtObjRef,inTypObjRef)->(MAtom(PClosurebfpat)inTgtObjRefinTypObjRef))(zip3inPatObjRefsinTgtObjRefsinTypObjRefs))++atoms)))inTgtObjRefss)++states)ValueSomething->throwError$Default"patternMatch: Only pattern variable can be pattern matched with Something"_->throwError$Default"patternMatch: second argument of match expressions must be type"Intermidiate(ITuplepats)->dopatObjRefs<-innerRefsToObjRefspatstgtObjRefs<-tupleToObjRefstgtObjReftypObjRefs<-tupleToObjRefstypObjRefpatternMatchflag$(MStateframe((map(\(pat,tgt,typ)->MAtom(PClosurebfpat)tgttyp)(zip3patObjRefstgtObjRefstypObjRefs))++atoms)):statesValue(Tuplepats)->dopatObjRefs<-liftIO$mapM(newIORef.Value)patstgtObjRefs<-tupleToObjRefstgtObjReftypObjRefs<-tupleToObjRefstypObjRefpatternMatchflag$(MStateframe((map(\(pat,tgt,typ)->MAtom(PClosurebfpat)tgttyp)(zip3patObjRefstgtObjRefstypObjRefs))++atoms)):statesValue(PredPatpredObjRefpatObjRefs)->doargsObjRef<-liftIO$newIORef$Intermidiate$ITuple$mapIElement$patObjRefs++[tgtObjRef]ret<-cApply1predObjRefargsObjRefcaseretofValue(BoolTrue)->patternMatchflag((MStateframeatoms):states)Value(BoolFalse)->patternMatchflagstates_->throwError(Default"patternMatch: return value of pred-pattern is not boolean value")Value(NotPatpatObjRef2)->doretFrames<-patternMatchMOne[(MStateframe[(MAtom(PClosurebfpatObjRef2)tgtObjReftypObjRef)])]caseretFramesof[]->patternMatchflag((MStateframeatoms):states)_->patternMatchflagstatesValue(AndPatpatObjRefs)->patternMatchflag((MStateframe((map(\patObjRef2->(MAtom(PClosurebfpatObjRef2)tgtObjReftypObjRef))patObjRefs)++atoms)):states)Value(OrPatpatObjRefs)->patternMatchflag((map(\patObjRef2->(MStateframe((MAtom(PClosurebfpatObjRef2)tgtObjReftypObjRef):atoms)))patObjRefs)++states)Value(CutPatpatObjRef2)->doretFrames<-patternMatchflag[(MStateframe((MAtom(PClosurebfpatObjRef2)tgtObjReftypObjRef):atoms))]caseretFramesof[]->return[]_->caseflagofMAll->dorestFrames<-patternMatchflagstatesreturn(retFrames++restFrames)MOne->returnretFrames_->throwError$Default$"invalid pattern: "++showpatObjinductiveMatch::DestructInfo->ObjectRef->ObjectRef->IOThrowsError([ObjectRef],[ObjectRef],[[ObjectRef]])inductiveMatch[]__=throwError$Default"inductiveMatch: not matched any primitive pattern clauses"inductiveMatch((pppat,typObjRef,pclss):rest)patObjReftgtObjRef=domRet<-primitivePatPatternMatchpppatpatObjRefcasemRetofNothing->inductiveMatchrestpatObjReftgtObjRefJust(patObjRefs,frame)->domPpmRet<-helperpclsscasemPpmRetofNothing->throwError$Default"inductiveMatch: not matched any primitive clauses"JusttgtObjRefss->dotypObjRefs<-tupleToObjRefstypObjRefreturn(typObjRefs,patObjRefs,tgtObjRefss)wherehelper[]=returnNothinghelper((env,ppat,expr):pclss2)=domPpmRet<-primitivePatternMatchppattgtObjRefcasemPpmRetofNothing->helperpclss2JustppmRet->donewEnv<-liftIO$extendEnvenv(ppmRet++frame)retObjRef<-liftIO$makeClosurenewEnvexprtgtObjRefs<-collectionToObjRefsretObjReftgtObjRefss<-mapMtupleToObjRefstgtObjRefsreturn$JusttgtObjRefssprimitivePatPatternMatch::PrimitivePatPattern->ObjectRef->IOThrowsError(Maybe([ObjectRef],FrameList))primitivePatPatternMatchPPWildCardpatObjRef=return$Just([patObjRef],[])primitivePatPatternMatch(PPValuePatname)patObjRef=dopatObj<-cRefEval1patObjRefcasepatObjofValue(ValuePatobjRef)->return$Just([],[((name,[]),objRef)])_->return$NothingprimitivePatPatternMatch(PPInductivePatppconspppats)patObjRef=dopatObj<-cRefEval1patObjRefcasepatObjofIntermidiate(IInductiveDatapconpatObjRefs)->ifppcons==pconthenprimitivePatPatternMatchListpppatspatObjRefselsereturnNothingValue(InductiveDatapconpatVals)->dopatObjRefs<-liftIO$mapM(newIORef.Value)patValsifppcons==pconthenprimitivePatPatternMatchListpppatspatObjRefselsereturnNothing_->return$NothingprimitivePatPatternMatchList::[PrimitivePatPattern]->[ObjectRef]->IOThrowsError(Maybe([ObjectRef],FrameList))primitivePatPatternMatchList[][]=return$Just([],[])primitivePatPatternMatchList(pppat:pppats)(patObjRef:patObjRefs)=domRet<-primitivePatPatternMatchpppatpatObjRefcasemRetofNothing->returnNothingJust(retPatObjRefs,retFrame)->domRetRest<-primitivePatPatternMatchListpppatspatObjRefscasemRetRestofNothing->returnNothingJust(retRestPatObjRefs,retRestFrame)->return$Just(retPatObjRefs++retRestPatObjRefs,retFrame++retRestFrame)primitivePatPatternMatchListpppats_=throwError$Default$"primitivePatPatternMatch: number of pppat and pat are different: "++showpppatsprimitivePatternMatch::PrimitivePattern->ObjectRef->IOThrowsError(MaybeFrameList)primitivePatternMatch(PPatBoolbool)objRef=doval<-cRefEvalobjRefcasevalofBoolbool2->ifbool==bool2thenreturn(Just[])elsereturnNothing_->returnNothingprimitivePatternMatch(PPatCharchr)objRef=doval<-cRefEvalobjRefcasevalofCharchr2->ifchr==chr2thenreturn(Just[])elsereturnNothing_->returnNothingprimitivePatternMatch(PPatNumbernum)objRef=doval<-cRefEvalobjRefcasevalofNumbernum2->ifnum==num2thenreturn(Just[])elsereturnNothing_->returnNothingprimitivePatternMatch(PPatFloatd)objRef=doval<-cRefEvalobjRefcasevalofFloatd2->ifd==d2thenreturn(Just[])elsereturnNothing_->returnNothingprimitivePatternMatchPWildCard_=return$Just[]primitivePatternMatch(PPatVarname)objRef=return(Just[((name,[]),objRef)])primitivePatternMatch(PInductivePatpConspPats)objRef=doobj<-cRefEval1objRefcaseobjofIntermidiate(IInductiveDataconsobjRefs)->ifpCons==consthenprimitivePatternMatchListpPatsobjRefselsereturnNothingValue(InductiveDataconsvals)->ifpCons==consthendoobjRefs<-liftIO$mapM(newIORef.Value)valsprimitivePatternMatchListpPatsobjRefselsereturnNothing_->returnNothingprimitivePatternMatchPEmptyPatobjRef=docRefEval1objRefb<-isEmptyCollectionobjRefifbthenreturn(Just[])elsereturnNothingprimitivePatternMatch(PConsPatcarPatcdrPat)objRef=docRefEval1objRefb<-isEmptyCollectionobjRefifbthenreturnNothingelsedo(carObjRef,cdrObjRef)<-consDestructobjRefmCarFrame<-primitivePatternMatchcarPatcarObjRefcasemCarFrameofNothing->returnNothingJustcarFrame->domCdrFrame<-primitivePatternMatchcdrPatcdrObjRefcasemCdrFrameofNothing->returnNothingJustcdrFrame->return(Just(carFrame++cdrFrame))primitivePatternMatch(PSnocPatrdcPatracPat)objRef=docRefEval1objRefb<-isEmptyCollectionForSnocobjRefifbthenreturnNothingelsedo(racObjRef,rdcObjRef)<-snocDestructobjRefmRacFrame<-primitivePatternMatchracPatracObjRefcasemRacFrameofNothing->returnNothingJustracFrame->domRdcFrame<-primitivePatternMatchrdcPatrdcObjRefcasemRdcFrameofJustrdcFrame->return(Just(racFrame++rdcFrame))Nothing->returnNothingprimitivePatternMatchList::[PrimitivePattern]->[ObjectRef]->IOThrowsError(MaybeFrameList)primitivePatternMatchList[][]=return(Just[])primitivePatternMatchList(pat:pats)(objRef:objRefs)=domFrame<-primitivePatternMatchpatobjRefcasemFrameofNothing->returnNothingJustframe->domRestFrame<-primitivePatternMatchListpatsobjRefscasemRestFrameofNothing->returnNothingJustrestFrame->return(Just(frame++restFrame))primitivePatternMatchList__=throwError(Default"primitivePatternMatchList : number of patterns and targets are different")objectRefToInnerRefs::ObjectRef->IOThrowsError[InnerValRef]objectRefToInnerRefsobjRef=doobj<-cRefEval1objRefcaseobjofIntermidiate(ICollectioninnerRefs)->returninnerRefsValue(Collectionval)->doobjRefs<-liftIO$mapM(newIORef.Value)valreturn$mapIElementobjRefsisEmptyCollection::ObjectRef->IOThrowsErrorBoolisEmptyCollectionobjRef=doobj<-liftIO$readIORefobjRefcaseobjofIntermidiate(ICollection[])->returnTrueIntermidiate(ICollection((IElement_):_))->returnFalseIntermidiate(ICollection((ISubCollectionsubObjRef):rest))->doinnerRefs<-objectRefToInnerRefssubObjRefliftIO$writeIORefobjRef$Intermidiate$ICollection$innerRefs++restisEmptyCollectionobjRefValue(Collection[])->returnTrueValue(Collection_)->returnFalse_->throwError$Default$"isEmptyCollection: not collection:"++showobjisEmptyCollectionForSnoc::ObjectRef->IOThrowsErrorBoolisEmptyCollectionForSnocobjRef=doobj<-liftIO$readIORefobjRefcaseobjofIntermidiate(ICollectioninnerRefs)->docasereverseinnerRefsof[]->returnTrue((IElement_):_)->returnFalse((ISubCollectionsubObjRef):rest)->dosubInnerRefs<-objectRefToInnerRefssubObjRefliftIO$writeIORefobjRef$Intermidiate$ICollection$reverserest++reversesubInnerRefsisEmptyCollectionForSnocobjRefValue(Collection[])->returnTrueValue(Collection_)->returnFalse_->throwError$Default$"isEmptyCollectionForSnoc: not collection:"++showobjconsDestruct::ObjectRef->IOThrowsError(ObjectRef,ObjectRef)consDestructobjRef=doobj<-liftIO$readIORefobjRefcaseobjofIntermidiate(ICollection[])->throwError$Default"consDestructInnerRefs: empty collection"Intermidiate(ICollection((IElementcarObjRef):rest))->docdrObjRef<-liftIO$newIORef$Intermidiate$ICollectionrestreturn(carObjRef,cdrObjRef)Intermidiate(ICollection((ISubCollectionsubObjRef):rest))->doinnerRefs<-objectRefToInnerRefssubObjRefliftIO$writeIORefobjRef$Intermidiate$ICollection$innerRefs++restconsDestructobjRefValue(Collection(val:vals))->docarObjRef<-liftIO$newIORef$ValuevalcdrObjRef<-liftIO$newIORef$Value$Collectionvalsreturn(carObjRef,cdrObjRef)_->throwError$Default"consDestruct: not collection"snocDestruct::ObjectRef->IOThrowsError(ObjectRef,ObjectRef)snocDestructobjRef=doobj<-liftIO$readIORefobjRefcaseobjofIntermidiate(ICollectioninnerRefs)->docasereverseinnerRefsof[]->throwError$Default"snocDestructInnerRefs: empty collection"((IElementracObjRef):rest)->dordcObjRef<-liftIO$newIORef$Intermidiate$ICollection$reverserestreturn(racObjRef,rdcObjRef)((ISubCollectionsubObjRef):rest)->dosubInnerRefs<-objectRefToInnerRefssubObjRefliftIO$writeIORefobjRef$Intermidiate$ICollection$reverserest++reversesubInnerRefssnocDestructobjRefValue(Collectionvals)->docasereversevalsof(val:rest)->doracObjRef<-liftIO$newIORef$ValuevalrdcObjRef<-liftIO$newIORef$Value$Collectionrestreturn(racObjRef,rdcObjRef)_->throwError$Default"snocDestruct: not collection"_->throwError$Default"snocDestruct: not collection"collectionToObjRefs::ObjectRef->IOThrowsError[ObjectRef]collectionToObjRefsobjRef=doobj<-cRefEval1objRefcaseobjofIntermidiate(ICollectioninnerRefs)->innerRefsToObjRefsinnerRefsValue(Collectionvals)->liftIO$mapM(newIORef.Value)vals_->throwError$Default"collectionToObjRefs: not collection"tupleToObjRefs::ObjectRef->IOThrowsError[ObjectRef]tupleToObjRefsobjRef=doobj<-cRefEval1objRefcaseobjofIntermidiate(ITupleinnerRefs)->innerRefsToObjRefsinnerRefsValue(Tuplevals)->liftIO$mapM(newIORef.Value)vals_->return[objRef]innerRefsToObjRefs::[InnerValRef]->IOThrowsError[ObjectRef]innerRefsToObjRefs[]=return[]innerRefsToObjRefs((IElementobjRef):rest)=doretRest<-innerRefsToObjRefsrestreturn$objRef:retRestinnerRefsToObjRefs((ISubCollectionobjRef):rest)=doretObj<-collectionToObjRefsobjRefretRest<-innerRefsToObjRefsrestreturn$retObj++retRestprimitiveBindings::IOEnvprimitiveBindings=doinitEnv<-nullEnvconstantsFrameList<-mapMdomakeObjRefconstantsiOFuncs<-mapM(domakeFuncIOFunc)ioPrimitivesprimitiveFuncs<-mapM(domakeFuncPrimitiveFunc)primitivesextendEnvinitEnv(constantsFrameList++iOFuncs++primitiveFuncs)wheredomakeFuncconstructor(name,func)=doobjRef<-newIORef$Value$constructorfuncreturn((name,[]),objRef)domakeObjRef(name,val)=doobjRef<-newIORef$Valuevalreturn((name,[]),objRef)constants::[(String,EgisonVal)]constants=[("pi",Float3.14)]{- I/O primitives -}ioPrimitives::[(String,[EgisonVal]->IOThrowsErrorEgisonVal)]ioPrimitives=[("open-input-file",makePortReadMode),("open-output-file",makePortWriteMode),("close-input-port",closePort),("close-output-port",closePort),("read-char",readChar),("read-line",readLine),("read",readFromStdin),("write-char",writeChar),("write-string",writeString),("print",writeStringLine),("write",write),("flush",flushStdout),("read-char-from-port",readCharFromPort),("read-line-from-port",readLineFromPort),("read-from-port",readFromPort),("write-char-to-port",writeCharToPort),("write-string-to-port",writeStringToPort),("print-to-port",writeStringLineToPort),("write-to-port",writeToPort),("flush-port",flushPort)]{- "Pure" primitive functions -}primitives::[(String,[EgisonVal]->ThrowsErrorEgisonVal)]primitives=[("+",numericBinop(+)),("-",numericBinop(-)),("*",numericBinop(*)),-- ("/", numericBinop (/)),("mod",numericBinopmod),("quotient",numericBinopquot),("remainder",numericBinoprem),("+f",floatBinop(+)),("-f",floatBinop(-)),("*f",floatBinop(*)),("/f",floatBinop(/)),("round",floatNumSglopround),("floor",floatNumSglopfloor),("ceiling",floatNumSglopceiling),("truncate",floatNumSgloptruncate),("exp",numExp),("log",numLog),("sin",floatSglopsin),("cos",floatSglopcos),("tan",floatSgloptan),("asin",floatSglopasin),("acos",floatSglopacos),("atan",floatSglopatan),("sinh",floatSglopsinh),("cosh",floatSglopcosh),("tanh",floatSgloptanh),("asinh",floatSglopasinh),("acosh",floatSglopacosh),("atanh",floatSglopatanh),("sqrt",numSqrt),("expt",numExpt),("eq?",eqv),("eq-n?",numBoolBinop(==)),("lt-n?",numBoolBinop(<)),("lte-n?",numBoolBinop(<=)),("gt-n?",numBoolBinop(>)),("gte-n?",numBoolBinop(>=)),("eq-f?",floatBoolBinop(==)),("lt-f?",floatBoolBinop(<)),("lte-f?",floatBoolBinop(<=)),("gt-f?",floatBoolBinop(>)),("gte-f?",floatBoolBinop(>=)),("eq-c?",charBoolBinop(==)),("eq-s?",strBoolBinop(==)),("string-append",stringBinop(++)),("string-to-chars",stringToChars),("chars-to-string",charsToString),("&&",boolBinop(&&)),("||",boolBinop(||)),("tuple-to-collection",tupleToCollection),("collection-to-tuple",collectionToTuple),("array-dimension",arrayDimension),("array-range",arrayRange),("array-size",arraySize),("array-keys",arrayKeys),("array-range?",arrayIsRange),("array-ref",arrayRef),-- ("array-sub-ref", arrayRef),-- ("array-to-collection", arrayToCollection),-- ("collection-to-array", collectionToArray),("eof?",isEgisonEOF)]