haskeem 0.7.5 → 0.7.7
raw patch · 12 files changed
+363/−203 lines, 12 files
Files
- Evaluator.hs +83/−117
- Library.hs +66/−15
- cpm.scm +17/−2
- haskeem.cabal +1/−1
- haskeem.doc +8/−7
- haskeem.hs +2/−2
- haskeem_readline.hs +1/−1
- heap.scm +2/−2
- macro-test.scm +3/−3
- regexp.scm +33/−26
- selftest.scm +98/−22
- stdlib.scm +49/−5
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.32 2009-06-29 03:59:13 uwe Exp $ -}+$Id: evaluator.hs,v 1.35 2009-07-04 07:47:22 uwe Exp $ -} module Evaluator (evalLisp) where import Prelude@@ -45,9 +45,12 @@ progError = error "internal error!" -lastOrNil = liftM lON- where lON [] = List []- lON l = last l+{-# INLINE mapML #-}+mapML fn lst = mapMLA (List []) fn lst+ where mapMLA r _ [] = return r+ mapMLA ro fn (x:xs) =+ do rn <- fn x+ mapMLA rn fn xs isTrue :: LispVal -> Bool isTrue (Boolean False) = False@@ -108,7 +111,7 @@ bindVarArgs varargs >>= evalBody where remainingArgs = drop (length params) args num = toInteger . length- evalBody env = lastOrNil (mapM (evalLisp env ql) body)+ evalBody env = mapML (evalLisp env ql) body bindVarArgs arg env = case arg of Just argName ->@@ -139,40 +142,40 @@ makeNormalMacro = makeMacro Nothing makeVarargsMacro = makeMacro . Just . show -isSpecialForm :: LispVal -> Bool-isSpecialForm (Symbol "and") = True-isSpecialForm (Symbol "apply") = True-isSpecialForm (Symbol "begin") = True-isSpecialForm (Symbol "case") = True-isSpecialForm (Symbol "cond") = True-isSpecialForm (Symbol "define") = True-isSpecialForm (Symbol "defmacro") = True-isSpecialForm (Symbol "delay") = True-isSpecialForm (Symbol "do") = True-isSpecialForm (Symbol "eval") = True-isSpecialForm (Symbol "force") = True-isSpecialForm (Symbol "guard") = True-isSpecialForm (Symbol "if") = True-isSpecialForm (Symbol "lambda") = True-isSpecialForm (Symbol "let") = True-isSpecialForm (Symbol "let*") = True-isSpecialForm (Symbol "letrec") = True-isSpecialForm (Symbol "letrec*") = True-isSpecialForm (Symbol "load") = True-isSpecialForm (Symbol "new-symbol") = True-isSpecialForm (Symbol "or") = True-isSpecialForm (Symbol "quasiquote") = True-isSpecialForm (Symbol "quote") = True-isSpecialForm (Symbol "set!") = True-isSpecialForm (Symbol "unquote") = True-isSpecialForm (Symbol "unquote-splicing") = True-isSpecialForm (Symbol "vector-fill!") = True-isSpecialForm (Symbol "vector-set!") = True+specialForms = ["and", "apply", "begin", "case", "cond", "define",+ "defmacro", "delay", "do", "eval", "force", "gensym",+ "guard", "if", "lambda", "let", "let*", "letrec",+ "letrec*", "load", "or", "quasiquote", "quote", "set!",+ "unquote", "unquote-splicing", "vector-fill!",+ "vector-set!", "trace", "dump-bindings"] -isSpecialForm (Symbol "trace") = True-isSpecialForm (Symbol "dump-bindings") = True+isSpecialForm (Symbol s) = seek s specialForms+ where seek _ [] = False+ seek s (sf:sfs) = if s == sf then True else seek s sfs isSpecialForm _ = False +isInt (IntNumber _) = True+isInt _ = False+getInt (IntNumber n) = n++isStr (String _) = True+isStr _ = False+getStr (String s) = s++isList (List _) = True+isList _ = False+getList (List l) = l++isDL (DottedList _ _) = True+isDL _ = False+getDLh (DottedList h _) = h+getDLt (DottedList _ t) = t++isVec (Vector _ _) = True+isVec _ = False+getVecL (Vector l _) = l+getVecV (Vector _ v) = v+ -- This is an internal symbol which temporarily replaces "unquote" and -- "unquote-splicing" after these have evaluated the expression(s): evalQQ -- looks for this marker and lifts the remainder of the list up by one@@ -230,15 +233,15 @@ evalQQ env ql (List (Symbol "unquote-splicing" : args)) = if ql == 1 then do vals <- mapM (evalLisp env 0) args- if isList vals+ if isLL vals then return (List ((Symbol unq):(peel vals))) else throwError (Default ("bad unquote-splicing form: " ++ (show args))) else do vals <- mapM (evalQQ env (ql - 1)) args return (List ((Symbol "unquote-splicing") : (liftLUnq vals)))- where isList [] = True- isList ((List _):ls) = isList ls- isList _ = False+ where isLL [] = True+ isLL ((List _):ls) = isLL ls+ isLL _ = False peel [] = [] peel ((List l):ls) = l ++ (peel ls) @@ -251,18 +254,11 @@ do vals <- mapM (evalQQ env ql) con vcab <- evalQQ env ql cab >>= liftSUnq let head = liftLUnq vals- if isl vcab- then return (List (head ++ (unpl vcab)))- else if isdl vcab- then return (DottedList (head ++ (unpdlh vcab)) (unpdlt vcab))+ if isList vcab+ then return (List (head ++ (getList vcab)))+ else if isDL vcab+ then return (DottedList (head ++ (getDLh vcab)) (getDLt vcab)) else return (DottedList head vcab)- where isl (List _) = True- isl _ = False- unpl (List l) = l- isdl (DottedList _ _) = True- isdl _ = False- unpdlh (DottedList h _) = h- unpdlt (DottedList _ t) = t evalQQ env ql (Vector _ con) = do vals <- mapM (evalQQ env ql) (remkey (DIM.toAscList con))@@ -319,8 +315,7 @@ -- the (or a) top-level environment. evalLisp env ql (List (Symbol "eval" : args)) =- do argVals <- mapM (evalLisp env ql) args- lastOrNil (mapM (evalLisp env ql) argVals)+ mapM (evalLisp env ql) args >>= mapML (evalLisp env ql) -- TODO: This is also not a special form according to R6RS; I think I -- could also make it a regular function, but it has the same issues@@ -330,19 +325,16 @@ -- function and modify the environment seen within that function. evalLisp env ql (List [Symbol "load", String filename]) =- loadFile filename >>= lastOrNil . mapM (evalLisp env ql)+ loadFile filename >>= mapML (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)+ then loadFile (getStr fname) >>= mapML (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)+ mapML (evalLisp env ql) args evalLisp _ _ (List [Symbol "quote", val]) = return val @@ -362,61 +354,44 @@ do vec <- evalLisp env ql (Symbol var) if isVec vec then do lk <- evalLisp env ql indx- let l = getL vec- k = getI lk- if ((isI lk) && k >= 0 && k < l)+ let l = getVecL vec+ k = getInt lk+ if ((isInt lk) && k >= 0 && k < l) then do val <- evalLisp env ql obj setVar env var (Vector l- (DIM.insert (fromInteger k) val (getV vec)))+ (DIM.insert (fromInteger k) val (getVecV vec))) else throwError (VectorBounds l lk) else throwError (Default ("bad vector-set! form: " ++ (show var) ++ " is not a vector"))- where isVec (Vector _ _) = True- isVec _ = False- isI (IntNumber _) = True- isI _ = False- getI (IntNumber n) = n- getL (Vector l _) = l- getV (Vector _ v) = v evalLisp env ql (List [Symbol "vector-fill!", Symbol var, obj]) = do vec <- evalLisp env ql (Symbol var) if isVec vec then do val <- evalLisp env ql obj- let n = getL vec+ let n = getVecL vec setVar env var (Vector n (DIM.fromAscList (addkey val (fromInteger n)))) else throwError (Default ("bad vector-fill! form: " ++ (show var) ++ " is not a vector"))- where isVec (Vector _ _) = True- isVec _ = False- getL (Vector l _) = l- addkey _ 0 = []+ where addkey _ 0 = [] addkey v n = ((n-1), v):(addkey v (n-1)) evalLisp env ql (List [Symbol "vector-resize!", Symbol var, obj]) = do vec <- evalLisp env ql (Symbol var) if isVec vec then do lk <- evalLisp env ql obj- let l = getL vec- k = getI lk- if (isI lk) && (k > 0)+ let l = getVecL vec+ k = getInt lk+ if (isInt lk) && (k > 0) then do let new = if k < l- then rem (getV vec) l k- else add (getV vec) k l+ then rem (getVecV vec) l k+ else add (getVecV vec) k l setVar env var (Vector k new) else throwError (Default ("bad vector-resize! size: " ++ (show k))) else throwError (Default ("bad vector-resize! form: " ++ (show var) ++ " is not a vector"))- where isVec (Vector _ _) = True- isVec _ = False- getL (Vector l _) = l- getV (Vector _ v) = v- isI (IntNumber _) = True- isI _ = False- getI (IntNumber n) = n- rem vec h l =+ where rem vec h l = if h == l then vec else rem (DIM.delete (fromInteger l) vec) h (l + 1)@@ -497,13 +472,11 @@ 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 lispFalse+ where 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)) =- do ret <- lastOrNil (mapM (evalLisp env ql) args)+ do ret <- mapML (evalLisp env ql) args return (True, ret) evc_clause env (List (pred : args)) = do tst <- evalLisp env ql pred@@ -511,8 +484,7 @@ Boolean False -> return (False, lispFalse) _ -> do ret <- if isArrow args then evcArrow env args tst- else lastOrNil- (mapM (evalLisp env ql) args)+ else mapML (evalLisp env ql) args return (True, ret) evc_clause _ _ = return (False, lispFalse) isArrow [Symbol "=>", _] = True@@ -544,7 +516,7 @@ if letCheck False params then dols params body env else errBadForm "let*" params- where dols [] body env = lastOrNil (mapM (evalLisp env ql) body)+ where dols [] body env = mapML (evalLisp env ql) body dols (p:ps) body env = do val <- evalLisp env ql (exv p) (liftIO (bindVars env [(exn p, val)])) >>= (dols ps body)@@ -560,7 +532,7 @@ envn <- liftIO (bindVars env varn) varv <- mapM (evalLisp envn ql) (map exv params) mapM (doSet envn) (repl varn varv) >>- lastOrNil (mapM (evalLisp envn ql) body)+ mapML (evalLisp envn ql) body exn (List [Symbol var, _]) = (var, lispFalse) exv (List [Symbol _, val]) = val repl [] [] = []@@ -575,30 +547,30 @@ do let varn = map exn params envn <- liftIO (bindVars env varn) mapM (evSet envn) params >>- lastOrNil (mapM (evalLisp envn ql) body)+ mapML (evalLisp envn ql) body exn (List [Symbol var, _]) = (var, lispFalse) evSet env (List [Symbol var, val]) = evalLisp env ql val >>= setVar env var evalLisp _ _ (List [Symbol "case"]) = return lispFalse evalLisp env ql (List (Symbol "case" : key : args)) =- if (isNull args) || (foldl1 (&&) (map isList args) == False)+ if (isNull args) || (foldl1 (&&) (map isLL args) == False) then errTypeMismatch "case" "case-clauses" (String (show args)) else evalLisp env ql key >>= evc env args where isNull [] = True isNull _ = False- isList (List (List _ : _)) = True- isList (List (Symbol "else" : _)) = True- isList _ = False+ isLL (List (List _ : _)) = True+ isLL (List (Symbol "else" : _)) = True+ isLL _ = 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)) _ =- do ret <- lastOrNil (mapM (evalLisp env ql) args)+ do ret <- mapML (evalLisp env ql) args return (True, ret) evc_clause env (List (List vals : args)) key = if valMatch key vals- then do ret <- lastOrNil (mapM (evalLisp env ql) args)+ then do ret <- mapML (evalLisp env ql) args return (True, ret) else return (False, lispFalse) evc_clause _ _ _ = return (False, lispFalse)@@ -610,19 +582,17 @@ evalLisp env ql (List (Symbol "guard" : List (Symbol var : clauses) : body)) = if foldl (&&) True (map isList clauses) == False then errTypeMismatch "guard" "error-clauses" (String (show clauses))- else catchError (lastOrNil (mapM (evalLisp env ql) body))+ else catchError (mapML (evalLisp env ql) body) (\err -> do let errval = unpackErr err liftIO (bindVars env [(var, errval)]) >>= evc err clauses)- where isList (List _) = True- isList _ = False- unpackErr (UserException val) = val+ where unpackErr (UserException val) = val unpackErr err = String (show err) evc err [] _ = throwError err evc err (cl:cls) env = do (tst,val) <- evc_clause env cl if tst then return val else evc err cls env evc_clause env (List (Symbol "else" : args)) =- do ret <- lastOrNil (mapM (evalLisp env ql) args)+ do ret <- mapML (evalLisp env ql) args return (True, ret) evc_clause env (List (pred : args)) = do tst <- evalLisp env ql pred@@ -630,8 +600,7 @@ Boolean False -> return (False, lispFalse) _ -> do ret <- if isArrow args then evcArrow env args tst- else lastOrNil- (mapM (evalLisp env ql) args)+ else mapML (evalLisp env ql) args return (True, ret) evc_clause _ _ = return (False, lispFalse) isArrow [Symbol "=>", _] = True@@ -647,10 +616,9 @@ evalLisp env _ (List [Symbol "delay", val]) = do dval <- getVar env delayCounter- let count = getCount dval+ let count = getInt dval do setVar env delayCounter (IntNumber (count + 1)) return (Delay val env (" delay." ++ (show count)))- where getCount (IntNumber n) = n evalLisp envc ql (List [Symbol "force", val]) = do vali <- evalLisp envc ql val@@ -684,7 +652,7 @@ doloop env names (test:rets) steps = do tval <- evalLisp env ql test if isTrue tval- then do lastOrNil (mapM (evalLisp env ql) rets) >>= return+ then mapML (evalLisp env ql) rets else do mapM (evalLisp env ql) body svals <- mapM (evalLisp env ql) steps mapM (doSet env) (zip names svals)@@ -693,13 +661,11 @@ -- This creates a new guaranteed-never-before-used symbol (and one which -- the user can't enter, so guaranteed no past present or future clashes). -evalLisp env _ (List [Symbol "new-symbol"]) =+evalLisp env _ (List [Symbol "gensym"]) = do sval <- getVar env symbolCounter- let count = getCount sval+ let count = getInt sval do setVar env symbolCounter (IntNumber (count + 1)) return (Symbol (" symbol." ++ (show count)))- where getCount (IntNumber n) = n- getCount _ = progError -- This is not an R6RS special form, but it is a haskeem one: it needs -- to be, because we don't want to evaluate the function name, and we
Library.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: library.hs,v 1.30 2009-06-27 21:51:29 uwe Exp $ -}+$Id: library.hs,v 1.33 2009-07-04 02:48:29 uwe Exp $ -} module Library (primitiveBindings, delayCounter, symbolCounter, loadFile, eqv) where@@ -314,6 +314,35 @@ return . IntNumber . foldl1 intOp else errTypeMismatch name "number" (List av) +-- wrappers around rational comparison operators so that+-- we can deal properly with infinities and NaNs++myRatEQ n1 n2 | n1 == myRatNaN || n2 == myRatNaN = False+ | otherwise = n1 == n2++myRatNE n1 n2 | n1 == myRatNaN || n2 == myRatNaN = True+ | otherwise = n1 /= n2++myRatLT n1 n2 | n1 == myRatNaN || n2 == myRatNaN = False+ | n1 == myRatNInf = n2 /= myRatNInf+ | n2 == myRatPInf = n1 /= myRatPInf+ | otherwise = n1 < n2++myRatLE n1 n2 | n1 == myRatNaN || n2 == myRatNaN = False+ | n1 == myRatNInf = True+ | n1 == myRatPInf = n2 == myRatPInf+ | otherwise = n1 <= n2++myRatGT n1 n2 | n1 == myRatNaN || n2 == myRatNaN = False+ | n2 == myRatNInf = n1 /= myRatNInf+ | n1 == myRatPInf = n2 /= myRatPInf+ | otherwise = n1 > n2++myRatGE n1 n2 | n1 == myRatNaN || n2 == myRatNaN = False+ | n1 == myRatPInf = True+ | n2 == myRatPInf = n1 == myRatPInf+ | otherwise = n1 >= n2+ numBoolBinop :: String -> (Integer -> Integer -> Bool) -> (Rational -> Rational -> Bool) -> (Double -> Double -> Bool) ->@@ -411,6 +440,18 @@ | (denominator n1 /= 0) = n2 | otherwise = n1 +mymin :: Rational -> Rational -> Rational+mymin n1 n2 =+ if n1 == myRatNInf || n2 == myRatNInf+ then myRatNInf+ else min n1 n2++mymax :: Rational -> Rational -> Rational+mymax n1 n2 =+ if n1 == myRatPInf || n2 == myRatPInf+ then myRatPInf+ else max n1 n2+ mypow :: Rational -> Integer -> Rational mypow b e | (b == myRatNaN) = myRatNaN | (b == myRatPInf && e > 0) = myRatPInf@@ -475,7 +516,7 @@ lispMin [RatNumber n] = return (RatNumber n) lispMin [FltNumber n] = return (FltNumber n) lispMin (val:[]) = errTypeMismatch "min" "number" (String (show val))-lispMin (a:as) = numericBinop "min" min min min (a:as)+lispMin (a:as) = numericBinop "min" min mymin min (a:as) lispMax :: [LispVal] -> ThrowsError LispVal lispMax [] = errNumArgs "max" 1 []@@ -483,21 +524,31 @@ lispMax [RatNumber n] = return (RatNumber n) lispMax [FltNumber n] = return (FltNumber n) lispMax (val:[]) = errTypeMismatch "max" "number" (String (show val))-lispMax (a:as) = numericBinop "max" max max max (a:as)+lispMax (a:as) = numericBinop "max" max mymax max (a:as) +-- It would probably be more reasonable to just make everything+-- involving infinities to return a NaN... that stuff is just too messy+ fltpow :: Double -> Double -> LispVal-fltpow x y | y == 0 = IntNumber 1- | (x == 0 && y > 0) = IntNumber 0- | (x == 0 && y < 0) = libRatPInf- | ((abs x) < 1 && y > 0 && isInfinite y) = IntNumber 0- | ((abs x) > 1 && y < 0 && isInfinite y) = IntNumber 0- | otherwise = FltNumber (x ** y)+fltpow x y | y == 0 = if isInfinite x+ then libFltNaN+ else IntNumber 1+ | x == 0 = if y > 0+ then IntNumber 0+ else libRatPInf+ | (abs x) < 1 && y > 0 && isInfinite y = IntNumber 0+ | (abs x) > 1 && y < 0 && isInfinite y = IntNumber 0+ | x == -1 && isInfinite y = libFltNaN+ | x < -1 && y > 0 && isInfinite y = libFltNaN+ | x > -1 && x < 0 && y < 0 && isInfinite y = libFltNaN+ | otherwise = FltNumber (x ** y) spow :: Rational -> Rational -> LispVal spow x y | x < -1 && y == myRatPInf = libRatNaN | x < 0 && x > -1 && y == myRatNInf = libRatNaN | x == -1 && (abs y) == myRatPInf = libRatNaN | x == myRatNInf && y > 0 && (denominator y) > 1 = libRatNaN+ | x == myRatPInf && y == 0 = libRatNaN | (abs x) == myRatPInf && y > 0 = libRatPInf | x > 1 && y == myRatPInf = libRatPInf | x > 0 && x < 1 && y == myRatNInf = libRatPInf@@ -907,12 +958,12 @@ ("remainder", integerBinop "remainder" rem), ("gcd", integerBinop "gcd" gcd), ("lcm", integerBinop "lcm" lcm),- ("=", numBoolBinop "=" (==) (==) (==) False),- ("<", numBoolBinop "<" (<) (<) (<) False),- (">", numBoolBinop ">" (>) (>) (>) False),- ("/=", numBoolBinop "/=" (/=) (/=) (/=) True),- (">=", numBoolBinop ">=" (>=) (>=) (>=) False),- ("<=", numBoolBinop "<=" (<=) (<=) (<=) False),+ ("=", numBoolBinop "=" (==) myRatEQ (==) False),+ ("<", numBoolBinop "<" (<) myRatLT (<) False),+ (">", numBoolBinop ">" (>) myRatGT (>) False),+ ("/=", numBoolBinop "/=" (/=) myRatNE (/=) True),+ (">=", numBoolBinop ">=" (>=) myRatGE (>=) False),+ ("<=", numBoolBinop "<=" (<=) myRatLE (<=) False), ("boolean?", isBool), ("symbol?", Library.isSymbol), ("char?", isChar),
cpm.scm view
@@ -1,5 +1,5 @@ ; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>-; $Id: cpm.scm,v 1.1 2009-06-29 03:59:41 uwe Exp $+; $Id: cpm.scm,v 1.3 2009-07-03 23:17:00 uwe Exp $ ; BSD3 ; Continuation-passing macros in the style of "On Lisp" by Paul Graham;@@ -33,6 +33,11 @@ (defmacro (=return val) `(*cont* ,val)) +; Define the (=bind) macro++(defmacro (=bind params expr . body)+ `(let ((*cont* (lambda ,params ,@body))) ,expr))+ ; Define the CPS analog of (define): define a macro that looks like ; the function without the continuation argument, and define the ; function using a generated symbol with the continuation argument.@@ -47,7 +52,7 @@ ; (define (,ifn ...) ...). Otherwise, it's tricky to get at it. (defmacro (=define formals . body)- (let ((ifn (new-symbol))+ (let ((ifn (gensym)) (fn (car formals)) (args (cdr formals))) (if (symbol? args)@@ -71,6 +76,11 @@ (display (foo *cont* 4)) (newline)) +; This should print "9 + 1 = 10"++(=bind (y) (=apply foo 9)+ (write-string "9 + 1 = " (number->string y) #\newline))+ ; This should print "14": the function says to add 10 to the value passed ; in, and the current continuation, which is the default identity, is then ; applied to that value: 4 + 10 -> identity -> 14@@ -87,6 +97,11 @@ (let ((*cont* (lambda (x) (+ 1 x)))) (display (bar 4)) (newline))++; This should print "9 + 10 = 19"++(=bind (y) (bar 9)+ (write-string "9 + 10 = " (number->string y) #\newline)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; explicit CPS conversion of fibonacci function:
haskeem.cabal view
@@ -1,5 +1,5 @@ Name: haskeem-Version: 0.7.5+Version: 0.7.7 Homepage: http://www.korgwal.com/haskeem/ Author: Uwe Hollerbach <uh@alumni.caltech.edu> Maintainer: Uwe Hollerbach <uh@alumni.caltech.edu>
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.36 2009-06-29 00:25:51 uwe Exp $+; $Id: haskeem.doc,v 1.39 2009-07-03 23:17:00 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@@ -42,10 +42,10 @@ ((form defmacro) (args (var params) body)) ((form defmacro) (args (var params . varargs) body)) -((form let) (args ???))-((form let*) (args ???))-((form letrec) (args ???))-((form letrec*) (args ???))+((form let) (args (vars params) . body))+((form let*) (args (vars params) . body))+((form letrec) (args (vars params) . body))+((form letrec*) (args (vars params) . body)) ((form do) (args a lot)) @@ -346,8 +346,6 @@ ((primitive set-no-buffering!) (args handle)) ((function stream-scale) (args scale stream) (return stream)) -; 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))@@ -440,3 +438,6 @@ ((function set-for-each) (args set fn)) ((function intset-for-each) (args intset fn)) ((function bitset-for-each) (args bitset fn))++((function make-stack) (args . values) (return function))+((macro fluid-let) (args (vars params) . body))
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.34 2009-06-29 04:21:36 uwe Exp $ -}+$Id: haskeem.hs,v 1.36 2009-07-04 19:07:00 uwe Exp $ -} module Main where import Prelude@@ -43,7 +43,7 @@ -- haskeem version version :: String-version = "0.7.5"+version = "0.7.7" -- a variable under which any command-line arguments to a script are -- made available; empty for interactive mode
haskeem_readline.hs view
@@ -43,7 +43,7 @@ -- haskeem version version :: String-version = "0.7.5"+version = "0.7.7" -- a variable under which any command-line arguments to a script are -- made available; empty for interactive mode
heap.scm view
@@ -1,5 +1,5 @@ ; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>-; $Id: heap.scm,v 1.2 2009-06-29 00:24:24 uwe Exp $+; $Id: heap.scm,v 1.3 2009-07-03 23:17:00 uwe Exp $ ; BSD3 ; Priority queues implemented as heaps@@ -90,7 +90,7 @@ ; in place, and return the highest-priority item (defmacro (heap-remove! heap)- (let ((l (new-symbol)))+ (let ((l (gensym))) `(let ((,l (heap-remove ,heap))) (set! ,heap (cadr ,l)) (car ,l))))
macro-test.scm view
@@ -12,7 +12,7 @@ ; This version is careful to evaluate tval only once (defmacro (numeric-if-1 tval ifn ifz ifp)- (let ((nit (new-symbol)))+ (let ((nit (gensym))) `(let ((,nit ,tval)) (if (number? ,nit) (if (negative? ,nit)@@ -71,7 +71,7 @@ (write-string "################ while test\n") (defmacro (while some-cond . some-actions)- (let ((mc (new-symbol)))+ (let ((mc (gensym))) `(do ((,mc 0 (+ ,mc 1))) ((not ,some-cond) ,mc) ,@some-actions)))@@ -94,7 +94,7 @@ (write-string "################ swap test\n") (defmacro (swap var1 var2)- (let ((vs (new-symbol)))+ (let ((vs (gensym))) `(let ((,vs ,var1)) (set! ,var1 ,var2) (set! ,var2 ,vs))))
regexp.scm view
@@ -1,5 +1,5 @@ ; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>-; $Id: regexp.scm,v 1.13 2009-06-29 00:25:19 uwe Exp $+; $Id: regexp.scm,v 1.14 2009-07-02 05:49:56 uwe Exp $ ; BSD3... but if you use this for anything serious, you gotta be kidding ; grammar for regular expressions: precedence is (highest to lowest)@@ -32,19 +32,19 @@ ; 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:+; integer. The names are generated by the st-count counter in the+; regexp-make-nfa routine: it starts at 0, and 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)) ;@@ -78,10 +78,12 @@ (letrec* ((tokens (filter (lambda (c) (not (char-whitespace? c))) (string->char str))) (cur-tok #f)+; look ahead one character without consuming it (peek (lambda () (if (null? tokens) #f (car tokens))))+; get and consume the current character (pop (lambda () (if (null? tokens) #f@@ -154,14 +156,17 @@ (eqv? cur #\+)) (raise "error: unexpected operator")) (else (pop))))))+; parse the whole regexp (regexp (p-re0)))- (if (eqv? (peek) #f)- regexp- (raise "error: input not completely used"))))+; if there's something left over, it's an error;+; otherwise, we've successfully parsed the regexp+ (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+; Flatten the AST produced by regexp-parse: instead of a nearly 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@@ -172,12 +177,11 @@ (define (regexp-flatten-ast ast) (let ((s-op (lambda (op t1 t2)- (let ((lst (list op))- (lifter (lambda (l)+ (let ((lifter (lambda (l) ((if (and (list? l) (eqv? (car l) op)) cdr list) l))))- (append (append lst (lifter t1)) (lifter t2))))))+ (cons op (append (lifter t1) (lifter t2))))))) (if (list? ast) (cond ((eqv? 'COUNT (car ast)) (list (car ast)@@ -192,11 +196,14 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; 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;+; 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.+; efficient character ranges now: rather than producing a pair of states+; for every single character in a range, and gluing all of these together+; with another pair of states, it just does one pair of states with a whole+; bunch of characters on which to transition. (define (regexp-make-nfa ast) (letrec* ((con3 (lambda (a b c) (cons a (cons b c))))@@ -366,7 +373,7 @@ ; {M} = eps-closure of NFA state 1 ; DFA state 1 = {M}-; add {M} to work queue (or stack, doesn't matter)+; add {M} to work queue (or stack, order doesn't particularly matter) ; while (work queue/stack not empty) ; remove {M} ; for each input character i
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.42 2009-06-20 03:09:42 uwe Exp $+; $Id: selftest.scm,v 1.45 2009-07-04 01:29:53 uwe Exp $ (define start (epochtime)) @@ -59,7 +59,7 @@ (define (chk-run expect expr) (chk-closeto eqv? expect expr)) (define (rel-tol x y)- (when verbose? + (when verbose? (write-string "\nrel diff " (number->string (abs (- x y))))) (< (abs (- x y)) (* (* 0.5 (+ (abs x) (abs y))) 1.25e-15))) @@ -135,6 +135,11 @@ (chk-run 11 '(- 5 4 -2 3 -11)) (chk-run 163 '(+ 1 (* 2 (expt 3 4)))) +(chk-run 163 '((car (list + * expt))+ 1 ((cadr (list + * expt))+ 2 ((caddr (list + * expt))+ 3 4))))+ (chk-run 1267650600228229401496703205376 '(expt 2 100)) (chk-run +nan.0 '(sqrt -1.0))@@ -2238,7 +2243,7 @@ (define test-value (lambda () (set! probe (+ probe 1000)) test-val)) (defmacro (test-numeric-if tval ifn ifz ifp)- (let ((nit (new-symbol)))+ (let ((nit (gensym))) `(let ((,nit ,tval)) (if (number? ,nit) (if (negative? ,nit)@@ -2304,7 +2309,7 @@ (begin (defmacro (test-swap var1 var2)- (let ((vs (new-symbol)))+ (let ((vs (gensym))) `(let ((,vs ,var1)) (set! ,var1 ,var2) (set! ,var2 ,vs))))@@ -2368,11 +2373,13 @@ (define (do-dir-tests) (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")+ #\linefeed+ "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"+ #\linefeed) (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)))@@ -2588,25 +2595,53 @@ (chk-run 1242 '(ilog (- (expt 2 1243) 1))) (chk-run 1243 '(ilog (expt 2 1243))) -(chk-run "1.2345e0" '(number->string 1.2345))-(chk-run "1.2345e0" '(number->string 1.2345 10))-(chk-run "1.2345" '(number->string 1.2345 10 4))-(chk-run "1.23450" '(number->string 1.2345 10 5))-(chk-run "1.234500" '(number->string 1.2345 10 6))+(define mynum 1.2345) -(chk-run "1.234" '(number->string 1.2345 10 3))-(chk-run "1.23" '(number->string 1.2345 10 2))-(chk-run "1.2" '(number->string 1.2345 10 1))-(chk-run "1." '(number->string 1.2345 10 0))-(chk-run "1.2e0" '(number->string 1.2345 10 -1))-(chk-run "1.23e0" '(number->string 1.2345 10 -2))+(write-string "The following two tests might fail, "+ "returning \"1.2345000000000002e0\" instead\n")+(chk-run "1.2345e0" '(number->string mynum))+(chk-run "1.2345e0" '(number->string mynum 10))+(chk-run "1.2345" '(number->string mynum 10 4))+(chk-run "1.23450" '(number->string mynum 10 5))+(chk-run "1.234500" '(number->string mynum 10 6)) -(chk-run "1.234e0" '(number->string 1.2345 10 -3))-(chk-run "1.2345e0" '(number->string 1.2345 10 -4))+(write-string "This test might fail, returning \"1.235\" instead\n")+(chk-run "1.234" '(number->string mynum 10 3))+(chk-run "1.23" '(number->string mynum 10 2))+(chk-run "1.2" '(number->string mynum 10 1))+(chk-run "1." '(number->string mynum 10 0))+(chk-run "1.2e0" '(number->string mynum 10 -1))+(chk-run "1.23e0" '(number->string mynum 10 -2))++(write-string "This test might fail, returning \"1.235e0\" instead\n")+(chk-run "1.234e0" '(number->string mynum 10 -3))+(chk-run "1.2345e0" '(number->string mynum 10 -4)) (chk-run "1.2345e0" '(number->string 12345e-4 10 -4)) (chk-run "1.2345" '(number->string 12345/10000 10 4)) (chk-run "1.2345e0" '(number->string 12345/10000 10 -4)) +; Same as 1.2345 decimal, but in the above when we read in 1.2345 the last+; four binary digits get turned into 1110 which doesn't quite get turned+; back into 1.2345; that leads to the four "might fail" cases above.++(set! mynum #b1.0011110000001000001100010010011011101001011110001101)++(chk-run "1.2345e0" '(number->string mynum))+(chk-run "1.2345e0" '(number->string mynum 10))+(chk-run "1.2345" '(number->string mynum 10 4))+(chk-run "1.23450" '(number->string mynum 10 5))+(chk-run "1.234500" '(number->string mynum 10 6))++(chk-run "1.234" '(number->string mynum 10 3))+(chk-run "1.23" '(number->string mynum 10 2))+(chk-run "1.2" '(number->string mynum 10 1))+(chk-run "1." '(number->string mynum 10 0))+(chk-run "1.2e0" '(number->string mynum 10 -1))+(chk-run "1.23e0" '(number->string mynum 10 -2))++(chk-run "1.234e0" '(number->string mynum 10 -3))+(chk-run "1.2345e0" '(number->string mynum 10 -4))+ (chk-run "1.0" '(number->string 0.99999 10 1)) (chk-run "1.00" '(number->string 0.99999 10 2)) (chk-run "1.000" '(number->string 0.99999 10 3))@@ -2736,6 +2771,47 @@ ; to make the distinction they do. (chk-run '((1 2) 3 4 five 6) '(let ((a 3)) `((1 2) ,a ,4 ,'five 6)))++(define st (make-stack))+(define counter 0)++(define (bump-counter)+ (set! counter (+ 1 counter))+ (st 'push counter)+ counter)++(chk-run #f '(st 'top))+(chk-run '(3) '(st 'push 3))+(chk-run '(2 3) '(st 'push 2))+(chk-run '(17 2 3) '(st 'push 17))+(chk-run 17 '(st 'pop))+(chk-run #f '(st 'empty?))+(chk-run '(1 2 3) '(st 'push 1))+(chk-run '(1 2 3) '(st 'dump))+(chk-run #f '(st 'top))+(chk-run #t '(st 'empty?))++(bump-counter)+(bump-counter)+(bump-counter)+(chk-run '(3 2 1) '(st 'dump))++(let ((counter 99))+ (bump-counter)+ (st 'push counter)+ (bump-counter)+ (st 'push counter)+ (bump-counter))+(chk-run '(6 99 5 99 4) '(st 'dump))++(fluid-let ((counter 99))+ (bump-counter)+ (st 'push counter)+ (bump-counter)+ (st 'push counter)+ (bump-counter))+(chk-run '(102 101 101 100 100) '(st 'dump))+(chk-run 6 counter) ; if anything gets past the guard, it'll kill the self-test; so don't do that
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.39 2009-06-20 03:09:42 uwe Exp $+; $Id: stdlib.scm,v 1.42 2009-07-03 23:17:01 uwe Exp $ ; The haskeem standard library @@ -471,13 +471,13 @@ ; These take zero or more trips through the loop (defmacro (while some-cond . some-actions)- (let ((mc (new-symbol)))+ (let ((mc (gensym))) `(do ((,mc 0 (+ ,mc 1))) ((not ,some-cond) ,mc) ,@some-actions))) (defmacro (until some-cond . some-actions)- (let ((mc (new-symbol)))+ (let ((mc (gensym))) `(do ((,mc 0 (+ ,mc 1))) (,some-cond ,mc) ,@some-actions)))@@ -485,13 +485,13 @@ ; These take at least one trip through the loop (defmacro (do-while some-cond . some-actions)- (let ((mc (new-symbol)))+ (let ((mc (gensym))) `(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)))+ (let ((mc (gensym))) `(do ((,mc 0 (+ ,mc 1))) ((and (positive? ,mc) ,some-cond) ,mc) ,@some-actions)))@@ -512,6 +512,50 @@ (if filepath `(load ,filepath) `(write-string "unable to find file '" ,fname "'\n"))))++; A stack generator:+; (make-stack . init) -> stacker, optionally initialized with init value(s)+; as though pushed in order from left to right+; (stacker 'push val) -> push val onto stack+; (stacker 'pop) -> return top of stack with popping+; (stacker 'top) -> return top of stack without popping+; in both of the above cases, return #f if the stack is empty+; (stacker 'empty?) -> return #t if the stack is empty, #f otherwise+; (stacker 'dump) -> make the stack empty, returning all of its content++(define (make-stack . init)+ (let* ((stk (reverse init))+ (ret #f)+ (fn (lambda (op . val)+ (cond ((eqv? 'push op) (if (null? val)+ (raise "nothing to push onto stack!")+ (set! stk (cons (car val) stk))))+ ((eqv? 'pop op) (if (null? stk)+ #f+ (begin (set! ret (car stk))+ (set! stk (cdr stk))+ ret)))+ ((eqv? 'top op) (if (null? stk) #f (car stk)))+ ((eqv? 'empty? op) (null? stk))+ ((eqv? 'dump op) (set! ret stk) (set! stk '()) ret)+ (else (raise "stack error: unknown op!"))))))+ fn))++; Shamelessly stolen from Dorai Sitaram "Teach Yourself Scheme in+; Fixnum Days"... I could independently write the single-variable+; version of this, (fluid-let1 (var val) body), but here the nested+; quasi-quotes got just a little hairy... yow!++(defmacro (fluid-let vals . body)+ (let ((svals (map (lambda (ig) (gensym)) vals))+ (result (gensym))+ (vars (map car vals))+ (tvals (map cadr vals)))+ `(let ,(map (lambda (s v) `(,s ,v)) svals vars)+ ,@(map (lambda (v t) `(set! ,v ,t)) vars tvals)+ (let ((,result (begin ,@body)))+ ,@(map (lambda (v s) `(set! ,v ,s)) vars svals)+ ,result)))) ; if desired, this can be enabled; that's a nice confirmation in the REPL ; that everything is ok