Mercurial > urweb

comparison src/cjr_print.sml @ 198:ab86aa858e6c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
'Option' datatype encoding
author Adam Chlipala <adamc@hcoop.net>
date Sat, 09 Aug 2008 19:23:31 -0400
parents b1b9bcfd8c42
children c938fe391c84
comparison
equal deleted inserted replaced
197:b1b9bcfd8c42 198:ab86aa858e6c
72 | TDatatype (Enum, n, _) => 72 | TDatatype (Enum, n, _) =>
73 (box [string "enum", 73 (box [string "enum",
74 space, 74 space,
75 string ("__lwe_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n)] 75 string ("__lwe_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n)]
76 handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n)) 76 handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n))
77 | TDatatype (Option, n, xncs) =>
78 (case ListUtil.search #3 (!xncs) of
79 NONE => raise Fail "CjrPrint: TDatatype marked Option has no constructor with an argument"
80 | SOME t =>
81 case #1 t of
82 TDatatype _ => p_typ' par env t
83 | _ => box [p_typ' par env t,
84 string "*"])
77 | TDatatype (Default, n, _) => 85 | TDatatype (Default, n, _) =>
78 (box [string "struct", 86 (box [string "struct",
79 space, 87 space,
80 string ("__lwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")] 88 string ("__lwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")]
81 handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n)) 89 handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n))
196 string "disc", 204 string "disc",
197 string (Int.toString (depth + 1)), 205 string (Int.toString (depth + 1)),
198 space, 206 space,
199 string "=", 207 string "=",
200 space, 208 space,
201 string "disc", 209 case dk of
202 string (Int.toString depth), 210 Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor"
203 string "->data.", 211 | Default => box [string "disc",
204 string x, 212 string (Int.toString depth),
213 string "->data.",
214 string x]
215 | Option =>
216 case #1 t of
217 TDatatype _ => box [string "disc",
218 string (Int.toString depth)]
219 | _ => box [string "*disc",
220 string (Int.toString depth)],
205 string ";", 221 string ";",
206 newline, 222 newline,
207 p, 223 p,
208 newline, 224 newline,
209 string "}"], 225 string "}"],
212 in 228 in
213 (box [string "if", 229 (box [string "if",
214 space, 230 space,
215 string "(disc", 231 string "(disc",
216 string (Int.toString depth), 232 string (Int.toString depth),
217 case dk of 233 case (dk, po) of
218 Enum => box [] 234 (Enum, _) => box [space,
219 | Default => string "->tag", 235 string "!=",
220 space, 236 space,
221 string "!=", 237 p_patCon env pc]
222 space, 238 | (Default, _) => box [string "->tag",
223 p_patCon env pc, 239 space,
240 string "!=",
241 space,
242 p_patCon env pc]
243 | (Option, NONE) => box [space,
244 string "!=",
245 space,
246 string "NULL"]
247 | (Option, SOME _) => box [space,
248 string "==",
249 space,
250 string "NULL"],
224 string ")", 251 string ")",
225 space, 252 space,
226 exit, 253 exit,
227 newline, 254 newline,
228 p], 255 p],
294 case e of 321 case e of
295 EPrim p => Prim.p_t p 322 EPrim p => Prim.p_t p
296 | ERel n => p_rel env n 323 | ERel n => p_rel env n
297 | ENamed n => p_enamed env n 324 | ENamed n => p_enamed env n
298 | ECon (Enum, pc, _) => p_patCon env pc 325 | ECon (Enum, pc, _) => p_patCon env pc
326 | ECon (Option, pc, NONE) => string "NULL"
327 | ECon (Option, pc, SOME e) =>
328 let
329 val to = case pc of
330 PConVar n => #2 (E.lookupConstructor env n)
331 | PConFfi {arg, ...} => arg
332
333 val t = case to of
334 NONE => raise Fail "CjrPrint: ECon argument status mismatch"
335 | SOME t => t
336 in
337 case #1 t of
338 TDatatype _ => p_exp' par env e
339 | _ => box [string "({",
340 newline,
341 p_typ env t,
342 space,
343 string "*tmp",
344 space,
345 string "=",
346 space,
347 string "lw_malloc(ctx, sizeof(",
348 p_typ env t,
349 string "));",
350 newline,
351 string "*tmp",
352 space,
353 string "=",
354 p_exp' par env e,
355 string ";",
356 newline,
357 string "tmp;",
358 newline,
359 string "})"]
360 end
299 | ECon (Default, pc, eo) => 361 | ECon (Default, pc, eo) =>
300 let 362 let
301 val (xd, xc, xn) = patConInfo env pc 363 val (xd, xc, xn) = patConInfo env pc
302 in 364 in
303 box [string "({", 365 box [string "({",
520 string "{", 582 string "{",
521 space, 583 space,
522 p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__lwc_" ^ x ^ "_" ^ Int.toString n)) xncs, 584 p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__lwc_" ^ x ^ "_" ^ Int.toString n)) xncs,
523 space, 585 space,
524 string "};"] 586 string "};"]
587 | DDatatype (Option, _, _, _) => box []
525 | DDatatype (Default, x, n, xncs) => 588 | DDatatype (Default, x, n, xncs) =>
526 let 589 let
527 val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE 590 val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE
528 | (x, n, SOME t) => SOME (x, n, t)) xncs 591 | (x, n, SOME t) => SOME (x, n, t)) xncs
529 in 592 in
805 string ")"] 868 string ")"]
806 in 869 in
807 doEm xncs 870 doEm xncs
808 end 871 end
809 872
873 | TDatatype (Option, i, xncs) =>
874 let
875 val (x, _) = E.lookupDatatype env i
876
877 val (no_arg, has_arg, t) =
878 case !xncs of
879 [(no_arg, _, NONE), (has_arg, _, SOME t)] =>
880 (no_arg, has_arg, t)
881 | [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
882 (no_arg, has_arg, t)
883 | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype"
884 in
885 box [string "(request[0] == '/' ? ++request : request,",
886 newline,
887 string "((!strncmp(request, \"",
888 string no_arg,
889 string "\", ",
890 string (Int.toString (size no_arg)),
891 string ") && (request[",
892 string (Int.toString (size no_arg)),
893 string "] == 0 || request[",
894 string (Int.toString (size no_arg)),
895 string "] == '/')) ? (request",
896 space,
897 string "+=",
898 space,
899 string (Int.toString (size no_arg)),
900 string ", NULL) : ((!strncmp(request, \"",
901 string has_arg,
902 string "\", ",
903 string (Int.toString (size has_arg)),
904 string ") && (request[",
905 string (Int.toString (size has_arg)),
906 string "] == 0 || request[",
907 string (Int.toString (size has_arg)),
908 string "] == '/')) ? (request",
909 space,
910 string "+=",
911 space,
912 string (Int.toString (size has_arg)),
913 string ", ",
914
915 case #1 t of
916 TDatatype _ => unurlify t
917 | _ => box [string "({",
918 newline,
919 p_typ env t,
920 space,
921 string "*tmp",
922 space,
923 string "=",
924 space,
925 string "lw_malloc(ctx, sizeof(",
926 p_typ env t,
927 string "));",
928 newline,
929 string "*tmp",
930 space,
931 string "=",
932 space,
933 unurlify t,
934 string ";",
935 newline,
936 string "tmp;",
937 newline,
938 string "})"],
939 string ")",
940 newline,
941 string ":",
942 space,
943 string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL))))")]
944 end
945
810 | TDatatype (Default, i, _) => 946 | TDatatype (Default, i, _) =>
811 let 947 let
812 val (x, xncs) = E.lookupDatatype env i 948 val (x, xncs) = E.lookupDatatype env i
813 949
814 fun doEm xncs = 950 fun doEm xncs =
953 in 1089 in
954 box [string "if (!strncmp(request, \"", 1090 box [string "if (!strncmp(request, \"",
955 string (String.toString s), 1091 string (String.toString s),
956 string "\", ", 1092 string "\", ",
957 string (Int.toString (size s)), 1093 string (Int.toString (size s)),
958 string ")) {", 1094 string ") && (request[",
1095 string (Int.toString (size s)),
1096 string "] == 0 || request[",
1097 string (Int.toString (size s)),
1098 string "] == '/')) {",
959 newline, 1099 newline,
960 string "request += ", 1100 string "request += ",
961 string (Int.toString (size s)), 1101 string (Int.toString (size s)),
962 string ";", 1102 string ";",
963 newline, 1103 newline,