Commit a1d221a2 authored by dnt's avatar dnt

[project @ 1996-11-26 15:44:35 by dnt]

Merged in changes from new-build-system branch
parent c29bb749
{-
From: Paul Sanders <psanders@srd.bt.co.uk>
To: partain
Subject: A puzzle for you
Date: Mon, 28 Oct 91 17:02:19 GMT
I'm struggling with the following code fragment at the moment:
-}
conv_list :: [a] -> [b] -> [[c]] -> Array (a,b) c -> Array (a,b) c
conv_list [] _ _ ar = ar
conv_list _ _ [] ar = ar
conv_list (r:rs) cls (rt:rts) ar
= conv_list rs cls rts ar'
where ar' = conv_elems r cls rt ar
conv_elems :: a -> [b] -> [c] -> Array (a,b) c -> Array (a,b) c
conv_elems row [] _ ar = ar
conv_elems _ _ [] ar = ar
conv_elems row (col:cls) (rt:rts) ar
= conv_elems row cls rts ar'
where ar' = ar // ((row,col) := rt)
ar_list = [[1,2,3],
[6,7,8],
[10,12,15]]
ar :: Array (Int, Int) Int
ar = conv_list [1..3] [1..3] ar_list init_ar
where init_ar = array ((1,1),(3,3)) []
main = appendChan stdout (show ar) abort done
{-
What it tries to do is turn a list of lists into a 2-d array in an incremental
fashion using 2 nested for-loops. It compiles okay on the prototype compiler
but gives a segmentation fault when it executes. I know I can define in the
array in one go (and I have done) but, for my piece of mind, I want to get this
way working properly.
Is it a bug in the prototype or is there a glaringly obvious error in my code
which I've been stupid to spot ????
Hoping its the latter,
Paul.
-}
import GlasgowIOMonad
import GlasgowIO
data CList = CNil | CCons Int CList
mk :: Int -> CList
mk n = if (n == 0) then
CNil
else
CCons 1 (mk (n - 1))
clen :: CList -> Int
clen CNil = 0
clen (CCons _ cl) = 1 + (clen cl)
main = case (clen list4) of
len4 ->
case (len4 `plusInt` len4) of
8 -> finish 65# -- 'A'
_ -> finish 66# -- 'B'
where
list4 = mk 4
finish :: IntPrim -> IO ()
finish n = ccall putchar n `thenIOPrim_` returnIO ()
import GlasgowIOMonad
import GlasgowIO
main = if foo == (1::Int) then
finish 65# -- 'A'
else
finish 66# -- 'B'
where
foo = f (f 3)
f = if ((3::Int) > (4::Int)) then inc else dec
inc, dec :: Int -> Int
inc x = x+1
dec x = x-1
finish :: IntPrim -> IO ()
finish n = ccall putchar n `thenIOPrim_` returnIO ()
import GlasgowIOMonad
import GlasgowIO
main = if foo == (16::Int) then
finish 65# -- 'A'
else
finish 66# -- 'B'
where
foo = twice twice twice inc 0
twice f x = f (f x)
inc :: Int -> Int
inc x = x+1
finish :: IntPrim -> IO ()
finish n = ccall putchar n `thenIOPrim_` returnIO ()
#define IHaveSubdirs
#if IncludeRealNoFibTests == YES
#define _RealTests real
#else
#define _RealTests /*none*/
#endif
#if IncludeSpectralNoFibTests == YES
#define _SpectralTests spectral
#else
#define _SpectralTests /*none*/
#endif
#if IncludeImaginaryNoFibTests == YES
#define _ImaginaryTests imaginary
#else
#define _ImaginaryTests /*none*/
#endif
#if IncludePENDINGNoFibTests == YES
#define _PENDINGTests PENDING
#else
#define _PENDINGTests /*none*/
#endif
#if IncludeUNUSEDNoFibTests == YES
#define _UNUSEDTests UNUSED
#else
#define _UNUSEDTests /*none*/
#endif
#if IncludeGHC_ONLYNoFibTests == YES
#define _GHC_ONLYTests GHC_ONLY
#else
#define _GHC_ONLYTests /*none*/
#endif
#if IncludePRIVATENoFibTests == YES
#define _PRIVATETests PRIVATE
#else
#define _PRIVATETests /*none*/
#endif
#if IncludeParallelNoFibTests == YES
#define _ParallelTests parallel
#else
#define _ParallelTests /*none*/
#endif
SUBDIRS = _GHC_ONLYTests _PRIVATETests _ParallelTests _PENDINGTests _UNUSEDTests _ImaginaryTests _SpectralTests _RealTests
# $Id: Makefile,v 1.2 1996/11/26 15:44:36 dnt Exp $
TOP = ..
SUBDIRS =
ifeq ($(IncludeImaginaryNoFibTests), YES)
SUBDIRS += imaginary
endif
ifeq ($(IncludeSpectralNoFibTests), YES)
SUBDIRS += spectral
endif
ifeq ($(IncludeRealNoFibTests), YES)
SUBDIRS += real
endif
ifeq ($(IncludePENDINGNoFibTests), YES)
SUBDIRS += PENDING
endif
ifeq ($(IncludeUNUSEDNoFibTests), YES)
SUBDIRS += UNUSED
endif
ifeq ($(IncludeGHC_ONLYNoFibTests), YES)
SUBDIRS += GHC_ONLY
endif
ifeq ($(IncludePRIVATENoFibTests), YES)
SUBDIRS += PRIVATE
endif
ifeq ($(IncludeParallelNoFibTests), YES)
SUBDIRS += parallel
endif
include $(TOP)/nofib/mk/nofib.mk
succ :: Int -> Int
succ x = x + 1
isdivs :: Int -> Int -> Bool
isdivs n x = mod x n /= 0
the_filter :: [Int] -> [Int]
the_filter (n:ns) = filter (isdivs n) ns
main = let
primes :: [Int]
primes = map head (iterate the_filter (iterate succ 2))
in
print (primes !! 1500)
--OLD: main = print (take 300 primes)
include $(TOP)/nofib/mk/site.mk
#-----------------------------------------------------------------------------
# General utilities
SHELL = /bin/sh
RM = rm -f
TIME = time
STRIP = strip
SIZE = size
#-----------------------------------------------------------------------------
# Haskell utilities
ifdef UseInstalledUtils
RUNSTDTEST = runstdtest
else
RUNSTDTEST = $(TOP)/glafp-utils/runstdtest/runstdtest
endif
#-----------------------------------------------------------------------------
# The 'all' target prints out the corrent configuration and builds runtests.
all ::
@echo HC = $(HC)
@echo HCFLAGS = $(HCFLAGS)
@echo RUNTESTFLAGS = $(RUNTESTFLAGS)
print_% ::
@echo HCFLAGS_$* = $(HCFLAGS_$*)
all :: $(foreach way,$(WAYS),print_$(way)) runtests
#-----------------------------------------------------------------------------
# Subdirs stuff.
ifdef SUBDIRS
clean::
@case '${MFLAGS}' in *[ik]*) set +e;; esac; \
for i in $(SUBDIRS) ; do \
$(MAKE) -C $$i $(MFLAGS) clean; \
done
veryclean::
@case '${MFLAGS}' in *[ik]*) set +e;; esac; \
for i in $(SUBDIRS) ; do \
$(MAKE) -C $$i $(MFLAGS) veryclean; \
done
runtests::
@case '${MFLAGS}' in *[ik]*) set +e;; esac; \
for i in $(SUBDIRS) ; do \
$(MAKE) -C $$i $(MFLAGS) runtests; \
done
endif
#-----------------------------------------------------------------------------
# Cleaning things.
clean ::
$(RM) *.CKP *.ln *.BAK *.bak *.o core a.out ,* *.a .emacs_* *.hi
$(RM) tags TAGS *.ind *.ilg *.idx *.idx-prev *.aux *.aux-prev *.dvi
$(RM) *.log *.toc *.lot *.lof *.blg *.info *.itxi *.itex *.cb errs
veryclean ::
$(RM) .??*~ *~ *.orig *.rej
#-----------------------------------------------------------------------------
# Nofib program targets.
ifdef PROG
ifndef SRCS
SRCS = Main.hs
endif
OBJS = $(patsubst %.lhs, %.o, $(patsubst %.hs, %.o, $(SRCS)))
define COMPILE
@echo === compiling $(PROG)/$@ $(EXTRA_HCFLAGS) ===
@$(TIME) $(HC) $(HCFLAGS) $(EXTRA_HCFLAGS) -o $@ -c $< \
$(HCFLAGS_$(patsubst .%,%,$(suffix $(basename $@))))
@echo === size of $(PROG)/$@ ===
@$(SIZE) $@
endef
%.normal.o %.mc.o %.mr.o %.mt.o %.mp.o %.mg.o %.2s.o %.1s.o %.du.o \
%.a.o %.b.o %.c.o %.d.o %.e.o %.f.o %.g.o %.h.o %.i.o %.j.o %.k.o \
%.l.o %.m.o %.n.o %.o.o %.p.o %.A.o %.B.o : %.hs
$(COMPILE)
%.normal.o %.mc.o %.mr.o %.mt.o %.mp.o %.mg.o %.2s.o %.1s.o %.du.o \
%.a.o %.b.o %.c.o %.d.o %.e.o %.f.o %.g.o %.h.o %.i.o %.j.o %.k.o \
%.l.o %.m.o %.n.o %.o.o %.p.o %.A.o %.B.o : %.lhs
$(COMPILE)
$(PROG)_% : $(OBJS:.o=.%.o)
@echo === linking $@ $(EXTRA_HCFLAGS) ===
@$(TIME) $(HC) $(HCFLAGS) $(EXTRA_HCFLAGS) -o $@ $^ $(LIBS)
@$(STRIP) $@
@echo === size of $@ ===
@$(SIZE) $@
runtest_% : $(PROG)_%
@echo === running $< $(EXTRA_RUNTESTFLAGS) ===
@$(TIME) $(RUNSTDTEST) ./$< \
$(addprefix -i ,$(wildcard $(PROG).stdin)) \
$(addprefix -o1 ,$(wildcard $(PROG).stdout)) \
$(addprefix -o2 ,$(wildcard $(PROG).stderr)) \
$(RUNTESTFLAGS) $(EXTRA_RUNTESTFLAGS)
runtests :: $(foreach way,$(WAYS),$(PROG)_$(way) runtest_$(way))
clean ::
$(RM) $(foreach way,$(WAYS),$(PROG)_$(way))
endif
#-----------------------------------------------------------------------------
# $Id: site.mk,v 1.2 1996/11/26 15:44:59 dnt Exp $
#-----------------------------------------------------------------------------
# Haskell compiler
#HC = $(TOP)/ghc/driver/ghc
HC = ghc-2.01
HCFLAGS = -H32m -K2m
#-----------------------------------------------------------------------------
# Flags to use when we run a test
RUNTESTFLAGS = +RTS -H48m -K32m --RTS
#-----------------------------------------------------------------------------
# Set WAYS according to which ways you want to build the nofib suite
WAYS = normal
#WAYS = normal mc mr mt mp mg 2s 1s du p t a b c d e f g h i j k l m n o p A B
# ================================================================
# BUILDS stuff: main sequential ones
HCFLAGS_normal =
HCFLAGS_p = -prof
HCFLAGS_t =
HCFLAGS_u =
# === builds: concurrent and parallel ============================
HCFLAGS_mc =
HCFLAGS_mr =
HCFLAGS_mt =
HCFLAGS_mp =
HCFLAGS_mg =
# === builds: non-std garbage collectors ==========================
HCFLAGS_2s = -gc-2s
HCFLAGS_1s = -gc-1s
HCFLAGS_du = -gc-du
# === builds: "user ways" =======================================
HCFLAGS_a =
HCFLAGS_b =
HCFLAGS_c =
HCFLAGS_d =
HCFLAGS_e =
HCFLAGS_f =
HCFLAGS_g =
HCFLAGS_h =
HCFLAGS_i =
HCFLAGS_j =
HCFLAGS_k =
HCFLAGS_l =
HCFLAGS_m =
HCFLAGS_n =
HCFLAGS_o =
HCFLAGS_A =
HCFLAGS_B =
TOP = ../..
SUBDIRS = anna bspt compress compress2 ebnf2ps fluid fulsom gamteb gg \
grep hidden HMMS hpg infer lift maillist mkhprog parser pic prolog \
reptile rsa symalg veritas
include $(TOP)/nofib/mk/nofib.mk
......@@ -149,29 +149,6 @@ maStrictAn table flagsInit fileName
fullEnvAug = fullEnv ++ map2nd deScheme maBaseTypes
deScheme (Scheme _ texpr) = texpr
{-
--==========================================================--
--
anna :: [Flag] -> String -> Dialogue
anna flags name
= getEnv "ANNADIR" noANNADIR (\anna_dir ->
readFile (anna_dir++"/anna_table") noTable (\tablestr ->
let table = rtReadTable tablestr in
readFile (name++".cor") noFile (\str ->
let result = maStrictAn table flags str in
appendChan stdout result writeFails done)))
where
noANNADIR err = abandon "ANNADIR not defined"
noTable err = abandon "Cannot find $ANNADIR/table"
noFile err = abandon ("Can't open "++name++".cor")
writeFails (WriteError s) = abandon s
abandon s = appendChan stdout s abort done
getEnv envvar fail succ = succ "/home/r62/users/sewardj/Bin"
twords n = "\nRead " ++ show n ++ " lattice sizes.\n"
-}
--==========================================================--
--
--main :: [Response] -> [Request]
......@@ -182,47 +159,11 @@ main = do
raw_args <- getArgs
let cmd_line_args = maGetFlags raw_args
anna_dir <- getEnv "ANNADIR"
tableStr <- readFile (anna_dir++"/anna_table")
tableStr <- readFile (anna_dir ++ "/anna_table")
file_contents <- getContents
let table = rtReadTable tableStr
putStr (maStrictAn table cmd_line_args file_contents)
{- OLD 1.2
main resps
= [
GetArgs,
fr 0 (GetEnv "ANNADIR"),
fr 1 (ReadFile ),
fr 2 (ReadChan stdin),
fr 3 (AppendChan stdout )
] ++ fr 4 [] (maStrictAn table cmd_line_args file_contents)
where
cmd_line_args = case (resps ## 0) of
StrList ss -> maGetFlags ss
_ -> panic "GetArgs request failed"
anna_dir = case (mySeq cmd_line_args (resps ## 1)) of
Str s -> s
_ -> myFail "Environment variable \"ANNADIR\" is not set."
tableStr = case (mySeq anna_dir (resps ## 2)) of
Str s -> s
_ -> myFail ("Can't read " ++ anna_dir ++ "/anna_table")
file_contents = case (mySeq (head tableStr) (resps ## 3)) of
Str s -> s
_ -> panic "ReadChan request failed"
--append_res = case (mySeq (head file_contents) (resps ## 4)) of
-- Success -> (42 :: Int)
-- _ -> panic "AppendChan request failed"
fr n x = case resps ## n of
Success -> x
_ -> x
table = rtReadTable tableStr
-}
--==========================================================--
--
......
TOP = ../../..
PROG = anna
SRCS = BaseDefs.hs MyUtils.hs Utils.hs AbstractVals2.hs \
SuccsAndPreds2.hs AbstractMisc.hs Dependancy.hs \
MakeDomains.hs Parser2.hs PrettyPrint.hs LambdaLift5.hs \
TypeCheck5.hs EtaAbstract.hs DomainExpr.hs AbsConc3.hs Apply.hs \
Inverse.hs BarakiMeet.hs BarakiConc3.hs \
Constructors.hs TExpr2DExpr.hs AbstractEval2.hs \
PrintResults.hs Simplify.hs SmallerLattice.hs \
FrontierMisc2.hs FrontierDATAFN2.hs FrontierGENERIC2.hs \
StrictAn6.hs ReadTable.hs Main.hs
EXTRA_RUNTESTFLAGS = \
-prescript ./anna.prescript -postscript ./anna.postscript \
-i big.cor -o1 big.sum.out
include $(TOP)/nofib/mk/nofib.mk
TOP = ../../..
PROG = bspt
SRCS = BSPT.lhs Euclid.lhs EuclidGMS.lhs GeomNum.lhs Init.lhs \
Input.lhs Interface.lhs Interpret.lhs Libfuns.lhs MGRlib.lhs \
Main.lhs Merge.lhs Params.lhs Prog.lhs Rationals.lhs \
Render.lhs Stdlib.lhs
include $(TOP)/nofib/mk/nofib.mk
interface Fulsom where {
{-# IMPORTING Shapes, Quad, Raster, Oct, Interval, Types #-}
main :: Dialogue {-# ARITY main = 1 #-}{-# STRICTNESS main = "T,T" ST #-}
}
--==========================================================--
--=== Raw lexical analysis (tokenisation) of source ===--
--=== Lexer.hs ===--
--==========================================================--
module Main where
----------------------------------------------------------
-- Lexemes --
----------------------------------------------------------
type Token = (Int, Int, Lex, String) -- (line, column, lexeme type, value)
data Lex = Lcon -- constructor used as prefix:
-- normal prefix constructor,
-- or bracketed infix constructor
| Lconop -- constructor used as infix:
-- normal prefix constructor in backquotes,
-- or infix constructor (starting with ":")
| Lvar -- variable used as prefix:
-- normal prefix variable,
-- or bracketed infix var (operator)
| Lvarop -- variable used as infix:
-- normal prefix variable in backquotes,
-- or infix variable (operator)
--| Ltycon -- constructor starting with A-Z
-- subcase of Lcon
--| Ltyvar -- variable starting with a-z
-- subcase of Lvar
| Lintlit -- integer literal
| Lcharlit -- character literal
| Lstringlit -- string literal
| Llbrace -- {
| Lrbrace -- }
| Lsemi -- ;
| Lequals -- =
| Lbar -- |
| Larrow -- ->
| Llparen -- (
| Lrparen -- )
| Lcomma -- ,
| Llbrack -- [
| Lrbrack -- ]
| Lunder -- _
| Lminus -- -
| Lslash -- \
| Lmodule
| Linfixl
| Linfixr
| Linfix
| Lext
| Ldata
| Lif
| Lthen
| Lelse
| Llet
| Lin
| Lcase
| Lof
| Lwhere
| Leof
#ifndef __GLASGOW_HASKELL__
deriving (Eq, Text)
#else
instance Eq Lex where
a == b = tag_Lex a == tag_Lex b
where
tag_Lex Lcon = (1::Int)
tag_Lex Lconop = 2
tag_Lex Lvar = 3
tag_Lex Lvarop = 4
tag_Lex Lintlit = 5
tag_Lex Lcharlit = 6
tag_Lex Lstringlit = 7
tag_Lex Llbrace = 8
tag_Lex Lrbrace = 9
tag_Lex Lsemi = 10
tag_Lex Lequals = 11
tag_Lex Lbar = 12
tag_Lex Larrow = 13
tag_Lex Llparen = 14
tag_Lex Lrparen = 15
tag_Lex Lcomma = 16
tag_Lex Llbrack = 17
tag_Lex Lrbrack = 18
tag_Lex Lunder =19
tag_Lex Lminus = 20
tag_Lex Lslash = 21
tag_Lex Lmodule = 22
tag_Lex Linfixl = 23
tag_Lex Linfixr = 24
tag_Lex Linfix = 25
tag_Lex Lext = 26
tag_Lex Ldata =27
tag_Lex Lif = 28
tag_Lex Lthen = 29
tag_Lex Lelse = 30
tag_Lex Llet =31
tag_Lex Lin = 32
tag_Lex Lcase = 33
tag_Lex Lof = 34
tag_Lex Lwhere = 35
tag_Lex Leof = 36
(/=) = dEFAULT_ne
#endif
{-
Lexing rules:
case (
if next is \, -> Llparen
if next is symbol, take symbols and expect closing ) -> Lvar
if next is :, take tail-ident-chars, expect closing ) -> Lcon
otherwise -> Llparen
case `
if next A-Z, take tail-ident-chars, expect ` -> Lconop
if next a-z, take tail-ident-chars, expect ` -> Lvarop
otherwise -> error
case A-Z
take tail-ident-chars -> Lcon