haskeem-0.7.12: Library.hs
{- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>
Portions of this were derived from Jonathan Tang's haskell
tutorial "Write yourself a scheme in 48 hours" and are thus
Copyright Jonathan Tang (but there isn't much of his stuff left).
This file is part of haskeem.
haskeem is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
haskeem is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
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.39 2009-08-06 05:05:15 uwe Exp $ -}
module Library (primitiveBindings, delayCounter, symbolCounter, contCounter,
loadFile, eqv)
where
import Prelude
import IO
import Data.Bits
import Data.Char
import Data.Ratio
import Control.Monad.Error as CME
import Data.IORef
import System.Directory
import System.Posix.Env
import System.Posix.Files
import System.Posix.Types()
import System.Exit
import System.Time
import System.CPUTime
import System.Random
import System.Process
import qualified Data.IntMap as DIM
import Network
import LispData
import Parser
import Environment
import WriteNumber
errNumArgs name want got = throwError (NumArgs name want got)
errTypeMismatch name want got = throwError (TypeMismatch name want got)
genericBadArg :: [LispVal] -> String -> String -> Int
-> ThrowsError LispVal
genericBadArg badArgList func want num =
if num < 0 || length badArgList == num
then errTypeMismatch func want (List badArgList)
else errNumArgs func (toInteger num) badArgList
genericIOBadArg :: [LispVal] -> String -> String -> Int
-> IOThrowsError LispVal
genericIOBadArg badArgList func want num =
if length badArgList == num
then errTypeMismatch func want (badArgList !! 0)
else errNumArgs func (toInteger num) badArgList
-- A bunch of library functions that don't do IO:
-- these get put into the primitives table below
isChar :: [LispVal] -> ThrowsError LispVal
isChar [Char _] = return lispTrue
isChar _ = return lispFalse
isBool :: [LispVal] -> ThrowsError LispVal
isBool [Boolean _] = return lispTrue
isBool _ = return lispFalse
isNumber :: [LispVal] -> ThrowsError LispVal
isNumber [IntNumber _] = return lispTrue
isNumber [RatNumber _] = return lispTrue
isNumber [FltNumber _] = return lispTrue
isNumber _ = return lispFalse
isInteger :: [LispVal] -> ThrowsError LispVal
isInteger [IntNumber _] = return lispTrue
isInteger [RatNumber n] = return (Boolean ((denominator n) == 1))
isInteger _ = return lispFalse
isRational :: [LispVal] -> ThrowsError LispVal
isRational [IntNumber _] = return lispTrue
isRational [RatNumber _] = return lispTrue
isRational _ = return lispFalse
isReal :: [LispVal] -> ThrowsError LispVal
isReal [IntNumber _] = return lispTrue
isReal [RatNumber _] = return lispTrue
isReal [FltNumber _] = return lispTrue
isReal _ = return lispFalse
isString :: [LispVal] -> ThrowsError LispVal
isString [String _] = return lispTrue
isString _ = return lispFalse
isSymbol :: [LispVal] -> ThrowsError LispVal
isSymbol [Symbol _] = return lispTrue
isSymbol _ = return lispFalse
isList :: [LispVal] -> ThrowsError LispVal
isList [List _] = return lispTrue
isList _ = return lispFalse
isPair :: [LispVal] -> ThrowsError LispVal
isPair [List []] = return lispFalse
isPair [List _] = return lispTrue
isPair [DottedList _ _] = return lispTrue
isPair _ = return lispFalse
isPort :: [LispVal] -> ThrowsError LispVal
isPort [Port _] = return lispTrue
isPort [Socket _] = return lispTrue
isPort _ = return lispFalse
isProcedure :: [LispVal] -> ThrowsError LispVal
isProcedure [Prim _] = return lispTrue
isProcedure [IOPrim _] = return lispTrue
isProcedure [Func _ _ _ _ _ _] = return lispTrue
isProcedure _ = return lispFalse
isVector :: [LispVal] -> ThrowsError LispVal
isVector [Vector _ _] = return lispTrue
isVector _ = return lispFalse
isNull :: [LispVal] -> ThrowsError LispVal
isNull [List []] = return lispTrue
isNull _ = return lispFalse
isZero :: [LispVal] -> ThrowsError LispVal
isZero [IntNumber n] =
if n == 0 then return lispTrue else return lispFalse
isZero [RatNumber n] =
if (n == 0) then return lispTrue else return lispFalse
isZero [FltNumber n] =
if n == 0 then return lispTrue else return lispFalse
isZero _ = return lispFalse
isPositive :: [LispVal] -> ThrowsError LispVal
isPositive [IntNumber n] =
if n > 0 then return lispTrue else return lispFalse
isPositive [RatNumber n] =
if n > 0 then return lispTrue else return lispFalse
isPositive [FltNumber n] =
if n > 0 then return lispTrue else return lispFalse
isPositive _ = return lispFalse
isNegative :: [LispVal] -> ThrowsError LispVal
isNegative [IntNumber n] =
if n < 0 then return lispTrue else return lispFalse
isNegative [RatNumber n] =
if n < 0 then return lispTrue else return lispFalse
isNegative [FltNumber n] =
if n < 0 then return lispTrue else return lispFalse
isNegative _ = return lispFalse
isPromise :: [LispVal] -> ThrowsError LispVal
isPromise [Delay _ _ _] = return lispTrue
isPromise _ = 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
-- sees the number 1/0. I think it ought to be Inf, or perhaps RatInf. So I'm
-- going to return true for isInf for the rational numbers 1/0 and -1/0, and
-- true for isNaN for 0/0, allow entering of both (/ 1 0) and 1/0 plus ninf
-- and nan, and deal with these when they arise in computations
lispIsNaN :: [LispVal] -> ThrowsError LispVal
lispIsNaN [RatNumber n] =
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 (Boolean (((numerator n) /= 0) && ((denominator n) == 0)))
lispIsInf [FltNumber n] = return (Boolean (isInfinite n))
lispIsInf _ = return lispFalse
lispIsFinite :: [LispVal] -> ThrowsError LispVal
lispIsFinite [IntNumber _] = return lispTrue
lispIsFinite [RatNumber n] = return (Boolean ((denominator n) /= 0))
lispIsFinite [FltNumber n] =
return (Boolean (not ((isInfinite n) && (isNaN n))))
lispIsFinite _ = return lispFalse
lispIsEven :: [LispVal] -> ThrowsError LispVal
lispIsEven [IntNumber n] | even n = return lispTrue
| otherwise = return lispFalse
lispIsEven _ = return lispFalse
lispIsOdd :: [LispVal] -> ThrowsError LispVal
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 [Boolean False] = return lispTrue
lispNot _ = return lispFalse
unpackChar :: LispVal -> ThrowsError Char
unpackChar (Char c) = return c
unpackChar notChar = errTypeMismatch "<unpackChar>" "character" notChar
unpackIntNum :: LispVal -> ThrowsError Integer
unpackIntNum (IntNumber n) = return n
unpackIntNum (RatNumber n) =
if (denominator n) /= 0
then return (truncate n)
else errTypeMismatch "<unpackIntNum>" "number" (RatNumber n)
unpackIntNum (FltNumber n) = return (truncate n)
unpackIntNum (List [n]) = unpackIntNum n
unpackIntNum notNum = errTypeMismatch "<unpackIntNum>" "number" notNum
unpackRatNum :: LispVal -> ThrowsError Rational
unpackRatNum (IntNumber n) = return (fromInteger n)
unpackRatNum (RatNumber n) = return n
unpackRatNum (FltNumber n) = return (toRational n)
unpackRatNum (List [n]) = unpackRatNum n
unpackRatNum notNum = errTypeMismatch "<unpackRatNum>" "number" notNum
unpackFltNum :: LispVal -> ThrowsError Double
unpackFltNum (IntNumber n) = return (fromInteger n)
unpackFltNum (RatNumber n) = return (fromRational n)
unpackFltNum (FltNumber n) = return n
unpackFltNum (List [n]) = unpackFltNum n
unpackFltNum notNum = errTypeMismatch "<unpackFltNum>" "number" notNum
unpackStr :: LispVal -> ThrowsError String
unpackStr (String s) = return s
unpackStr (IntNumber n) = return (show n)
unpackStr (RatNumber n) = return (show n)
unpackStr (FltNumber n) = return (show n)
unpackStr (Boolean b) = return (show b)
unpackStr notString = errTypeMismatch "<unpackStr>" "string" notString
-- first cut at "number tower": if we have a set of args that are all
-- integers, we want to keep everything as an integer, including the result;
-- if there's a rational in there somewhere, promote them all to rationals;
-- ditto for doubles.
isIntType, isRatType, isFltType, isOther :: Int
isIntType = 0
isRatType = 1
isFltType = 2
isOther = 3
libRatNaN, libFltNaN, libRatPInf :: LispVal
libRatNaN = RatNumber myRatNaN
libFltNaN = FltNumber myFltNaN
libRatPInf = RatNumber myRatPInf
scanRatNaN :: [LispVal] -> Bool
scanRatNaN [] = False
scanRatNaN (IntNumber _:vs) = scanRatNaN vs
scanRatNaN (RatNumber v:vs) = if v == myRatNaN then True else scanRatNaN vs
scanFltNaN :: [LispVal] -> Bool
scanFltNaN [] = False
scanFltNaN (IntNumber _:vs) = scanFltNaN vs
scanFltNaN (RatNumber v:vs) = if v == myRatNaN then True else scanFltNaN vs
scanFltNaN (FltNumber v:vs) = if isNaN v then True else scanFltNaN vs
getType :: [LispVal] -> Int
getType p = foldl1 max (map g p)
where g (IntNumber _) = isIntType
g (RatNumber _) = isRatType
g (FltNumber _) = isFltType
g _ = isOther
isNumType :: Int -> Bool
isNumType n = (n == isIntType || n == isRatType || n == isFltType)
intOrRat :: Rational -> LispVal
intOrRat n | (denominator n) == 1 = (IntNumber (numerator n))
| otherwise = (RatNumber n)
numericBinop :: String -> (Integer -> Integer -> Integer) ->
(Rational -> Rational -> Rational) ->
(Double -> Double -> Double) ->
[LispVal] -> ThrowsError LispVal
numericBinop name intOp ratOp dblOp av =
do let mytype = getType av
if length av < 2
then errNumArgs name 2 ((String (show (length av))) : av)
else if mytype == isIntType
then mapM unpackIntNum av >>=
return . IntNumber . foldl1 intOp
else if mytype == isRatType
then if scanRatNaN av
then return libRatNaN
else mapM unpackRatNum av >>=
return . intOrRat . foldl1 ratOp
else if mytype == isFltType
then if scanFltNaN av
then return libFltNaN
else mapM unpackFltNum av >>=
return . FltNumber . foldl1 dblOp
else errTypeMismatch name "number" (List av)
integerBinop :: String -> (Integer -> Integer -> Integer) ->
[LispVal] -> ThrowsError LispVal
integerBinop name intOp av =
do let mytype = getType av
if length av < 2
then errNumArgs name 2 av
else if mytype == isIntType
then mapM unpackIntNum av >>=
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) ->
Bool -> [LispVal] -> ThrowsError LispVal
numBoolBinop name intOp ratOp dblOp nanval av =
do let mytype = getType av
if length av < 2
then errNumArgs name 2 av
else if mytype == isIntType
then do ll <- unpackIntNum (av !! 0)
rr <- unpackIntNum (av !! 1)
return (Boolean (intOp ll rr))
else if mytype == isRatType
then if scanRatNaN av
then return (Boolean nanval)
else do ll <- unpackRatNum (av !! 0)
rr <- unpackRatNum (av !! 1)
return (Boolean (ratOp ll rr))
else if mytype == isFltType
then if scanFltNaN av
then return (Boolean nanval)
else do ll <- unpackFltNum (av !! 0)
rr <- unpackFltNum (av !! 1)
return (Boolean (dblOp ll rr))
else errTypeMismatch name "number" (List av)
numericFunc :: String -> (Double -> Double) -> [LispVal] -> ThrowsError LispVal
numericFunc name fun av =
do let mytype = getType av
if length av /= 1
then errNumArgs name 1 av
else if isNumType mytype
then if scanFltNaN av
then return libFltNaN
else unpackFltNum (av !! 0) >>=
return . FltNumber . fun
else errTypeMismatch name "number" (List av)
lispNumerator :: [LispVal] -> ThrowsError LispVal
lispNumerator [IntNumber n] = return (IntNumber n)
lispNumerator [RatNumber n] = return (IntNumber (numerator n))
lispNumerator (val:[]) = errTypeMismatch "-" "number" (String (show val))
lispNumerator badArgList =
genericBadArg badArgList "numerator" "integer or rational" 1
lispDenominator :: [LispVal] -> ThrowsError LispVal
lispDenominator [IntNumber _] = return (IntNumber 1)
lispDenominator [RatNumber n] = return (IntNumber (denominator n))
lispDenominator (val:[]) = errTypeMismatch "-" "number" (String (show val))
lispDenominator badArgList =
genericBadArg badArgList "denominator" "integer or rational" 1
-- I want haskeem to be able to deal with rational-number infinities and
-- nans, so this stuff works around haskell's normalization of rational
-- numbers, which breaks for non-finite numbers like 1/0 or 0/0.
-- There are some asymmetries in these case tables, arising from the fact
-- that there are positive and negative infinities, but not also positive
-- and negative zero; so for example the reciprocal of -inf is 0, and thus
-- (reciprocal (reciprocal -inf)) is +inf rather than -inf. In that respect,
-- rational infs and nan aren't numbers; but then, they are also not
-- number-like in that they are their own successors: inf + 1 = inf. One of
-- the SRFIs points this out as a reason to only have inexact, ie
-- floating-point, infinities and NaNs; but I still prefer to have
-- rational-format infinities and NaNs when all calculations are only
-- integers and rationals: if the final answer in such a calculation comes
-- out finite, ie by dividing by an infinity, it will remain an exact
-- quantity; that is mathematically correct, but would not be the case if
-- infinities were necessarily inexact.
myrecip :: Rational -> Rational
myrecip n | n == myRatNaN = myRatNaN
| (n == myRatPInf || n == myRatNInf) = 0
| n == 0 = myRatPInf
| otherwise = (recip n)
mymul :: Rational -> Rational -> Rational
mymul n1 n2 | ((denominator n1 /= 0) &&
(denominator n2 /= 0)) = n1 * n2
| (n1 == myRatNaN || n2 == myRatNaN) ||
(n1 == 0 && (n2 == myRatPInf ||
n2 == myRatNInf)) ||
(n2 == 0 && (n1 == myRatPInf ||
n1 == myRatNInf)) = myRatNaN
| (sg n1) == (sg n2) = myRatPInf
| otherwise = myRatNInf
where sg n = if n > 0 then 1 else -1
myadd :: Rational -> Rational -> Rational
myadd n1 n2 | ((denominator n1 /= 0) &&
(denominator n2 /= 0)) = n1 + n2
| (n1 == myRatNaN || n2 == myRatNaN) ||
(n1 == myRatPInf && n2 == myRatNInf) ||
(n1 == myRatNInf && n2 == myRatPInf) = myRatNaN
| (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
| (b == myRatPInf && e == 0) = myRatNaN
| (b == myRatNInf && e > 0 && even e) = myRatPInf
| (b == myRatNInf && e > 0 && odd e) = myRatNInf
| (b == myRatNInf && e == 0) = myRatNaN
| (b == 0 && e > 0) = 0
| (e == 0) = 1 -- including 0**0,
-- mandated by R6RS
| (e < 0) = mypow (myrecip b) (negate e)
| otherwise = b ^ e
addOp = numericBinop "+" (+) myadd (+)
mulOp = numericBinop "*" (*) mymul (*)
lispPlus :: [LispVal] -> ThrowsError LispVal
lispPlus [] = return (IntNumber 0)
lispPlus [IntNumber n] = return (IntNumber n)
lispPlus [RatNumber n] = return (RatNumber n)
lispPlus [FltNumber n] = return (FltNumber n)
lispPlus (val:[]) = errTypeMismatch "+" "number" (String (show val))
lispPlus (v:vs) = addOp (v:vs)
lispMinus :: [LispVal] -> ThrowsError LispVal
lispMinus [IntNumber n] = return (IntNumber (negate n))
lispMinus [RatNumber n] = return (RatNumber (negate n))
lispMinus [FltNumber n] = return (FltNumber (negate n))
lispMinus (val:[]) = errTypeMismatch "-" "number" (String (show val))
lispMinus (a:as) =
do aux <- addOp ((IntNumber 0):as)
rec <- lispMinus [aux]
res <- addOp (a:[rec])
return res
lispMul :: [LispVal] -> ThrowsError LispVal
lispMul [] = return (IntNumber 1)
lispMul [IntNumber n] = return (IntNumber n)
lispMul [RatNumber n] = return (RatNumber n)
lispMul [FltNumber n] = return (FltNumber n)
lispMul (val:[]) = errTypeMismatch "*" "number" (String (show val))
lispMul (v:vs) = mulOp (v:vs)
lispDiv :: [LispVal] -> ThrowsError LispVal
lispDiv [IntNumber n] = return (RatNumber (myrecip (fromInteger n)))
lispDiv [RatNumber n] =
let nr = myrecip n
in if (denominator nr) == 1
then return (IntNumber (numerator nr))
else return (RatNumber nr)
lispDiv [FltNumber n] = return (FltNumber (1.0 / n))
lispDiv (val:[]) = errTypeMismatch "/" "number" (String (show val))
lispDiv (a:as) =
do aux <- mulOp ((IntNumber 1):as)
rec <- lispDiv [aux]
res <- mulOp (a:[rec])
return res
lispMin :: [LispVal] -> ThrowsError LispVal
lispMin [] = errNumArgs "min" 1 []
lispMin [IntNumber n] = return (IntNumber n)
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 mymin min (a:as)
lispMax :: [LispVal] -> ThrowsError LispVal
lispMax [] = errNumArgs "max" 1 []
lispMax [IntNumber n] = return (IntNumber n)
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 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 = 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
| (abs x) == myRatPInf && y < 0 = IntNumber 0
| x == 1 = IntNumber 1
| otherwise = fltpow (fromRational x) (fromRational y)
ratpow :: Rational -> Rational -> LispVal
ratpow x y =
if (denominator y) == 1
then let pow = mypow x (numerator y)
in if (denominator pow) == 1
then (IntNumber (numerator pow))
else (RatNumber pow)
else (spow x y)
lispPow :: [LispVal] -> ThrowsError LispVal
lispPow av =
if length av /= 2
then do errNumArgs "**" 2 av
else do let mytype = getType av
if isNumType mytype
then if (mytype == isIntType || mytype == isRatType)
then if scanRatNaN av
then return libRatNaN
else do b <- unpackRatNum (av !! 0)
e <- unpackRatNum (av !! 1)
return (ratpow b e)
else if scanFltNaN av
then return libFltNaN
else do b <- unpackFltNum (av !! 0)
e <- unpackFltNum (av !! 1)
return (fltpow b e)
else errTypeMismatch "expt" "number" (List av)
boolBinop :: (LispVal -> ThrowsError a) -> String -> (a -> a -> Bool) ->
[LispVal] -> ThrowsError LispVal
boolBinop unpacker name op args =
if length args /= 2
then errNumArgs name 2 args
else do ll <- unpacker (args !! 0)
rr <- unpacker (args !! 1)
return (Boolean (ll `op` rr))
strBoolBinop = boolBinop unpackStr
charBoolBinop = boolBinop unpackChar
car :: [LispVal] -> ThrowsError LispVal
car [List (x:_)] = return x
car [DottedList (x:_) _] = return x
car badArgList = genericBadArg badArgList "car" "pair or list" 1
cdr :: [LispVal] -> ThrowsError LispVal
cdr [List (_:xs)] = return (List xs)
cdr [DottedList (_:[]) x] = return x
cdr [DottedList (_:xs) x] = return (DottedList xs x)
cdr badArgList = genericBadArg badArgList "cdr" "pair or list" 1
cons :: [LispVal] -> ThrowsError LispVal
cons [xl, List []] = return (List [xl])
cons [x, List xs] = return (List ([x] ++ xs))
cons [x, DottedList xs xl] = return (DottedList ([x] ++ xs) xl)
cons [x1, x2] = return (DottedList [x1] x2)
cons badArgList = errNumArgs "cons" 2 badArgList
eqv :: [LispVal] -> Bool
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)
eqv [(FltNumber v1), (FltNumber v2)] = (v1 == v2) || ((isNaN v1) && (isNaN v2))
eqv [(String v1), (String v2)] = (v1 == v2)
eqv [(Symbol v1), (Symbol v2)] = (v1 == v2)
eqv [(DottedList l1 t1), (DottedList l2 t2)] =
eqv [(List (l1 ++ [t1])), (List (l2 ++ [t2]))]
eqv [(List l1), (List l2)] =
((length l1 == length l2) && (and (map eqvPair (zip l1 l2))))
where eqvPair (x1,x2) = eqv [x1,x2]
eqv [(Vector l1 v1), (Vector l2 v2)] =
((l1 == l2) && (and (map eqvPair (zip (getval (DIM.toAscList v1))
(getval (DIM.toAscList v2))))))
where eqvPair (x1,x2) = eqv [x1,x2]
getval [] = []
getval ((_,v):vs) = v:(getval vs)
eqv _ = False
eqvFunc :: [LispVal] -> ThrowsError LispVal
eqvFunc (v1:v2:[]) = return (Boolean (eqv [v1,v2]))
eqvFunc badArgList = genericBadArg badArgList "eqv?" "matched types" 2
char2int :: [LispVal] -> ThrowsError LispVal
char2int [Char c] = return (IntNumber (toInteger (ord c)))
char2int badArgList = genericBadArg badArgList "char->integer" "character" 1
int2char :: [LispVal] -> ThrowsError LispVal
int2char [IntNumber c] = return (Char (chr (fromInteger c)))
int2char badArgList = genericBadArg badArgList "integer->char" "integer" 1
char2str :: [LispVal] -> ThrowsError LispVal
char2str [] = return (String "")
char2str [List chars] = char2str chars
char2str chars = mapM unpackChar chars >>= return . String . (foldr (:) [])
str2char :: [LispVal] -> ThrowsError LispVal
str2char [] = return (List [])
str2char [String s] = return (List (map Char s))
str2char badArgList = genericBadArg badArgList "string->char" "string" 1
symb2str :: [LispVal] -> ThrowsError LispVal
symb2str [] = return (String "")
symb2str [Symbol s] = return (String s)
symb2str badArgList = genericBadArg badArgList "symbol->string" "string" 1
str2symb :: [LispVal] -> ThrowsError LispVal
str2symb [String []] = genericBadArg [String ""] "string->symbol" "string" 1
str2symb [String s] = return (Symbol (sanitize s))
where sanitize (c:cs) = schar isAlpha c : map (schar isAlphaNum) cs
schar pred c =
if (pred c) || (c `elem` specialSymbolChars) then c else '_'
str2symb badArgList = genericBadArg badArgList "string->symbol" "string" 1
readNum :: [LispVal] -> ThrowsError LispVal
readNum [String s] = readNumber s
readNum badArgList = genericBadArg badArgList "string->number" "string" 1
charIs :: (Char -> Bool) -> [LispVal] -> ThrowsError LispVal
charIs op [Char c] = return (Boolean (op c))
charIs _ badArgList = genericBadArg badArgList "char-istype?" "character" 1
charTo :: (Char -> Char) -> [LispVal] -> ThrowsError LispVal
charTo op [Char char] = return (Char (op char))
charTo op [List chars] = charTo op chars
charTo op [String str] = return (String (map op str))
charTo op chars =
mapM oneTo chars >>= return . List
where oneTo (Char c) = return (Char (op c))
oneTo notChar = errTypeMismatch "charTo" "character" notChar
lispFloor :: [LispVal] -> ThrowsError LispVal
lispFloor [IntNumber c] = return (IntNumber c)
lispFloor [RatNumber c] =
if (denominator c) /= 0
then return (IntNumber (floor c))
else return (RatNumber c)
lispFloor [FltNumber c] = return (IntNumber (floor c))
lispFloor badArgList = genericBadArg badArgList "floor" "number" 1
lispTruncate :: [LispVal] -> ThrowsError LispVal
lispTruncate [IntNumber c] = return (IntNumber c)
lispTruncate [RatNumber c] =
if (denominator c) /= 0
then return (IntNumber (truncate c))
else return (RatNumber c)
lispTruncate [FltNumber c] = return (IntNumber (truncate c))
lispTruncate badArgList = genericBadArg badArgList "truncate" "number" 1
-- TODO: implement relative-tolerance rounding, so that specifying
-- 3 digits relative gives X.XXXeXX, for any exponent
-- round to a {rational,floating-point} number with a specified non-negative
-- number of digits to the right of the decimal point; this is a number of
-- the same type as the input
roundToAP :: RealFrac a => a -> Integer -> Integer -> a
roundToAP n b d =
let bd = (fromInteger (b^d))
in (fromInteger (round (n * bd)))/bd
-- equivalent of the above, except with the truncation point to the left
-- of the decimal point; that means the result is always an integer
roundToAN :: RealFrac a => a -> Integer -> Integer -> Integer
roundToAN n b d =
let bd = b^d
in bd*(round (n/(fromInteger bd)))
lispRound :: [LispVal] -> ThrowsError LispVal
lispRound [IntNumber c] = return (IntNumber c)
lispRound [RatNumber c] =
if (denominator c) /= 0
then return (IntNumber (round c))
else return (RatNumber c)
lispRound [FltNumber c] = return (IntNumber (round c))
lispRound [IntNumber c, IntNumber b, IntNumber d] =
if b > 1
then if d >= 0
then return (IntNumber c)
else return (IntNumber (roundToAN (toRational c) b (- d)))
else throwError (Default ("bad base arg to round: " ++ (show b)))
lispRound [RatNumber c, IntNumber b, IntNumber d] =
if (denominator c) /= 0
then if b > 1
then if d > 0
then return (RatNumber (roundToAP c b d))
else return (IntNumber (roundToAN c b (- d)))
else throwError (Default ("bad base arg to round: " ++ (show b)))
else return (RatNumber c)
lispRound [FltNumber c, IntNumber b, IntNumber d] =
if b > 1
then if d > 0
then return (FltNumber (roundToAP c b d))
else return (IntNumber (roundToAN c b (- d)))
else throwError (Default ("bad base arg to round: " ++ (show b)))
lispRound badArgList = genericBadArg badArgList "round" "number" 1
lispCeiling :: [LispVal] -> ThrowsError LispVal
lispCeiling [IntNumber c] = return (IntNumber c)
lispCeiling [RatNumber c] =
if (denominator c) /= 0
then return (IntNumber (ceiling c))
else return (RatNumber c)
lispCeiling [FltNumber c] = return (IntNumber (ceiling c))
lispCeiling badArgList = genericBadArg badArgList "ceiling" "number" 1
lispAbs :: [LispVal] -> ThrowsError LispVal
lispAbs [IntNumber c] = return (IntNumber (abs c))
lispAbs [RatNumber n] = return (RatNumber (abs n))
lispAbs [FltNumber c] = return (FltNumber (abs c))
lispAbs badArgList = genericBadArg badArgList "abs" "number" 1
lispATan2 :: [LispVal] -> ThrowsError LispVal
lispATan2 av =
do let mytype = getType av
if isNumType mytype
then if scanFltNaN av
then return libFltNaN
else case length av of
1 -> mapM unpackFltNum av >>=
return . FltNumber . atan . head
2 -> mapM unpackFltNum av >>=
return . FltNumber . at2
_ -> errNumArgs "atan" 2 av
else errTypeMismatch "atan" "number" (List av)
where at2 (y:x:[]) = atan2 y x
lispListFromArgs :: [LispVal] -> ThrowsError LispVal
lispListFromArgs vals = return (List vals)
lispReverse :: [LispVal] -> ThrowsError LispVal
lispReverse [List lst] = return (List (reverse lst))
lispReverse badArgList = genericBadArg badArgList "reverse" "list" 1
lispLast :: [LispVal] -> ThrowsError LispVal
lispLast [List []] = return (List [])
lispLast [List lst] = return (last lst)
lispLast badArgList = genericBadArg badArgList "last" "list" 1
lispLength :: [LispVal] -> ThrowsError LispVal
lispLength [List lst] = return (IntNumber (toInteger (length lst)))
lispLength badArgList = genericBadArg badArgList "length" "list" 1
lispListHead :: [LispVal] -> ThrowsError LispVal
lispListHead [List lst, IntNumber n] = return (List (take (fromInteger n) lst))
lispListHead badArgList =
genericBadArg badArgList "list-head" "list + number" 2
lispListTail :: [LispVal] -> ThrowsError LispVal
lispListTail [List lst, IntNumber n] = return (List (drop (fromInteger n) lst))
lispListTail badArgList =
genericBadArg badArgList "list-tail" "list + number" 2
lispListRef :: [LispVal] -> ThrowsError LispVal
lispListRef [List lst, IntNumber n] =
return (hON (drop (fromInteger n) lst))
where hON [] = List []
hON (x:_) = x
lispListRef badArgList = genericBadArg badArgList "list-ref" "list + number" 2
lispILog :: [LispVal] -> ThrowsError LispVal
lispILog [IntNumber n] = return (IntNumber (ilogb 2 n))
lispILog [IntNumber b, IntNumber n] =
if b < 2
then errTypeMismatch "ilog" "b > 2" (IntNumber b)
else return (IntNumber (ilogb b n))
lispILog badArgList = genericBadArg badArgList "ilog" "integer" 1
lispFactorial :: [LispVal] -> ThrowsError LispVal
lispFactorial [IntNumber n] =
if n > 0
then return (IntNumber (product [1 .. n]))
else if n == 0
then return (IntNumber 1)
else genericBadArg [IntNumber n] "factorial"
"non-negative integer" 1
lispFactorial badArgList = genericBadArg badArgList "factorial" "integer" 1
-- Vector primitives
lispMakeVector :: [LispVal] -> ThrowsError LispVal
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))))
else errTypeMismatch "make-vector" "n > 0" (IntNumber n)
where addkey _ 0 = []
addkey v k = ((k-1), v):(addkey v (k-1))
lispMakeVector badArgList = genericBadArg badArgList "make-vector" "integer" 1
lispVecFromArgs :: [LispVal] -> ThrowsError LispVal
lispVecFromArgs vals =
return (Vector (toInteger (length vals)) (DIM.fromAscList (addkey 0 vals)))
where addkey _ [] = []
addkey n (v:vs) = (n, v):(addkey (n+1) vs)
lispListToVec :: [LispVal] -> ThrowsError LispVal
lispListToVec [List vals] =
return (Vector (toInteger (length vals)) (DIM.fromAscList (addkey 0 vals)))
where addkey _ [] = []
addkey n (v:vs) = (n, v):(addkey (n+1) vs)
lispListToVec badArgList =
genericBadArg badArgList "list->vector" "list" 1
lispVecToList :: [LispVal] -> ThrowsError LispVal
lispVecToList [Vector _ vec] =
return (List (getval (DIM.toAscList vec)))
where getval [] = []
getval ((_,v):vs) = v:(getval vs)
lispVecToList badArgList =
genericBadArg badArgList "vector->list" "vector" 1
lispVecSize :: [LispVal] -> ThrowsError LispVal
lispVecSize [Vector len _] = return (IntNumber len)
lispVecSize badArgList = genericBadArg badArgList "vector-length" "vector" 1
lispVecRef :: [LispVal] -> ThrowsError LispVal
lispVecRef [Vector len vec, IntNumber n] =
if (n >= 0 && n < len)
then return (DIM.findWithDefault lispFalse (fromInteger n) vec)
else throwError (VectorBounds len (IntNumber n))
lispVecRef badArgList =
genericBadArg badArgList "vector-ref" "vector + integer" 2
getfn1 :: LispVal -> [LispVal] -> LispVal
getfn1 a b = List (Symbol "lambda" : a : b)
getfn :: [String] -> Maybe String -> [LispVal] -> LispVal
getfn ps Nothing body = getfn1 (List (map Symbol ps)) body
getfn [] (Just v) body = getfn1 (Symbol v) body
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 [Delay obj _ _] = return obj
proc2data [Prim _] =
throwError (Default "procedure->data can't handle builtin functions")
proc2data [IOPrim _] =
throwError (Default "procedure->data can't handle builtin functions")
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),
("*", lispMul),
("/", lispDiv),
("expt", lispPow),
("min", lispMin),
("max", lispMax),
("modulo", integerBinop "modulo" mod),
("quotient", integerBinop "quotient" quot),
("remainder", integerBinop "remainder" rem),
("gcd", integerBinop "gcd" gcd),
("lcm", integerBinop "lcm" lcm),
("=", 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),
("number?", Library.isNumber),
("integer?", isInteger),
("rational?", isRational),
("real?", isReal),
("string?", isString),
("pair?", isPair),
("list?", isList),
("null?", isNull),
("port?", isPort),
("procedure?", isProcedure),
("promise?", isPromise),
("vector?", isVector),
("even?", lispIsEven),
("odd?", lispIsOdd),
("zero?", isZero),
("positive?", isPositive),
("negative?", isNegative),
("nan?", lispIsNaN),
("infinite?", lispIsInf),
("finite?", lispIsFinite),
("not", lispNot),
("id", lispId),
("string=?", strBoolBinop "string=?" (==)),
("string<?", strBoolBinop "string<?" (<)),
("string>?", strBoolBinop "string>?" (>)),
("string>=?", strBoolBinop "string>=?" (>=)),
("string<=?", strBoolBinop "string<=?" (<=)),
("char=?", charBoolBinop "char=?" (==)),
("char<?", charBoolBinop "char<?" (<)),
("char>?", charBoolBinop "char>?" (>)),
("char>=?", charBoolBinop "char>=?" (>=)),
("char<=?", charBoolBinop "char<=?" (<=)),
("char->string", char2str),
("string->char", str2char),
("string->number", readNum),
("number->string", writeNum),
("symbol->string", symb2str),
("string->symbol", str2symb),
("char-alphabetic?", charIs isAlpha),
("char-numeric?", charIs isDigit),
("char-oct-digit?", charIs isOctDigit),
("char-hex-digit?", charIs isHexDigit),
("char-whitespace?", charIs isSpace),
("char-upper-case?", charIs isUpper),
("char-lower-case?", charIs isLower),
("char-alphanumeric?", charIs isAlphaNum),
("char-control?", charIs isControl),
("char-printable?", charIs isPrint),
("char-upcase", charTo toUpper),
("char-downcase", charTo toLower),
("string-upcase", charTo toUpper),
("string-downcase", charTo toLower),
("car", car),
("cdr", cdr),
("cons", cons),
("eqv?", eqvFunc),
("char->integer", char2int),
("integer->char", int2char),
("floor", lispFloor),
("truncate", lispTruncate),
("round", lispRound),
("ceiling", lispCeiling),
("numerator", lispNumerator),
("denominator", lispDenominator),
("abs", lispAbs),
("sqrt", numericFunc "sqrt" sqrt),
("exp", numericFunc "exp" exp),
("log", numericFunc "log" log),
("sin", numericFunc "sin" sin),
("cos", numericFunc "cos" cos),
("tan", numericFunc "tan" tan),
("sinh", numericFunc "sinh" sinh),
("cosh", numericFunc "cosh" cosh),
("tanh", numericFunc "tanh" tanh),
("asin", numericFunc "asin" asin),
("acos", numericFunc "acos" acos),
("atan", lispATan2),
("asinh", numericFunc "asinh" asinh),
("acosh", numericFunc "acosh" acosh),
("atanh", numericFunc "atanh" atanh),
("list", lispListFromArgs),
("reverse", lispReverse),
("last", lispLast),
("length", lispLength),
("list-head", lispListHead),
("list-tail", lispListTail),
("list-ref", lispListRef),
("ilog", lispILog),
("factorial", lispFactorial),
("make-vector", lispMakeVector),
("vector", lispVecFromArgs),
("vector-length", lispVecSize),
("list->vector", lispListToVec),
("vector->list", lispVecToList),
("vector-ref", lispVecRef),
("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
-- This is the wrapper which catches IO errors... I dunno what type it is
-- This converts a system-level error into a lisp-level error by the
-- kinda-funky (Default (show err)), assuming we don't swallow the error
doIOAction action ctor epred =
do ret <- liftIO (try action)
case ret of
Left err -> if epred err
then throwError (Default (show err))
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 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 _ = lispTrue
allErrs _ = True
noEOF err = not (isEOFError err)
makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal
makePort mode [String filename] =
doIOAction (openFile filename mode) Port allErrs
makePort _ badArgList = genericIOBadArg badArgList "open-IO-file" "string" 1
closePort :: [LispVal] -> IOThrowsError LispVal
closePort [Port port] =
doIOAction (hClose port) dropToBool allErrs
closePort [Socket sock] =
doIOAction (sClose sock) dropToBool allErrs
closePort _ = return lispFalse
readLine :: [LispVal] -> IOThrowsError LispVal
readLine [] = readLine [Port stdin]
readLine [Port port] = doIOAction (hGetLine port) String noEOF
readLine badArgList = genericIOBadArg badArgList "read-line" "read port" 1
readChar :: [LispVal] -> IOThrowsError LispVal
readChar [] = readChar [Port stdin]
readChar [Port port] = doIOAction (hGetChar port) Char noEOF
readChar badArgList = genericIOBadArg badArgList "read-char" "read port" 1
displayProc :: [LispVal] -> IOThrowsError LispVal
displayProc [obj] = displayProc [obj, Port stdout]
displayProc [obj, Port port] =
doIOAction (hPutStr port (show obj)) dropToBool allErrs
displayProc badArgList = genericIOBadArg badArgList "display" "write port" 2
readContents :: [LispVal] -> IOThrowsError LispVal
readContents [String filename] = doIOAction (readFile filename) String allErrs
readContents badArgList = genericIOBadArg badArgList "read-contents" "string" 1
loadFile :: String -> IOThrowsError [LispVal]
loadFile filename =
do str <- doIOAction (readFile filename) String allErrs
case str of
Boolean False -> throwError (Default "operation failed")
String val -> liftThrows (readExprList val)
readAll :: [LispVal] -> IOThrowsError LispVal
readAll [String filename] = liftM List (loadFile filename)
readAll badArgList = genericIOBadArg badArgList "read-all" "string" 1
lispPutStr :: [LispVal] -> IOThrowsError LispVal
lispPutStr [] = return lispFalse
lispPutStr ((Port port):rest) =
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
lispPutStr (s:ss) = lispPutStr ((Port stdout):s:ss)
flushPort :: [LispVal] -> IOThrowsError LispVal
flushPort [] = flushPort [Port stdout]
flushPort [Port p] = doIOAction (hFlush p) dropToBool allErrs
flushPort badArgList = genericIOBadArg badArgList "flush-port" "port" 1
lispError :: [LispVal] -> IOThrowsError LispVal
lispError [] = throwError (UserException (List []))
lispError [val] = throwError (UserException val)
lispError info = throwError (UserException (List info))
lispExit :: [LispVal] -> IOThrowsError LispVal
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)))
lispExit [String s] = liftIO (hPutStrLn stderr s >> exitWith (ExitFailure 1))
lispExit _ = liftIO (hPutStrLn stderr "goodbye!" >> exitWith (ExitFailure 1))
lispFileExists :: [LispVal] -> IOThrowsError LispVal
lispFileExists [String filename] =
doIOAction (doesFileExist filename) Boolean allErrs
lispFileExists badArgList =
genericIOBadArg badArgList "file-exists?" "string" 1
lispDirExists :: [LispVal] -> IOThrowsError LispVal
lispDirExists [String dirname] =
doIOAction (doesDirectoryExist dirname) Boolean allErrs
lispDirExists badArgList =
genericIOBadArg badArgList "directory-exists?" "string" 1
lispRenameFile :: [LispVal] -> IOThrowsError LispVal
lispRenameFile [String oldname, String newname] =
doIOAction (renameFile oldname newname) dropToBool allErrs
lispRenameFile badArgList = genericIOBadArg badArgList "rename-file" "string" 2
lispCreateLink :: [LispVal] -> IOThrowsError LispVal
lispCreateLink [String oldname, String newname] =
doIOAction (createLink oldname newname) dropToBool allErrs
lispCreateLink badArgList = genericIOBadArg badArgList "create-link" "string" 2
lispCreateSymbolicLink :: [LispVal] -> IOThrowsError LispVal
lispCreateSymbolicLink [String oldname, String newname] =
doIOAction (createSymbolicLink oldname newname) dropToBool allErrs
lispCreateSymbolicLink badArgList =
genericIOBadArg badArgList "create-symbolic-link" "string" 2
lispRemoveFile :: [LispVal] -> IOThrowsError LispVal
lispRemoveFile [String filename] =
doIOAction (removeFile filename) dropToBool allErrs
lispRemoveFile badArgList = genericIOBadArg badArgList "remove-file" "string" 2
lispCreateDir :: [LispVal] -> IOThrowsError LispVal
lispCreateDir [String dirname] =
doIOAction (createDirectory dirname) dropToBool allErrs
lispCreateDir badArgList =
genericIOBadArg badArgList "create-directory" "string" 1
lispRemoveDir :: [LispVal] -> IOThrowsError LispVal
lispRemoveDir [String dirname] =
doIOAction (removeDirectory dirname) dropToBool allErrs
lispRemoveDir badArgList =
genericIOBadArg badArgList "remove-directory" "string" 1
lispRenameDir :: [LispVal] -> IOThrowsError LispVal
lispRenameDir [String oldname, String newname] =
doIOAction (renameDirectory oldname newname) dropToBool allErrs
lispRenameDir badArgList =
genericIOBadArg badArgList "rename-directory" "string" 2
lispSetCurrentDir :: [LispVal] -> IOThrowsError LispVal
lispSetCurrentDir [String dirname] =
doIOAction (setCurrentDirectory dirname) dropToBool allErrs
lispSetCurrentDir badArgList =
genericIOBadArg badArgList "set-current-directory" "nothing" 0
lispGetCurrentDir :: [LispVal] -> IOThrowsError LispVal
lispGetCurrentDir [] =
doIOAction (getCurrentDirectory) String allErrs
lispGetCurrentDir badArgList =
genericIOBadArg badArgList "get-current-directory" "nothing" 0
lispGetDirContents :: [LispVal] -> IOThrowsError LispVal
lispGetDirContents [String dirname] =
doIOAction (getDirectoryContents dirname) loS allErrs
where loS arr = List (toS arr)
toS [] = []
toS (str:strs) = (String str):(toS strs)
lispGetDirContents badArgList =
genericIOBadArg badArgList "read-directory" "string" 1
lispGetEnv :: [LispVal] -> IOThrowsError LispVal
lispGetEnv [] =
doIOAction (getEnvironment) loSS allErrs
where loSS arr = List (toSS arr)
toSS [] = []
toSS ((key,val):strs) =
(DottedList [String key] (String val)):(toSS strs)
lispGetEnv [String key] =
doIOAction (getEnvDefault key "") String allErrs
lispGetEnv badArgList =
genericIOBadArg badArgList "get-environment" "string" 1
lispSetEnv :: [LispVal] -> IOThrowsError LispVal
lispSetEnv [String key, String val] =
doIOAction (putEnv (key ++ "=" ++ val)) dropToBool allErrs
lispSetEnv badArgList =
genericIOBadArg badArgList "set-environment" "string" 2
lispUnSetEnv :: [LispVal] -> IOThrowsError LispVal
lispUnSetEnv [String key] = doIOAction (unsetEnv key) dropToBool allErrs
lispUnSetEnv badArgList =
genericIOBadArg badArgList "unset-environment" "string" 1
lispEpochTime :: [LispVal] -> IOThrowsError LispVal
lispEpochTime [] = doIOAction (getClockTime) getET allErrs
where getET (TOD sec psec) =
FltNumber ((fromInteger sec) + 1.0e-12*(fromInteger psec))
lispEpochTime badArgList = genericIOBadArg badArgList "epochtime" "nothing" 0
lispLocalTime :: [LispVal] -> IOThrowsError LispVal
lispLocalTime [] = doIOAction (getClockTime) toS allErrs
where toS val = String (show val)
lispLocalTime [IntNumber n] =
doIOAction (toCalendarTime (TOD n 0)) toS allErrs
where toS val = String (calendarTimeToString val)
lispLocalTime [RatNumber n] =
doIOAction (toCalendarTime (TOD (round n) 0)) toS allErrs
where toS val = String (calendarTimeToString val)
lispLocalTime [FltNumber n] =
doIOAction (toCalendarTime (TOD (round n) 0)) toS allErrs
where toS val = String (calendarTimeToString val)
lispLocalTime badArgList = genericIOBadArg badArgList "localtime" "nothing" 0
lispUTCTime :: [LispVal] -> IOThrowsError LispVal
lispUTCTime [] = doIOAction (getClockTime) toS allErrs
where toS val = String (calendarTimeToString (toUTCTime val))
lispUTCTime [IntNumber n] =
return (String (calendarTimeToString (toUTCTime (TOD n 0))))
lispUTCTime [RatNumber n] =
return (String (calendarTimeToString (toUTCTime (TOD (round n) 0))))
lispUTCTime [FltNumber n] =
return (String (calendarTimeToString (toUTCTime (TOD (round n) 0))))
lispUTCTime badArgList = genericIOBadArg badArgList "UTCtime" "nothing" 0
lispGetCPUTime :: [LispVal] -> IOThrowsError LispVal
lispGetCPUTime [] =
doIOAction (getCPUTime) toS allErrs
where toS val = FltNumber ((fromInteger val)/1.0e12)
lispGetCPUTime badArgList =
genericIOBadArg badArgList "cputime" "nothing" 0
statData :: FileStatus -> LispVal
statData stat =
List [IntNumber (read (show (deviceID stat))),
IntNumber (toInteger (fileID stat)),
IntNumber (toInteger (fileMode stat)),
IntNumber (toInteger (linkCount stat)),
IntNumber (toInteger (fileOwner stat)),
IntNumber (toInteger (fileGroup stat)),
IntNumber (read (show (specialDeviceID stat))),
IntNumber (toInteger (fileSize stat)),
getET (accessTime stat),
getET (modificationTime stat),
getET (statusChangeTime stat)]
where getET t = FltNumber (realToFrac t)
lispGetFileStatus :: [LispVal] -> IOThrowsError LispVal
lispGetFileStatus [String filename] =
doIOAction (getFileStatus filename) statData allErrs
lispGetFileStatus badArgList =
genericIOBadArg badArgList "get-file-status" "string" 1
lispGetLinkStatus :: [LispVal] -> IOThrowsError LispVal
lispGetLinkStatus [String filename] =
doIOAction (getSymbolicLinkStatus filename) statData allErrs
lispGetLinkStatus badArgList =
genericIOBadArg badArgList "get-link-status" "string" 1
lispIsBlockDevice :: [LispVal] -> IOThrowsError LispVal
lispIsBlockDevice [String filename] =
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) (Boolean . isCharacterDevice) allErrs
lispIsCharacterDevice badArgList =
genericIOBadArg badArgList "is-char-device?" "string" 1
lispIsNamedPipe :: [LispVal] -> IOThrowsError LispVal
lispIsNamedPipe [String filename] =
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) (Boolean . isRegularFile) allErrs
lispIsRegularFile badArgList =
genericIOBadArg badArgList "is-regular-file?" "string" 1
lispIsDirectory :: [LispVal] -> IOThrowsError LispVal
lispIsDirectory [String filename] =
doIOAction (getFileStatus filename) (Boolean . isDirectory) allErrs
lispIsDirectory badArgList =
genericIOBadArg badArgList "is-directory?" "string" 1
lispIsSymbolicLink :: [LispVal] -> IOThrowsError LispVal
lispIsSymbolicLink [String filename] =
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) (Boolean . isSocket) allErrs
lispIsSocket badArgList =
genericIOBadArg badArgList "is-socket?" "string" 1
lispRandUni :: [LispVal] -> IOThrowsError LispVal
lispRandUni [] =
doIOAction (getStdRandom (randomR (0 :: Double, 1))) FltNumber allErrs
lispRandUni [IntNumber lo, IntNumber hi] =
if lo < hi
then doIOAction (getStdRandom (randomR (lo, hi))) IntNumber allErrs
else doIOAction (getStdRandom (randomR (hi, lo))) IntNumber allErrs
lispRandUni [FltNumber lo, FltNumber hi] =
if lo < hi
then doIOAction (getStdRandom (randomR (lo, hi))) FltNumber allErrs
else doIOAction (getStdRandom (randomR (hi, lo))) FltNumber allErrs
lispRandUni badArgList =
genericIOBadArg badArgList "random-uniform" "two numbers" 2
lispRandExp :: [LispVal] -> IOThrowsError LispVal
lispRandExp [FltNumber m] =
if m > 0
then getrand >>= return . FltNumber . (sc m) . negate . log
else genericIOBadArg [FltNumber m] "random-exponential" "positive rate" 1
where getrand =
do val <- lispRandUni []
if getnum val == 0
then getrand
else return (getnum val)
getnum (FltNumber n) = n
sc s v = v/s
lispRandExp [] = lispRandExp [FltNumber 1.0]
lispRandExp [IntNumber m] = lispRandExp [FltNumber (fromInteger m)]
lispRandExp [RatNumber m] = lispRandExp [FltNumber (fromRational m)]
lispRandExp badArgList =
genericIOBadArg badArgList "random-exponential" "number" 1
lispRandNorm :: [LispVal] -> IOThrowsError LispVal
lispRandNorm [FltNumber m, FltNumber s] =
if s > 0
then do x1 <- getrand
x2 <- getrand
let a = s*sqrt (-2.0*(log x1))
b = 2.0*pi*x2
y1 = m + a*(cos b)
y2 = m + a*(sin b)
return (List [FltNumber y1, FltNumber y2])
else throwError (Default ("random-normal-pair needs a positive stddev,"
++ " got " ++ (show s)))
where getrand =
do val <- lispRandUni []
if getnum val == 0
then getrand
else return (getnum val)
getnum (FltNumber n) = n
lispRandNorm [] = lispRandNorm [FltNumber 0.0, FltNumber 1.0]
lispRandNorm [IntNumber m, IntNumber s] =
lispRandNorm [FltNumber (fromInteger m), FltNumber (fromInteger s)]
lispRandNorm [IntNumber m, RatNumber s] =
lispRandNorm [FltNumber (fromInteger m), FltNumber (fromRational s)]
lispRandNorm [IntNumber m, FltNumber s] =
lispRandNorm [FltNumber (fromInteger m), FltNumber s]
lispRandNorm [RatNumber m, IntNumber s] =
lispRandNorm [FltNumber (fromRational m), FltNumber (fromInteger s)]
lispRandNorm [RatNumber m, RatNumber s] =
lispRandNorm [FltNumber (fromRational m), FltNumber (fromRational s)]
lispRandNorm [RatNumber m, FltNumber s] =
lispRandNorm [FltNumber (fromRational m), FltNumber s]
lispRandNorm [FltNumber m, IntNumber s] =
lispRandNorm [FltNumber m, FltNumber (fromInteger s)]
lispRandNorm [FltNumber m, RatNumber s] =
lispRandNorm [FltNumber m, FltNumber (fromRational s)]
lispRandNorm badArgList =
genericIOBadArg badArgList "random-normal-pair" "number" 2
-- TODO: for large lambda, this will be slow! Fix!
lispRandPoisson :: [LispVal] -> IOThrowsError LispVal
lispRandPoisson [FltNumber lambda] =
if lambda > 0
then do val <- doit (exp (-lambda)) (-1) (1 :: Double)
return (IntNumber val)
else throwError (Default ("random-poisson needs a positive lambda,"
++ " got " ++ (show lambda)))
where doit l k p =
do r <- lispRandUni []
let pp = p*(getnum r)
kp = k + 1
if pp < l
then return kp
else doit l kp pp
getnum (FltNumber n) = n
lispRandPoisson [IntNumber m] = lispRandPoisson [FltNumber (fromInteger m)]
lispRandPoisson [RatNumber m] = lispRandPoisson [FltNumber (fromRational m)]
lispSeedRandom :: [LispVal] -> IOThrowsError LispVal
lispSeedRandom [IntNumber n] =
doIOAction (setStdGen (mkStdGen (fromInteger n))) dropToBool allErrs
lispSeedRandom [String s] =
doIOAction (setStdGen (read s)) dropToBool allErrs
lispSeedRandom badArgList =
genericIOBadArg badArgList "random-seed!" "integer or string" 1
lispConnectTo :: [LispVal] -> IOThrowsError LispVal
lispConnectTo [String hostname, IntNumber port] =
doIOAction (connectTo hostname (PortNumber (fromInteger port))) Port allErrs
lispConnectTo [String hostname, String usock] =
doIOAction (connectTo hostname (UnixSocket usock)) Port allErrs
lispConnectTo badArgList =
genericIOBadArg badArgList "connect-to" "host port" 2
lispListenOn :: [LispVal] -> IOThrowsError LispVal
lispListenOn [IntNumber port] =
doIOAction (listenOn (PortNumber (fromInteger port))) Socket allErrs
lispListenOn [String usock] =
doIOAction (listenOn (UnixSocket usock)) Socket allErrs
lispListenOn badArgList =
genericIOBadArg badArgList "listen-on" "port" 1
lispAccept :: [LispVal] -> IOThrowsError LispVal
lispAccept [Socket s] =
do ret <- liftIO (try (accept s))
case ret of
Left err -> throwError (Default (show err))
Right val -> return (List [Port (val1 val),
String (val2 val),
IntNumber (toInteger (val3 val))])
where val1 (a,_,_) = a
val2 (_,b,_) = b
val3 (_,_,c) = c
lispAccept badArgList =
genericIOBadArg badArgList "accept" "socket" 1
lispSetLineBuf :: [LispVal] -> IOThrowsError LispVal
lispSetLineBuf [Port h] =
doIOAction (hSetBuffering h LineBuffering) dropToBool allErrs
lispSetLineBuf badArgList =
genericIOBadArg badArgList "set-line-buffering!" "port" 1
lispSetNoBuf :: [LispVal] -> IOThrowsError LispVal
lispSetNoBuf [Port h] =
doIOAction (hSetBuffering h NoBuffering) dropToBool allErrs
lispSetNoBuf badArgList =
genericIOBadArg badArgList "set-no-buffering!" "port" 1
-- Old version that was just one argument, no optional working directory
-- lispRunCmd :: [LispVal] -> IOThrowsError LispVal
-- lispRunCmd [String cmd] =
-- doIOAction (system cmd) getStatus allErrs
-- where getStatus (ExitSuccess) = IntNumber 0
-- getStatus (ExitFailure n) = IntNumber (fromIntegral n)
-- lispRunCmd badArgList =
-- genericIOBadArg badArgList "run-command" "command" 1
lispRunCmd :: [LispVal] -> IOThrowsError LispVal
lispRunCmd [String cmd] = lispRunCmd [String cmd, String ""]
lispRunCmd [String cmd, String dir] =
do ret <- liftIO (try (createProcess (shell cmd)
{ cwd = if dir /= "" then Just dir else Nothing }))
case ret of
Left err -> throwError (Default (show err))
Right _ -> return lispTrue
lispRunCmd badArgList =
genericIOBadArg badArgList "run-command" "command+dir" 2
lispReadCmd :: [LispVal] -> IOThrowsError LispVal
lispReadCmd [String cmd] = lispReadCmd [String cmd, String ""]
lispReadCmd [String cmd, String dir] =
do ret <- liftIO (try (createProcess (shell cmd)
{ cwd = if dir /= "" then Just dir else Nothing,
std_out = CreatePipe }))
case ret of
Left err -> throwError (Default (show err))
Right val -> return (Port (val2 val))
where val2 (_, Just hout, _, _) = hout
lispReadCmd badArgList =
genericIOBadArg badArgList "run-read-command" "command+dir" 2
lispWriteCmd :: [LispVal] -> IOThrowsError LispVal
lispWriteCmd [String cmd] = lispWriteCmd [String cmd, String ""]
lispWriteCmd [String cmd, String dir] =
do ret <- liftIO (try (createProcess (shell cmd)
{ cwd = if dir /= "" then Just dir else Nothing,
std_in = CreatePipe }))
case ret of
Left err -> throwError (Default (show err))
Right val -> return (Port (val1 val))
where val1 (Just hin, _, _, _) = hin
lispWriteCmd badArgList =
genericIOBadArg badArgList "run-write-command" "command+dir" 2
ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]
ioPrimitives = [("open-input-file", makePort ReadMode),
("open-output-file", makePort WriteMode),
("open-append-file", makePort AppendMode),
("rename-file", lispRenameFile),
("remove-file", lispRemoveFile),
("create-link", lispCreateLink),
("create-symbolic-link", lispCreateSymbolicLink),
("close-port", closePort),
("raise", lispError),
("display", displayProc),
("read-line", readLine),
("read-char", readChar),
("read-contents", readContents),
("read-all", readAll),
("write-string", lispPutStr),
("flush-port", flushPort),
("exit", lispExit),
("get-current-directory", lispGetCurrentDir),
("set-current-directory", lispSetCurrentDir),
("create-directory", lispCreateDir),
("remove-directory", lispRemoveDir),
("rename-directory", lispRenameDir),
("read-directory", lispGetDirContents),
("file-exists?", lispFileExists),
("directory-exists?", lispDirExists),
("get-environment", lispGetEnv),
("set-environment", lispSetEnv),
("unset-environment", lispUnSetEnv),
("epochtime", lispEpochTime),
("localtime", lispLocalTime),
("UTCtime", lispUTCTime),
("cputime", lispGetCPUTime),
("get-file-status", lispGetFileStatus),
("get-link-status", lispGetLinkStatus),
("is-block-device?", lispIsBlockDevice),
("is-char-device?", lispIsCharacterDevice),
("is-named-pipe?", lispIsNamedPipe),
("is-regular-file?", lispIsRegularFile),
("is-directory?", lispIsDirectory),
("is-symbolic-link?", lispIsSymbolicLink),
("is-socket?", lispIsSocket),
("random-uniform", lispRandUni),
("random-exponential", lispRandExp),
("random-normal-pair", lispRandNorm),
("random-poisson", lispRandPoisson),
("random-seed!", lispSeedRandom),
("set-line-buffering!", lispSetLineBuf),
("set-no-buffering!", lispSetNoBuf),
("connect-to", lispConnectTo),
("listen-on", lispListenOn),
("accept", lispAccept),
("run-command", lispRunCmd),
("run-read-command", lispReadCmd),
("run-write-command", lispWriteCmd)]
-- A couple of predefined data values
ioPorts :: [(String, LispVal)]
ioPorts = [("stdin", (Port stdin)),
("stdout", (Port stdout)),
("stderr", (Port stderr)),
("pi", (FltNumber pi))]
-- And finally some stuff for internal work
-- delayCounter is the name under which a counter for delay objects
-- is stored in the environment. It contains spaces, so that it is
-- impossible for the user to enter this as a valid symbol. Ditto
-- for symbolCounter: this is for generating new internal symbols.
-- contCounter is for counting continuations operators; this could
-- equally well be done by symbolCounter.
delayCounter :: String
delayCounter = " delay "
symbolCounter :: String
symbolCounter = " symbol "
contCounter :: String
contCounter = " continuation "
internals :: [(String, LispVal)]
internals = [(delayCounter, (IntNumber 0)),
(symbolCounter, (IntNumber 0)),
(contCounter, (IntNumber 0))]
primitiveBindings :: IO Env
primitiveBindings = newIORef [] >>=
(flip bindVars (internals ++ map (mkf IOPrim) ioPrimitives ++
map (mkf Prim) primitives ++ ioPorts))
where mkf constructor (var, func) = (var, constructor func)