{-# LANGUAGE CPP #-}{- |
Module : Language.Scheme.Core
Copyright : Justin Ethier
Licence : MIT (see LICENSE in the distribution)
Maintainer : github.com/justinethier
Stability : experimental
Portability : portable
This module contains Core functionality, primarily Scheme expression evaluation.
-}moduleLanguage.Scheme.Core(-- * Scheme code evaluationevalLisp,evalLisp',evalString,evalAndPrint,apply,continueEval-- * Core data,primitiveBindings,r5rsEnv,version-- * Utility functions,getDataFileFullPath,registerExtensions,showBanner,substr,updateVector,updateByteVector)whereimportqualifiedPaths_husk_schemeasPHS(getDataFileName)#ifdef UseFfiimportqualifiedLanguage.Scheme.FFI#endifimportLanguage.Scheme.LibrariesimportqualifiedLanguage.Scheme.MacroimportLanguage.Scheme.NumericalimportLanguage.Scheme.ParserimportLanguage.Scheme.PrimitivesimportLanguage.Scheme.TypesimportLanguage.Scheme.UtilimportLanguage.Scheme.VariablesimportControl.Monad.ErrorimportData.ArrayimportqualifiedData.ByteStringasBSimportqualifiedData.CharimportqualifiedData.MapimportData.WordimportqualifiedSystem.ExitimportSystem.IO-- import Debug.Trace-- |husk version numberversion::Stringversion="3.7"-- |A utility function to display the husk console bannershowBanner::IO()showBanner=doputStrLn" _ _ __ _ "putStrLn" | | | | \\\\\\ | | "putStrLn" | |__ _ _ ___| | __ \\\\\\ ___ ___| |__ ___ _ __ ___ ___ "putStrLn" | '_ \\| | | / __| |/ / //\\\\\\ / __|/ __| '_ \\ / _ \\ '_ ` _ \\ / _ \\ "putStrLn" | | | | |_| \\__ \\ < /// \\\\\\ \\__ \\ (__| | | | __/ | | | | | __/ "putStrLn" |_| |_|\\__,_|___/_|\\_\\ /// \\\\\\ |___/\\___|_| |_|\\___|_| |_| |_|\\___| "putStrLn" "putStrLn" http://justinethier.github.com/husk-scheme "putStrLn" (c) 2010-2013 Justin Ethier "putStrLn$" Version "++version++" "putStrLn" "-- |Get the full path to a data file installed for huskgetDataFileFullPath::String->IOStringgetDataFileFullPaths=PHS.getDataFileNames-- |Register optional SRFI extensionsregisterExtensions::Env->(FilePath->IOFilePath)->IO()registerExtensionsenvgetDataFileName=do_<-registerSRFIenvgetDataFileName1_<-registerSRFIenvgetDataFileName2return()-- |Register the given SRFIregisterSRFI::Env->(FilePath->IOFilePath)->Integer->IO()registerSRFIenvgetDataFileNamenum=dofilename<-getDataFileName$"lib/srfi/srfi-"++shownum++".scm"_<-evalStringenv$"(register-extension '(srfi "++shownum++") \""++(escapeBackslashesfilename)++"\")"return(){- |Evaluate a string containing Scheme code
@
env <- primitiveBindings
evalString env "(+ x x x)"
"3"
evalString env "(+ x x x (* 3 9))"
"30"
evalString env "(* 3 9)"
"27"
@
-}evalString::Env->String->IOStringevalStringenvexpr=dorunIOThrowsREPL$liftMshow$(liftThrows$readExprexpr)>>=evalLispenv-- |Evaluate a string and print results to consoleevalAndPrint::Env->String->IO()evalAndPrintenvexpr=evalStringenvexpr>>=putStrLn-- |Evaluate a lisp data structure and return a value for use by huskevalLisp::Env->LispVal->IOThrowsErrorLispValevalLispenvlisp=dov<-mevalenv(makeNullContinuationenv)lisprecDerefPtrsv-- |Evaluate a lisp data structure and return the LispVal or LispError-- result directly-- -- @-- result <- evalLisp' env $ List [Atom "/", Number 1, Number 0]-- case result of-- Left err -> putStrLn $ "Error: " ++ (show err)-- Right val -> putStrLn $ show val-- @evalLisp'::Env->LispVal->IO(ThrowsErrorLispVal)evalLisp'envlisp=runErrorT(evalLispenvlisp)-- |A wrapper for macroEval and evalmeval,mprepareApply::Env->LispVal->LispVal->IOThrowsErrorLispValmevalenvcontlisp=mfuncenvcontlispevalmprepareApplyenvcontlisp=mfuncenvcontlispprepareApplymfunc::Env->LispVal->LispVal->(Env->LispVal->LispVal->IOThrowsErrorLispVal)->IOThrowsErrorLispValmfuncenvcontlispfunc=doLanguage.Scheme.Macro.macroEvalenvlispapply>>=(funcenvcont){- OBSOLETE:
old code for updating env's in the continuation chain (see below)
if False --needToExtendEnv lisp
then do
expanded <- macroEval env lisp
exEnv <- liftIO $ extendEnv env []
-- Recursively replace env of nextCont with the extended env
-- This is more expensive than I would like, but I think it should be straightforward enough...
exCont <- updateContEnv exEnv cont
func exEnv (trace ("extending Env") exCont) expanded
else macroEval env lisp >>= (func env cont)
-}{- EXPERIMENTAL CODE FOR REPLACING ENV's in the continuation chain
This is a difficult problem to solve and this code will likely just
end up going away because we are not going with this approach...
updateContEnv :: Env -> LispVal -> IOThrowsError LispVal
updateContEnv env (Continuation _ curC (Just nextC) xargs dwind) = do
next <- updateContEnv env nextC
return $ Continuation env curC (Just next) xargs dwind
updateContEnv env (Continuation _ curC Nothing xargs dwind) = do
return $ Continuation env curC Nothing xargs dwind
updateContEnv _ val = do
return val
-}{- |A support function for eval; eval calls into this function instead of
returning values directly. continueEval then uses the continuation
argument to manage program control flow.
-}continueEval::Env-- ^ Current environment->LispVal-- ^ Current continuation->LispVal-- ^ Value of previous computation->IOThrowsErrorLispVal-- ^ Final value of computation{- Passing a higher-order function as the continuation; just evaluate it. This is
- done to enable an 'eval' function to be broken up into multiple sub-functions,
- so that any of the sub-functions can be passed around as a continuation.
-
- Carry extra args from the current continuation into the next, to support (call-with-values)
-}continueEval_(ContinuationcEnv(Just(HaskellBodyfuncfuncArgs))(Just(Continuationccecncccc_cdynwind))xargs_)-- rather sloppy, should refactor code so this is not necessaryval=funccEnv(Continuationccecnccccxargscdynwind)valfuncArgs{-
- No higher order function, so:
-
- If there is Scheme code to evaluate in the function body, we continue to evaluate it.
-
- Otherwise, if all code in the function has been executed, we 'unwind' to an outer
- continuation (if there is one), or we just return the result. Yes technically with
- CPS you are supposed to keep calling into functions and never return, but in this case
- when the computation is complete, you have to return something.
-}continueEval_(ContinuationcEnv(Just(SchemeBodycBody))(JustcCont)extraArgsdynWind)val=do-- case (trace ("cBody = " ++ show cBody) cBody) ofcasecBodyof[]->docasecContofContinuationnEnvncContnnCont_nDynWind->-- Pass extra args along if last expression of a function, to support (call-with-values)continueEvalnEnv(ContinuationnEnvncContnnContextraArgsnDynWind)val_->return(val)[lv]->mevalcEnv(ContinuationcEnv(Just(SchemeBody[]))(JustcCont)NothingdynWind)lv(lv:lvs)->mevalcEnv(ContinuationcEnv(Just(SchemeBodylvs))(JustcCont)NothingdynWind)lv-- No current continuation, but a next cont is available; call into itcontinueEval_(ContinuationcEnvNothing(JustcCont)__)val=continueEvalcEnvcContval-- There is no continuation code, just return valuecontinueEval_(Continuation_NothingNothing__)val=returnvalcontinueEval___=throwError$Default"Internal error in continueEval"{- |Core eval function
Evaluate a scheme expression.
NOTE: This function does not include macro support and should not be called directly. Instead, use 'evalLisp' -}------ Implementation Notes:---- Internally, this function is written in continuation passing style (CPS) to allow the Scheme language-- itself to support first-class continuations. That is, at any point in the evaluation, call/cc may-- be used to capture the current continuation. Thus this code must call into the next continuation point, eg: ---- eval ... (makeCPS ...)---- Instead of calling eval directly from within the same function, eg:---- eval ...-- eval ...---- This can make the code harder to follow, however some coding conventions have been established to make the-- code easier to follow. Whenever a single function has been broken into multiple ones for the purpose of CPS,-- those additional functions are defined locally using 'where', and each has been given a 'cps' prefix.--eval::Env->LispVal->LispVal->IOThrowsErrorLispValevalenvcontval@(Nil_)=continueEvalenvcontvalevalenvcontval@(String_)=continueEvalenvcontvalevalenvcontval@(Char_)=continueEvalenvcontvalevalenvcontval@(Complex_)=continueEvalenvcontvalevalenvcontval@(Float_)=continueEvalenvcontvalevalenvcontval@(Rational_)=continueEvalenvcontvalevalenvcontval@(Number_)=continueEvalenvcontvalevalenvcontval@(Bool_)=continueEvalenvcontvalevalenvcontval@(HashTable_)=continueEvalenvcontvalevalenvcontval@(Vector_)=continueEvalenvcontvalevalenvcontval@(ByteVector_)=continueEvalenvcontvalevalenvcontval@(LispEnv_)=continueEvalenvcontvalevalenvcontval@(Pointer__)=continueEvalenvcontvalevalenvcont(Atoma)=dov<-getVarenvaval<-return$casevof#ifdef UsePointersList_->PointeraenvDottedList__->PointeraenvString_->PointeraenvVector_->PointeraenvByteVector_->PointeraenvHashTable_->Pointeraenv#endif_->vcontinueEvalenvcontval-- Quote an expression by simply passing along the valueevalenvcont(List[Atom"quote",val])=continueEvalenvcontval-- A special form to assist with debugging macrosevalenvcontargs@(List[Atom"expand",_body])=dobound<-liftIO$isRecBoundenv"expand"ifboundthenprepareApplyenvcontargs-- if bound to a variable in this scope; call into itelseLanguage.Scheme.Macro.expandenvFalse_bodyapply>>=continueEvalenvcont-- A rudimentary implementation of let-syntaxevalenvcontargs@(List(Atom"let-syntax":List_bindings:_body))=dobound<-liftIO$isRecBoundenv"let-syntax"ifboundthenprepareApplyenvcontargs-- if bound to a variable in this scope; call into itelsedobodyEnv<-liftIO$extendEnvenv[]_<-Language.Scheme.Macro.loadMacrosenvbodyEnvNothingFalse_bindings-- Expand whole body as a single continuous macro, to ensure hygieneexpanded<-Language.Scheme.Macro.expandbodyEnvFalse(List_body)applycaseexpandedofListe->continueEvalbodyEnv(ContinuationbodyEnv(Just$SchemeBodye)(Justcont)NothingNothing)$Nil""e->continueEvalbodyEnvconteevalenvcontargs@(List(Atom"letrec-syntax":List_bindings:_body))=dobound<-liftIO$isRecBoundenv"letrec-syntax"ifboundthenprepareApplyenvcontargs-- if bound to a variable in this scope; call into itelsedobodyEnv<-liftIO$extendEnvenv[]-- A primitive means of implementing letrec, by simply assuming that each macro is defined in-- the letrec's environment, instead of the parent env. Not sure if this is 100% correct but it-- is good enough to pass the R5RS test case so it will be used as a rudimentary implementation -- for now..._<-Language.Scheme.Macro.loadMacrosbodyEnvbodyEnvNothingFalse_bindings-- Expand whole body as a single continuous macro, to ensure hygieneexpanded<-Language.Scheme.Macro.expandbodyEnvFalse(List_body)applycaseexpandedofListe->continueEvalbodyEnv(ContinuationbodyEnv(Just$SchemeBodye)(Justcont)NothingNothing)$Nil""e->continueEvalbodyEnvconte-- A non-standard way to rebind a macro to another keywordevalenvcontargs@(List[Atom"define-syntax",AtomnewKeyword,Atomkeyword])=dobound<-liftIO$isNamespacedRecBoundenvmacroNamespacekeywordifboundthendom<-getNamespacedVarenvmacroNamespacekeyworddefineNamespacedVarenvmacroNamespacenewKeywordmelsethrowError$TypeMismatch"macro"$Atomkeywordevalenvcontargs@(List[Atom"define-syntax",Atomkeyword,(List[Atom"er-macro-transformer",(List(Atom"lambda":Listfparams:fbody))])])=dobound<-liftIO$isRecBoundenv"define-syntax"ifboundthenprepareApplyenvcontargs-- if bound to var in this scope; call itelsedo-- TODO: ensure fparams is 3 atoms-- TODO: now just need to figure out initial entry point to the ER func-- for now can ignore complications of an ER found during syn-rules transformationf<-makeNormalFuncenvfparamsfbody_<-defineNamespacedVarenvmacroNamespacekeyword$SyntaxExplicitRenamingfcontinueEvalenvcont$Nil""evalenvcontargs@(List[Atom"define-syntax",Atomkeyword,(List(Atom"syntax-rules":(Listidentifiers:rules)))])=dobound<-liftIO$isRecBoundenv"define-syntax"ifboundthenprepareApplyenvcontargs-- if bound to a variable in this scope; call into itelsedo{-
- FUTURE: Issue #15: there really ought to be some error checking of the syntax rules,
- since they could be malformed...
- As it stands now, there is no checking until the code attempts to perform a macro transformation.
- At a minimum, should check identifiers to make sure each is an atom (see findAtom)
-}-- -- I think it seems to be a better solution to use this defEnv, but-- that causes problems when a var is changed via (define) or (set!) since most-- schemes interpret allow this change to propagate back to the point of definition-- (or at least, when modules are not in play). See:---- http://stackoverflow.com/questions/7999084/scheme-syntax-rules-difference-in-variable-bindings-between-let-anddefine---- Anyway, this may come back. But not using it for now...---- defEnv <- liftIO $ copyEnv env_<-defineNamespacedVarenvmacroNamespacekeyword$Syntax(Justenv)NothingFalseidentifiersrulescontinueEvalenvcont$Nil""evalenvcontargs@(List[Atom"if",predic,conseq,alt])=dobound<-liftIO$isRecBoundenv"if"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsemevalenv(makeCPSenvcontcps)predicwherecps::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsecresult_=case(result)ofBoolFalse->mevalecalt_->mevalecconseqevalenvcontargs@(List[Atom"if",predic,conseq])=dobound<-liftIO$isRecBoundenv"if"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsemevalenv(makeCPSenvcontcpsResult)predicwherecpsResult::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsResultecresult_=caseresultofBoolFalse->continueEvalec$Nil""-- Unspecified return value per R5RS_->mevalecconseqevalenvcontargs@(List[Atom"set!",Atomvar,form])=dobound<-liftIO$isRecBoundenv"set!"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsemevalenv(makeCPSenvcontcpsResult)formwherecpsResult::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsResultecresult_=setVarevarresult>>=continueEvalecevalenvcontargs@(List[Atom"set!",nonvar,_])=dobound<-liftIO$isRecBoundenv"set!"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsethrowError$TypeMismatch"variable"nonvarevalenvcontfargs@(List(Atom"set!":args))=dobound<-liftIO$isRecBoundenv"set!"ifboundthenprepareApplyenvcontfargs-- if is bound to a variable in this scope; call into itelsethrowError$NumArgs(Just2)argsevalenvcontargs@(List[Atom"define",Atomvar,form])=dobound<-liftIO$isRecBoundenv"define"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsemevalenv(makeCPSenvcontcpsResult)formwherecpsResult::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsResultecresult_=defineVarevarresult>>=continueEvalecevalenvcontargs@(List(Atom"define":List(Atomvar:fparams):fbody))=dobound<-liftIO$isRecBoundenv"define"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsedo-- Experimenting with macro expansion of body of function-- ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp apply) fbodyresult<-(makeNormalFuncenvfparamsfbody>>=defineVarenvvar)continueEvalenvcontresultevalenvcontargs@(List(Atom"define":DottedList(Atomvar:fparams)varargs:fbody))=dobound<-liftIO$isRecBoundenv"define"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsedoresult<-(makeVarargsvarargsenvfparamsfbody>>=defineVarenvvar)continueEvalenvcontresultevalenvcontargs@(List(Atom"lambda":Listfparams:fbody))=dobound<-liftIO$isRecBoundenv"lambda"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsedoresult<-makeNormalFuncenvfparamsfbodycontinueEvalenvcontresultevalenvcontargs@(List(Atom"lambda":DottedListfparamsvarargs:fbody))=dobound<-liftIO$isRecBoundenv"lambda"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsedoresult<-makeVarargsvarargsenvfparamsfbodycontinueEvalenvcontresultevalenvcontargs@(List(Atom"lambda":varargs@(Atom_):fbody))=dobound<-liftIO$isRecBoundenv"lambda"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsedoresult<-makeVarargsvarargsenv[]fbodycontinueEvalenvcontresultevalenvcontargs@(List[Atom"string-set!",Atomvar,i,character])=dobound<-liftIO$isRecBoundenv"string-set!"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsemevalenv(makeCPSenvcontcpsStr)iwherecpsStr::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsStrecidx_=dovalue<-getVarenvvarderefValue<-recDerefPtrsvaluemevale(makeCPSWArgseccpsSubStr$[idx])derefValuecpsSubStr::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsSubStrecstr(Just[idx])=substr(str,character,idx)>>=updateObjectevar>>=continueEvaleccpsSubStr____=throwError$InternalError"Invalid argument to cpsSubStr"evalenvcontargs@(List[Atom"string-set!",nonvar,_,_])=dobound<-liftIO$isRecBoundenv"string-set!"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsethrowError$TypeMismatch"variable"nonvarevalenvcontfargs@(List(Atom"string-set!":args))=dobound<-liftIO$isRecBoundenv"string-set!"ifboundthenprepareApplyenvcontfargs-- if is bound to a variable in this scope; call into itelsethrowError$NumArgs(Just3)argsevalenvcontargs@(List[Atom"set-car!",Atomvar,argObj])=dobound<-liftIO$isRecBoundenv"set-car!"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsedovalue<-getVarenvvarderefValue<-recDerefPtrsvaluecontinueEvalenv(makeCPSenvcontcpsObj)derefValuewherecpsObj::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsObj__obj@(List[])_=throwError$TypeMismatch"pair"objcpsObjecobj@(List(_:_))_=mevale(makeCPSWArgseccpsSet$[obj])argObjcpsObjecobj@(DottedList__)_=mevale(makeCPSWArgseccpsSet$[obj])argObjcpsObj__obj_=throwError$TypeMismatch"pair"objcpsSet::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsSetecobj(Just[List(_:ls)])=updateObjectevar(List(obj:ls))>>=continueEvalec-- Wrong constructor? Should it be DottedList?cpsSetecobj(Just[DottedList(_:ls)l])=updateObjectevar(DottedList(obj:ls)l)>>=continueEvaleccpsSet____=throwError$InternalError"Unexpected argument to cpsSet"evalenvcontargs@(List[Atom"set-car!",nonvar,_])=dobound<-liftIO$isRecBoundenv"set-car!"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsethrowError$TypeMismatch"variable"nonvarevalenvcontfargs@(List(Atom"set-car!":args))=dobound<-liftIO$isRecBoundenv"set-car!"ifboundthenprepareApplyenvcontfargs-- if is bound to a variable in this scope; call into itelsethrowError$NumArgs(Just2)argsevalenvcontargs@(List[Atom"set-cdr!",Atomvar,argObj])=dobound<-liftIO$isRecBoundenv"set-cdr!"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsedovalue<-getVarenvvarderefValue<-recDerefPtrsvalue--derefPtr valuecontinueEvalenv(makeCPSenvcontcpsObj)derefValuewherecpsObj::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsObj__pair@(List[])_=throwError$TypeMismatch"pair"paircpsObjecpair@(List(_:_))_=mevale(makeCPSWArgseccpsSet$[pair])argObjcpsObjecpair@(DottedList__)_=mevale(makeCPSWArgseccpsSet$[pair])argObjcpsObj__pair_=throwError$TypeMismatch"pair"paircpsSet::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsSetecobj(Just[List(l:_)])=dol'<-recDerefPtrslobj'<-recDerefPtrsobj(liftThrows$cons[l',obj'])>>=updateObjectevar>>=continueEvaleccpsSetecobj(Just[DottedList(l:_)_])=dol'<-recDerefPtrslobj'<-recDerefPtrsobj(liftThrows$cons[l',obj'])>>=updateObjectevar>>=continueEvaleccpsSet____=throwError$InternalError"Unexpected argument to cpsSet"evalenvcontargs@(List[Atom"set-cdr!",nonvar,_])=dobound<-liftIO$isRecBoundenv"set-cdr!"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsedo-- TODO: eval nonvar, then can process it if we get a listthrowError$TypeMismatch"variable"nonvarevalenvcontfargs@(List(Atom"set-cdr!":args))=dobound<-liftIO$isRecBoundenv"set-cdr!"ifboundthenprepareApplyenvcontfargs-- if is bound to a variable in this scope; call into itelsethrowError$NumArgs(Just2)argsevalenvcontargs@(List[Atom"vector-set!",Atomvar,i,object])=dobound<-liftIO$isRecBoundenv"vector-set!"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsemevalenv(makeCPSenvcontcpsObj)iwherecpsObj::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsObjecidx_=mevale(makeCPSWArgseccpsVec$[idx])objectcpsVec::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsVececobj(Just[idx])=(mevale(makeCPSWArgseccpsUpdateVec$[idx,obj])=<<getVarevar)cpsVec____=throwError$InternalError"Invalid argument to cpsVec"cpsUpdateVec::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsUpdateVececvec(Just[idx,obj])=updateVectorvecidxobj>>=updateObjectevar>>=continueEvaleccpsUpdateVec____=throwError$InternalError"Invalid argument to cpsUpdateVec"evalenvcontargs@(List[Atom"vector-set!",nonvar,_,_])=dobound<-liftIO$isRecBoundenv"vector-set!"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsethrowError$TypeMismatch"variable"nonvarevalenvcontfargs@(List(Atom"vector-set!":args))=dobound<-liftIO$isRecBoundenv"vector-set!"ifboundthenprepareApplyenvcontfargs-- if is bound to a variable in this scope; call into itelsethrowError$NumArgs(Just3)argsevalenvcontargs@(List[Atom"bytevector-u8-set!",Atomvar,i,object])=dobound<-liftIO$isRecBoundenv"bytevector-u8-set!"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsemevalenv(makeCPSenvcontcpsObj)iwherecpsObj::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsObjecidx_=mevale(makeCPSWArgseccpsVec$[idx])objectcpsVec::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsVececobj(Just[idx])=(mevale(makeCPSWArgseccpsUpdateVec$[idx,obj])=<<getVarevar)cpsVec____=throwError$InternalError"Invalid argument to cpsVec"cpsUpdateVec::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsUpdateVececvec(Just[idx,obj])=updateByteVectorvecidxobj>>=updateObjectevar>>=continueEvaleccpsUpdateVec____=throwError$InternalError"Invalid argument to cpsUpdateVec"evalenvcontargs@(List[Atom"bytevector-u8-set!",nonvar,_,_])=dobound<-liftIO$isRecBoundenv"bytevector-u8-set!"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsethrowError$TypeMismatch"variable"nonvarevalenvcontfargs@(List(Atom"bytevector-u8-set!":args))=dobound<-liftIO$isRecBoundenv"bytevector-u8-set!"ifboundthenprepareApplyenvcontfargs-- if is bound to a variable in this scope; call into itelsethrowError$NumArgs(Just3)argsevalenvcontargs@(List[Atom"hash-table-set!",Atomvar,rkey,rvalue])=dobound<-liftIO$isRecBoundenv"hash-table-set!"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsemevalenv(makeCPSenvcontcpsValue)rkeywherecpsValue::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsValueeckey_=mevale(makeCPSWArgseccpsH$[key])rvaluecpsH::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsHecvalue(Just[key])=dov<-getVarevarderefVar<-recDerefPtrsvmevale(makeCPSWArgseccpsEvalH$[key,value])derefVarcpsH____=throwError$InternalError"Invalid argument to cpsH"cpsEvalH::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsEvalHech(Just[key,value])=docasehofHashTableht->doupdateObjectenvvar(HashTable$Data.Map.insertkeyvalueht)>>=mevalecother->throwError$TypeMismatch"hash-table"othercpsEvalH____=throwError$InternalError"Invalid argument to cpsEvalH"evalenvcontargs@(List[Atom"hash-table-set!",nonvar,_,_])=dobound<-liftIO$isRecBoundenv"hash-table-set!"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsethrowError$TypeMismatch"variable"nonvarevalenvcontfargs@(List(Atom"hash-table-set!":args))=dobound<-liftIO$isRecBoundenv"hash-table-set!"ifboundthenprepareApplyenvcontfargs-- if is bound to a variable in this scope; call into itelsethrowError$NumArgs(Just3)argsevalenvcontargs@(List[Atom"hash-table-delete!",Atomvar,rkey])=dobound<-liftIO$isRecBoundenv"hash-table-delete!"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsemevalenv(makeCPSenvcontcpsH)rkeywherecpsH::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsHeckey_=dovalue<-getVarevarderefValue<-recDerefPtrsvaluemevale(makeCPSWArgseccpsEvalH$[key])derefValuecpsEvalH::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsEvalHech(Just[key])=docasehofHashTableht->doupdateObjectenvvar(HashTable$Data.Map.deletekeyht)>>=mevalecother->throwError$TypeMismatch"hash-table"othercpsEvalH____=throwError$InternalError"Invalid argument to cpsEvalH"evalenvcontargs@(List[Atom"hash-table-delete!",nonvar,_])=dobound<-liftIO$isRecBoundenv"hash-table-delete!"ifboundthenprepareApplyenvcontargs-- if is bound to a variable in this scope; call into itelsethrowError$TypeMismatch"variable"nonvarevalenvcontfargs@(List(Atom"hash-table-delete!":args))=dobound<-liftIO$isRecBoundenv"hash-table-delete!"ifboundthenprepareApplyenvcontfargs-- if is bound to a variable in this scope; call into itelsethrowError$NumArgs(Just2)argsevalenvcontargs@(List(_:_))=mprepareApplyenvcontargseval__badForm=throwError$BadSpecialForm"Unrecognized special form"badForm-- |A helper function for the special form /(string-set!)/substr::(LispVal,LispVal,LispVal)->IOThrowsErrorLispValsubstr(Stringstr,Charchar,Numberii)=doreturn$String$(take(fromIntegerii).drop0)str++[char]++(take(lengthstr).drop(fromIntegerii+1))strsubstr(String_,Char_,n)=throwError$TypeMismatch"number"nsubstr(String_,c,_)=throwError$TypeMismatch"character"csubstr(s,_,_)=throwError$TypeMismatch"string"s-- |A helper function for the special form /(vector-set!)/updateVector::LispVal->LispVal->LispVal->IOThrowsErrorLispValupdateVector(Vectorvec)(Numberidx)obj=return$Vector$vec//[(fromIntegeridx,obj)]updateVectorptr@(Pointer__)iobj=dovec<-recDerefPtrsptrupdateVectorveciobjupdateVectorv__=throwError$TypeMismatch"vector"v-- |A helper function for the special form /(bytevector-u8-set!)/updateByteVector::LispVal->LispVal->LispVal->IOThrowsErrorLispValupdateByteVector(ByteVectorvec)(Numberidx)obj=caseobjofNumberbyte->do-- TODO: error checkinglet(h,t)=BS.splitAt(fromIntegeridx)vecreturn$ByteVector$BS.concat[h,BS.pack$[fromIntegerbyte::Word8],BS.tailt]badType->throwError$TypeMismatch"byte"badTypeupdateByteVectorptr@(Pointer__)iobj=dovec<-recDerefPtrsptrupdateByteVectorveciobjupdateByteVectorv__=throwError$TypeMismatch"bytevector"v{- Prepare for apply by evaluating each function argument,
and then execute the function via 'apply' -}prepareApply::Env->LispVal->LispVal->IOThrowsErrorLispValprepareApplyenvcont(List(function:functionArgs))=doevalenv(makeCPSWArgsenvcontcpsPrepArgs$functionArgs)functionwherecpsPrepArgs::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsPrepArgsecfunc(Justargs)=-- case (trace ("prep eval of args: " ++ show args) args) ofcase(args)of[]->applycfunc[]-- No args, immediately apply the function[a]->mevalenv(makeCPSWArgseccpsEvalArgs$[func,List[],List[]])a(a:as)->mevalenv(makeCPSWArgseccpsEvalArgs$[func,List[],Listas])acpsPrepArgs___Nothing=throwError$Default"Unexpected error in function application (1)"{- Store value of previous argument, evaluate the next arg until all are done
parg - Previous argument that has now been evaluated
state - List containing the following, in order:
- Function to apply when args are ready
- List of evaluated parameters
- List of parameters awaiting evaluation -}cpsEvalArgs::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsEvalArgsecevaledArg(Just[func,ListargsEvaled,ListargsRemaining])=caseargsRemainingof[]->applycfunc(argsEvaled++[evaledArg])[a]->mevale(makeCPSWArgseccpsEvalArgs$[func,List(argsEvaled++[evaledArg]),List[]])a(a:as)->mevale(makeCPSWArgseccpsEvalArgs$[func,List(argsEvaled++[evaledArg]),Listas])acpsEvalArgs___(Just_)=throwError$Default"Unexpected error in function application (1)"cpsEvalArgs___Nothing=throwError$Default"Unexpected error in function application (2)"prepareApply___=throwError$Default"Unexpected error in prepareApply"-- |Call into a Scheme functionapply::LispVal-- ^ Current continuation->LispVal-- ^ Function or continuation to execute->[LispVal]-- ^ Arguments->IOThrowsErrorLispVal-- ^ Final value of computationapply_cont@(Continuationenvccontncont_ndynwind)args=do-- case (trace ("calling into continuation. dynWind = " ++ show ndynwind) ndynwind) ofcasendynwindof-- Call into dynWind.before if it exists...Just([DynamicWindersbeforeFunc_])->apply(makeCPSenvcontcpsApply)beforeFunc[]_->doApplyenvcontwherecpsApply::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsApplyec__=doApplyecdoApplyec=do-- TODO (?): List dargs <- recDerefPtrs $ List args -- Deref any pointerscase(toInteger$lengthargs)of0->throwError$NumArgs(Just1)[]1->continueEvalec$headargs_->-- Pass along additional arguments, so they are available to (call-with-values)continueEvale(Continuationenvccontncont(Just$tailargs)ndynwind)$headargsapplycont(IOFuncfunc)args=doListdargs<-recDerefPtrs$Listargs-- Deref any pointersresult<-funcdargscasecontofContinuationcEnv____->continueEvalcEnvcontresult_->returnresultapplycont(EvalFuncfunc)args=do{- An EvalFunc extends the evaluator so it needs access to the current continuation;
pass it as the first argument. -}Listdargs<-recDerefPtrs$Listargs-- Deref any pointersfunc(cont:dargs)applycont(PrimitiveFuncfunc)args=doListdargs<-recDerefPtrs$Listargs-- Deref any pointersresult<-liftThrows$funcdargscasecontofContinuationcEnv____->continueEvalcEnvcontresult_->returnresultapplycont(Funcaparamsavarargsabodyaclosure)args=ifnumaparams/=numargs&&avarargs==NothingthenthrowError$NumArgs(Just(numaparams))argselse(liftIO$extendEnvaclosure$zip(map((,)varNamespace)aparams)args)>>=bindVarArgsavarargs>>=(evalBodyabody)whereremainingArgs=drop(lengthaparams)argsnum=toInteger.length---- Continue evaluation within the body, preserving the outer continuation.--{- This link was helpful for implementing this, and has a *lot* of other useful information:
http://icem-www.folkwang-hochschule.de/~finnendahl/cm_kurse/doc/schintro/schintro_73.html#SEC80 -}--{- What we are doing now is simply not saving a continuation for tail calls. For now this may
be good enough, although it may need to be enhanced in the future in order to properly
detect all tail calls. -}---- See: http://icem-www.folkwang-hochschule.de/~finnendahl/cm_kurse/doc/schintro/schintro_142.html#SEC294--evalBodyevBodyenv=casecontofContinuation_(Just(SchemeBodycBody))(JustcCont)_cDynWind->iflengthcBody==0thencontinueWContenv(evBody)cContcDynWind-- else continueWCont env (evBody) cont (trace ("cDynWind = " ++ show cDynWind) cDynWind) -- Might be a problem, not fully optimizingelsecontinueWContenv(evBody)contcDynWind-- Might be a problem, not fully optimizingContinuation____cDynWind->continueWContenv(evBody)contcDynWind_->continueWContenv(evBody)contNothing-- Shortcut for calling continueEvalcontinueWContcwcEnvcwcBodycwcContcwcDynWind=continueEvalcwcEnv(ContinuationcwcEnv(Just(SchemeBodycwcBody))(JustcwcCont)NothingcwcDynWind)$Nil""bindVarArgsargenv=caseargofJustargName->liftIO$extendEnvenv[((varNamespace,argName),List$remainingArgs)]Nothing->returnenvapplycont(HFuncaparamsavarargsabodyaclosure)args=ifnumaparams/=numargs&&avarargs==NothingthenthrowError$NumArgs(Just(numaparams))argselse(liftIO$extendEnvaclosure$zip(map((,)varNamespace)aparams)args)>>=bindVarArgsavarargs>>=(evalBodyabody)whereremainingArgs=drop(lengthaparams)argsnum=toInteger.lengthevalBodyevBodyenv=evBodyenvcont(Nil"")Nothing{- TODO: may need to handle cases from Func, such as dynamic winders
case cont of
Continuation _ (Just (SchemeBody cBody)) (Just cCont) _ cDynWind -> if length cBody == 0
then continueWCont env (evBody) cCont cDynWind
else continueWCont env (evBody) cont cDynWind -- Might be a problem, not fully optimizing
Continuation _ _ _ _ cDynWind -> continueWCont env (evBody) cont cDynWind
_ -> continueWCont env (evBody) cont Nothing
-- Shortcut for calling continueEval
continueWCont cwcEnv cwcBody cwcCont cwcDynWind =
continueEval cwcEnv (Continuation cwcEnv (Just (SchemeBody cwcBody)) (Just cwcCont) Nothing cwcDynWind) $ Nil ""-}bindVarArgsargenv=caseargofJustargName->liftIO$extendEnvenv[((varNamespace,argName),List$remainingArgs)]Nothing->returnenvapply_funcargs=doList[func']<-recDerefPtrs$List[func]-- Deref any pointersListargs'<-recDerefPtrs$ListargsthrowError$BadSpecialForm"Unable to evaluate form"$List(func':args')-- |Environment containing the primitive forms that are built into the Scheme -- language. This function only includes forms that are implemented in Haskell; -- derived forms implemented in Scheme (such as let, list, etc) are available-- in the standard library which must be pulled into the environment using /(load)/---- For the purposes of using husk as an extension language, /r5rsEnv/ will-- probably be more useful.primitiveBindings::IOEnvprimitiveBindings=nullEnv>>=(flipextendEnv$map(domakeFuncIOFunc)ioPrimitives++map(domakeFuncEvalFunc)evalFunctions++map(domakeFuncPrimitiveFunc)primitives)wheredomakeFuncconstructor(var,func)=((varNamespace,var),constructorfunc)-- |Load the standard r5rs environment, including librariesr5rsEnv::IOEnvr5rsEnv=doenv<-primitiveBindingsstdlib<-PHS.getDataFileName"lib/stdlib.scm"srfi55<-PHS.getDataFileName"lib/srfi/srfi-55.scm"-- (require-extension)-- Load standard library_<-evalStringenv$"(load \""++(escapeBackslashesstdlib)++"\")"-- Load (require-extension), which can be used to load other SRFI's_<-evalStringenv$"(load \""++(escapeBackslashessrfi55)++"\")"registerExtensionsenvPHS.getDataFileName#ifdef UseLibraries-- Load module meta-language metalib<-PHS.getDataFileName"lib/modules.scm"metaEnv<-nullEnvWithParentenv-- Load env as parent of metaenv_<-evalStringmetaEnv$"(load \""++(escapeBackslashesmetalib)++"\")"-- Load meta-env so we can find it later_<-evalLisp'env$List[Atom"define",Atom"*meta-env*",LispEnvmetaEnv]-- Bit of a hack to load (import)_<-evalLisp'env$List[Atom"%bootstrap-import"]-- Load (r5rs base)_<-evalStringmetaEnv"(add-module! '(r5rs) (make-module #f (interaction-environment) '()))"#endifreturnenv-- Functions that extend the core evaluator, but that can be defined separately.--{- These functions have access to the current environment via the
current continuation, which is passed as the first LispVal argument. -}--evalfuncExitSuccess,evalfuncExitFail,evalfuncApply,evalfuncDynamicWind,evalfuncEval,evalfuncLoad,evalfuncCallCC,evalfuncCallWValues,evalfuncMakeEnv,evalfuncNullEnv,evalfuncInteractionEnv,evalfuncImport::[LispVal]->IOThrowsErrorLispVal{-
- A (somewhat) simplified implementation of dynamic-wind
-
- The implementation must obey these 4 rules:
-
- 1) The dynamic extent is entered when execution of the body of the called procedure begins.
- 2) The dynamic extent is also entered when execution is not within the dynamic extent and a continuation is invoked that was captured (using call-with-current-continuation) during the dynamic extent.
- 3) It is exited when the called procedure returns.
- 4) It is also exited when execution is within the dynamic extent and a continuation is invoked that was captured while not within the dynamic extent.
-
- Basically (before) must be called either when thunk is called into, or when a continuation captured
- during (thunk) is called into.
- And (after) must be called either when thunk returns *or* a continuation is called into during (thunk).
- FUTURE:
- At this point dynamic-wind works well enough now to pass all tests, although I am not convinced the implementation
- is 100% correct since a stack is not directly used to hold the winders. I think there must still be edge
- cases that are not handled properly...
-}evalfuncDynamicWind[cont@(Continuationenv____),beforeFunc,thunkFunc,afterFunc]=doapply(makeCPSenvcontcpsThunk)beforeFunc[]wherecpsThunk,cpsAfter::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsThunke(Continuationcecccncca_{- FUTURE: cwindrz -})__=apply(Continuatione(Just(HaskellBodycpsAfterNothing))(Just(ContinuationcecccnccaNothing))Nothing(Just([DynamicWindersbeforeFuncafterFunc])))-- FUTURE: append if existing windersthunkFunc[]cpsThunk____=throwError$Default"Unexpected error in cpsThunk during (dynamic-wind)"cpsAfter_c__=applycafterFunc[]-- FUTURE: remove dynamicWinder from above from the list before calling afterevalfuncDynamicWind(_:args)=throwError$NumArgs(Just3)args-- Skip over continuation argumentevalfuncDynamicWind_=throwError$NumArgs(Just3)[]evalfuncCallWValues[cont@(Continuationenv____),producer,consumer]=doapply(makeCPSenvcontcpsEval)producer[]-- Call into prod to get valueswherecpsEval::Env->LispVal->LispVal->Maybe[LispVal]->IOThrowsErrorLispValcpsEval_c@(Continuation___(Justxargs)_)value_=applycconsumer(value:xargs)cpsEval_cvalue_=applycconsumer[value]evalfuncCallWValues(_:args)=throwError$NumArgs(Just2)args-- Skip over continuation argumentevalfuncCallWValues_=throwError$NumArgs(Just2)[]--evalfuncApply [cont@(Continuation _ _ _ _ _), func, List args] = apply cont func argsevalfuncApply(cont@(Continuation_____):func:args)=doletaRev=reverseargsifnullargsthenthrowError$NumArgs(Just2)argselseapplyArgs$headaRevwhereapplyArgsaRev=docaseaRevofListaLastElems->doapplycontfunc$(initargs)++aLastElemsPointerpVarpEnv->dovalue<-recDerefPtrsaRevapplyArgsvalueother->throwError$TypeMismatch"List"otherevalfuncApply(_:args)=throwError$NumArgs(Just2)args-- Skip over continuation argumentevalfuncApply_=throwError$NumArgs(Just2)[]evalfuncMakeEnv(cont@(Continuationenv____):_)=doe<-liftIO$nullEnvcontinueEvalenvcont$LispEnveevalfuncNullEnv[cont@(Continuationenv____),Numberversion]=donullEnv<-liftIO$primitiveBindingscontinueEvalenvcont$LispEnvnullEnvevalfuncNullEnv(_:args)=throwError$NumArgs(Just1)args-- Skip over continuation argumentevalfuncNullEnv_=throwError$NumArgs(Just1)[]evalfuncInteractionEnv(cont@(Continuationenv____):_)=docontinueEvalenvcont$LispEnvenvevalfuncImport[cont@(Continuationenvabcd),toEnv,LispEnvfromEnv,imports,_]=doLispEnvtoEnv'<-casetoEnvofLispEnve->returntoEnvBoolFalse->do-- A hack to load imports into the main env, which-- in modules.scm is the grandparent envcaseparentEnvenvofJust(Environment(Justgp)__)->return$LispEnvgpJust(EnvironmentNothing__)->throwError$InternalError"import into empty parent env"Nothing->throwError$InternalError"import into empty env"caseimportsofListi->doresult<-moduleImporttoEnv'fromEnvicontinueEvalenvcontresultBoolFalse->do-- Export everythingnewEnv<-liftIO$importEnvtoEnv'fromEnvcontinueEvalenv(Continuationenvabcd)(LispEnvnewEnv)-- This is just for debugging purposes:evalfuncImport(cont@(Continuationenv____):cs)=docontinueEvalenvcont$Nil""-- |Load import into the main environmentbootstrapImport[cont@(Continuationenv____)]=doLispEnvme<-getVarenv"*meta-env*"ri<-getNamespacedVarmemacroNamespace"repl-import"renv<-defineNamespacedVarenvmacroNamespace"import"ricontinueEvalenvcontrenvevalfuncLoad[cont@(Continuation_abcd),Stringfilename,LispEnvenv]=doevalfuncLoad[Continuationenvabcd,Stringfilename]evalfuncLoad[cont@(Continuationenv____),Stringfilename]=do{-
-- It would be nice to use CPS style below.
--
-- This code mostly works, but causes looping problems in t-cont. need to test to see if
-- those are an artifact of this change or a code problem in that test suite:
code <- load filename
if not (null code)
then continueEval env (Continuation env (Just $ SchemeBody code) (Just cont) Nothing Nothing) $ Nil ""
else return $ Nil "" -- Empty, unspecified value
-}results<-loadfilename>>=mapM(evaluateenv(makeNullContinuationenv))ifnot(nullresults)thendoresult<-return.last$resultscontinueEvalenvcontresultelsereturn$Nil""-- Empty, unspecified valuewhereevaluateenv2cont2val2=mevalenv2cont2val2evalfuncLoad(_:args)=throwError$NumArgs(Just1)args-- Skip over continuation argumentevalfuncLoad_=throwError$NumArgs(Just1)[]-- Evaluate an expression in the current environment---- Assumption is any macro transform is already performed-- prior to this step.---- FUTURE: consider allowing env to be specified, per R5RS--evalfuncEval[cont@(Continuationenv____),val]=mevalenvcontvalevalfuncEval[cont@(Continuation_____),val,LispEnvenv]=mevalenvcontvalevalfuncEval(_:args)=throwError$NumArgs(Just1)args-- Skip over continuation argumentevalfuncEval_=throwError$NumArgs(Just1)[]evalfuncCallCC[cont@(Continuation_____),func]=docasefuncofContinuation_____->applycontfunc[cont]PrimitiveFuncf->doresult<-liftThrows$f[cont]casecontofContinuationcEnv____->continueEvalcEnvcontresult_->returnresultFunc_(Just_)__->applycontfunc[cont]-- Variable # of args (pair). Just call into contFuncaparams___->if(toInteger$lengthaparams)==1thenapplycontfunc[cont]elsethrowError$NumArgs(Just(toInteger$lengthaparams))[cont]HFunc_(Just_)__->applycontfunc[cont]-- Variable # of args (pair). Just call into cont HFuncaparams___->if(toInteger$lengthaparams)==1thenapplycontfunc[cont]elsethrowError$NumArgs(Just(toInteger$lengthaparams))[cont]other->throwError$TypeMismatch"procedure"otherevalfuncCallCC(_:args)=throwError$NumArgs(Just1)args-- Skip over continuation argumentevalfuncCallCC_=throwError$NumArgs(Just1)[]evalfuncExitFail_=do_<-liftIO$System.Exit.exitFailurereturn$Nil""evalfuncExitSuccess_=do_<-liftIO$System.Exit.exitSuccessreturn$Nil""{- Primitive functions that extend the core evaluator -}evalFunctions::[(String,[LispVal]->IOThrowsErrorLispVal)]evalFunctions=[("apply",evalfuncApply),("call-with-current-continuation",evalfuncCallCC),("call-with-values",evalfuncCallWValues),("dynamic-wind",evalfuncDynamicWind),("eval",evalfuncEval),("load",evalfuncLoad),("null-environment",evalfuncNullEnv),("current-environment",evalfuncInteractionEnv),("interaction-environment",evalfuncInteractionEnv),("make-environment",evalfuncMakeEnv)-- Non-standard extensions#ifdef UseFfi,("load-ffi",Language.Scheme.FFI.evalfuncLoadFFI)#endif#ifdef UseLibraries,("%import",evalfuncImport),("%bootstrap-import",bootstrapImport)#endif,("exit-fail",evalfuncExitFail),("exit-success",evalfuncExitSuccess)]{- I/O primitives
Primitive functions that execute within the IO monad -}ioPrimitives::[(String,[LispVal]->IOThrowsErrorLispVal)]ioPrimitives=[("open-input-file",makePortReadMode),("open-output-file",makePortWriteMode),("close-input-port",closePort),("close-output-port",closePort),("input-port?",isInputPort),("output-port?",isOutputPort),("char-ready?",isCharReady),-- The following optional procedures are NOT implemented:--{- with-input-from-file
with-output-from-file
transcript-on
transcript-off -}--{- Consideration may be given in a future release, but keep in mind
the impact to the other I/O functions. -}("current-input-port",currentInputPort),("current-output-port",currentOutputPort),("read",readProc),("read-char",readCharProchGetChar),("peek-char",readCharProchLookAhead),("write",writeProc(\portobj->hPrintportobj)),("write-char",writeCharProc),("display",writeProc(\portobj->docaseobjofStringstr->hPutStrportstr_->hPutStrport$showobj)),-- From SRFI 96("file-exists?",fileExists),("delete-file",deleteFile),-- Other I/O functions("print-env",printEnv'),("env-exports",exportsFromEnv'),("read-contents",readContents),("read-all",readAll),("find-module-file",findModuleFile),("gensym",gensym)]printEnv'::[LispVal]->IOThrowsErrorLispValprintEnv'[LispEnvenv]=doresult<-liftIO$printEnvenvreturn$StringresultexportsFromEnv'::[LispVal]->IOThrowsErrorLispValexportsFromEnv'[LispEnvenv]=doresult<-liftIO$exportsFromEnvenvreturn$Listresult--exportsFromEnv' err = throwError $ Default $ "bad args: " ++ show errexportsFromEnv'err=return$List[]{- "Pure" primitive functions -}primitives::[(String,[LispVal]->ThrowsErrorLispVal)]primitives=[("+",numAdd),("-",numSub),("*",numMul),("/",numDiv),("modulo",numMod),("quotient",numericBinopquot),("remainder",numericBinoprem),("rationalize",numRationalize),("round",numRound),("floor",numFloor),("ceiling",numCeiling),("truncate",numTruncate),("numerator",numNumerator),("denominator",numDenominator),("exp",numExp),("log",numLog),("sin",numSin),("cos",numCos),("tan",numTan),("asin",numAsin),("acos",numAcos),("atan",numAtan),("sqrt",numSqrt),("expt",numExpt),("make-rectangular",numMakeRectangular),("make-polar",numMakePolar),("real-part",numRealPart),("imag-part",numImagPart),("magnitude",numMagnitude),("angle",numAngle),("exact->inexact",numExact2Inexact),("inexact->exact",numInexact2Exact),("number->string",num2String),("=",numBoolBinopEq),(">",numBoolBinopGt),(">=",numBoolBinopGte),("<",numBoolBinopLt),("<=",numBoolBinopLte),("&&",boolBoolBinop(&&)),("||",boolBoolBinop(||)),("string=?",strBoolBinop(==)),("string<?",strBoolBinop(<)),("string>?",strBoolBinop(>)),("string<=?",strBoolBinop(<=)),("string>=?",strBoolBinop(>=)),("string-ci=?",stringCIEquals),("string-ci<?",stringCIBoolBinop(<)),("string-ci>?",stringCIBoolBinop(>)),("string-ci<=?",stringCIBoolBinop(<=)),("string-ci>=?",stringCIBoolBinop(>=)),("char=?",charBoolBinop(==)),("char<?",charBoolBinop(<)),("char>?",charBoolBinop(>)),("char<=?",charBoolBinop(<=)),("char>=?",charBoolBinop(>=)),("char-ci=?",charCIBoolBinop(==)),("char-ci<?",charCIBoolBinop(<)),("char-ci>?",charCIBoolBinop(>)),("char-ci<=?",charCIBoolBinop(<=)),("char-ci>=?",charCIBoolBinop(>=)),("char-alphabetic?",charPredicateData.Char.isAlpha),("char-numeric?",charPredicateData.Char.isNumber),("char-whitespace?",charPredicateData.Char.isSpace),("char-upper-case?",charPredicateData.Char.isUpper),("char-lower-case?",charPredicateData.Char.isLower),("char->integer",char2Int),("integer->char",int2Char),("char-upper",charUpper),("char-lower",charLower),("car",car),("cdr",cdr),("cons",cons),("eq?",eqv),("eqv?",eqv),("equal?",equal),("pair?",isDottedList),("procedure?",isProcedure),("number?",isNumber),("complex?",isComplex),("real?",isReal),("rational?",isRational),("integer?",isInteger),("list?",unaryOpisList),("null?",isNull),("eof-object?",isEOFObject),("symbol?",isSymbol),("symbol->string",symbol2String),("string->symbol",string2Symbol),("char?",isChar),("vector?",unaryOpisVector),("make-vector",makeVector),("vector",buildVector),("vector-length",vectorLength),("vector-ref",vectorRef),("vector->list",vectorToList),("list->vector",listToVector),("bytevector?",unaryOpisByteVector),("make-bytevector",makeByteVector),("bytevector",byteVector),("bytevector-length",byteVectorLength),("bytevector-u8-ref",byteVectorRef),("bytevector-append",byteVectorAppend),("bytevector-copy",byteVectorCopy),("utf8->string",byteVectorUtf2Str),("string->utf8",byteVectorStr2Utf),("make-hash-table",hashTblMake),("hash-table?",isHashTbl),("hash-table-exists?",hashTblExists),("hash-table-ref",hashTblRef),("hash-table-size",hashTblSize),("hash-table->alist",hashTbl2List),("hash-table-keys",hashTblKeys),("hash-table-values",hashTblValues),("hash-table-copy",hashTblCopy),("string?",isString),("string",buildString),("make-string",makeString),("string-length",stringLength),("string-ref",stringRef),("substring",substring),("string-append",stringAppend),("string->number",stringToNumber),("string->list",stringToList),("list->string",listToString),("string-copy",stringCopy),("boolean?",isBoolean)]