some small fixes

docs/overloaded-strings.md

@@ -0,0 +1,92 @@
+# Overloaded string literals
+
+`OverloadedStrings`
+
+:   Since:   GHC 6.8.1
+
+    Enable overloaded string literals (e.g. string literals desugared
+    via the `IsString` class).
+
+GHC supports *overloaded string literals*. Normally a string literal has
+type `String`, but with overloaded
+string literals enabled (with `OverloadedStrings`) a
+string literal has type `(IsString a) => a`.
+
+This means that the usual string syntax can be used, e.g., for
+`ByteString`, `Text`, and other variations of string like types. String
+literals behave very much like integer literals, i.e., they can be used
+in both expressions and patterns. If used in a pattern the literal will
+be replaced by an equality test, in the same way as an integer literal
+is.
+
+The class `IsString` is defined as:
+
+```haskell
+class IsString a where
+    fromString :: String -> a
+```
+
+The only predefined instance is the obvious one to make strings work as
+usual:
+
+```haskell
+instance IsString [Char] where
+    fromString cs = cs
+```
+
+The class `IsString` is not in scope by
+default. If you want to mention it explicitly (for example, to give an
+instance declaration for it), you can import it from module
+`Data.String`.
+
+Haskell's defaulting mechanism ([Haskell Report, Section 4.3.4](https://www.haskell.org/onlinereport/decls.html#sect4.3.4))
+is extended to cover string literals, when
+`OverloadedStrings` is
+specified. Specifically:
+
+-   Each type in a `default`
+    declaration must be an instance of `Num`
+    *or* of `IsString`.
+-   If no `default` declaration is
+    given, then it is just as if the module contained the declaration
+    `default( Integer, Double, String)`.
+-   The standard defaulting rule is extended thus: defaulting applies
+    when all the unresolved constraints involve standard classes *or*
+    `IsString`; and at least one is a
+    numeric class *or* `IsString`.
+
+So, for example, the expression `length "foo"`
+will give rise to an ambiguous use of
+`IsString a0` which, because of the
+above rules, will default to `String`.
+
+A small example:
+
+```haskell
+module Main where
+
+import Data.String( IsString(..) )
+
+newtype MyString = MyString String deriving (Eq, Show)
+instance IsString MyString where
+    fromString = MyString
+
+greet :: MyString -> MyString
+greet "hello" = "world"
+greet other = other
+
+main = do
+    print $ greet "hello"
+    print $ greet "fool"
+```
+
+Note that deriving `Eq` is necessary
+for the pattern matching to work since it gets translated into an
+equality comparison.
+
+---
+© Copyright 2023, GHC Team.
+
+Adapted from
+<https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/overloaded_strings.html>
+(accessed 2024-06-21 14:45 BST).

download-packages.sh

@@ -149,6 +149,9 @@ download_tool "cpphs" $cpphs_ver $cpphs_md5
 download_tool "hsc2hs" $hsc2hs_ver $hsc2hs_md5
 download_tool "happy" $happy_ver $happy_md5
 
+#apply patch for hsc2hs
+cat patches/hsc2hs-001-add-alignment-feature.patch|patch -p1 -d hsc2hs
+
 #apply patch for happy
 cat patches/happy-001-use-cpphs-hugs-to-generate-templates.patch|patch -p1 -d happy
 cp patches/happy/*.hs happy/src/
@@ -174,3 +177,7 @@ popd >/dev/null
 cat patches/base-001-check-gettimeofday.patch|patch -p1 -d packages/base
 cat patches/base-002-fix-upstream-mistake.patch|patch -p1 -d packages/base
 cat patches/base-003-fix-clang-preprocess.patch|patch -p1 -d packages/base
+cat patches/base-004-utf8-to-ascii.patch|patch -p1 -d packages/base
+
+find */ -name config.sub -exec cp config.sub '{}' \;
+find */ -name config.guess -exec cp config.guess '{}' \;

libraries/hugsbase/Hugs/Dynamic.hs

@@ -1,6 +1,7 @@
-module Hugs.Dynamic(module Data.Dynamic, coerceDynamic, runDyn) where
+module Hugs.Dynamic(module Data.Dynamic, coerceDynamic, runDyn, runDynInt, runDynAddr) where
 
 import Data.Dynamic
+import Hugs.Ptr
 
 coerceDynamic :: Typeable a => Dynamic -> a
 coerceDynamic d = fromDyn d def
@@ -9,3 +10,9 @@ coerceDynamic d = fromDyn d def
 
 runDyn :: Dynamic -> IO ()
 runDyn = coerceDynamic
+
+runDynInt :: Dynamic -> IO Int
+runDynInt = coerceDynamic
+
+runDynAddr :: Dynamic -> IO (Ptr ())
+runDynAddr = coerceDynamic

libraries/hugsbase/Hugs/Prelude.hs

@@ -977,11 +977,12 @@ instance RealFloat Float where
     floatRange  _ = (primFloatMinExp, primFloatMaxExp)
     encodeFloat = primFloatEncode
     decodeFloat = primFloatDecode
-    isNaN       _ = False
-    isInfinite  _ = False
-    isDenormalized _ = False
-    isNegativeZero _ = False
-    isIEEE      _ = False
+    isNaN       x = not (x == x)
+    isInfinite  x = recip x == 0
+    isDenormalized x = x /= 0 && abs x < smallestNormal
+      where smallestNormal = encodeFloat 1 (fst (floatRange x) - 1)
+    isNegativeZero x = x == 0 && 1 / x < 0
+    isIEEE      _ = True
 
 primitive primDoubleRadix  :: Integer
 primitive primDoubleDigits :: Int
@@ -996,11 +997,12 @@ instance RealFloat Double where
     floatRange  _ = (primDoubleMinExp, primDoubleMaxExp)
     encodeFloat   = primDoubleEncode
     decodeFloat   = primDoubleDecode
-    isNaN       _ = False
-    isInfinite  _ = False
-    isDenormalized _ = False
-    isNegativeZero _ = False
-    isIEEE      _ = False
+    isNaN       x = not (x == x)
+    isInfinite  x = recip x == 0
+    isDenormalized x = x /= 0 && abs x < smallestNormal
+      where smallestNormal = encodeFloat 1 (fst (floatRange x) - 1)
+    isNegativeZero x = x == 0 && 1 / x < 0
+    isIEEE      _ = True
 
 instance Enum Float where
     succ x                = x+1

packages.list

@@ -4,6 +4,7 @@ bytestring-0.9.0.1 f4c9d187a5d954e8136a995ceaa83781
 Cabal-1.6.0.3 71cf18d4b49734142c273a9c4ce063ed
 cgi-3001.1.5.1 ae66c8147039a9146705401e732b7868
 containers-0.2.0.0 c8a44ffb6626bf60c53fbf9f785c7197
+deepseq-1.1.0.2 90b66480f0eb659c1db209ee703e0162
 directory-1.0.0.3 f421321ec2c48413eb0c0067dd5db607
 fgl-5.4.1.1 c5e8b1dbec6134dcab655de47311153f
 filepath-1.1.0.0 0cc3f09ebafa7bde0a3c9e01d5e7c09f

patches/base-004-utf8-to-ascii.patch

@@ -0,0 +1,11 @@
+--- base/Data/Monoid.hs	2024-06-20 20:54:40.200804655 +0100
++++ basen/Data/Monoid.hs	2024-06-20 22:04:43.390804906 +0100
+@@ -189,7 +189,7 @@
+ -- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to
+ -- <http://en.wikipedia.org/wiki/Monoid>: \"Any semigroup @S@ may be
+ -- turned into a monoid simply by adjoining an element @e@ not in @S@
+--- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\" Since
++-- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ? S@.\" Since
+ -- there is no \"Semigroup\" typeclass providing just 'mappend', we
+ -- use 'Monoid' instead.
+ instance Monoid a => Monoid (Maybe a) where

patches/hsc2hs-001-add-alignment-feature.patch

@@ -0,0 +1,12 @@
+--- hsc2hs.orig/template-hsc.h	2024-06-19 16:43:10.893708694 +0000
++++ hsc2hs/template-hsc.h	2024-06-19 16:42:15.209200635 +0000
+@@ -72,6 +72,9 @@
+ #define hsc_size(t) \
+     printf("(%ld)", (long) sizeof(t));
+
++#define hsc_alignment(t) \
++    printf("(%ld)", (long) __alignof(t));
++
+ #define hsc_enum(t, f, print_name, x)         \
+     print_name;                               \
+     printf (" :: %s\n", #t);                  \

src/bignums.c

@@ -114,7 +114,7 @@ Int n; {
 	unsigned long no;
 	Cell nx;
 	if (n<0) {
-	    no = (unsigned long)(-n);
+	    no = (unsigned long)(-(signed long)n);
 	    bn = pair(NEGNUM,NIL);
 	}
 	else {
@@ -192,22 +192,14 @@ Bignum n; {
 		m = digitOf(hd(ds));
 		while (nonNull(ds=tl(ds))) {
 		    Int d = digitOf(hd(ds));
-		    if (b > (Int)(MAXHUGSWORD/BIGBASE))
-			return NIL;
 		    b *= BIGBASE;
-		    if (d > (Int)((MAXHUGSWORD - m)/b))
-			return NIL;
 		    m += b*d;
 		}
 	    } else { /* fst(n)==NEGNUM */
 		m = - digitOf(hd(ds));
 		while (nonNull(ds=tl(ds))) {
 		    Int d = - digitOf(hd(ds));
-		    if (b > (MAXPOSINT/BIGBASE))
-			return NIL;
 		    b *= BIGBASE;
-		    if (d < (MINNEGINT - m)/b)
-			return NIL;
 		    m += b*d;
 		}
 	    }

src/errors.c

@@ -178,15 +178,24 @@ sigHandler(breakHandler) {              /* respond to break interrupt      */
 /* --------------------------------------------------------------------------
  * Stack overflow handler:
  * ------------------------------------------------------------------------*/
-void stackOverflow(int emergency, stackoverflow_context_t scp) {
-    sigsegv_leave_handler();
+void stackOverflow_continuation(void *arg1, void *arg2, void *arg3) {
+    int emergency = (intptr_t)(arg1);
     breakOn(TRUE);
     if (emergency)
 	fatal("Stack overflow");
     else
 	hugsStackOverflow();
     /*NOTREACHED*/
 }
+void stackOverflow(int emergency, stackoverflow_context_t scp) {
+#if LIBSIGSEGV_VERSION >= 0x0206
+    sigsegv_leave_handler(stackOverflow_continuation, (void *)(intptr_t)(emergency), NULL, NULL);
+#else
+    sigsegv_leave_handler();
+    stackOverflow_continuation((void *)(intptr_t)(emergency), NULL, NULL);
+#endif
+    /*NOTREACHED*/
+}
 #endif
 
 /* --------------------------------------------------------------------------

src/server.c

@@ -274,6 +274,8 @@ HugsServerAPI* hserv; {
  * ------------------------------------------------------------------------*/
 #ifndef NO_DYNAMIC_TYPES
 static Name  nameRunDyn;
+static Name  nameRunDynInt;
+static Name  nameRunDynAddr;
 static Name  nameDynApp;
 static Name  nameToDyn;
 static Name  nameCoerceDynamic;
@@ -282,12 +284,16 @@ static Class classTypeable;
 static Bool linkDynamic()
 {
     nameRunDyn        = findName(findText("runDyn"));
+    nameRunDynInt     = findName(findText("runDynInt"));
+    nameRunDynAddr    = findName(findText("runDynAddr"));
     nameDynApp        = findName(findText("dynApp"));
     nameToDyn         = findName(findText("toDyn"));
     nameCoerceDynamic = findName(findText("coerceDynamic"));
     classTypeable     = findClass(findText("Typeable"));
 
     return (   nonNull(nameRunDyn        )
+	    && nonNull(nameRunDynInt     )
+	    && nonNull(nameRunDynAddr    )
 	    && nonNull(nameDynApp        )
 	    && nonNull(nameToDyn         )
 	    && nonNull(nameCoerceDynamic )
@@ -707,7 +713,7 @@ static Int DoIO_Int(int* phval)
         StackPtr oldsp = sp;
         startEval();
 #ifndef NO_DYNAMIC_TYPES
-        ok = safeEval(ap(nameIORun,ap(nameRunDyn,pop())));
+        ok = safeEval(ap(nameIORun,ap(nameRunDynInt,pop())));
 #else
         ok = safeEval(ap(nameIORun,pop()));
 #endif
@@ -748,7 +754,7 @@ static Int DoIO_Addr(void** phval)
         StackPtr oldsp = sp;
         startEval();
 #ifndef NO_DYNAMIC_TYPES
-        ok = safeEval(ap(nameIORun,ap(nameRunDyn,pop())));
+        ok = safeEval(ap(nameIORun,ap(nameRunDynAddr,pop())));
 #else
         ok = safeEval(ap(nameIORun,pop()));
 #endif