diff --git a/Environment.hs b/Environment.hs --- a/Environment.hs +++ b/Environment.hs @@ -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))) diff --git a/Evaluator.hs b/Evaluator.hs --- a/Evaluator.hs +++ b/Evaluator.hs @@ -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) diff --git a/Library.hs b/Library.hs --- a/Library.hs +++ b/Library.hs @@ -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 "" "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 diff --git a/LispData.hs b/LispData.hs --- a/LispData.hs +++ b/LispData.hs @@ -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 _) = "" -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 = _}) = - " "" - Just arg -> " . " ++ arg) ++ ") ...>" +showVal (Func {params = args, vararg = varargs, body = bd, + closure = _, name = nm, macro = ismac}) = + let lopen = 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 _) = "" showVal (Port _) = "" showVal (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 = _}) = - "" ++ (show o) +showVal (Delay {obj = o, closure = _, tag = _}) = "" ++ (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 diff --git a/Parser.hs b/Parser.hs --- a/Parser.hs +++ b/Parser.hs @@ -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 diff --git a/gendoc.scm b/gendoc.scm --- a/gendoc.scm +++ b/gendoc.scm @@ -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") diff --git a/haskeem.cabal b/haskeem.cabal --- a/haskeem.cabal +++ b/haskeem.cabal @@ -1,11 +1,11 @@ Name: haskeem -Version: 0.7.0 +Version: 0.7.4 Author: Uwe Hollerbach Maintainer: Uwe Hollerbach 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. diff --git a/haskeem.doc b/haskeem.doc --- a/haskeem.doc +++ b/haskeem.doc @@ -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)) diff --git a/haskeem.hs b/haskeem.hs --- a/haskeem.hs +++ b/haskeem.hs @@ -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 diff --git a/haskeem_readline.hs b/haskeem_readline.hs --- a/haskeem_readline.hs +++ b/haskeem_readline.hs @@ -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 diff --git a/macro-test.scm b/macro-test.scm --- a/macro-test.scm +++ b/macro-test.scm @@ -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") diff --git a/regexp.scm b/regexp.scm new file mode 100644 --- /dev/null +++ b/regexp.scm @@ -0,0 +1,552 @@ +; Copyright 2009 Uwe Hollerbach +; $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) diff --git a/selftest.scm b/selftest.scm --- a/selftest.scm +++ b/selftest.scm @@ -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 stringstring (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" diff --git a/set.scm b/set.scm new file mode 100644 --- /dev/null +++ b/set.scm @@ -0,0 +1,192 @@ +; Copyright 2009 Uwe Hollerbach +; $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))) diff --git a/stdlib.scm b/stdlib.scm --- a/stdlib.scm +++ b/stdlib.scm @@ -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