shithub: MicroHs

Download patch

ref: 3bf37ac6467745a4fa52474a628786f2c3022f6a
parent: 4b09e427931ca2909c4f27b3d4fadc3e6ec25a04
author: Lennart Augustsson <lennart@augustsson.net>
date: Sat Oct 28 20:00:43 EDT 2023 

Make primtives for no-match and no-default.

These would be more nicely expressed by computing and
error message and calling error.  But that requires
parts of the prelude like (++) and showInt.


--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
 v4.0
-1133
-((A :0 _956) ((A :1 ((B _1002) _0)) ((A :2 (((S' _1002) _0) I)) ((A :3 _926) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _955) ((C _84) _5))) ((A :7 (((C' _6) (_973 _73)) ((_84 _971) _72))) ((A :8 ((B ((S _1002) _971)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_84 _210)) _10)) ((A :12 ((B (B (_82 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_82 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_82 _9)) P)) ((A :15 ((B (B (_82 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 (((C' B) _12) (((C' B) _12) (B _14)))) ((A :18 ((B (_82 _9)) (B (P _884)))) ((A :19 ((B (_82 _9)) (BK (P _884)))) ((A :20 ((_82 _9) ((S P) I))) ((A :21 ((B (_82 _9)) ((C (S' P)) I))) ((A :22 ((B Y) ((B (B (P (_14 _122)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _123)))))) ((A :23 ((B Y) ((B (B (P (_14 _884)))) ((B (C' B)) (B _13))))) ((A :24 _3) ((A :25 (T (_14 _884))) ((A :26 (_22 _85)) ((A :27 (R _34)) ((A :28 (T _33)) ((A :29 ((P _34) _33)) ((A :30 _34) ((A :31 ((C ((C S') _29)) I)) ((A :32 ((C S) _29)) ((A :33 K) ((A :34 A) ((A :35 ((_76 _920) _921)) ((A :36 ((_76 _930) (_80 _36))) ((A :37 _931) ((A :38 _932) ((A :39 (((S' _28) (_923 #97)) ((C _923) #122))) ((A :40 (((S' _28) (_923 #65)) ((C _923) #90))) ((A :41 (((S' _27) _39) _40)) ((A :42 (((S' _28) (_923 #48)) ((C _923) #57))) ((A :43 (((S' _28) (_923 #32)) ((C _923) #126))) ((A :44 _920) ((A :45 _921) ((A :46 _923) ((A :47 _922) ((A :48 (((S' _27) ((C (_77 _35)) #32)) (((S' _27) ((C (_77 _35)) #9)) ((C (_77 _35)) #10)))) ((A :49 ((S ((S (((S' _28) (_46 #65)) ((C _46) #90))) (_34 (((_883 "lib/Data/Char.hs") #3) #8)))) ((B _37) (((C' _91) (((C' _92) _38) (_38 #65))) (_38 #97))))) ((A :50 ((S ((S (((S' _28) (_46 #97)) ((C _46) #97))) (_34 (((_883 "lib/Data/Char.hs") #3) #8)))) ((B _37) (((C' _91) (((C' _92) _38) (_38 #97))) (_38 #65))))) ((A :51 _891) ((A :52 _892) ((A :53 _893) ((A :54 _894) ((A :55 (_52 %0.0)) ((A :56 _51) ((A :57 _52) ((A :58 _53) ((A :59 _54) ((A :60 ((_76 _895) _896)) ((A :61 (_77 _60)) ((A :62 (_78 _60)) ((A :63 _897) ((A :64 _898) ((A :65 _899) ((A :66 _900) ((A :67 _63) ((A :68 _64) ((A :69 _65) ((A :70 _66) ((A :71 _901) ((A :72 ((B BK) T)) ((A :73 (BK T)) ((A :74 (((S' _76) (((S' C) ((B (C S')) (((C' C) ((B (C C')) ((B _77) (T K)))) (K _33)))) ((B ((C' B) (T (K _33)))) ((B _77) (T A))))) ((B _80) ((B _74) (((S' P) (T K)) (T A)))))) ((A :75 P) ((A :76 P) ((A :77 (T K)) ((A :78 (T A)) ((A :79 (K (noDefault "Eq.=="))) ((A :80 ((B (B (B _29))) _77)) ((A :81 ((_76 ((C ((C S') _29)) I)) (_80 _81))) ((A :82 I) ((A :83 (S _928)) ((A :84 B) ((A :85 I) ((A :86 K) ((A :87 C) ((A :88 _927) ((A :89 ((C ((C S') _210)) _211)) ((A :90 (((C' (S' (C' B))) B) I)) ((A :91 _885) ((A :92 _886) ((A :93 _887) ((A :94 _888) ((A :95 _889) ((A :96 _890) ((A :97 (_92 #0)) ((A :98 ((_76 _908) _909)) ((A :99 _910) ((A :100 _911) ((A :101 _912) ((A :102 _913) ((A :103 (BK K)) ((A :104 ((B BK) ((B (B BK)) P))) ((A :105 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :106 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _27) (_100 #0))) ((C (_77 _98)) #0)))) ((B (B ((C' P) (_96 #1)))) _91))) (C P))) _94)) _95)) ((A :107 _103) ((A :108 (((S' C) ((B (P _197)) (((C' (C' B)) (((C' C) (_77 _98)) _197)) _198))) ((B ((C' (C' (C' C))) (((C' (C' (C' C))) (((C' (C' (C' (C' S')))) ((B (B (B (B C)))) ((B ((C' (C' (C' C))) ((B (B (B ((S' S') ((C (_77 _98)) #0))))) ((B ((C' (C' C)) ((B (B ((S' S') ((C (_77 _98)) #1)))) ((B ((C' C) ((B ((C' S') ((C (_77 _98)) #2))) (C _108)))) (C _108))))) (C _108))))) (C _108)))) (T K))) (T A)))) ((C _106) #4)))) ((A :109 (_115 _86)) ((A :110 ((_131 (_89 _109)) _107)) ((A :111 ((C (((C' B) ((P _122) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _112)))) (((S' (C' (C' B))) ((B (B (B _112))) (((S' (C' B)) ((B (B _112)) (((C' B) ((B _129) (T #0))) _111))) (((C' B) ((B _129) (T #1))) _111)))) (((C' B) ((B _129) (T #2))) _111)))) (((C' B) ((B _129) (T #3))) _111)))) ((B T) ((B (B P)) ((C' _91) (_93 #4)))))) ((A :112 ((S S) ((B BK) ((B BK) (((S' S) T) ((B BK) ((B BK) ((C (((S' C
\ No newline at end of file
+1132
+((A :0 _955) ((A :1 ((B _1001) _0)) ((A :2 (((S' _1001) _0) I)) ((A :3 _925) ((A :4 (_3 "undefined")) ((A :5 I) ((A :6 (((C' B) _954) ((C _84) _5))) ((A :7 (((C' _6) (_972 _73)) ((_84 _970) _72))) ((A :8 ((B ((S _1001) _970)) _3)) ((A :9 T) ((A :10 (T I)) ((A :11 ((B (_84 _210)) _10)) ((A :12 ((B (B (_82 _9))) (((C' B) ((B C) _10)) (B _10)))) ((A :13 ((B (B (_82 _9))) (((C' B) ((B C) _10)) (BK _10)))) ((A :14 ((B (_82 _9)) P)) ((A :15 ((B (B (_82 _9))) ((B ((C' C) _10)) (B P)))) ((A :16 _15) ((A :17 (((C' B) _12) (((C' B) _12) (B _14)))) ((A :18 ((B (_82 _9)) (B (P _883)))) ((A :19 ((B (_82 _9)) (BK (P _883)))) ((A :20 ((_82 _9) ((S P) I))) ((A :21 ((B (_82 _9)) ((C (S' P)) I))) ((A :22 ((B Y) ((B (B (P (_14 _122)))) (((C' B) ((B (C' B)) (B _12))) (((C' (C' B)) (B _12)) ((B (B _14)) _123)))))) ((A :23 ((B Y) ((B (B (P (_14 _883)))) ((B (C' B)) (B _13))))) ((A :24 _3) ((A :25 (T (_14 _883))) ((A :26 (_22 _85)) ((A :27 (R _34)) ((A :28 (T _33)) ((A :29 ((P _34) _33)) ((A :30 _34) ((A :31 ((C ((C S') _29)) I)) ((A :32 ((C S) _29)) ((A :33 K) ((A :34 A) ((A :35 ((_76 _919) _920)) ((A :36 ((_76 _929) (_80 _36))) ((A :37 _930) ((A :38 _931) ((A :39 (((S' _28) (_922 #97)) ((C _922) #122))) ((A :40 (((S' _28) (_922 #65)) ((C _922) #90))) ((A :41 (((S' _27) _39) _40)) ((A :42 (((S' _28) (_922 #48)) ((C _922) #57))) ((A :43 (((S' _28) (_922 #32)) ((C _922) #126))) ((A :44 _919) ((A :45 _920) ((A :46 _922) ((A :47 _921) ((A :48 (((S' _27) ((C (_77 _35)) #32)) (((S' _27) ((C (_77 _35)) #9)) ((C (_77 _35)) #10)))) ((A :49 ((S ((S (((S' _28) (_46 #65)) ((C _46) #90))) (_34 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _37) (((C' _91) (((C' _92) _38) (_38 #65))) (_38 #97))))) ((A :50 ((S ((S (((S' _28) (_46 #97)) ((C _46) #97))) (_34 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _37) (((C' _91) (((C' _92) _38) (_38 #97))) (_38 #65))))) ((A :51 _890) ((A :52 _891) ((A :53 _892) ((A :54 _893) ((A :55 (_52 %0.0)) ((A :56 _51) ((A :57 _52) ((A :58 _53) ((A :59 _54) ((A :60 ((_76 _894) _895)) ((A :61 (_77 _60)) ((A :62 (_78 _60)) ((A :63 _896) ((A :64 _897) ((A :65 _898) ((A :66 _899) ((A :67 _63) ((A :68 _64) ((A :69 _65) ((A :70 _66) ((A :71 _900) ((A :72 ((B BK) T)) ((A :73 (BK T)) ((A :74 (((S' _76) (((S' C) ((B (C S')) (((C' C) ((B (C C')) ((B _77) (T K)))) (K _33)))) ((B ((C' B) (T (K _33)))) ((B _77) (T A))))) ((B _80) ((B _74) (((S' P) (T K)) (T A)))))) ((A :75 P) ((A :76 P) ((A :77 (T K)) ((A :78 (T A)) ((A :79 (K (noDefault "Eq.=="))) ((A :80 ((B (B (B _29))) _77)) ((A :81 ((_76 ((C ((C S') _29)) I)) (_80 _81))) ((A :82 I) ((A :83 (S _927)) ((A :84 B) ((A :85 I) ((A :86 K) ((A :87 C) ((A :88 _926) ((A :89 ((C ((C S') _210)) _211)) ((A :90 (((C' (S' (C' B))) B) I)) ((A :91 _884) ((A :92 _885) ((A :93 _886) ((A :94 _887) ((A :95 _888) ((A :96 _889) ((A :97 (_92 #0)) ((A :98 ((_76 _907) _908)) ((A :99 _909) ((A :100 _910) ((A :101 _911) ((A :102 _912) ((A :103 (BK K)) ((A :104 ((B BK) ((B (B BK)) P))) ((A :105 ((B (B (B BK))) ((B (B (B BK))) ((B (B (B C))) ((B (B C)) P))))) ((A :106 (((S' S) (((S' (S' C)) (((C' (C' S)) (((C' B) ((B (S' S')) (((C' B) ((B _27) (_100 #0))) ((C (_77 _98)) #0)))) ((B (B ((C' P) (_96 #1)))) _91))) (C P))) _94)) _95)) ((A :107 _103) ((A :108 (((S' C) ((B (P _197)) (((C' (C' B)) (((C' C) (_77 _98)) _197)) _198))) ((B ((C' (C' (C' C))) (((C' (C' (C' C))) (((C' (C' (C' (C' S')))) ((B (B (B (B C)))) ((B ((C' (C' (C' C))) ((B (B (B ((S' S') ((C (_77 _98)) #0))))) ((B ((C' (C' C)) ((B (B ((S' S') ((C (_77 _98)) #1)))) ((B ((C' C) ((B ((C' S') ((C (_77 _98)) #2))) (C _108)))) (C _108))))) (C _108))))) (C _108)))) (T K))) (T A)))) ((C _106) #4)))) ((A :109 (_115 _86)) ((A :110 ((_131 (_89 _109)) _107)) ((A :111 ((C (((C' B) ((P _122) (((C' (C' O)) P) K))) (((S' (C' (C' (C' B)))) ((B (B (B (B _112)))) (((S' (C' (C' B))) ((B (B (B _112))) (((S' (C' B)) ((B (B _112)) (((C' B) ((B _129) (T #0))) _111))) (((C' B) ((B _129) (T #1))) _111)))) (((C' B) ((B _129) (T #2))) _111)))) (((C' B) ((B _129) (T #3))) _111)))) ((B T) ((B (B P)) ((C' _91) (_93 #4)))))) ((A :112 ((S S) ((B BK) ((B BK) (((S' S) T) ((B BK) ((B BK) ((C (
\ No newline at end of file
--- a/lib/Prelude.hs
+++ b/lib/Prelude.hs
@@ -14,7 +14,6 @@
   module Data.Tuple,
   module System.IO,
   module Text.String,
-  _noMatch,
   ) where
 import Control.Error
 import Data.Bool
@@ -30,8 +29,10 @@
 import System.IO
 import Text.String
 
+{-
 -- Called on pattern match failure.
 _noMatch :: forall a . [Char] -> Int -> Int -> a
 _noMatch fn l c = error $ "no match at " ++
   if null fn then "no location" else
   showString fn ++ ": " ++ "line " ++ showInt l ++ ", col " ++ showInt c
+-}
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -370,7 +370,7 @@
 
 eMatchErr :: SLoc -> Exp
 eMatchErr (SLoc fn l c) =
-  App (App (App (Var (mkIdent "Prelude._noMatch")) (Lit (LStr fn))) (Lit (LInt l))) (Lit (LInt c))
+  App (App (App (Lit (LPrim "noMatch")) (Lit (LStr fn))) (Lit (LInt l))) (Lit (LInt c))
 
 -- If the first expression isn't a variable/literal, then use
 -- a let binding and pass variable to f.
--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -152,7 +152,7 @@
                 T_FADD, T_FSUB, T_FMUL, T_FDIV,
                 T_FEQ, T_FNE, T_FLT, T_FLE, T_FGT, T_FGE, T_FSHOW, T_FREAD,
                 T_EQ, T_NE, T_LT, T_LE, T_GT, T_GE, T_ULT, T_ULE, T_UGT, T_UGE,
-                T_ERROR, T_NODEFAULT, T_SEQ, T_EQUAL, T_COMPARE, T_RNF,
+                T_ERROR, T_NODEFAULT, T_NOMATCH, T_SEQ, T_EQUAL, T_COMPARE, T_RNF,
                 T_IO_BIND, T_IO_THEN, T_IO_RETURN, T_IO_GETCHAR, T_IO_PUTCHAR,
                 T_IO_SERIALIZE, T_IO_DESERIALIZE, T_IO_OPEN, T_IO_CLOSE, T_IO_ISNULLHANDLE,
                 T_IO_STDIN, T_IO_STDOUT, T_IO_STDERR, T_IO_GETARGS, T_IO_DROPARGS,
@@ -673,6 +673,7 @@
   { "seq", T_SEQ },
   { "error", T_ERROR },
   { "noDefault", T_NODEFAULT },
+  { "noMatch", T_NOMATCH },
   { "equal", T_EQUAL },
   { "compare", T_COMPARE },
   { "rnf", T_RNF },
@@ -1404,6 +1405,7 @@
   case T_UGE: fprintf(f, "u>="); break;
   case T_ERROR: fprintf(f, "error"); break;
   case T_NODEFAULT: fprintf(f, "noDefault"); break;
+  case T_NOMATCH: fprintf(f, "noMatch"); break;
   case T_EQUAL: fprintf(f, "equal"); break;
   case T_COMPARE: fprintf(f, "compare"); break;
   case T_RNF: fprintf(f, "rnf"); break;
@@ -1732,7 +1734,6 @@
   double rd;
   FILE *hdl;
   char *msg;
-  char *emsg;
   heapoffs_t l;
 
 /* Reset stack pointer and return. */
@@ -1882,11 +1883,34 @@
     case T_UGT:  CMPU(>);
     case T_UGE:  CMPU(>=);
 
+    case T_NOMATCH:
+      {
+      CHECK(3);
+      msg = evalstring(ARG(TOP(0)));
+      xi = evalint(ARG(TOP(1)));
+      yi = evalint(ARG(TOP(2)));
+      int sz = strlen(msg) + 100;
+      char *res = malloc(sz);
+      snprintf(res, sz, "no match at %s, line %"PRIvalue", col %"PRIvalue, msg, xi, yi);
+      POP(2);
+      ARG(TOP(0)) = mkStringC(res);
+      free(res);
+      free(msg);
+      goto err;                 /* XXX not right message if the error is caught */
+      }
     case T_NODEFAULT:
-      emsg = "no default for ";
-      goto err;                 /* XXX not right if the error is caught */
+      {
+      CHECK(1);
+      msg = evalstring(ARG(TOP(0)));
+      int sz = strlen(msg) + 100;
+      char *res = malloc(sz);
+      snprintf(res, sz, "no default for %s", msg);
+      ARG(TOP(0)) = mkStringC(res);
+      free(res);
+      free(msg);
+      goto err;                 /* XXX not right message if the error is caught */
+      }
     case T_ERROR:
-      emsg = "";
     err:
       if (cur_handler) {
         /* Pass the string to the handler */
@@ -1896,7 +1920,7 @@
       } else {
         /* No handler, so just die. */
         CHKARGEV1(msg = evalstring(x));
-        fprintf(stderr, "error: %s%s\n", emsg, msg);
+        fprintf(stderr, "error: %s\n", msg);
         free(msg);
         exit(1);
       }
-- 
⑨