Commit 5d95275e authored by sof's avatar sof

[project @ 1999-01-18 19:38:27 by sof]

Misc (backward compatible) changes to make srcs acceptable
to a Haskell 98 compiler.
parent 8441d28d
--!!! Wentworth's version of a program to generate
--!!! all the expansions of a generalised regular expression
--!!!
-- !!! Wentworth's version of a program to generate
-- !!! all the expansions of a generalised regular expression
-- !!!
--
module Main (main) where
......
--!!! count the number of solutions to the "n queens" problem.
-- !!! count the number of solutions to the "n queens" problem.
-- (grabbed from LML dist)
main = print (nsoln 10)
......
--!!! the ultra-notorious "nfib 30" does w/ Floats
-- !!! the ultra-notorious "nfib 30" does w/ Floats
--
module Main (main) where
......
......@@ -51,6 +51,13 @@ They were documented in earlier chapters (Part~\ref{part:modules}).
> (=:) a b = (a,b)
>#endif
#if __HASKELL1__ < 5
#define amap map
#else
#define amap fmap
#endif
\end{verbatim}
......@@ -288,7 +295,7 @@ definition stands for ``tied-mixture continuation.''
> can't_read :: String -> String
> can't_read file = " can't read the file " ++ file
> make_tm_table = map (\as -> array (1, length as) as) .
> make_tm_table = amap (\as -> array (1, length as) as) .
> accumArray (flip (:)) [] phone_bounds
\end{haskell}
......
......@@ -22,6 +22,13 @@ vectors.
> import HmmConstants
> import Array--1.3
#if __HASKELL1__ < 5
#define amap map
#else
#define amap fmap
#endif
\end{haskell}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
......@@ -343,7 +350,7 @@ for efficient retrieval.
> eval_log_densities :: TmTable -> Vector -> LogDensityTable
> eval_log_densities tmt x = ldt
> where ldt = map (map eval_tied_mixture) tmt
> where ldt = amap (amap eval_tied_mixture) tmt
> eval_tied_mixture (Gm gm) = eval_log_mixture x gm
> eval_tied_mixture (Tie p k) = ldt!p!k
......
......@@ -37,6 +37,12 @@ described in later chapters in Part~\ref{part:library}.
> import Array--1.3
> import Ix--1.3
#if __HASKELL1__ < 5
#define amap map
#else
#define amap fmap
#endif
\end{verbatim}
......@@ -655,7 +661,7 @@ the probabilities for all HMMs in an array.
\begin{haskell}{get_log_probs}
> get_log_probs :: (Ix a) => Array a (HmmTsL b) -> Array a (HmmTsL b)
> get_log_probs = map convert_to_log_probs
> get_log_probs = amap convert_to_log_probs
\end{haskell}
......
......@@ -55,7 +55,7 @@ HS_OBJS = Alignments.o \
SRC_MKDEPENDHS_OPTS += -syslib misc
SRC_RUNTEST_OPTS += -o2 HMMS.stderr hmms/h9 hmms/h9.ties hmms/h9.dgs sentences
SRC_HC_OPTS += -fglasgow-exts -syslib misc
SRC_HC_OPTS += -fglasgow-exts -syslib misc -cpp
MaybeStateT_HC_OPTS += -cpp
BatchAlign_HC_OPTS += -cpp
......
--==========================================================--
--=== Concretisation of function points. ===--
--=== AbsConc3.hs ===--
--==========================================================--
-- ==========================================================--
-- === Concretisation of function points. ===--
-- === AbsConc3.hs ===--
-- ==========================================================--
module AbsConc3 where
import BaseDefs
......@@ -14,7 +14,7 @@ import AbstractMisc
import DomainExpr
--==========================================================--
-- ==========================================================--
--
acUncurryWRT :: Domain -> Domain -> Domain
-- small big
......@@ -48,7 +48,7 @@ acUncurryWRT (Func ds_s dt_s) (Func ds_b dt_b)
totally_fixed
--==========================================================--
-- ==========================================================--
--
acNormAndCurried :: Domain -> Domain -> (Domain, Domain)
......@@ -57,7 +57,7 @@ acNormAndCurried small_d big_d
in (big_d_u, acUncurryWRT small_d big_d_u)
--==========================================================--
-- ==========================================================--
-- big domain smaller domain
acCompatible :: Domain -> Domain -> Bool
--
......@@ -83,7 +83,7 @@ acCompatible _ _
= False
--==========================================================--
-- ==========================================================--
--
acConc :: ACMode -> Domain -> Domain -> Route -> Route
......@@ -105,7 +105,7 @@ acConc s_or_l big_d small_d small_r
else acConcData s_or_l big_d_u small_d small_r
--==========================================================--
-- ==========================================================--
-- big small
--
acConcData :: ACMode -> Domain -> Domain -> Route -> Route
......@@ -128,7 +128,7 @@ acConcData s_or_l (Lift2 dbs) (Lift2 dss) (UpUp2 rs)
= UpUp2 (myZipWith3 (acConc s_or_l) dbs dss rs)
--==========================================================--
-- ==========================================================--
-- big_c big_u small
acConcRep :: ACMode -> Domain -> Domain -> Domain -> Rep -> Rep
......@@ -146,7 +146,7 @@ acConcRep s_or_l big_d_c@(Func dss_b_c dt_b_c)
concd_all
--==========================================================--
-- ==========================================================--
-- Concretise target domain of a function.
-- target_big rep_current
acConcTarget :: ACMode -> Domain -> Domain -> Rep -> Rep
......@@ -235,7 +235,7 @@ acConcTarget
--==========================================================--
-- ==========================================================--
--
ac_increase_arity_safe :: Int -> -- arity increase
[Domain] -> -- existing arg domains
......@@ -255,7 +255,7 @@ ac_increase_arity_safe arity_increase argds new_argds fr
--==========================================================--
-- ==========================================================--
--
ac_increase_arity_live :: Int -> -- arity increase
[Domain] -> -- existing arg domains
......@@ -275,7 +275,7 @@ ac_increase_arity_live arity_increase argds new_argds fr
--==========================================================--
-- ==========================================================--
--
ac_ia_aux :: ACMode -> -- mode
Int -> -- arity increase
......@@ -296,7 +296,7 @@ ac_ia_aux
--==========================================================--
-- ==========================================================--
--
ac_extend_fr :: ACMode ->
[Domain] ->
......@@ -316,7 +316,7 @@ ac_extend_fr s_or_l final_argds f1 f0 new_points
Live -> (new_f1_live, new_f0_live)
--==========================================================--
-- ==========================================================--
-- big_args small_args
acConcSource_aux :: ACMode -> [Domain] -> [Domain] -> Frontier -> Frontier
......@@ -337,7 +337,7 @@ acConcSource_aux Live dbs dss (Min1Max0 ar f1 f0)
Min1Max0 ar new_f1 new_f0
--==========================================================--
-- ==========================================================--
-- Concretise source domain of a function
-- big small
acConcSource :: ACMode -> Domain -> Domain -> Rep -> Rep
......@@ -382,7 +382,7 @@ acConcSource s_or_l (Func dss_b (Lift2 dts_b))
Rep2 new_lf new_mf new_hfs
--==========================================================--
-- ==========================================================--
-- Figure out the domain of the thing created by acConcSource.
-- big small
acConcSourceD :: Domain -> Domain -> Domain
......@@ -411,7 +411,7 @@ acConcSourceD (Func dss_b (Lift2 dts_b)) (Func dss_s (Lift2 dts_s))
Func dss_res (Lift1 dts_res) -> Func dss_res (Lift2 dts_res)
--==========================================================--
-- ==========================================================--
--
acMakeInstance :: ACMode -> -- should be Safe for real applications
DExpr -> -- simplest instance domain of point (DXFunc _ _)
......@@ -437,6 +437,6 @@ acMakeInstance s_or_l
acConc s_or_l finalDomain basicDomain f_simplest
--==========================================================--
--=== end AbsConc3.hs ===--
--==========================================================--
-- ==========================================================--
-- === end AbsConc3.hs ===--
-- ==========================================================--
--==========================================================--
--=== Reduction of abstract expressions ===--
--=== AbstractEval2.hs ===--
--==========================================================--
-- ==========================================================--
-- === Reduction of abstract expressions ===--
-- === AbstractEval2.hs ===--
-- ==========================================================--
module AbstractEval2 where
import BaseDefs
......@@ -11,7 +11,7 @@ import MyUtils
import AbstractVals2
import Apply
--==========================================================--
-- ==========================================================--
--
aeEval :: HExpr Naam -> HExpr Naam
......@@ -38,7 +38,7 @@ aeEval (HApp f@(HPoint _) e)
aeEval x = panic "aeEval(4)"
--==========================================================--
-- ==========================================================--
--
aeEvalConst :: HExpr Naam -> Route
......@@ -46,7 +46,7 @@ aeEvalConst e
= case aeEval e of {HPoint p -> p; _ -> panic "aeEvalConst"}
--==========================================================--
-- ==========================================================--
--
aeEvalExact :: HExpr Naam -> [HExpr Naam] -> Route
......@@ -55,7 +55,7 @@ aeEvalExact (HLam vs e) args
{HPoint p -> p; _ -> panic "aeEvalExact"}
--==========================================================--
-- ==========================================================--
--
aeSubst :: AList Naam (HExpr Naam) -> HExpr Naam -> HExpr Naam
......@@ -68,7 +68,7 @@ aeSubst rho (HApp e1 e2) = HApp (aeSubst rho e1) (aeSubst rho e2)
aeSubst rho (HVAp f es) = HVAp (aeSubst rho f) (map (aeSubst rho) es)
--==========================================================--
-- ==========================================================--
--
aeMkMeet :: HExpr Naam -> [HExpr Naam] -> HExpr Naam
......@@ -77,6 +77,6 @@ aeMkMeet bottom [x] = x
aeMkMeet bottom xs = HMeet xs
--==========================================================--
--=== end AbstractEval2.hs ===--
--==========================================================--
-- ==========================================================--
-- === end AbstractEval2.hs ===--
-- ==========================================================--
--==========================================================--
--=== Miscellaneous operations in the Abstract value ===--
--=== world. AbstractMisc.hs ===--
--==========================================================--
-- ==========================================================--
-- === Miscellaneous operations in the Abstract value ===--
-- === world. AbstractMisc.hs ===--
-- ==========================================================--
module AbstractMisc where
import BaseDefs
......@@ -13,21 +13,21 @@ import SuccsAndPreds2
import List(nub) -- 1.3
--==========================================================--
-- ==========================================================--
--
amIAboves :: Domain -> Route -> [Route]
amIAboves d r = map (r \/) (spSuccsR d r)
--==========================================================--
-- ==========================================================--
--
amIBelows :: Domain -> Route -> [Route]
amIBelows d r = map (r /\) (spPredsR d r)
--==========================================================--
-- ==========================================================--
--
amPushUpFF :: Domain -> [Route] -> [Route]
......@@ -35,7 +35,7 @@ amPushUpFF d [] = []
amPushUpFF d xs = nub (concat (map (amIAboves d) xs))
--==========================================================--
-- ==========================================================--
--
amPushDownFF :: Domain -> [Route] -> [Route]
......@@ -43,7 +43,7 @@ amPushDownFF d [] = []
amPushDownFF d xs = nub (concat (map (amIBelows d) xs))
--==========================================================--
-- ==========================================================--
--
amAllUpSlices :: Domain -> [[Route]]
......@@ -51,7 +51,7 @@ amAllUpSlices d
= takeWhile (not.null) (iterate (amPushUpFF d) [avBottomR d])
--==========================================================--
-- ==========================================================--
--
amAllDownSlices :: Domain -> [[Route]]
......@@ -59,7 +59,7 @@ amAllDownSlices d
= takeWhile (not.null) (iterate (amPushDownFF d) [avTopR d])
--==========================================================--
-- ==========================================================--
--
amAllRoutes :: Domain -> [Route]
......@@ -76,7 +76,7 @@ amAllRoutes (Func dss dt)
= concat (amAllUpSlices (Func dss dt))
--==========================================================--
-- ==========================================================--
--
amUpCloseOfMinf :: Domain -> [Route] -> [Route]
......@@ -87,7 +87,7 @@ amUpCloseOfMinf d q@(x:_)
(avMinR [ y \/ z | y <- q, z <- spSuccsR d x ]))
--==========================================================--
-- ==========================================================--
--
amDownCloseOfMaxf :: Domain -> [Route] -> [Route]
......@@ -98,7 +98,7 @@ amDownCloseOfMaxf d q@(x:_)
(avMaxR [ y /\ z | y <- q, z <- spPredsR d x ]))
--==========================================================--
-- ==========================================================--
--
amAllRoutesMinusTopJONES :: Domain -> [Route]
......@@ -106,7 +106,7 @@ amAllRoutesMinusTopJONES d
= amDownCloseOfMaxf d (spPredsR d (avTopR d))
--==========================================================--
-- ==========================================================--
--
--amAllRoutesMinusTopMINE :: Domain -> [Route]
--
......@@ -120,7 +120,7 @@ amAllRoutesMinusTopJONES d
-- concat allSlices
--==========================================================--
-- ==========================================================--
--
amEqualPoints :: Point -> Point -> Bool
......@@ -130,7 +130,7 @@ amEqualPoints (d1, r1) (d2, r2)
else panic "Comparing points in different domains."
--==========================================================--
-- ==========================================================--
--
amIsaHOF :: Domain -> Bool
......@@ -139,7 +139,7 @@ amIsaHOF (Func dss dt)
myAny amContainsFunctionSpace dss
--==========================================================--
-- ==========================================================--
--
amContainsFunctionSpace :: Domain -> Bool
......@@ -149,14 +149,14 @@ amContainsFunctionSpace (Lift2 dss) = myAny amContainsFunctionSpace dss
amContainsFunctionSpace (Func _ _) = True
--==========================================================--
-- ==========================================================--
--
amIsDataFn :: Domain -> Bool
amIsDataFn (Func _ dt) = not (amContainsFunctionSpace dt)
--==========================================================--
-- ==========================================================--
--
amRepArity :: Rep -> Int
......@@ -165,7 +165,7 @@ amRepArity (Rep1 (Min1Max0 lf_ar lf_f1 lf_f0) hfs) = lf_ar
amRepArity (Rep2 (Min1Max0 lf_ar lf_f1 lf_f0) mf hfs) = lf_ar
--==========================================================--
-- ==========================================================--
--
amStrongNormalise :: Domain -> Domain
......@@ -185,7 +185,7 @@ amStrongNormalise (Func dss non_func_res)
= Func (map amStrongNormalise dss) (amStrongNormalise non_func_res)
--==========================================================--
-- ==========================================================--
--
amMeetIRoutes :: Domain -> [Route]
......@@ -200,7 +200,7 @@ amMeetIRoutes (Lift2 ds)
map UpUp2 (myListVariants (map avTopR ds) (map amMeetIRoutes ds))
--==========================================================--
--=== end AbstractMisc.hs ===--
--==========================================================--
-- ==========================================================--
-- === end AbstractMisc.hs ===--
-- ==========================================================--
--==========================================================--
--=== Revised domain operations for HO analysis ===--
--=== AbstractVals2.hs ===--
--==========================================================--
-- ==========================================================--
-- === Revised domain operations for HO analysis ===--
-- === AbstractVals2.hs ===--
-- ==========================================================--
module AbstractVals2 where
import BaseDefs
......@@ -15,13 +15,13 @@ infix 9 /\ -- Binary GLB for routes
infix 9 \/ -- Binary LUB for routes
--==========================================================--
--=== ===--
--=== Top and bottom points of domains. ===--
--=== ===--
--==========================================================--
-- ==========================================================--
-- === ===--
-- === Top and bottom points of domains. ===--
-- === ===--
-- ==========================================================--
--==========================================================--
-- ==========================================================--
--
avUncurry :: [Domain] -> Domain -> Domain
......@@ -29,7 +29,7 @@ avUncurry dss (Func dss2 dt) = Func (dss++dss2) dt
avUncurry dss non_func_dom = Func dss non_func_dom
--==========================================================--
-- ==========================================================--
--
avTopR :: Domain -> Route
......@@ -39,7 +39,7 @@ avTopR (Lift2 ds) = UpUp2 (map avTopR ds)
avTopR d@(Func dss dt) = Rep (avTopR_aux d)
--==========================================================--
-- ==========================================================--
--
avTopR_aux_2 :: [Domain] -> Frontier
......@@ -47,7 +47,7 @@ avTopR_aux_2 dss
= Min1Max0 (length dss) [MkFrel (map avBottomR dss)] []
--==========================================================--
-- ==========================================================--
--
avTopR_aux :: Domain -> Rep
......@@ -69,7 +69,7 @@ avTopR_aux (Func dss (Lift2 dts))
Rep2 lf lf hfs
--==========================================================--
-- ==========================================================--
--
avBottomR :: Domain -> Route
......@@ -79,7 +79,7 @@ avBottomR (Lift2 ds) = Stop2
avBottomR d@(Func dss dt) = Rep (avBottomR_aux d)
--==========================================================--
-- ==========================================================--
--
avBottomR_aux_2 :: [Domain] -> Frontier
......@@ -87,7 +87,7 @@ avBottomR_aux_2 dss
= Min1Max0 (length dss) [] [MkFrel (map avTopR dss)]
--==========================================================--
-- ==========================================================--
--
avBottomR_aux :: Domain -> Rep
......@@ -109,7 +109,7 @@ avBottomR_aux (Func dss (Lift2 dts))
Rep2 lf lf hfs
--==========================================================--
-- ==========================================================--
--
avIsBottomR :: Route -> Bool
......@@ -123,7 +123,7 @@ avIsBottomR (UpUp2 _) = False
avIsBottomR (Rep r) = avIsBottomRep r
--==========================================================--
-- ==========================================================--
--
avIsBottomRep :: Rep -> Bool
......@@ -135,7 +135,7 @@ avIsBottomRep (Rep2 (Min1Max0 lf_ar lf_f1 lf_f0) mf hfs)
= null lf_f1
--==========================================================--
-- ==========================================================--
-- Is this correct? I think so.
--
avIsTopR :: Route -> Bool
......@@ -150,7 +150,7 @@ avIsTopR (UpUp2 rs) = myAll avIsTopR rs
avIsTopR (Rep r) = avIsTopRep r
--==========================================================--
-- ==========================================================--
--
avIsTopRep :: Rep -> Bool
......@@ -162,13 +162,13 @@ avIsTopRep (Rep2 lf mf hfs)
= myAll avIsTopRep hfs
--==========================================================--
--=== ===--
--=== Partial ordering predicates for points in domains. ===--
--=== ===--
--==========================================================--
-- ==========================================================--
-- === ===--
-- === Partial ordering predicates for points in domains. ===--
-- === ===--
-- ==========================================================--
--==========================================================--
-- ==========================================================--
--
(<<) :: Route -> Route -> Bool
......@@ -189,7 +189,7 @@ UpUp2 rs1 << _ = False
Rep rep1 << Rep rep2 = avBelowEQrep rep1 rep2
--==========================================================--
-- ==========================================================--
-- A little bit of Cordy-style loop unrolling
-- although not actually tail-strict :-)
--
......@@ -239,7 +239,7 @@ avLEQR_list (a1:a2:a3:a4:as@(_:_)) (b1:b2:b3:b4:bs@(_:_))
avLEQR_list _ _ = panic "avLEQR_list: unequal lists"
--==========================================================--
-- ==========================================================--
--
avBelowEQfrel :: FrontierElem -> FrontierElem -> Bool
......@@ -247,7 +247,7 @@ avBelowEQfrel (MkFrel rs1) (MkFrel rs2)
= avLEQR_list rs1 rs2
--==========================================================--
-- ==========================================================--
--
avBelowEQfrontier :: Frontier -> Frontier -> Bool
......@@ -268,7 +268,7 @@ avBelowEQfrontier (Min1Max0 ar1 f1a f0a) (Min1Max0 ar2 f1b f0b)