haskeem 0.7.0 → 0.7.4
raw patch · 15 files changed
+1471/−292 lines, 15 files
Files
- Environment.hs +2/−2
- Evaluator.hs +68/−68
- Library.hs +167/−104
- LispData.hs +31/−38
- Parser.hs +6/−6
- gendoc.scm +46/−4
- haskeem.cabal +2/−2
- haskeem.doc +44/−4
- haskeem.hs +12/−6
- haskeem_readline.hs +1/−1
- macro-test.scm +65/−19
- regexp.scm +552/−0
- selftest.scm +206/−31
- set.scm +192/−0
- stdlib.scm +77/−7
Environment.hs view
@@ -19,7 +19,7 @@ along with haskeem; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -$Id: environment.hs,v 1.10 2009-05-31 01:41:07 uwe Exp $ -}+$Id: environment.hs,v 1.11 2009-06-27 20:31:51 uwe Exp $ -} module Environment (isBound, getVar, setVar, defineVar, bindVars, dumpEnv) where@@ -67,7 +67,7 @@ dumpEnv :: Env -> Handle -> IOThrowsError LispVal dumpEnv envRef port = liftRead envRef >>= doDump- where doDump [] = return (Bool True)+ where doDump [] = return lispTrue doDump ((key, vref):vars) = do val <- liftRead vref liftIO (hPutStrLn port (key ++ " -> " ++ (show val)))
Evaluator.hs view
@@ -19,7 +19,7 @@ along with haskeem; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -$Id: evaluator.hs,v 1.27 2009-06-06 20:40:08 uwe Exp $ -}+$Id: evaluator.hs,v 1.31 2009-06-27 21:51:29 uwe Exp $ -} module Evaluator (evalLisp) where import Prelude@@ -50,7 +50,7 @@ lON l = last l isTrue :: LispVal -> Bool-isTrue (Bool False) = False+isTrue (Boolean False) = False isTrue _ = True -- Check that a variable is unique in a list,@@ -123,21 +123,19 @@ apply :: Integer -> LispVal -> [LispVal] -> IOThrowsError LispVal apply _ (Prim func) args = liftThrows (func args) apply _ (IOPrim func) args = func args-apply ql (Func params varargs body closure) args =- doApply False "" params varargs body closure ql args-apply ql (Macro params varargs body closure) args =+apply ql (Func params varargs body closure Nothing _) args = doApply False "" params varargs body closure ql args-apply ql (TraceFunc name params varargs body closure) args =+apply ql (Func params varargs body closure (Just name) _) args = doApply True name params varargs body closure ql args apply _ func _ = throwError (NotFunction "apply got non-function" func) makeFunc varargs env params body =- return (Func (map show params) varargs body env)+ return (Func (map show params) varargs body env Nothing False) makeNormalFunc = makeFunc Nothing makeVarargsFunc = makeFunc . Just . show makeMacro varargs env params body =- return (Macro (map show params) varargs body env)+ return (Func (map show params) varargs body env Nothing True) makeNormalMacro = makeMacro Nothing makeVarargsMacro = makeMacro . Just . show @@ -166,12 +164,10 @@ isSpecialForm (Symbol "quasiquote") = True isSpecialForm (Symbol "quote") = True isSpecialForm (Symbol "set!") = True-isSpecialForm (Symbol "unless") = True isSpecialForm (Symbol "unquote") = True isSpecialForm (Symbol "unquote-splicing") = True isSpecialForm (Symbol "vector-fill!") = True isSpecialForm (Symbol "vector-set!") = True-isSpecialForm (Symbol "when") = True isSpecialForm (Symbol "trace") = True isSpecialForm (Symbol "dump-bindings") = True@@ -291,7 +287,7 @@ evalLisp _ _ val@(IntNumber _) = return val evalLisp _ _ val@(RatNumber _) = return val evalLisp _ _ val@(FltNumber _) = return val-evalLisp _ _ val@(Bool _) = return val+evalLisp _ _ val@(Boolean _) = return val evalLisp _ _ val@(Char _) = return val evalLisp _ _ (List []) = return (List []) evalLisp env _ (Symbol id) = getVar env id@@ -335,6 +331,15 @@ evalLisp env ql (List [Symbol "load", String filename]) = loadFile filename >>= lastOrNil . mapM (evalLisp env ql)+evalLisp env ql (List [Symbol "load", arg]) =+ do fname <- evalLisp env ql arg+ if isStr fname+ then loadFile (getStr fname) >>= lastOrNil . mapM (evalLisp env ql)+ else throwError (Default ("bad load form: " +++ (show fname) ++ " is not a string"))+ where isStr (String _) = True+ isStr _ = False+ getStr (String s) = s evalLisp env ql (List (Symbol "begin" : args)) = lastOrNil (mapM (evalLisp env ql) args)@@ -418,34 +423,34 @@ add vec h l = if h == l then vec- else add (DIM.insert (fromInteger l) (Bool False) vec) h (l + 1)+ else add (DIM.insert (fromInteger l) lispFalse vec) h (l + 1) evalLisp env ql (List [Symbol "define", Symbol var, val]) =- do defineVar env var (Bool False)+ do defineVar env var lispFalse evalLisp env ql val >>= setVar env var evalLisp env _ (List [Symbol "define", Symbol var]) =- defineVar env var (Bool False)+ defineVar env var lispFalse evalLisp env _ (List (Symbol "define" : List (Symbol var : params) : body)) = if paramsCheck params- then do defineVar env var (Bool False)+ then do defineVar env var lispFalse makeNormalFunc env params body >>= setVar env var else errBadForm "define" params evalLisp env _ (List (Symbol "define" : DottedList (Symbol var : params) varargs : body)) = if paramsCheck (params ++ [varargs])- then do defineVar env var (Bool False)+ then do defineVar env var lispFalse makeVarargsFunc varargs env params body >>= setVar env var else errBadForm "define" [DottedList params varargs] evalLisp env _ (List (Symbol "defmacro" : List (Symbol var : params) : body)) = if paramsCheck params- then do defineVar env var (Bool False)+ then do defineVar env var lispFalse makeNormalMacro env params body >>= setVar env var else errBadForm "defmacro" params evalLisp env _ (List (Symbol "defmacro" : DottedList (Symbol var : params) varargs : body)) = if paramsCheck (params ++ [varargs])- then do defineVar env var (Bool False)+ then do defineVar env var lispFalse makeVarargsMacro varargs env params body >>= setVar env var else errBadForm "defmacro" [DottedList params varargs] @@ -463,50 +468,38 @@ evalLisp env ql (List [Symbol "if", pred, tcase, fcase]) = do result <- evalLisp env ql pred case result of- Bool False -> evalLisp env ql fcase+ Boolean False -> evalLisp env ql fcase _ -> evalLisp env ql tcase evalLisp env ql (List [Symbol "if", pred, tcase]) = do result <- evalLisp env ql pred case result of- Bool False -> return (Bool False)+ Boolean False -> return lispFalse _ -> evalLisp env ql tcase -evalLisp env ql (List (Symbol "when" : pred : docase)) =- do result <- evalLisp env ql pred- case result of- Bool False -> return (Bool False)- _ -> lastOrNil (mapM (evalLisp env ql) docase)--evalLisp env ql (List (Symbol "unless" : pred : docase)) =- do result <- evalLisp env ql pred- case result of- Bool False -> lastOrNil (mapM (evalLisp env ql) docase)- _ -> return (Bool False)--evalLisp env ql (List (Symbol "and" : args)) = eva env args (Bool True)+evalLisp env ql (List (Symbol "and" : args)) = eva env args lispTrue where eva _ [] ret = return ret eva env (t:ts) _ = do result <- evalLisp env ql t case result of- Bool False -> return (Bool False)+ Boolean False -> return lispFalse _ -> eva env ts result -evalLisp env ql (List (Symbol "or" : args)) = evo env args (Bool False)+evalLisp env ql (List (Symbol "or" : args)) = evo env args lispFalse where evo _ [] ret = return ret evo env (t:ts) _ = do result <- evalLisp env ql t case result of- Bool False -> evo env ts result+ Boolean False -> evo env ts result _ -> return result -evalLisp _ _ (List [Symbol "cond"]) = return (Bool False)+evalLisp _ _ (List [Symbol "cond"]) = return lispFalse evalLisp env ql (List (Symbol "cond" : args)) = if foldl1 (&&) (map isList args) == False then errTypeMismatch "cond" "cond-clauses" (String (show args)) else evc env args where isList (List _) = True isList _ = False- evc _ [] = return (Bool False)+ evc _ [] = return lispFalse evc env (cl:cls) = do (tst,val) <- evc_clause env cl if tst then return val else evc env cls evc_clause env (List (Symbol "else" : args)) =@@ -515,13 +508,13 @@ evc_clause env (List (pred : args)) = do tst <- evalLisp env ql pred case tst of- Bool False -> return (False, (Bool False))+ Boolean False -> return (False, lispFalse) _ -> do ret <- if isArrow args then evcArrow env args tst else lastOrNil (mapM (evalLisp env ql) args) return (True, ret)- evc_clause _ _ = return (False, (Bool False))+ evc_clause _ _ = return (False, lispFalse) isArrow [Symbol "=>", _] = True isArrow _ = False evcArrow env [Symbol "=>", proc] val =@@ -538,7 +531,7 @@ evalLisp env ql (List (Symbol "let" : Symbol lname : List params : body)) = if letCheck True params- then do envn <- liftIO (bindVars env [(lname, Bool False)])+ then do envn <- liftIO (bindVars env [(lname, lispFalse)]) func <- makeNormalFunc envn (map exn params) body setVar envn lname func argVals <- mapM (evalLisp env ql) (map exv params)@@ -568,10 +561,10 @@ varv <- mapM (evalLisp envn ql) (map exv params) mapM (doSet envn) (repl varn varv) >> lastOrNil (mapM (evalLisp envn ql) body)- exn (List [Symbol var, _]) = (var, Bool False)+ exn (List [Symbol var, _]) = (var, lispFalse) exv (List [Symbol _, val]) = val repl [] [] = []- repl ((n, Bool False):ns) (v:vs) = (n, v):(repl ns vs)+ repl ((n, lispFalse):ns) (v:vs) = (n, v):(repl ns vs) doSet env (n,v) = setVar env n v evalLisp env ql (List (Symbol "letrec*" : List params : body)) =@@ -583,11 +576,11 @@ envn <- liftIO (bindVars env varn) mapM (evSet envn) params >> lastOrNil (mapM (evalLisp envn ql) body)- exn (List [Symbol var, _]) = (var, Bool False)+ exn (List [Symbol var, _]) = (var, lispFalse) evSet env (List [Symbol var, val]) = evalLisp env ql val >>= setVar env var -evalLisp _ _ (List [Symbol "case"]) = return (Bool False)+evalLisp _ _ (List [Symbol "case"]) = return lispFalse evalLisp env ql (List (Symbol "case" : key : args)) = if (isNull args) || (foldl1 (&&) (map isList args) == False) then errTypeMismatch "case" "case-clauses" (String (show args))@@ -597,7 +590,7 @@ isList (List (List _ : _)) = True isList (List (Symbol "else" : _)) = True isList _ = False- evc _ [] _ = return (Bool False)+ evc _ [] _ = return lispFalse evc env (cl:cls) key = do (tst,val) <- evc_clause env cl key if tst then return val else evc env cls key evc_clause env (List (Symbol "else" : args)) _ =@@ -607,8 +600,8 @@ if valMatch key vals then do ret <- lastOrNil (mapM (evalLisp env ql) args) return (True, ret)- else return (False, (Bool False))- evc_clause _ _ _ = return (False, (Bool False))+ else return (False, lispFalse)+ evc_clause _ _ _ = return (False, lispFalse) valMatch key (v:vs) = if Library.eqv [key, v] then True else (valMatch key vs)@@ -634,13 +627,13 @@ evc_clause env (List (pred : args)) = do tst <- evalLisp env ql pred case tst of- Bool False -> return (False, (Bool False))+ Boolean False -> return (False, lispFalse) _ -> do ret <- if isArrow args then evcArrow env args tst else lastOrNil (mapM (evalLisp env ql) args) return (True, ret)- evc_clause _ _ = return (False, (Bool False))+ evc_clause _ _ = return (False, lispFalse) isArrow [Symbol "=>", _] = True isArrow _ = False evcArrow env [Symbol "=>", proc] val =@@ -725,27 +718,26 @@ swval <- evalLisp env ql sw if isPr val then throwError (Default "can't trace primitives")- else if (isNF val) && (isTrue swval)- then (remark ("trace " ++ var ++ " on")) >>- setVar env var (trOn var val) >>- return (Bool True)- else if (isTF val) && (not (isTrue swval))- then (remark ("trace " ++ var ++ " off")) >>+ else if (isF val)+-- TODO: this can be cleaned up a bit more... doit!+ then if (isTrue swval)+ then (remark ("trace " ++ var ++ " on")) >>+ setVar env var (trOn var val) >>+ return lispTrue+ else (remark ("trace " ++ var ++ " off")) >> setVar env var (trOff val) >>- return (Bool True)- else errBadForm "trace" ((Symbol var):[sw])+ return lispFalse+ else errBadForm "trace" ((Symbol var):[sw]) where isPr (Prim _) = True isPr (IOPrim _) = True isPr _ = False- isNF (Func _ _ _ _) = True- isNF _ = False- isTF (TraceFunc _ _ _ _ _) = True- isTF _ = False- trOn name (Func params varargs body closure) =- (TraceFunc name params varargs body closure)+ isF (Func _ _ _ _ _ _) = True+ isF _ = False+ trOn name (Func params varargs body closure _ mac) =+ (Func params varargs body closure (Just name) mac) trOn _ _ = progError- trOff (TraceFunc _ params varargs body closure) =- (Func params varargs body closure)+ trOff (Func params varargs body closure _ mac) =+ (Func params varargs body closure Nothing mac) trOff _ = progError -- This is also not an R6RS special form, but a haskeem one: it needs@@ -770,10 +762,18 @@ then throwError (BadSpecial "bad syntax for special form" function) else do func <- evalLisp env ql function if isM func- then apply ql func args >>= evalLisp env ql+ then apply ql func args >>=+ prtTrace (isT func) >>=+ evalLisp env ql else mapM (evalLisp env ql) args >>= apply ql func- where isM (Macro _ _ _ _) = True+ where isM (Func _ _ _ _ _ mac) = mac isM _ = False+ isT (Func _ _ _ _ (Just _) _) = True+ isT _ = False+ prtTrace trace vals =+ if trace+ then remark (" -> " ++ (show vals)) >> return vals+ else return vals evalLisp _ _ badForm = throwError (BadSpecial "Unrecognized special form" badForm)
Library.hs view
@@ -19,12 +19,13 @@ along with haskeem; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -$Id: library.hs,v 1.26 2009-05-31 01:41:08 uwe Exp $ -}+$Id: library.hs,v 1.30 2009-06-27 21:51:29 uwe Exp $ -} module Library (primitiveBindings, delayCounter, symbolCounter, loadFile, eqv) where import Prelude import IO+import Data.Bits import Data.Char import Data.Ratio import Control.Monad.Error as CME@@ -66,99 +67,98 @@ -- these get put into the primitives table below isChar :: [LispVal] -> ThrowsError LispVal-isChar [Char _] = return (Bool True)-isChar _ = return (Bool False)+isChar [Char _] = return lispTrue+isChar _ = return lispFalse isBool :: [LispVal] -> ThrowsError LispVal-isBool [Bool _] = return (Bool True)-isBool _ = return (Bool False)+isBool [Boolean _] = return lispTrue+isBool _ = return lispFalse isNumber :: [LispVal] -> ThrowsError LispVal-isNumber [IntNumber _] = return (Bool True)-isNumber [RatNumber _] = return (Bool True)-isNumber [FltNumber _] = return (Bool True)-isNumber _ = return (Bool False)+isNumber [IntNumber _] = return lispTrue+isNumber [RatNumber _] = return lispTrue+isNumber [FltNumber _] = return lispTrue+isNumber _ = return lispFalse isInteger :: [LispVal] -> ThrowsError LispVal-isInteger [IntNumber _] = return (Bool True)-isInteger [RatNumber n] = return (Bool ((denominator n) == 1))-isInteger _ = return (Bool False)+isInteger [IntNumber _] = return lispTrue+isInteger [RatNumber n] = return (Boolean ((denominator n) == 1))+isInteger _ = return lispFalse isRational :: [LispVal] -> ThrowsError LispVal-isRational [IntNumber _] = return (Bool True)-isRational [RatNumber _] = return (Bool True)-isRational _ = return (Bool False)+isRational [IntNumber _] = return lispTrue+isRational [RatNumber _] = return lispTrue+isRational _ = return lispFalse isReal :: [LispVal] -> ThrowsError LispVal-isReal [IntNumber _] = return (Bool True)-isReal [RatNumber _] = return (Bool True)-isReal [FltNumber _] = return (Bool True)-isReal _ = return (Bool False)+isReal [IntNumber _] = return lispTrue+isReal [RatNumber _] = return lispTrue+isReal [FltNumber _] = return lispTrue+isReal _ = return lispFalse isString :: [LispVal] -> ThrowsError LispVal-isString [String _] = return (Bool True)-isString _ = return (Bool False)+isString [String _] = return lispTrue+isString _ = return lispFalse isSymbol :: [LispVal] -> ThrowsError LispVal-isSymbol [Symbol _] = return (Bool True)-isSymbol _ = return (Bool False)+isSymbol [Symbol _] = return lispTrue+isSymbol _ = return lispFalse isList :: [LispVal] -> ThrowsError LispVal-isList [List _] = return (Bool True)-isList _ = return (Bool False)+isList [List _] = return lispTrue+isList _ = return lispFalse isPair :: [LispVal] -> ThrowsError LispVal-isPair [List []] = return (Bool False)-isPair [List _] = return (Bool True)-isPair [DottedList _ _] = return (Bool True)-isPair _ = return (Bool False)+isPair [List []] = return lispFalse+isPair [List _] = return lispTrue+isPair [DottedList _ _] = return lispTrue+isPair _ = return lispFalse isPort :: [LispVal] -> ThrowsError LispVal-isPort [Port _] = return (Bool True)-isPort [Socket _] = return (Bool True)-isPort _ = return (Bool False)+isPort [Port _] = return lispTrue+isPort [Socket _] = return lispTrue+isPort _ = return lispFalse isProcedure :: [LispVal] -> ThrowsError LispVal-isProcedure [Prim _] = return (Bool True)-isProcedure [IOPrim _] = return (Bool True)-isProcedure [Func _ _ _ _] = return (Bool True)-isProcedure [TraceFunc _ _ _ _ _] = return (Bool True)-isProcedure _ = return (Bool False)+isProcedure [Prim _] = return lispTrue+isProcedure [IOPrim _] = return lispTrue+isProcedure [Func _ _ _ _ _ _] = return lispTrue+isProcedure _ = return lispFalse isVector :: [LispVal] -> ThrowsError LispVal-isVector [Vector _ _] = return (Bool True)-isVector _ = return (Bool False)+isVector [Vector _ _] = return lispTrue+isVector _ = return lispFalse isNull :: [LispVal] -> ThrowsError LispVal-isNull [List []] = return (Bool True)-isNull _ = return (Bool False)+isNull [List []] = return lispTrue+isNull _ = return lispFalse isZero :: [LispVal] -> ThrowsError LispVal isZero [IntNumber n] =- if n == 0 then return (Bool True) else return (Bool False)+ if n == 0 then return lispTrue else return lispFalse isZero [RatNumber n] =- if (n == 0) then return (Bool True) else return (Bool False)+ if (n == 0) then return lispTrue else return lispFalse isZero [FltNumber n] =- if n == 0 then return (Bool True) else return (Bool False)-isZero _ = return (Bool False)+ if n == 0 then return lispTrue else return lispFalse+isZero _ = return lispFalse isPositive :: [LispVal] -> ThrowsError LispVal isPositive [IntNumber n] =- if n > 0 then return (Bool True) else return (Bool False)+ if n > 0 then return lispTrue else return lispFalse isPositive [RatNumber n] =- if n > 0 then return (Bool True) else return (Bool False)+ if n > 0 then return lispTrue else return lispFalse isPositive [FltNumber n] =- if n > 0 then return (Bool True) else return (Bool False)-isPositive _ = return (Bool False)+ if n > 0 then return lispTrue else return lispFalse+isPositive _ = return lispFalse isNegative :: [LispVal] -> ThrowsError LispVal isNegative [IntNumber n] =- if n < 0 then return (Bool True) else return (Bool False)+ if n < 0 then return lispTrue else return lispFalse isNegative [RatNumber n] =- if n < 0 then return (Bool True) else return (Bool False)+ if n < 0 then return lispTrue else return lispFalse isNegative [FltNumber n] =- if n < 0 then return (Bool True) else return (Bool False)-isNegative _ = return (Bool False)+ if n < 0 then return lispTrue else return lispFalse+isNegative _ = return lispFalse -- The treatment of Inf and NaN is not quite according to R6RS here. they say -- (/ 1 0) causes an exception, but I can't find what happens if the parser@@ -169,39 +169,39 @@ lispIsNaN :: [LispVal] -> ThrowsError LispVal lispIsNaN [RatNumber n] =- return (Bool (((numerator n) == 0) && ((denominator n) == 0)))-lispIsNaN [FltNumber n] = return (Bool (isNaN n))-lispIsNaN _ = return (Bool False)+ return (Boolean (((numerator n) == 0) && ((denominator n) == 0)))+lispIsNaN [FltNumber n] = return (Boolean (isNaN n))+lispIsNaN _ = return lispFalse lispIsInf :: [LispVal] -> ThrowsError LispVal lispIsInf [RatNumber n] = - return (Bool (((numerator n) /= 0) && ((denominator n) == 0)))-lispIsInf [FltNumber n] = return (Bool (isInfinite n))-lispIsInf _ = return (Bool False)+ return (Boolean (((numerator n) /= 0) && ((denominator n) == 0)))+lispIsInf [FltNumber n] = return (Boolean (isInfinite n))+lispIsInf _ = return lispFalse lispIsFinite :: [LispVal] -> ThrowsError LispVal-lispIsFinite [IntNumber _] = return (Bool True)-lispIsFinite [RatNumber n] = return (Bool ((denominator n) /= 0))+lispIsFinite [IntNumber _] = return lispTrue+lispIsFinite [RatNumber n] = return (Boolean ((denominator n) /= 0)) lispIsFinite [FltNumber n] =- return (Bool (not ((isInfinite n) && (isNaN n))))-lispIsFinite _ = return (Bool False)+ return (Boolean (not ((isInfinite n) && (isNaN n))))+lispIsFinite _ = return lispFalse lispIsEven :: [LispVal] -> ThrowsError LispVal-lispIsEven [IntNumber n] | even n = return (Bool True)- | otherwise = return (Bool False)-lispIsEven _ = return (Bool False)+lispIsEven [IntNumber n] | even n = return lispTrue+ | otherwise = return lispFalse+lispIsEven _ = return lispFalse lispIsOdd :: [LispVal] -> ThrowsError LispVal-lispIsOdd [IntNumber n] | even n = return (Bool False)- | otherwise = return (Bool True)-lispIsOdd _ = return (Bool False)+lispIsOdd [IntNumber n] | even n = return lispFalse+ | otherwise = return lispTrue+lispIsOdd _ = return lispFalse lispId :: [LispVal] -> ThrowsError LispVal lispId [val@(_)] = return val lispNot :: [LispVal] -> ThrowsError LispVal-lispNot [Bool False] = return (Bool True)-lispNot _ = return (Bool False)+lispNot [Boolean False] = return lispTrue+lispNot _ = return lispFalse unpackChar :: LispVal -> ThrowsError Char unpackChar (Char c) = return c@@ -236,7 +236,7 @@ unpackStr (IntNumber n) = return (show n) unpackStr (RatNumber n) = return (show n) unpackStr (FltNumber n) = return (show n)-unpackStr (Bool b) = return (show b)+unpackStr (Boolean b) = return (show b) unpackStr notString = errTypeMismatch "<unpackStr>" "string" notString -- first cut at "number tower": if we have a set of args that are all@@ -325,19 +325,19 @@ else if mytype == isIntType then do ll <- unpackIntNum (av !! 0) rr <- unpackIntNum (av !! 1)- return (Bool (intOp ll rr))+ return (Boolean (intOp ll rr)) else if mytype == isRatType then if scanRatNaN av- then return (Bool nanval)+ then return (Boolean nanval) else do ll <- unpackRatNum (av !! 0) rr <- unpackRatNum (av !! 1)- return (Bool (ratOp ll rr))+ return (Boolean (ratOp ll rr)) else if mytype == isFltType then if scanFltNaN av- then return (Bool nanval)+ then return (Boolean nanval) else do ll <- unpackFltNum (av !! 0) rr <- unpackFltNum (av !! 1)- return (Bool (dblOp ll rr))+ return (Boolean (dblOp ll rr)) else errTypeMismatch name "number" (List av) numericFunc :: String -> (Double -> Double) -> [LispVal] -> ThrowsError LispVal@@ -540,7 +540,7 @@ then errNumArgs name 2 args else do ll <- unpacker (args !! 0) rr <- unpacker (args !! 1)- return (Bool (ll `op` rr))+ return (Boolean (ll `op` rr)) strBoolBinop = boolBinop unpackStr charBoolBinop = boolBinop unpackChar@@ -564,7 +564,7 @@ cons badArgList = errNumArgs "cons" 2 badArgList eqv :: [LispVal] -> Bool-eqv [(Bool v1), (Bool v2)] = (v1 == v2)+eqv [(Boolean v1), (Boolean v2)] = (v1 == v2) eqv [(Char c1), (Char c2)] = (c1 == c2) eqv [(IntNumber v1), (IntNumber v2)] = (v1 == v2) eqv [(RatNumber v1), (RatNumber v2)] = (v1 == v2)@@ -585,7 +585,7 @@ eqv _ = False eqvFunc :: [LispVal] -> ThrowsError LispVal-eqvFunc (v1:v2:[]) = return (Bool (eqv [v1,v2]))+eqvFunc (v1:v2:[]) = return (Boolean (eqv [v1,v2])) eqvFunc badArgList = genericBadArg badArgList "eqv?" "matched types" 2 char2int :: [LispVal] -> ThrowsError LispVal@@ -616,7 +616,7 @@ readNum badArgList = genericBadArg badArgList "string->number" "string" 1 charIs :: (Char -> Bool) -> [LispVal] -> ThrowsError LispVal-charIs op [Char c] = return (Bool (op c))+charIs op [Char c] = return (Boolean (op c)) charIs _ badArgList = genericBadArg badArgList "char-istype?" "character" 1 charTo :: (Char -> Char) -> [LispVal] -> ThrowsError LispVal@@ -779,7 +779,7 @@ -- Vector primitives lispMakeVector :: [LispVal] -> ThrowsError LispVal-lispMakeVector [IntNumber n] = lispMakeVector [IntNumber n, Bool False]+lispMakeVector [IntNumber n] = lispMakeVector [IntNumber n, Boolean False] lispMakeVector [IntNumber n, val] = if n > 0 then return (Vector n (DIM.fromAscList (addkey val (fromInteger n))))@@ -817,7 +817,7 @@ lispVecRef :: [LispVal] -> ThrowsError LispVal lispVecRef [Vector len vec, IntNumber n] = if (n >= 0 && n < len)- then return (DIM.findWithDefault (Bool False) (fromInteger n) vec)+ then return (DIM.findWithDefault lispFalse (fromInteger n) vec) else throwError (VectorBounds len (IntNumber n)) lispVecRef badArgList = genericBadArg badArgList "vector-ref" "vector + integer" 2@@ -831,8 +831,7 @@ getfn ps (Just v) body = getfn1 (DottedList (map Symbol ps) (Symbol v)) body proc2data :: [LispVal] -> ThrowsError LispVal-proc2data [Func pars var body _] = return (getfn pars var body)-proc2data [TraceFunc _ pars var body _] = return (getfn pars var body)+proc2data [Func pars var body _ _ _] = return (getfn pars var body) proc2data [Delay obj _ _] = return obj proc2data [Prim _] = throwError (Default "procedure->data can't handle builtin functions")@@ -841,6 +840,60 @@ proc2data badArgList = genericBadArg badArgList "procedure->data" "lisp function" 1 +bitsAnd :: [LispVal] -> ThrowsError LispVal+bitsAnd [IntNumber n1, IntNumber n2] = return (IntNumber (n1 .&. n2))+bitsAnd badArgList = genericBadArg badArgList "bits-and" "integer" 2++bitsOr :: [LispVal] -> ThrowsError LispVal+bitsOr [IntNumber n1, IntNumber n2] = return (IntNumber (n1 .|. n2))+bitsOr badArgList = genericBadArg badArgList "bits-or" "integer" 2++bitsXOr :: [LispVal] -> ThrowsError LispVal+bitsXOr [IntNumber n1, IntNumber n2] = return (IntNumber (xor n1 n2))+bitsXOr badArgList = genericBadArg badArgList "bits-xor" "integer" 2++-- It's not quite clear to me that this one is useful...+-- it seems to implement the function+-- bn :: Integer -> Integer+-- bn n = -(n + 1)+-- which is correct enough in infinite-bits 2-adic numbers,+-- but the actual bit patterns returned don't look like complements.+-- Use bitsFlip instead...++-- bitsNot :: [LispVal] -> ThrowsError LispVal+-- bitsNot [IntNumber n] = return (IntNumber (complement n))+-- bitsNot badArgList = genericBadArg badArgList "bits-not" "integer" 1++bitsShift :: [LispVal] -> ThrowsError LispVal+bitsShift [IntNumber n1, IntNumber n2] =+ return (IntNumber (shift n1 (fromInteger n2)))+bitsShift badArgList = genericBadArg badArgList "bits-shift" "integer" 2++bitsSet :: [LispVal] -> ThrowsError LispVal+bitsSet [IntNumber n1, IntNumber n2] =+ return (IntNumber (setBit n1 (fromInteger n2)))+bitsSet badArgList = genericBadArg badArgList "bits-set" "integer" 2++bitsClear :: [LispVal] -> ThrowsError LispVal+bitsClear [IntNumber n1, IntNumber n2] =+ return (IntNumber (clearBit n1 (fromInteger n2)))+bitsClear badArgList = genericBadArg badArgList "bits-clear" "integer" 2++bitsFlip :: [LispVal] -> ThrowsError LispVal+bitsFlip [IntNumber n1, IntNumber n2] =+ return (IntNumber (complementBit n1 (fromInteger n2)))+bitsFlip badArgList = genericBadArg badArgList "bits-flip" "integer" 2++bitsGet :: [LispVal] -> ThrowsError LispVal+bitsGet [IntNumber n1, IntNumber n2] =+ return (IntNumber (n1 .&. (bit (fromInteger n2))))+bitsGet badArgList = genericBadArg badArgList "bits-get" "integer" 2++bitsIsSet :: [LispVal] -> ThrowsError LispVal+bitsIsSet [IntNumber n1, IntNumber n2] =+ return (Boolean (testBit n1 (fromInteger n2)))+bitsIsSet badArgList = genericBadArg badArgList "bits-set?" "integer" 2+ primitives :: [(String, [LispVal] -> ThrowsError LispVal)] primitives = [("+", lispPlus), ("-", lispMinus),@@ -956,7 +1009,17 @@ ("list->vector", lispListToVec), ("vector->list", lispVecToList), ("vector-ref", lispVecRef),- ("procedure->data", proc2data)]+ ("procedure->data", proc2data),+ ("bits-and", bitsAnd),+ ("bits-or", bitsOr),+ ("bits-xor", bitsXOr),+-- ("bits-not", bitsNot),+ ("bits-shift", bitsShift),+ ("bits-set", bitsSet),+ ("bits-clear", bitsClear),+ ("bits-flip", bitsFlip),+ ("bits-get", bitsGet),+ ("bits-set?", bitsIsSet)] -- A bunch of library functions that do IO: -- these get put into the ioPrimitives table below@@ -970,16 +1033,16 @@ case ret of Left err -> if epred err then throwError (Default (show err))- else return (Bool False)+ else return lispFalse Right val -> return (ctor val) -- A couple of utility functions for using doIOAction: dropToBool is a -- quasi-constructor which drops whatever it was handed, and instead only--- returns Bool True; allErrs and noEOF are selectors for various errors:+-- returns lispTrue; allErrs and noEOF are selectors for various errors: -- generally we want to hear about errors, but EOF when reading a line or -- character isn't really an error, so we silence that one. -dropToBool _ = Bool True+dropToBool _ = lispTrue allErrs _ = True noEOF err = not (isEOFError err) @@ -993,7 +1056,7 @@ doIOAction (hClose port) dropToBool allErrs closePort [Socket sock] = doIOAction (sClose sock) dropToBool allErrs-closePort _ = return (Bool False)+closePort _ = return lispFalse readLine :: [LispVal] -> IOThrowsError LispVal readLine [] = readLine [Port stdin]@@ -1019,7 +1082,7 @@ loadFile filename = do str <- doIOAction (readFile filename) String allErrs case str of- Bool False -> throwError (Default "operation failed")+ Boolean False -> throwError (Default "operation failed") String val -> liftThrows (readExprList val) readAll :: [LispVal] -> IOThrowsError LispVal@@ -1027,9 +1090,9 @@ readAll badArgList = genericIOBadArg badArgList "read-all" "string" 1 lispPutStr :: [LispVal] -> IOThrowsError LispVal-lispPutStr [] = return (Bool False)+lispPutStr [] = return lispFalse lispPutStr ((Port port):rest) =- mapM outStr rest >> return (Bool True)+ mapM outStr rest >> return lispTrue where outStr (String s) = doIOAction (hPutStr port s) dropToBool allErrs outStr (Char c) = doIOAction (hPutChar port c) dropToBool allErrs outStr notS = genericIOBadArg [notS] "write-string" "string" 1@@ -1046,8 +1109,8 @@ lispError info = throwError (UserException (List info)) lispExit :: [LispVal] -> IOThrowsError LispVal-lispExit [Bool False] = liftIO (exitWith (ExitFailure 1))-lispExit [Bool True] = liftIO (exitWith ExitSuccess)+lispExit [Boolean False] = liftIO (exitWith (ExitFailure 1))+lispExit [Boolean True] = liftIO (exitWith ExitSuccess) lispExit [IntNumber n] | n == 0 = liftIO (exitWith ExitSuccess) | otherwise = liftIO(exitWith (ExitFailure (fromInteger n)))@@ -1056,13 +1119,13 @@ lispFileExists :: [LispVal] -> IOThrowsError LispVal lispFileExists [String filename] =- doIOAction (doesFileExist filename) Bool allErrs+ doIOAction (doesFileExist filename) Boolean allErrs lispFileExists badArgList = genericIOBadArg badArgList "file-exists?" "string" 1 lispDirExists :: [LispVal] -> IOThrowsError LispVal lispDirExists [String dirname] =- doIOAction (doesDirectoryExist dirname) Bool allErrs+ doIOAction (doesDirectoryExist dirname) Boolean allErrs lispDirExists badArgList = genericIOBadArg badArgList "directory-exists?" "string" 1 @@ -1218,43 +1281,43 @@ lispIsBlockDevice :: [LispVal] -> IOThrowsError LispVal lispIsBlockDevice [String filename] =- doIOAction (getFileStatus filename) (Bool . isBlockDevice) allErrs+ doIOAction (getFileStatus filename) (Boolean . isBlockDevice) allErrs lispIsBlockDevice badArgList = genericIOBadArg badArgList "is-block-device?" "string" 1 lispIsCharacterDevice :: [LispVal] -> IOThrowsError LispVal lispIsCharacterDevice [String filename] =- doIOAction (getFileStatus filename) (Bool . isCharacterDevice) allErrs+ doIOAction (getFileStatus filename) (Boolean . isCharacterDevice) allErrs lispIsCharacterDevice badArgList = genericIOBadArg badArgList "is-char-device?" "string" 1 lispIsNamedPipe :: [LispVal] -> IOThrowsError LispVal lispIsNamedPipe [String filename] =- doIOAction (getFileStatus filename) (Bool . isNamedPipe) allErrs+ doIOAction (getFileStatus filename) (Boolean . isNamedPipe) allErrs lispIsNamedPipe badArgList = genericIOBadArg badArgList "is-named-pipe?" "string" 1 lispIsRegularFile :: [LispVal] -> IOThrowsError LispVal lispIsRegularFile [String filename] =- doIOAction (getFileStatus filename) (Bool . isRegularFile) allErrs+ doIOAction (getFileStatus filename) (Boolean . isRegularFile) allErrs lispIsRegularFile badArgList = genericIOBadArg badArgList "is-regular-file?" "string" 1 lispIsDirectory :: [LispVal] -> IOThrowsError LispVal lispIsDirectory [String filename] =- doIOAction (getFileStatus filename) (Bool . isDirectory) allErrs+ doIOAction (getFileStatus filename) (Boolean . isDirectory) allErrs lispIsDirectory badArgList = genericIOBadArg badArgList "is-directory?" "string" 1 lispIsSymbolicLink :: [LispVal] -> IOThrowsError LispVal lispIsSymbolicLink [String filename] =- doIOAction (getFileStatus filename) (Bool . isSymbolicLink) allErrs+ doIOAction (getFileStatus filename) (Boolean . isSymbolicLink) allErrs lispIsSymbolicLink badArgList = genericIOBadArg badArgList "is-symbolic-link?" "string" 1 lispIsSocket :: [LispVal] -> IOThrowsError LispVal lispIsSocket [String filename] =- doIOAction (getFileStatus filename) (Bool . isSocket) allErrs+ doIOAction (getFileStatus filename) (Boolean . isSocket) allErrs lispIsSocket badArgList = genericIOBadArg badArgList "is-socket?" "string" 1
LispData.hs view
@@ -19,16 +19,17 @@ along with haskeem; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -$Id: lispdata.hs,v 1.12 2009-06-06 20:40:09 uwe Exp $ -}+$Id: lispdata.hs,v 1.14 2009-06-27 21:51:29 uwe Exp $ -} module LispData- (LispVal(Symbol, Bool, Char, Delay, DottedList, IntNumber, RatNumber,- FltNumber, Func, IOPrim, List, Macro, Port, Prim, Socket,- String, TraceFunc, Vector),+ (LispVal(Symbol, Boolean, Char, Delay, DottedList, IntNumber,+ RatNumber, FltNumber, Func, IOPrim, List, Port, Prim,+ Socket, String, Vector), LispError(NumArgs, TypeMismatch, Parser, BadSpecial, NotFunction, UnboundVar, Default, OutOfRange, VectorBounds, UserException), ThrowsError, Env, IOThrowsError, liftThrows,- myRatPInf, myRatNInf, myRatNaN, myFltPInf, myFltNInf, myFltNaN) where+ myRatPInf, myRatNInf, myRatNaN, myFltPInf, myFltNInf, myFltNaN,+ lispTrue, lispFalse) where import Prelude import IO hiding (try) import Data.Char@@ -64,7 +65,7 @@ -- A lisp value: these are the stuff which normally gets processed data LispVal = Symbol String- | Bool Bool+ | Boolean Bool | IntNumber Integer | RatNumber Rational | FltNumber Double@@ -76,16 +77,9 @@ | Func {params :: [String], vararg :: (Maybe String), body :: [LispVal],- closure :: Env}- | TraceFunc {name :: String,- params :: [String],- vararg :: (Maybe String),- body :: [LispVal],- closure :: Env}- | Macro {params :: [String],- vararg :: (Maybe String),- body :: [LispVal],- closure :: Env}+ closure :: Env,+ name :: (Maybe String),+ macro :: Bool} | Delay {obj :: LispVal, closure :: Env, tag :: String}@@ -98,8 +92,8 @@ showVal :: LispVal -> String showVal (Symbol atom) = atom-showVal (Bool True) = "#t"-showVal (Bool False) = "#f"+showVal (Boolean True) = "#t"+showVal (Boolean False) = "#f" showVal (IntNumber num) = show num showVal (RatNumber num) = (show (numerator num)) ++ "/" ++ (show (denominator num))@@ -124,32 +118,31 @@ | isPrint ch = "#\\" ++ [ch] | otherwise = [ch] showVal (Prim _) = "<primitive>"-showVal (Func {params = args, vararg = varargs, body = _, closure = _}) =- "(lambda (" ++ (unwords args) ++- (case varargs of- Nothing -> ""- Just arg -> " . " ++ arg) ++ ") ...)"-showVal (Macro {params = args, vararg = varargs, body = _, closure = _}) =- "<macro (" ++ (unwords args) ++- (case varargs of- Nothing -> ""- Just arg -> " . " ++ arg) ++ ") ...>"+showVal (Func {params = args, vararg = varargs, body = bd,+ closure = _, name = nm, macro = ismac}) =+ let lopen = if ismac then "<macro" else "(lambda"+ lclose = if ismac then ">" else ")"+ inner = lopen ++ " (" ++ (unwords args) +++ (case varargs of+ Nothing -> ""+ Just arg -> " . " ++ arg) ++ ") " +++ (unwords (map showVal bd)) ++ lclose+ in case nm of+ Nothing -> inner+ Just val -> "(" ++ val ++ " . " ++ inner ++ ")" showVal (IOPrim _) = "<IO primitive>" showVal (Port _) = "<IO port>" showVal (Socket _) = "<IO socket>"-showVal (TraceFunc {name = nm, params = args, vararg = varargs,- body = bd, closure = _}) =- "(" ++ nm ++ " . (lambda (" ++ (unwords args) ++- (case varargs of- Nothing -> ""- Just arg -> " . " ++ arg) ++ ") " ++- (unwords (map showVal bd)) ++ "))"--showVal (Delay {obj = o, closure = _, tag = _}) =- "<promise>" ++ (show o)+showVal (Delay {obj = o, closure = _, tag = _}) = "<promise>" ++ (show o) showVal (Vector _ vals) = "#(" ++ (unwords (map showVal (DIM.elems vals))) ++ ")"++-- True and False at the scheme level++lispTrue, lispFalse :: LispVal+lispTrue = Boolean True+lispFalse = Boolean False -- A lisp error: these get processed when an error of some kind occurs
Parser.hs view
@@ -19,7 +19,7 @@ along with haskeem; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -$Id: parser.hs,v 1.13 2009-05-31 01:41:08 uwe Exp $ -}+$Id: parser.hs,v 1.14 2009-06-27 20:31:52 uwe Exp $ -} module Parser (readExpr, readExprList, readNumber) where import Prelude@@ -124,10 +124,10 @@ do char '#' v <- oneOf "tTfF" return (case v of- 't' -> Bool True- 'T' -> Bool True- 'f' -> Bool False- 'F' -> Bool False)+ 't' -> lispTrue+ 'T' -> lispTrue+ 'f' -> lispFalse+ 'F' -> lispFalse) parseString :: Parser LispVal parseString =@@ -410,5 +410,5 @@ readNumber :: String -> ThrowsError LispVal readNumber input = case parse parseJustNumber "number" input of- Left _ -> return (Bool False)+ Left _ -> return lispFalse Right val -> return val
gendoc.scm view
@@ -15,22 +15,30 @@ ; along with haskeem; if not, write to the Free Software ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -; $Id: gendoc.scm,v 1.5 2008/02/10 06:32:20 uwe Exp $+; $Id: gendoc.scm,v 1.7 2009-06-19 00:54:26 uwe Exp $ ; A small documentation generator: it reads the file "haskeem.doc" and ; processes its contents into the desired format... currently just a ; sorted list to stdout +; Put this stuff first, so that we don't include the (in part large) stuff+; defined below++(define fp (open-output-file "/tmp/bindings.dat"))+(dump-bindings fp)+(close-port fp)+ ; How to sort doc items: first by section, then within each section by name. ; Sections are are identified by one of a couple of keywords:-; "form", "function", "primitive", "data", or "port"+; "form", "function", "macro", "primitive", "data", or "port" (define (type-map type) (case type (("form") 1) (("function" "primitive") 2)- (("data" "port") 3)- (else 4)))+ (("macro") 3)+ (("data" "port") 4)+ (else 5))) (define (doc-sort d1 d2) (let* ((t1 (symbol->string (caar d1)))@@ -65,3 +73,37 @@ (define section) (map show doc-data)++(define (find-in-doc docs name)+ (cond ((null? docs) '())+ ((string=? name (symbol->string (cadaar docs))) (car docs))+ (else (find-in-doc (cdr docs) name))))++; Add this to the list, since we newly defined it above+; before dumping the bindings++(set! doc-data (cons '((port fp)) doc-data))++; TODO: check type of item against what's in doc-data++(define (check item)+ (unless (char-whitespace? (car (string->char item)))+ (let* ((tmp (string-split-by char-whitespace? item))+ (name (car tmp))+ (info (cddr tmp))+ (entry (find-in-doc doc-data name)))+ (when (null? entry)+ (write-string " " name #\linefeed)))))++(define (do-lines fp)+ (let ((cur (read-line fp)))+ (when cur+ (check cur)+ (do-lines fp))))++(write-string "\nTo be checked:\n\n")++(set! fp (open-input-file "/tmp/bindings.dat"))+(do-lines fp)+(write-string #\newline)+(remove-file "/tmp/bindings.dat")
haskeem.cabal view
@@ -1,11 +1,11 @@ Name: haskeem-Version: 0.7.0+Version: 0.7.4 Author: Uwe Hollerbach <uh@alumni.caltech.edu> Maintainer: Uwe Hollerbach <uh@alumni.caltech.edu> Synopsis: A small scheme interpreter Description: This is a moderately complete small scheme interpreter. It implements most of R6RS, with the exception of call/cc.- It has a macro system, but not R6RS hygienic macros.+ It has a macro system, although not R6RS hygienic macros. It is also not necessarily fully tail-recursive; so it's not industrial-strength. For playing with or learning scheme, it should be pretty good.
haskeem.doc view
@@ -15,7 +15,7 @@ ; along with haskeem; if not, write to the Free Software ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -; $Id: haskeem.doc,v 1.29 2008/03/08 03:52:38 uwe Exp $+; $Id: haskeem.doc,v 1.35 2009-06-20 03:09:42 uwe Exp $ ; Input to documentation generator for haskeem. The intent is that this ; does NOT have to be globally ordered, it is possible to just add new@@ -39,6 +39,8 @@ ((form define) (args var val)) ((form define) (args (var params) body)) ((form define) (args (var params . varargs) body))+((form defmacro) (args (var params) body))+((form defmacro) (args (var params . varargs) body)) ((form let) (args ???)) ((form let*) (args ???))@@ -57,8 +59,8 @@ ((form if) (args pred true-case false-case)) ((form if) (args pred true-case)) -((form unless) (args pred expression))-((form when) (args pred expression))+((macro unless) (args pred expressions))+((macro when) (args pred expressions)) ((form load) (args filename)) @@ -343,4 +345,42 @@ ((primitive set-line-buffering!) (args handle)) ((primitive set-no-buffering!) (args handle)) ((function stream-scale) (args scale stream) (return stream))-((function assert) (args expr) (return expr-value))++; TODO: what have I missed? defmacro added above++((primitive procedure->data) (args lisp-function) (return list))+((macro assert) (args expr) (return expr))+((function list-remove-dups) (args list) (return list))+((macro while) (args cond . actions) (return trip-count))+((macro until) (args cond . actions) (return trip-count))+((macro do-while) (args cond . actions) (return trip-count))+((macro do-until) (args cond . actions) (return trip-count))+((macro load-library) (args filename))++((primitive bits-and) (args integer integer) (return integer))+((primitive bits-or) (args integer integer) (return integer))+((primitive bits-xor) (args integer integer) (return integer))+((primitive bits-not) (args integer) (return integer))+((primitive bits-shift) (args integer integer) (return integer))+((primitive bits-set) (args integer integer) (return integer))+((primitive bits-clear) (args integer integer) (return integer))+((primitive bits-flip) (args integer integer) (return integer))+((primitive bits-set?) (args integer integer) (return bool))+((primitive bits-get) (args integer integer) (return integer))+((function stream-take-while) (args keep? strm) (return strm))+((function fcdr) (args promise) (return value))+((function nth) (args n list) (return value))+((function newline) (args . port))+((primitive create-directory) (args dirname))+((primitive remove-directory) (args dirname))+((primitive rename-directory) (args dirname))+((primitive vector?) (args vector) (return bool))++; This is a boolean saying whether the session is interactive or not++((data interactive?))++; This contains the command-line args of the haskeem process++((data args))+((function cycle) (args list) (return stream))
haskeem.hs view
@@ -19,7 +19,7 @@ along with haskeem; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -$Id: haskeem.hs,v 1.27 2009-06-06 20:40:08 uwe Exp $ -}+$Id: haskeem.hs,v 1.33 2009-06-27 20:31:51 uwe Exp $ -} module Main where import Prelude@@ -29,7 +29,7 @@ import Control.Monad.Error as CME import Control.OldException as CE import Data.Char-import System.Console.Haskeline+import System.Console.Haskeline as SCH import System.Posix.Signals() import Control.Concurrent() import Data.Typeable()@@ -43,7 +43,7 @@ -- haskeem version version :: String-version = "0.7.0"+version = "0.7.4" -- a variable under which any command-line arguments to a script are -- made available; empty for interactive mode@@ -62,7 +62,8 @@ evalAndPrint :: Env -> Bool -> String -> InputT IO () evalAndPrint env pflag expr =- do ret <- liftIO (runErrorT (liftThrows (readExpr expr) >>= evalLisp env 0))+ do ret <- liftIO (runErrorT (liftThrows (readExpr (dropWhile isSpace expr))+ >>= evalLisp env 0)) case ret of Left err -> outputStrLn (show err) Right val -> if pflag then outputStrLn (show val) else outputStr ""@@ -84,7 +85,7 @@ setupBindings :: [LispVal] -> Bool -> IO Env setupBindings args inter = primitiveBindings >>= flip bindVars [(scriptArgs, List args),- (interactive, Bool inter)]+ (interactive, Boolean inter)] -- interactive mode: print header, run initialization, then dive into REPL @@ -100,6 +101,9 @@ -- the actual REPL, combined with tasty haskeline goodness +catcher :: CE.Exception -> InputT IO ()+catcher e = outputStrLn "Interrupt!"+ doREPL :: Env -> InputT IO () doREPL env = do maybeLine <- getInputLine "lisp> "@@ -108,7 +112,9 @@ Just "quit" -> return () Just line -> if isBlank line then doREPL env- else evalAndPrint env True line >> doREPL env+ else do SCH.catch (evalAndPrint env True line)+ catcher+ doREPL env where isBlank [] = True isBlank _ = False
haskeem_readline.hs view
@@ -82,7 +82,7 @@ setupBindings :: [LispVal] -> Bool -> IO Env setupBindings args inter = primitiveBindings >>= flip bindVars [(scriptArgs, List args),- (interactive, Bool inter)]+ (interactive, Boolean inter)] -- interactive mode: print header, run initialization, then dive into REPL
macro-test.scm view
@@ -8,22 +8,19 @@ (define pos-action (lambda () (set! probe (+ probe 100)) "positive!")) ; The value returned from this determines which of the three branches is chosen-(define test-value (lambda () (set! probe (+ probe 1000)) -1))--(define numeric-if-tmp "foo")+(define test-value (lambda () (set! probe (+ probe 1000)) 1)) ; This version is careful to evaluate tval only once (defmacro (numeric-if-1 tval ifn ifz ifp)- `(let ((numeric-if-tmp ,tval))- (display numeric-if-tmp)- (newline)- (if (number? numeric-if-tmp)- (if (negative? numeric-if-tmp)- ,ifn- (if (positive? numeric-if-tmp)- ,ifp- ,ifz))- (raise "error: non-numeric test value passed to numeric-if"))))+ (let ((nit (new-symbol)))+ `(let ((,nit ,tval))+ (if (number? ,nit)+ (if (negative? ,nit)+ ,ifn+ (if (positive? ,nit)+ ,ifp+ ,ifz))+ (raise "error: non-numeric test value passed to numeric-if"))))) ; This version might evaluate tval two or three times (defmacro (numeric-if-2 tval ifn ifz ifp)@@ -38,8 +35,10 @@ ; A function version of numeric-if would evaluate each argument precisely once, ; so that after the test the value of probe would be 1111 -(display numeric-if-tmp)+(write-string "test-value returns ")+(display (test-value)) (newline)+(set! probe 0) (write-string "before: probe is " (number->string probe) #\newline) (define ret (guard@@ -47,18 +46,18 @@ (display err) (write-string "'\n") #t) err))- (numeric-if-2 (test-value)+ (numeric-if-1 (test-value) (neg-action) (zero-action) (pos-action))))-(write-string "after: probe is " (number->string probe) #\newline)-(write-string "result returned: ")+(write-string "after: probe is " (number->string probe) #\newline)+(write-string "result is ") (display ret) (newline)-(display numeric-if-tmp)-(newline) (write-string "################ assertion test\n")+; really we ought to raise an exception here if the assertion failed;+; this is just to be friendly for the test (defmacro (assert some-cond) `(when (not ,some-cond) (write-string "assertion failure: ")@@ -69,5 +68,52 @@ (display x) (newline) (assert (eqv? x "bar"))++(write-string "################ while test\n")+(defmacro (while some-cond . some-actions)+ (let ((mc (new-symbol)))+ `(do ((,mc 0 (+ ,mc 1)))+ ((not ,some-cond) ,mc)+ ,@some-actions)))++(define i 0)+(define count (while (< i 10) (set! i (+ i 1)) (display i)))+(write-string #\newline "i sez " (number->string i) #\newline+ "loop count sez " (number->string count) #\newline)++(write-string "######## nested while test\n")+(define j 0)+(set! i 0)+(while (< i 4)+ (set! j 0)+ (while (< j 4)+ (set! j (+ j 1))+ (write-string (number->string i) "/"+ (number->string j) #\newline))+ (set! i (+ i 1)))++(write-string "################ swap test\n")+(defmacro (swap var1 var2)+ (let ((vs (new-symbol)))+ `(let ((,vs ,var1))+ (set! ,var1 ,var2)+ (set! ,var2 ,vs))))++(define val1 0)+(define val2 1)+(write-string "before: val1 is " (number->string val1)+ ", val2 is " (number->string val2) #\newline)+(swap val1 val2)+(write-string "after: val1 is " (number->string val1)+ ", val2 is " (number->string val2) #\newline)++; can we break it? I don't think so... at least not this way:+; haskeem doesn't support re-binding of special forms, and set! is one+(write-string "before: val1 is " (number->string val1)+ ", val2 is " (number->string val2) #\newline)+(let ((set! display))+ (swap val1 val2))+(write-string "after: val1 is " (number->string val1)+ ", val2 is " (number->string val2) #\newline) (write-string "################ th-th-that's all, folks!\n")
+ regexp.scm view
@@ -0,0 +1,552 @@+; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>+; $Id: regexp.scm,v 1.12 2009-06-26 05:22:27 uwe Exp $+; BSD3... but if you use this for anything serious, you gotta be kidding++; grammar for regular expressions: precedence is (highest to lowest)+; counting operators: *+? TODO: add count {N} or range {LO,HI}+; -> convert current ops to+; ('count lo hi ...) kind of thing+; concatenation+; alternation RE1 | RE2+; parentheses force grouping+; TODO: add negated ranges [^a-z], more-complex character ranges [a-fq-z] etc+;+; regexp = re1+; | re1 '|' regexp+;+; re1 = re2+; | re2 re1+;+; re2 = re3+; | re3 '?'+; | re3 '*'+; | re3 '+'+;+; re3 = character+; | escaped-character+; | character-range (only simple ranges [x-y])+; | '(' regexp ')'+;+; NOTE!!! escaped characters are '\(' for example; but the scheme reader+; already processes '\', so if entering from keyboard or some literal+; string, need to double-escape it: for example (regexp-parse "(a|\\()*")++; An NFA state is a list: the car is the name of the state itself, a simple+; integer. The names are generated by the st-count counter in this routine:+; it starts at 0, but it's pre-incremented, so state names start at 1. In+; principle, they could be arbitrary, but we make use of the fact that they+; are non-negative integers in the next routine, where we generate the+; epsilon-closure of each state: we use bit-sets there, which assume (in my+; implementation) that all elements of a set are non-negative integers.+; The second element of the NFA state list is the set of states to which+; epsilon-transitions are possible. In the output of this routine, that is+; a simple list of state names; in the output of gen-eps-closure, it gets+; turned into a bitset which is represented as a single integer.+; The remaining entries in the list are themselves lists, each representing+; a new state to which a transition may be made, and the inputs triggering+; that transition. For example:+;+; (2 (10) (1 #\+ #\-) (5 #\a #\b) (7 #\c #\d))+;+; describes NFA state 2, with an eps-transition to state 10, and capable of+; undergoing a transition to state 1 on inputs #\+ and #\-, to state 5 on+; inputs #\a and #\b, and to state 7 on inputs #\c and #\d.+;+; A complete NFA is a list of such NFA states. The first state in the list is+; the start state, and the second state in the list is the end state (although+; of course multiple internal states can & often will make eps-transitions to+; that final state, so that they too are accepting states). States beyond the+; first two are internal states (subject to the previous comment).+;+; There is no particular order associated with the state identifiers.+; Generally the start state will be 2, due to the particulars of how the+; make-nfa routine allocates its states; but there is no significance+; attached to that.++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+; Parse a complete regular expression, checking that there is nothing left+; at the end. This is kind of a large function... but I don't really want to+; expose the individual levels, they don't make much sense by themselves.++; This returns an AST: a literal character or a list of lists describing+; sub-regexps. The car of each list is a description of the type of regexp:+; 'CONCAT, 'ALT, or 'COUNT. If the type is 'COUNT, then the cadr of the list+; descibes the count range: currently one of #\? #\* #\+. Remaining entries+; in all the lists are again ASTs.++(define (regexp-parse str)+ (letrec* ((tokens (filter (lambda (c) (not (char-whitespace? c)))+ (string->char str)))+ (cur-tok #f)+ (peek (lambda ()+ (if (null? tokens)+ #f+ (car tokens))))+ (pop (lambda ()+ (if (null? tokens)+ #f+ (begin (set! cur-tok (car tokens))+ (set! tokens (cdr tokens))+ cur-tok))))+; handle choice operator '|'+ (p-re0 (lambda ()+ (let* ((re1 (p-re1))+ (cur (peek)))+ (if (eqv? cur #\|)+ (begin (pop)+ (list 'ALT re1 (p-re0)))+ re1))))+; handle special kind of choice: character range; for now, only handle+; [a-b] type (except that the brackets are done outside these routines)+ (gen-range (lambda (cs)+ (if (null? (cdr cs))+ (car cs)+ (list 'ALT (car cs) (gen-range (cdr cs))))))+ (p-range (lambda ()+ (let* ((c1 (char->integer (pop)))+ (cminus (pop))+ (c2 (char->integer (pop)))+ (lo (min c1 c2))+ (hi (max c1 c2))+ (n (+ 1 (- hi lo))))+ (if (eqv? cminus #\-)+ (gen-range (map integer->char (upfrom lo n)))+ (raise "bad character range")))))+; handle concatenation "operator"+ (p-re1 (lambda ()+ (let* ((re2 (p-re2))+ (cur (peek)))+ (if (or (eqv? cur #f)+ (eqv? cur #\|)+ (eqv? cur #\)))+ re2+ (list 'CONCAT re2 (p-re1))))))+; handle count operators '?', '*', and '+'+ (p-re2 (lambda ()+ (let* ((re3 (p-re3))+ (cur (peek)))+ (if (or (eqv? cur #\?)+ (eqv? cur #\*)+ (eqv? cur #\+))+ (list 'COUNT (pop) re3)+ re3))))+; handle individual characters and parenthesized regexps+ (p-re3 (lambda ()+ (let ((cur (peek)))+ (cond ((eqv? cur #\()+ (pop)+ (set! cur (p-re0))+ (if (eqv? (peek) #\))+ (begin (pop) cur)+ (raise "error: unbalanced parentheses")))+ ((eqv? cur #\[)+ (pop)+ (set! cur (p-range))+ (if (eqv? (peek) #\])+ (begin (pop) cur)+ (raise "error: unbalanced brackets")))+ ((eqv? cur #\\)+ (pop)+ (pop))+ ((or (eqv? cur #\|)+ (eqv? cur #\?)+ (eqv? cur #\*)+ (eqv? cur #\+))+ (raise "error: unexpected operator"))+ (else (pop))))))+ (regexp (p-re0)))+ (if (eqv? (peek) #f)+ regexp+ (raise "error: input not completely used"))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+; Flatten the AST produced by regexp-parse: instead of a pure tree of+; binary ops, CONCAT and ALT get turned into multi-operand operators+; where applicable. For example+; (CONCAT #\a (CONCAT #\b (CONCAT #\c (CONCAT #\d #\e))))+; gets turned into+; (CONCAT #\a #\b #\c #\d #\e)+; This makes the NFA have a lot fewer intermediate states.+; Probably this should eventually just get added into regexp-parse, but+; for now it's nicer to be able to look at all the intermediate steps.++(define (regexp-flatten-ast ast)+ (let ((s-op (lambda (op t1 t2)+ (let ((lst (list op))+ (lifter (lambda (l)+ ((if (and (list? l) (eqv? (car l) op))+ cdr+ list) l))))+ (append (append lst (lifter t1)) (lifter t2))))))+ (if (list? ast)+ (cond ((eqv? 'COUNT (car ast))+ (list (car ast)+ (cadr ast)+ (regexp-flatten-ast (caddr ast))))+ ((or (eqv? 'CONCAT (car ast)) (eqv? 'ALT (car ast)))+ (s-op (car ast)+ (regexp-flatten-ast (cadr ast))+ (regexp-flatten-ast (caddr ast))))+ (else ast))+ ast)))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+; This routine generates a list of states describing an NFA, given an AST+; generated from the above routine(s). The first state in the list will be the+; start state, and the second state in the list will be the end state;+; intermediate states will follow after that. The initial version produces+; copious intermediate states with epsilon-transitions. It does do fairly+; efficient character ranges now.++(define (regexp-make-nfa ast)+ (letrec* ((con3 (lambda (a b c) (cons a (cons b c))))+; Make a new state+ (st-count 0)+ (mk-st (lambda ()+ (set! st-count (+ 1 st-count))+ (list st-count '())))+; Add a transition from state ST1 to state ST2 on character C+; or an eps-transition if c is the empty list+ (add-tr (lambda (st1 st2 c)+ (cons (car st1)+ (append+ (cond ((null? c)+ (list (cons (car st2) (cadr st1))))+ ((char? c)+ (list (cadr st1) (list (car st2) c)))+ (else+ (list (cadr st1) (cons (car st2) c))))+ (cddr st1)))))+; Make a simple alternation across a range of chars+ (mk-alt-range (lambda (chars)+ (let* ((st2 (mk-st))+ (st1 (add-tr (mk-st) st2 chars)))+ (list st1 st2))))+; Add an eps-transition from state ST to each of the states in the list STS+ (add-h-eps (lambda (st sts)+ (if (null? sts)+ st+ (add-h-eps+ (add-tr st (car sts) '()) (cdr sts)))))+; Add an eps-transition from the tail state of NFA to state ST+ (add-t-eps (lambda (nfa st)+ (con3 (car nfa)+ (add-tr (cadr nfa) st '())+ (cddr nfa))))+; Merge two NFAs into one which represents their concatenation+ (merge-nfas (lambda (nfa1 nfa2)+ (cond ((null? nfa1) nfa2)+ ((null? nfa2) nfa1)+ (else (let ((h2 (car nfa2)))+ (con3 (car nfa1) (cadr nfa2)+ (append+ (list+ (add-tr+ (cadr nfa1) h2 '()) h2)+ (cddr nfa1)+ (cddr nfa2))))))))+; Main routine to walk the AST and translate into an NFA+ (gen-nfa (lambda (ast)+ (let ((st #f)+ (cop #f)+ (sub #f))+ (cond ((char? ast)+ (set! st (mk-st))+ (list (add-tr (mk-st) st ast) st))+ ((eqv? 'COUNT (car ast))+ (set! cop (cadr ast))+ (set! sub (gen-nfa (caddr ast)))+ (cond ((eqv? #\? cop)+ (cons (add-tr (car sub) (cadr sub) '())+ (cdr sub)))+ ((eqv? #\+ cop)+ (con3 (car sub)+ (add-tr (cadr sub) (car sub) '())+ (cddr sub)))+ ((eqv? #\* cop)+ (con3 (add-tr (car sub) (cadr sub) '())+ (add-tr (cadr sub) (car sub) '())+ (cddr sub)))+ (else (raise "unknown COUNT op!"))))+ ((eqv? 'CONCAT (car ast))+ (foldl merge-nfas '() (map gen-nfa (cdr ast))))+ ((eqv? 'ALT (car ast))+ (let* ((part (partition char? (cdr ast)))+ (chars (car part))+ (other (cadr part)))+ (unless (null? chars)+ (set! chars (mk-alt-range chars)))+ (unless (null? other)+ (set! sub (map gen-nfa other))+ (unless (null? chars)+ (set! sub+ (cons (list chars) sub))+ (set! chars '())))+ (if (null? other)+ chars+ (begin+ (set! st (mk-st))+ (con3 (add-h-eps (mk-st)+ (map car sub)) st+ (apply append+ (map (lambda (a)+ (add-t-eps a st))+ sub)))))))+ (else (raise "unknown regexp op!")))))))+ (gen-nfa ast)))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+; This is a lot simpler using a vector than it would be with pure lists...+; it would be possible, but the vector gives us the equivalent of set-car!+; and that makes a huge difference. With bitsets, it's even not+; unreasonably slow.++(define (regexp-gen-eps-closure nfa)+ (letrec* ((max-state (lambda (nfa m)+ (if (null? nfa)+ m+ (max-state (cdr nfa) (max m (caar nfa))))))+ (n (+ 1 (max-state nfa 1)))+ (vec (make-vector n))+ (cur #f)+ (new #f)+ (change #t))+ (map (lambda (s)+ (vector-set! vec (car s)+ (foldl bitset-add (bitset-new) (cadr s))))+ nfa)+ (while change+ (set! change #f)+ (do ((i 1 (+ i 1)))+ ((>= i n) #t)+ (set! cur (vector-ref vec i))+ (set! new cur)+ (bitset-foreach+ cur (lambda (j)+ (set! new (bitset-or new (vector-ref vec j)))))+ (unless (bitset-equal? new cur)+ (set! change #t)+ (vector-set! vec i new))))+ (map (lambda (s)+ (let ((ec (vector-ref vec (car s))))+ (set! ec (bitset-add ec (car s)))+ (cons (car s) (cons ec (cddr s)))))+ nfa)))++; This generates the epsilon-union of a state set from the nfa++(define (find-eps-union set nfa)+ (letrec* ((eps-union (bitset-new))+ (find-eps-closure+ (lambda (s nfa)+ (cond ((null? nfa)+ (raise "programming error! state not in nfa!"))+ ((= s (caar nfa)) (cadar nfa))+ (else (find-eps-closure s (cdr nfa))))))+ (merge-eps-closure+ (lambda (s)+ (set! eps-union+ (bitset-or eps-union (find-eps-closure s nfa))))))+ (bitset-foreach set merge-eps-closure)+ eps-union))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+; This makes a DFA from the NFA... eventually.++; It assumes an NFA that is the output of gen-eps-closure rather than one+; that comes directly out of make-nfa; we might need to eventually test for+; that and do it automatically. It also assumes that the initial state is+; the first one in the NFA, and the matching state is the second one; this+; is as constructed by make-nfa and preserved by gen-eps-closure. If I+; understand J & C correctly, the gen-eps-closure routine has done a fair+; part of the work for this already, since it has generated the+; eps-closures for all the NFA states already.++; pseudo-code from J & C:++; {M} = eps-closure of NFA state 1+; DFA state 1 = {M}+; add {M} to work queue (or stack, doesn't matter)+; while (work queue/stack not empty)+; remove {M}+; for each input character i+; {P} = set of states reachable from {M} on input i+; if ({P} is the empty set) then+; do nothing+; else+; {N} = eps-union({P})+; if ({N} already exists as a DFA state) then+; do nothing+; else+; add {N} to work queue/stack+; end if+; add a transition from {M} to {N} labeled i+; end if+; end do+; end while++(define (regexp-make-dfa nfa)+ (let ((counter 0)+ (dfa-states '())+ (agenda '()))+ #f))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+; NFA walker++; This makes a single transition from any one of the input states STS,+; given the character CH++(define (make-transition nfa sts ch)+ (letrec ((find-transitions+ (lambda (s ss)+ (cond ((null? ss) (raise "programming error! state not in nfa!"))+ ((= s (caar ss)) (cddar ss))+ (else (find-transitions s (cdr ss))))))+ (p-trans (lambda (acc trans)+ (if (memv ch (cdr trans))+ (bitset-add acc (car trans))+ acc)))+ (eps-union (find-eps-union sts nfa))+ (new-sts (bitset-new)))+; make all possible transitions to new states from this eps-union+; TODO: this is a foldl, too... make it so -- maybe need a bitset-foldl++; unholy mix of scheme and quasi-haskell syntax, and some details are+; wrong... but something vaguely like this is what I think I want++; (bitset-foldl (bitset-or . (find-transitions s nfa)) (bitset-new) eps-union)++ (bitset-foreach eps-union+ (lambda (s)+ (set! new-sts+ (bitset-or new-sts+ (foldl p-trans (bitset-new)+ (find-transitions s nfa))))))+ new-sts))++; Make a series of transitions++(define (make-transitions nfa init-state str . match-states)+ (letrec* ((chars (string->char str))+ (matches (foldl bitset-add (bitset-new) match-states))+ (no-matches? (null? match-states))+ (last-accept '())+ (last-accept-state 0)+ (mk-ret (lambda (a s)+ (let ((mr1 (lambda (a s)+ (list (char->string (reverse a)) s))))+ (if no-matches?+ (mr1 a s)+ (mr1 last-accept last-accept-state)))))+ (doit (lambda (sts chs acc)+ (if (null? chs)+ (mk-ret acc sts)+ (let* ((new-st (make-transition nfa sts (car chs)))+ (nsu (find-eps-union new-st nfa)))+ (if (bitset-empty? new-st)+ (mk-ret acc sts)+ (begin (set! acc (cons (car chs) acc))+ (unless (bitset-empty?+ (bitset-and matches nsu))+ (set! last-accept acc)+ (set! last-accept-state nsu))+ (doit new-st (cdr chs) acc)))))))+ (result (doit (bitset-add (bitset-new) init-state) chars '()))+ (final-state (find-eps-union (cadr result) nfa)))+ (if no-matches?+ (cons #t result)+ (begin (set! matches (bitset-and matches last-accept-state))+ (if (bitset-empty? matches)+ (list #f)+ (list #t (car result) matches))))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+; Some simple regexps to try out: note that all the escaped characters+; are double-escaped: to get a literal '+' into the regexp parser, we+; need to get it (a) past the REPL's escape mechanism, then (b) escape+; it for the regexp parser. Hence all the '\\+'++; unsigned and signed integers: very simple++(define unsigned-integer "[0-9]+")+(define signed-integer "(\\+|-)?[0-9]+")++; an unsigned decimal number: xxx.yyy, where both xxx and yyy can+; represent any number of digits including none, except that they+; can't both be empty simultaneously. allow plain unsigned integers,+; don't require a decimal point++(define unsigned-decimal+ "(([0-9]+(.[0-9]*)?)|([0-9]*.[0-9]+))")++; same as above, with an optional sign out front++(define signed-decimal+ (string-join-by "" "(\\+|-)?" unsigned-decimal))++; same as above, with an optional scientific-notation trailer++(define signed-scientific+ (string-join-by "" signed-decimal "((e|E)(\\+|-)?[0-9]+)?"))++; same in base-2, for simplicity++(define unsigned-integer2 "[0-1]+")+(define signed-integer2 "(\\+|-)?[0-1]+")+(define unsigned-decimal2+ "(([0-1]+.[0-1]*)|([0-1]*.[0-1]+))")+(define signed-decimal2+ (string-join-by "" "(\\+|-)?" unsigned-decimal2))+(define signed-scientific2+ (string-join-by "" signed-decimal2 "((e|E)(\\+|-)?[0-1]+)?"))++; Possible variable names for a C-like language... this runs very fast+; (for some value of "very"...)++(define var-or-keyword "([A-Z]|[a-z]|_)([a-z]|[A-Z]|[0-9]|_)*")++; These two are for conveniently building "killer" regexps which will+; cause backtracking NFA implementations (such as in perl, python, and+; many other scripting languages) to run exponentially slowly. We do+; better than that... although the constant out front is kinda bad :-)++(define (make-slow-string n)+ (string-join-by "" (replicate "a" n)))++(define (make-slow-regexp n)+ (string-join-by "" (append (replicate "a?" n) (replicate "a" n))))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+; debugging stuff++(define (show-eps cur)+ (if (number? cur)+ (let ((start #\<))+ (if (bitset-empty? cur)+ (write-string start)+ (bitset-foreach cur (lambda (j)+ (write-string start)+ (set! start #\space)+ (write-string (number->string j)))))+ (write-string ">"))+ (display cur)))++(define (tab) (write-string #\tab))+(define (space) (write-string #\space))++(define (show-state s)+ (write-string "state = ")+ (display (car s))+ (unless (null? (cadr s))+ (write-string "\teps ")+ (show-eps (cadr s)))+ (unless (null? (cddr s))+ (write-string " regular ")+ (map (lambda (x) (display x) (space)) (cddr s)))+ (newline))++(define (show-states s)+ (write-string "states = \n")+ (map (lambda (st) (show-state st)) s)+ #t)
selftest.scm view
@@ -15,7 +15,7 @@ ; along with haskeem; if not, write to the Free Software ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -; $Id: selftest.scm,v 1.38 2009-05-30 04:52:00 uwe Exp $+; $Id: selftest.scm,v 1.42 2009-06-20 03:09:42 uwe Exp $ (define start (epochtime)) @@ -25,14 +25,17 @@ (set! verbose? #t) (set! args (cdr args))) -(write-string "Some simple self-tests for haskeem" #\linefeed #\linefeed)+(write-string "Some simple self-tests for haskeem\n\n") -; first define the function to run the tests, plus counters+; First define the functions to run the tests, plus counters (define n-tests 0) (define n-fails 0)+(define n-excepts 0) -; this was originally named assert, but R6RS claims that as a syntactic form+; These (chk-*) functions could all be rewritten as macros, which would+; make them cleaner in some respects... but they were written long before+; macros appeared in haskeem. C'est la vie. (define (chk-closeto cmp expect expr) (set! n-tests (+ n-tests 1))@@ -83,9 +86,17 @@ (define (chk-query expect expr) (chk-closeto maybe expect expr)) +(defmacro (catch-exceptions body)+ `(guard (err+ (else (write-string "caught exception ")+ (display err)+ (newline)+ (set! n-excepts (+ 1 n-excepts))))+ ,body))+ ; test the chk-run function itself: this should fail -(write-string "checking chk-run... expect a failure message here\n")+(write-string "checking chk-run and catch-exceptions... expect failure messages here\n") (chk-run #f '1) (if (zero? n-fails) (begin (write-string "uh-oh! chk-run didn't record failure,"@@ -94,6 +105,14 @@ (begin (write-string "ok, zeroing out n-fails so this" " won't be recorded as a failure\n\n") (set! n-fails 0)))+(catch-exceptions (raise "exception test"))+(if (zero? n-excepts)+ (begin (write-string "uh-oh! catch-exceptions didn't record exception,"+ " better check that!\n\n")+ (set! n-excepts 1))+ (begin (write-string "ok, zeroing out n-excepts so this"+ " won't be recorded as an exception\n\n")+ (set! n-excepts 0))) ; now do real tests @@ -303,6 +322,9 @@ (define m3 (curry * 3)) (define m3p3 (compose m3 p3)) +(chk-run '(a a a a a a a a a a) '(stream-head (cycle '(a)) 10))+(chk-run '(a b c a b c a b c a) '(stream-head (cycle '(a b c)) 10))+ (chk-run 3 '(p3)) (chk-run 5 '(p3 2)) (chk-run 10 '(p3 2 5))@@ -946,6 +968,8 @@ (chk-run '((1 2) (7 9 3 4 4 6 -1 8 11 -24)) '(list-take-while (lambda (v) (< v 5)) lst)) +(chk-run '(1 2 3 2 1) '(list-remove-dups '(1 2 2 3 3 2 2 2 2 2 1 1)))+ (chk-run '("it" "works" "he" "said" "in" "a" "small" "quiet" "voice") '(string-split-by (lambda (c) (not (char-alphabetic? c))) "it works, he said, in a small quiet voice"))@@ -2191,8 +2215,120 @@ (set! promise-target 10) (chk-run 5 '(force promise)) -; summarize these results+; define and test some macros +; 3-way numeric if macro -- depending on whether test-value is negative,+; zero, or positive, evaluate one of three forms and return its value.+; It's /not/ kosher to evaluate all three and only return the correct one.++(begin+; This tests how many times everything gets evaluated+ (define probe 0)++; This is what actually gets tested... the wrapper below is just to+; diddle the value of probe++ (define test-val -1)++ (define n-action (lambda () (set! probe (+ probe 1)) "negative!"))+ (define z-action (lambda () (set! probe (+ probe 10)) "zero!"))+ (define p-action (lambda () (set! probe (+ probe 100)) "positive!"))++; The value returned from this determines which of the three branches is chosen+ (define test-value (lambda () (set! probe (+ probe 1000)) test-val))++ (defmacro (test-numeric-if tval ifn ifz ifp)+ (let ((nit (new-symbol)))+ `(let ((,nit ,tval))+ (if (number? ,nit)+ (if (negative? ,nit)+ ,ifn+ (if (positive? ,nit)+ ,ifp+ ,ifz))))))++ (set! probe 0)+ (set! test-val -1)+ (chk-run "negative!"+ '(test-numeric-if (test-value) (n-action) (z-action) (p-action)))+ (chk-run 1001 probe)++ (set! probe 0)+ (set! test-val 0)+ (chk-run "zero!"+ '(test-numeric-if (test-value) (n-action) (z-action) (p-action)))+ (chk-run 1010 probe)++ (set! probe 0)+ (set! test-val 1)+ (chk-run "positive!"+ '(test-numeric-if (test-value) (n-action) (z-action) (p-action)))+ (chk-run 1100 probe))++(define i 0)+(define j 0)+(define ret '())+(chk-run 10 '(while (< i 10) (set! i (+ i 1)) (set! ret (cons i ret))))+(chk-run '(10 9 8 7 6 5 4 3 2 1) 'ret)++(set! i 0)+(set! ret '())+(while (< i 4)+ (set! j 0)+ (while (< j 4)+ (set! j (+ j 1))+ (set! ret (cons (cons i j) ret)))+ (set! i (+ i 1)))++; Note we increment j before accumulating into ret, but we+; increment i after; thus the dotted-pairs aren't symmetric++(chk-run '((3 . 4) (3 . 3) (3 . 2) (3 . 1)+ (2 . 4) (2 . 3) (2 . 2) (2 . 1)+ (1 . 4) (1 . 3) (1 . 2) (1 . 1)+ (0 . 4) (0 . 3) (0 . 2) (0 . 1)) 'ret)++(set! i 0)+(chk-run 1 '(do-while #f (set! i (+ i 1))))+(chk-run 1 'i)++(set! i 3)+(chk-run 8 '(until (> i 10) (set! i (+ i 1))))+(chk-run 11 'i)++(set! i 20)+(chk-run 1 '(do-until (> i 10) (set! i (+ i 1))))+(chk-run 21 'i)++; A "swap" macro++(begin+ (defmacro (test-swap var1 var2)+ (let ((vs (new-symbol)))+ `(let ((,vs ,var1))+ (set! ,var1 ,var2)+ (set! ,var2 ,vs))))++ (define val1 0)+ (define val2 1)+ (chk-run #t '(and (eqv? val1 0) (eqv? val2 1)))+ (test-swap val1 val2)+ (chk-run #t '(and (eqv? val1 1) (eqv? val2 0)))+ (test-swap val1 val2)+ (chk-run #t '(and (eqv? val1 0) (eqv? val2 1))))++; A "let" macro... tests are exactly the same as for the actual "let" above++(begin+ (defmacro (test-let bindings . body)+ `((lambda ,(map car bindings) ,@body) ,@(map cadr bindings)))+ (chk-run 42 '(test-let ((x 23)) (set! x 42) x))+ (chk-run 35 '(test-let ((x 2) (y 3))+ (test-let ((x 7) (z (+ x y)))+ (* z x)))))++; Summarize these results+ (write-string "\ntotal tests run: " (number->string n-tests) "\ntests failed: "@@ -2206,12 +2342,13 @@ "re-run the test in verbose mode by adding '-v' to the command line,\n" "you will have a chance to verify whether they are reasonable.\n\n") -(chk-query "your home directory" '(get-environment "HOME"))-(chk-query "the current local time" '(localtime))-(chk-query "the current local time" '(localtime (epochtime)))-(chk-query "the current UTC time" '(UTCtime))-(chk-query "the current UTC time" '(UTCtime (epochtime)))-(chk-query "current directory" '(get-current-directory))+(catch-exceptions (chk-query "your home directory" '(get-environment "HOME")))+(catch-exceptions (chk-query "the current local time" '(localtime)))+(catch-exceptions+ (chk-query "the current local time" '(localtime (epochtime))))+(catch-exceptions (chk-query "the current UTC time" '(UTCtime)))+(catch-exceptions (chk-query "the current UTC time" '(UTCtime (epochtime))))+(catch-exceptions (chk-query "current directory" '(get-current-directory))) ; these need to be global because apparently eval isn't picking them ; up if I define them via let inside do-dir-tests... which is right@@ -2230,30 +2367,39 @@ (define (ssort lst) (list-sort string<? lst)) (define (do-dir-tests)- (chk-run #f '(directory-exists? test-dir1))- (chk-run #t '(create-directory test-dir1))- (chk-run #t '(create-directory test-dir2))- (chk-run (ssort '("." ".." "subdir")) '(ssort (read-directory test-dir1)))- (chk-run #t '(remove-directory test-dir2))- (chk-run #f '(file-exists? test-file1))+ (write-string+ " Some of the tests involving directory and file creation\n"+ " and removal may fail if run on an NFS-mounted filesystem.\n"+ " If you see weird files like '.nfs000000000029a82600000001'\n"+ " and an exception while removing the test directory, that\n"+ " is the likely cause. Don't Panic!\n")+ (catch-exceptions (chk-run #f '(directory-exists? test-dir1)))+ (catch-exceptions (chk-run #t '(create-directory test-dir1)))+ (catch-exceptions (chk-run #t '(create-directory test-dir2)))+ (catch-exceptions+ (chk-run (ssort '("." ".." "subdir")) '(ssort (read-directory test-dir1))))+ (catch-exceptions (chk-run #t '(remove-directory test-dir2)))+ (catch-exceptions (chk-run #f '(file-exists? test-file1))) (set! port (open-output-file test-file1))- (chk-run #t '(file-exists? test-file1))+ (catch-exceptions (chk-run #t '(file-exists? test-file1))) (write-string port line1 #\linefeed) (close-port port)- (chk-run #t '(rename-file test-file1 test-file2))- (chk-run (ssort '("." ".." "testfile2")) '(ssort (read-directory test-dir1)))- (chk-run #f '(file-exists? test-file1))- (chk-run #t '(file-exists? test-file2))+ (catch-exceptions (chk-run #t '(rename-file test-file1 test-file2)))+ (catch-exceptions (chk-run (ssort '("." ".." "testfile2"))+ '(ssort (read-directory test-dir1))))+ (catch-exceptions (chk-run #f '(file-exists? test-file1)))+ (catch-exceptions (chk-run #t '(file-exists? test-file2))) (set! port (open-input-file test-file2)) (set! line2 (read-line port))- (chk-run #t '(string=? line1 line2))- (chk-run #t '(remove-file test-file2))- (chk-run #f '(file-exists? test-file2))- (chk-run (ssort '("." "..")) '(ssort (read-directory test-dir1)))- (chk-run #t '(set-current-directory test-dir1))- (chk-query "test directory" '(get-current-directory))- (chk-run #t '(set-current-directory ".."))- (chk-run #t '(remove-directory test-dir1)))+ (catch-exceptions (chk-run #t '(string=? line1 line2)))+ (catch-exceptions (chk-run #t '(remove-file test-file2)))+ (catch-exceptions (chk-run #f '(file-exists? test-file2)))+ (catch-exceptions (chk-run (ssort '("." ".."))+ '(ssort (read-directory test-dir1))))+ (catch-exceptions (chk-run #t '(set-current-directory test-dir1)))+ (catch-exceptions (chk-query "test directory" '(get-current-directory)))+ (catch-exceptions (chk-run #t '(set-current-directory "..")))+ (catch-exceptions (chk-run #t '(remove-directory test-dir1)))) (if (directory-exists? test-dir1) (write-string "\nSkipping file and directory I/O tests,\n"@@ -2496,6 +2642,33 @@ (chk-run "9.990020930143845079440327643300335909804291390541816917715293e30102" '(number->string (expt 2 100000) 10 -60)) +; check a couple of bit manipulations++(chk-run 1 '(bits-shift 1 0))+(chk-run 2 '(bits-shift 1 1))+(chk-run 4 '(bits-shift 1 2))+(chk-run 8 '(bits-shift 1 3))+(chk-run 65536 '(bits-shift 1 16))+(chk-run (expt 2 128) '(bits-shift 1 128))+(chk-run (expt 2 1000) '(bits-shift 1 1000))+(chk-run 32768 '(bits-shift 65536 -1))+(chk-run 16384 '(bits-shift 65536 -2))+(chk-run 2 '(bits-shift 65536 -15))+(chk-run 1 '(bits-shift 65536 -16))+(chk-run #b111000 '(bits-and #b111111000 #b111111))+(chk-run #b111111111 '(bits-or #b111111000 #b111111))+(chk-run #b111000111 '(bits-xor #b111111000 #b111111))+(chk-run #b111010111 '(bits-set #b111000111 4))+(chk-run #b111010111 '(bits-set #b111010111 4))+(chk-run #b111000111 '(bits-clear #b111000111 4))+(chk-run #b111000111 '(bits-clear #b111010111 4))+(chk-run #b111010111 '(bits-flip #b111000111 4))+(chk-run #b111000111 '(bits-flip #b111010111 4))+(chk-run 0 '(bits-get #b111000111 4))+(chk-run 16 '(bits-get #b111010111 4))+(chk-run #f '(bits-set? #b111000111 4))+(chk-run #t '(bits-set? #b111010111 4))+ (chk-run '#(a b c 1 2 3) '(list->vector '(a b c 1 2 3))) (chk-run '(a b c 1 2 3) '(vector->list '#(a b c 1 2 3))) (chk-run '#(a b c 1 2 3) '(vector 'a 'b 'c 1 2 3))@@ -2625,6 +2798,8 @@ (number->string n-tests) "\ntests failed:\t\t" (number->string n-fails)+ "\nexceptions caught:\t"+ (number->string n-excepts) "\ntotal CPU time:\t\t" (number->string (cputime) 10 3) " seconds\n"
+ set.scm view
@@ -0,0 +1,192 @@+; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>+; $Id: set.scm,v 1.8 2009-06-26 05:22:27 uwe Exp $+; BSD3++; This could all go into stdlib?++; set operations:+; is a given element in a set?+; add an element to a set+; remove an element from a set+; find the union of two sets+; find the intersection of two sets+; a set is a list of elements, not necessarily sorted+; specialized versions "set" -> "intset" where we assert that the+; elements are integers, so that the list is simply sortable -> faster+; more specialized versions "set" -> "bitset", where each set is simply+; a single infinite-precision integer, and we just flip bits; that means+; that the individual elements again have to be integers++; Create a new empty set++(define (set-new) '())+(define (intset-new) '())+(define (bitset-new) 0)++; Test if el is in set++(define (set-member? set el)+ (cond ((null? set) #f)+ ((eqv? el (car set)) #t)+ (else (set-member? (cdr set) el))))++(define (intset-member? set el)+ (cond ((null? set) #f)+ ((< el (car set)) #f)+ ((eqv? el (car set)) #t)+ (else (intset-member? (cdr set) el))))++(define (bitset-member? set el) (bits-set? set el))++; Test if a set is empty++(define (set-empty? set) (null? set))++(define intset-empty? set-empty?)++(define bitset-empty? zero?)++; Return a new set containing el++(define (set-add set el)+ (if (set-member? set el) set (cons el set)))++(define (intset-add set el)+ (unless (integer? el)+ (raise "non-integer input to intset-add"))+ (if (intset-member? set el) set (list-sort < (cons el set))))++(define (bitset-add set el)+ (bits-set set el))++; Return a new set not containing el++(define (set-remove set el)+ (filter (lambda (x) (not (eqv? x el))) set))++(define intset-remove set-remove)++(define (bitset-remove set el)+ (bits-clear set el))++; Return a new set without duplications++(define (set-remove-dups set)+ (letrec ((srd (lambda (s a)+ (if (null? s)+ (reverse a)+ (srd (filter (lambda (x) (not (eqv? x (car s))))+ (cdr s))+ (cons (car s) a))))))+ (srd set '())))++(define (intset-remove-dups set)+ (letrec ((srd (lambda (l a)+ (if (null? l)+ (reverse a)+ (srd (list-drop-while (lambda (x) (eqv? x (car l)))+ (cdr l))+ (cons (car l) a))))))+ (srd (list-sort < set) '())))++; D'oh!++(define (bitset-remove-dups set) set)++; Return the OR of two sets++; Really the set-remove-dups aren't needed, just append would be good enough,+; but this keeps the set smaller. Doing individual set-remove-dups before+; appending would be better if the sets are not already dup-free.++(define (set-or s1 s2) (set-remove-dups (append s1 s2)))++; For the integer versions of the various logical operations, list+; merges with the appropriate selectors work very well++(define (intset-or s1 s2)+ (cond ((intset-empty? s2) s1)+ ((intset-empty? s1) s2)+ ((< (car s1) (car s2)) (cons (car s1) (intset-or (cdr s1) s2)))+ ((> (car s1) (car s2)) (cons (car s2) (intset-or s1 (cdr s2))))+ (else (cons (car s1) (intset-or (cdr s1) (cdr s2))))))++(define (bitset-or s1 s2) (bits-or s1 s2))++; Return those elements of s1 that are not also in s2++(define (set-andnot s1 s2)+ (if (null? s2)+ s1+ (set-andnot (set-remove s1 (car s2)) (cdr s2))))++(define (intset-andnot s1 s2)+ (cond ((intset-empty? s2) s1)+ ((intset-empty? s1) '())+ ((< (car s1) (car s2)) (cons (car s1) (intset-andnot (cdr s1) s2)))+ ((> (car s1) (car s2)) (intset-andnot s1 (cdr s2)))+ (else (intset-andnot (cdr s1) (cdr s2)))))++(define (bitset-andnot s1 s2)+ (- s1 (bits-and s1 s2)))++; Return those elements which are in one or the other but not both sets++(define (set-xor s1 s2)+ (set-or (set-andnot s1 s2)+ (set-andnot s2 s1)))++(define (intset-xor s1 s2)+ (cond ((intset-empty? s2) s1)+ ((intset-empty? s1) s2)+ ((< (car s1) (car s2)) (cons (car s1) (intset-xor (cdr s1) s2)))+ ((> (car s1) (car s2)) (cons (car s2) (intset-xor s1 (cdr s2))))+ (else (intset-xor (cdr s1) (cdr s2)))))++(define (bitset-xor s1 s2) (bits-xor s1 s2))++; Return the intersection of two sets: those elements that are in both sets++(define (set-and s1 s2)+ (set-andnot (set-or s1 s2) (set-xor s1 s2)))++(define (intset-and s1 s2)+ (cond ((or (intset-empty? s1) (intset-empty? s2)) '())+ ((< (car s1) (car s2)) (intset-and (cdr s1) s2))+ ((> (car s1) (car s2)) (intset-and s1 (cdr s2)))+ (else (cons (car s1) (intset-and (cdr s1) (cdr s2))))))++(define (bitset-and s1 s2) (bits-and s1 s2))++; Check if two sets are equal++(define (set-equal? s1 s2) (set-empty? (set-xor s1 s2)))++(define (intset-equal? s1 s2)+ (cond ((and (intset-empty? s1) (intset-empty? s2)) #t)+ ((or (intset-empty? s1) (intset-empty? s2)) #f)+ ((= (car s1) (car s2)) (intset-equal? (cdr s1) (cdr s2)))+ (else #f)))++(define (bitset-equal? s1 s2) (= s1 s2))++; Given a bit-set, return a list of its members in an unspecified order+; (which happens to be descending order)++(define (bitset->list set)+ (letrec ((loop (lambda (s c l)+ (cond ((zero? s) l)+ ((even? s) (loop (bits-shift s -1) (+ c 1) l))+ (else (loop (bits-shift s -1) (+ c 1) (cons c l)))))))+ (loop set 0 '())))++; Apply a function to each member of a set++(define (set-foreach set fn)+ (map fn set))++(define (intset-foreach set fn)+ (map fn set))++(define (bitset-foreach set fn)+ (map fn (bitset->list set)))
stdlib.scm view
@@ -19,7 +19,7 @@ ; along with haskeem; if not, write to the Free Software ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -; $Id: stdlib.scm,v 1.34 2009-06-04 06:20:58 uwe Exp $+; $Id: stdlib.scm,v 1.39 2009-06-20 03:09:42 uwe Exp $ ; The haskeem standard library @@ -73,11 +73,6 @@ (define (force x) (force x)) -; TODO: this should be a syntactic form, so that it can print out not just-; "assertion failure!" but what the expression was that failed--(define (assert x) (if x x (raise "assertion failure!")))- (define (append lst . lsts) (foldl (lambda (l1 l2) (foldr cons l2 l1)) lst lsts)) @@ -118,6 +113,13 @@ (define fcdr (compose force cdr)) +(define (cycle lst)+ (letrec ((next (lambda (cur)+ (if (null? cur)+ (next lst)+ (cons (car cur) (delay (next (cdr cur))))))))+ (next lst)))+ (define (unzip lst) (letrec* ((cars '())@@ -201,7 +203,9 @@ (define (assv obj lst) (assp (lambda (x) (eqv? x obj)) lst)) -; merge-sort "lst" using comparison function "cmp"+; merge-sort "lst" using comparison function "is-lt?" which when+; called as (is-lt? a b) returns #t if a is less than b, ie, should+; come ahead of b in the sorted list. ; this is a stable sort as required by R6RS (define (list-sort is-lt? lst)@@ -235,6 +239,17 @@ (list (reverse a) l))))) (tw lst '()))) +; Remove adjacent duplicates in a list: '(1 2 2 3 2 2 1 1) -> '(1 2 3 2 1)++(define (list-remove-dups lst)+ (letrec ((lrd (lambda (l a)+ (if (null? l)+ (reverse a)+ (lrd (list-drop-while (lambda (x) (eqv? x (car l)))+ (cdr l))+ (cons (car l) a))))))+ (lrd lst '())))+ (define (find proc lst) (cond ((null? lst) #f) ((proc (car lst)) (car lst))@@ -442,6 +457,61 @@ (if (zero? (length port)) (write-string #\linefeed) (write-string (car port) #\linefeed)))++(defmacro (assert some-cond)+ `(when (not ,some-cond)+ (write-string stderr "assertion failure: ")+ (display ',some-cond stderr)+ (newline stderr)+ (raise "assertion failure!")))++(defmacro (when pred . actions) `(if ,pred (begin ,@actions)))+(defmacro (unless pred . actions) `(if (not ,pred) (begin ,@actions)))++; These take zero or more trips through the loop++(defmacro (while some-cond . some-actions)+ (let ((mc (new-symbol)))+ `(do ((,mc 0 (+ ,mc 1)))+ ((not ,some-cond) ,mc)+ ,@some-actions)))++(defmacro (until some-cond . some-actions)+ (let ((mc (new-symbol)))+ `(do ((,mc 0 (+ ,mc 1)))+ (,some-cond ,mc)+ ,@some-actions)))++; These take at least one trip through the loop++(defmacro (do-while some-cond . some-actions)+ (let ((mc (new-symbol)))+ `(do ((,mc 0 (+ ,mc 1)))+ ((and (positive? ,mc) (not ,some-cond)) ,mc)+ ,@some-actions)))++(defmacro (do-until some-cond . some-actions)+ (let ((mc (new-symbol)))+ `(do ((,mc 0 (+ ,mc 1)))+ ((and (positive? ,mc) ,some-cond) ,mc)+ ,@some-actions)))++; Load a file, looking in a pre-specified list of directories++(defmacro (load-library fname)+ (letrec* ((paths (string-split-by (lambda (c) (eqv? c #\:))+ (get-environment "HASKEEM_LIBRARY_PATH")))+ (find (lambda (ps)+ (if (null? ps)+ #f+ (let ((fp (string-join-by "/" (car ps) fname)))+ (if (file-exists? fp)+ fp+ (find (cdr ps)))))))+ (filepath (find paths)))+ (if filepath+ `(load ,filepath)+ `(write-string "unable to find file '" ,fname "'\n")))) ; if desired, this can be enabled; that's a nice confirmation in the REPL ; that everything is ok