# HG changeset patch # User Adam Chlipala # Date 1216753940 14400 # Node ID f0d3402184d114c973bccde7966a37e1e46c833a # Parent 4b9c2bd6157cd7e470af8500d52243d53f71ace2 Simple forms work diff -r 4b9c2bd6157c -r f0d3402184d1 include/lacweb.h --- a/include/lacweb.h Sun Jul 20 13:30:19 2008 -0400 +++ b/include/lacweb.h Tue Jul 22 15:12:20 2008 -0400 @@ -12,6 +12,9 @@ void *lw_malloc(lw_context, size_t); int lw_send(lw_context, int sock); +void lw_set_input(lw_context, char *name, char *value); +char *lw_get_input(lw_context, int name); + void lw_write(lw_context, const char*); diff -r 4b9c2bd6157c -r f0d3402184d1 src/c/driver.c --- a/src/c/driver.c Sun Jul 20 13:30:19 2008 -0400 +++ b/src/c/driver.c Tue Jul 22 15:12:20 2008 -0400 @@ -86,9 +86,11 @@ *back = 0; if (s = strstr(buf, "\r\n\r\n")) { - char *cmd, *path; + char *cmd, *path, *inputs; *s = 0; + + printf("Read: %s\n", buf); if (!(s = strstr(buf, "\r\n"))) { fprintf(stderr, "No newline in buf\n"); @@ -114,9 +116,33 @@ break; } + if (inputs = strchr(path, '?')) { + char *name, *value; + *inputs++ = 0; + + while (*inputs) { + name = inputs; + if (value = strchr(inputs, '=')) { + *value++ = 0; + if (inputs = strchr(value, '&')) + *inputs++ = 0; + else + inputs = strchr(value, 0); + lw_set_input(ctx, name, value); + } + else if (inputs = strchr(value, '&')) { + *inputs++ = 0; + lw_set_input(ctx, name, ""); + } + else { + inputs = strchr(value, 0); + lw_set_input(ctx, name, ""); + } + } + } + printf("Serving URI %s....\n", path); - ctx = lw_init(1024, 1024); lw_write (ctx, "HTTP/1.1 200 OK\r\n"); lw_write(ctx, "Content-type: text/html\r\n\r\n"); lw_write(ctx, ""); diff -r 4b9c2bd6157c -r f0d3402184d1 src/c/lacweb.c --- a/src/c/lacweb.c Sun Jul 20 13:30:19 2008 -0400 +++ b/src/c/lacweb.c Tue Jul 22 15:12:20 2008 -0400 @@ -11,8 +11,11 @@ struct lw_context { char *page, *page_front, *page_back; char *heap, *heap_front, *heap_back; + char **inputs; }; +extern int lw_inputs_len; + lw_context lw_init(size_t page_len, size_t heap_len) { lw_context ctx = malloc(sizeof(struct lw_context)); @@ -22,18 +25,45 @@ ctx->heap_front = ctx->heap = malloc(heap_len); ctx->heap_back = ctx->heap_front + heap_len; + ctx->inputs = calloc(lw_inputs_len, sizeof(char *)); + return ctx; } void lw_free(lw_context ctx) { free(ctx->page); free(ctx->heap); + free(ctx->inputs); free(ctx); } void lw_reset(lw_context ctx) { ctx->page_front = ctx->page; ctx->heap_front = ctx->heap; + memset(ctx->inputs, 0, lw_inputs_len * sizeof(char *)); +} + +int lw_input_num(char*); + +void lw_set_input(lw_context ctx, char *name, char *value) { + int n = lw_input_num(name); + + if (n < 0) { + printf("Bad input name"); + exit(1); + } + + assert(n < lw_inputs_len); + ctx->inputs[n] = value; + + printf("[%d] %s = %s\n", n, name, value); +} + +char *lw_get_input(lw_context ctx, int n) { + assert(n >= 0); + assert(n < lw_inputs_len); + printf("[%d] = %s\n", n, ctx->inputs[n]); + return ctx->inputs[n]; } static void lw_check_heap(lw_context ctx, size_t extra) { @@ -294,14 +324,20 @@ } -lw_Basis_int lw_unurlifyInt(char **s) { - char *new_s = strchr(*s, '/'); - int r; +static char *lw_unurlify_advance(char *s) { + char *new_s = strchr(s, '/'); if (new_s) *new_s++ = 0; else - new_s = strchr(*s, 0); + new_s = strchr(s, 0); + + return new_s; +} + +lw_Basis_int lw_unurlifyInt(char **s) { + char *new_s = lw_unurlify_advance(*s); + int r; r = atoi(*s); *s = new_s; @@ -309,34 +345,19 @@ } lw_Basis_float lw_unurlifyFloat(char **s) { - char *new_s = strchr(*s, '/'); + char *new_s = lw_unurlify_advance(*s); int r; - if (new_s) - *new_s++ = 0; - else - new_s = strchr(*s, 0); - r = atof(*s); *s = new_s; return r; } -lw_Basis_string lw_unurlifyString(lw_context ctx, char **s) { - char *new_s = strchr(*s, '/'); - char *r, *s1, *s2; - int len, n; +static lw_Basis_string lw_unurlifyString_to(char *r, char *s) { + char *s1, *s2; + int n; - if (new_s) - *new_s++ = 0; - else - new_s = strchr(*s, 0); - - len = strlen(*s); - lw_check_heap(ctx, len + 1); - - r = ctx->heap_front; - for (s1 = r, s2 = *s; *s2; ++s1, ++s2) { + for (s1 = r, s2 = s; *s2; ++s1, ++s2) { char c = *s2; switch (c) { @@ -344,7 +365,7 @@ *s1 = ' '; break; case '%': - assert(s2 + 2 < new_s); + assert(s2[1] != 0 && s2[2] != 0); sscanf(s2+1, "%02X", &n); *s1 = n; s2 += 2; @@ -354,7 +375,19 @@ } } *s1++ = 0; - ctx->heap_front = s1; + return s1; +} + +lw_Basis_string lw_unurlifyString(lw_context ctx, char **s) { + char *new_s = lw_unurlify_advance(*s); + char *r, *s1, *s2; + int len, n; + + len = strlen(*s); + lw_check_heap(ctx, len + 1); + + r = ctx->heap_front; + ctx->heap_front = lw_unurlifyString_to(ctx->heap_front, *s); *s = new_s; return r; } diff -r 4b9c2bd6157c -r f0d3402184d1 src/cjr.sml --- a/src/cjr.sml Sun Jul 20 13:30:19 2008 -0400 +++ b/src/cjr.sml Tue Jul 22 15:12:20 2008 -0400 @@ -62,6 +62,6 @@ withtype decl = decl' located -type file = decl list * (string * int * typ list) list +type file = decl list * (Core.export_kind * string * int * typ list) list end diff -r 4b9c2bd6157c -r f0d3402184d1 src/cjr_print.sml --- a/src/cjr_print.sml Sun Jul 20 13:30:19 2008 -0400 +++ b/src/cjr_print.sml Tue Jul 22 15:12:20 2008 -0400 @@ -37,6 +37,20 @@ structure E = CjrEnv structure EM = ErrorMsg +structure SK = struct +type ord_key = string +val compare = String.compare +end + +structure SS = BinarySetFn(SK) +structure SM = BinaryMapFn(SK) +structure IS = IntBinarySet + +structure CM = BinaryMapFn(struct + type ord_key = char + val compare = Char.compare + end) + val debug = ref false val dummyTyp = (TNamed 0, ErrorMsg.dummySpan) @@ -208,90 +222,11 @@ newline] end -fun unurlify env (t, loc) = - case t of - TFfi ("Basis", "int") => string "lw_unurlifyInt(&request)" - | TFfi ("Basis", "float") => string "lw_unurlifyFloat(&request)" - | TFfi ("Basis", "string") => string "lw_unurlifyString(ctx, &request)" +datatype 'a search = + Found of 'a + | NotFound + | Error - | TRecord 0 => string "lw_unit_v" - | TRecord i => - let - val xts = E.lookupStruct env i - in - box [string "({", - newline, - box (map (fn (x, t) => - box [p_typ env t, - space, - string x, - space, - string "=", - space, - unurlify env t, - string ";", - newline]) xts), - string "struct", - space, - string "__lws_", - string (Int.toString i), - space, - string "__lw_tmp", - space, - string "=", - space, - string "{", - space, - p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts, - space, - string "};", - newline, - string "__lw_tmp;", - newline, - string "})"] - end - - | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function"; - space) - -fun p_page env (s, n, ts) = - box [string "if (!strncmp(request, \"", - string (String.toString s), - string "\", ", - string (Int.toString (size s)), - string ")) {", - newline, - string "request += ", - string (Int.toString (size s)), - string ";", - newline, - string "if (*request == '/') ++request;", - newline, - box [string "{", - newline, - box (ListUtil.mapi (fn (i, t) => box [p_typ env t, - space, - string "arg", - string (Int.toString i), - space, - string "=", - space, - unurlify env t, - string ";", - newline]) ts), - p_enamed env n, - string "(", - p_list_sep (box [string ",", space]) - (fn x => x) - (string "ctx" :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts), - string ");", - newline, - string "return;", - newline, - string "}", - newline, - string "}"] - ] fun p_file env (ds, ps) = let @@ -299,13 +234,318 @@ (p_decl env d, E.declBinds env d)) env ds - val pds' = map (p_page env) ps + + val fields = foldl (fn ((ek, _, _, ts), fields) => + case ek of + Core.Link => fields + | Core.Action => + case List.last ts of + (TRecord i, _) => + let + val xts = E.lookupStruct env i + val xtsSet = SS.addList (SS.empty, map #1 xts) + in + foldl (fn ((x, _), fields) => + let + val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty) + in + SM.insert (fields, x, SS.union (SS.delete (xtsSet, x), + xtsSet')) + end) fields xts + end + | _ => raise Fail "CjrPrint: Last argument of action isn't record") + SM.empty ps + + val fnums = SM.foldli (fn (x, xs, fnums) => + let + val unusable = SS.foldl (fn (x', unusable) => + case SM.find (fnums, x') of + NONE => unusable + | SOME n => IS.add (unusable, n)) + IS.empty xs + + fun findAvailable n = + if IS.member (unusable, n) then + findAvailable (n + 1) + else + n + in + SM.insert (fnums, x, findAvailable 0) + end) + SM.empty fields + + fun makeSwitch (fnums, i) = + case SM.foldl (fn (n, NotFound) => Found n + | (n, Error) => Error + | (n, Found n') => if n = n' then + Found n' + else + Error) NotFound fnums of + NotFound => box [string "return", + space, + string "-1;"] + | Found n => box [string "return", + space, + string (Int.toString n), + string ";"] + | Error => + let + val cmap = SM.foldli (fn (x, n, cmap) => + let + val ch = if i < size x then + String.sub (x, i) + else + chr 0 + + val fnums = case CM.find (cmap, ch) of + NONE => SM.empty + | SOME fnums => fnums + val fnums = SM.insert (fnums, x, n) + in + CM.insert (cmap, ch, fnums) + end) + CM.empty fnums + + val cmap = CM.listItemsi cmap + in + case cmap of + [(_, fnums)] => + box [string "if", + space, + string "(name[", + string (Int.toString i), + string "]", + space, + string "==", + space, + string "0)", + space, + string "return", + space, + string "-1;", + newline, + makeSwitch (fnums, i+1)] + | _ => + box [string "switch", + space, + string "(name[", + string (Int.toString i), + string "])", + space, + string "{", + newline, + box (map (fn (ch, fnums) => + box [string "case", + space, + if ch = chr 0 then + string "0:" + else + box [string "'", + string (Char.toString ch), + string "':"], + newline, + makeSwitch (fnums, i+1), + newline]) cmap), + string "default:", + newline, + string "return", + space, + string "-1;", + newline, + string "}"] + end + + fun unurlify (t, loc) = + case t of + TFfi ("Basis", "int") => string "lw_unurlifyInt(&request)" + | TFfi ("Basis", "float") => string "lw_unurlifyFloat(&request)" + | TFfi ("Basis", "string") => string "lw_unurlifyString(ctx, &request)" + + | TRecord 0 => string "lw_unit_v" + | TRecord i => + let + val xts = E.lookupStruct env i + in + box [string "({", + newline, + box (map (fn (x, t) => + box [p_typ env t, + space, + string x, + space, + string "=", + space, + unurlify t, + string ";", + newline]) xts), + string "struct", + space, + string "__lws_", + string (Int.toString i), + space, + string "__lw_tmp", + space, + string "=", + space, + string "{", + space, + p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts, + space, + string "};", + newline, + string "__lw_tmp;", + newline, + string "})"] + end + + | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function"; + space) + + + fun p_page (ek, s, n, ts) = + let + val (ts, defInputs, inputsVar) = + case ek of + Core.Link => (ts, string "", string "") + | Core.Action => + case List.last ts of + (TRecord i, _) => + let + val xts = E.lookupStruct env i + in + (List.drop (ts, 1), + box [box (map (fn (x, t) => box [p_typ env t, + space, + string "lw_input_", + string x, + string ";", + newline]) xts), + newline, + box (map (fn (x, t) => + let + val n = case SM.find (fnums, x) of + NONE => raise Fail "CjrPrint: Can't find in fnums" + | SOME n => n + in + box [string "request = lw_get_input(ctx, ", + string (Int.toString n), + string ");", + newline, + string "if (request == NULL) {", + newline, + box [string "printf(\"Missing input ", + string x, + string "\\n\");", + newline, + string "exit(1);"], + newline, + string "}", + newline, + string "lw_input_", + string x, + space, + string "=", + space, + unurlify t, + string ";", + newline] + end) xts), + string "struct __lws_", + string (Int.toString i), + space, + string "lw_inputs", + space, + string "= {", + newline, + box (map (fn (x, _) => box [string "lw_input_", + string x, + string ",", + newline]) xts), + string "};", + newline], + box [string ",", + space, + string "lw_inputs"]) + end + + | _ => raise Fail "CjrPrint: Last argument to an action isn't a record" + in + box [string "if (!strncmp(request, \"", + string (String.toString s), + string "\", ", + string (Int.toString (size s)), + string ")) {", + newline, + string "request += ", + string (Int.toString (size s)), + string ";", + newline, + string "if (*request == '/') ++request;", + newline, + box [string "{", + newline, + box (ListUtil.mapi (fn (i, t) => box [p_typ env t, + space, + string "arg", + string (Int.toString i), + space, + string "=", + space, + unurlify t, + string ";", + newline]) ts), + defInputs, + p_enamed env n, + string "(", + p_list_sep (box [string ",", space]) + (fn x => x) + (string "ctx" :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts), + inputsVar, + string ");", + newline, + string "return;", + newline, + string "}", + newline, + string "}"] + ] + end + + val pds' = map p_page ps in - box [string "#include \"lacweb.h\"", + box [string "#include ", + newline, + string "#include ", + newline, + newline, + string "#include \"lacweb.h\"", newline, newline, p_list_sep newline (fn x => x) pds, newline, + string "int lw_inputs_len = ", + string (Int.toString (SM.foldl Int.max 0 fnums + 1)), + string ";", + newline, + newline, + string "int lw_input_num(char *name) {", + newline, + string "if", + space, + string "(name[0]", + space, + string "==", + space, + string "0)", + space, + string "return", + space, + string "-1;", + newline, + makeSwitch (fnums, 0), + string "}", + newline, + newline, string "void lw_handle(lw_context ctx, char *request) {", newline, p_list_sep newline (fn x => x) pds', diff -r 4b9c2bd6157c -r f0d3402184d1 src/cjrize.sml --- a/src/cjrize.sml Sun Jul 20 13:30:19 2008 -0400 +++ b/src/cjrize.sml Tue Jul 22 15:12:20 2008 -0400 @@ -225,11 +225,11 @@ (SOME (L'.DFunRec vis, loc), NONE, sm) end - | L.DExport (s, n, ts) => + | L.DExport (ek, s, n, ts) => let val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts in - (NONE, SOME ("/" ^ s, n, ts), sm) + (NONE, SOME (ek, "/" ^ s, n, ts), sm) end fun cjrize ds = diff -r 4b9c2bd6157c -r f0d3402184d1 src/core.sml --- a/src/core.sml Sun Jul 20 13:30:19 2008 -0400 +++ b/src/core.sml Tue Jul 22 15:12:20 2008 -0400 @@ -80,11 +80,15 @@ withtype exp = exp' located +datatype export_kind = + Link + | Action + datatype decl' = DCon of string * int * kind * con | DVal of string * int * con * exp * string | DValRec of (string * int * con * exp * string) list - | DExport of int + | DExport of export_kind * int withtype decl = decl' located diff -r 4b9c2bd6157c -r f0d3402184d1 src/core_print.sig --- a/src/core_print.sig Sun Jul 20 13:30:19 2008 -0400 +++ b/src/core_print.sig Tue Jul 22 15:12:20 2008 -0400 @@ -33,6 +33,7 @@ val p_exp : CoreEnv.env -> Core.exp Print.printer val p_decl : CoreEnv.env -> Core.decl Print.printer val p_file : CoreEnv.env -> Core.file Print.printer + val p_export_kind : Core.export_kind Print.printer val debug : bool ref end diff -r 4b9c2bd6157c -r f0d3402184d1 src/core_print.sml --- a/src/core_print.sml Sun Jul 20 13:30:19 2008 -0400 +++ b/src/core_print.sml Tue Jul 22 15:12:20 2008 -0400 @@ -264,6 +264,11 @@ p_exp env e] end +fun p_export_kind ck = + case ck of + Link => string "link" + | Action => string "action" + fun p_decl env (dAll as (d, _) : decl) = case d of DCon (x, n, k, c) => @@ -300,9 +305,15 @@ space, p_list_sep (box [newline, string "and", space]) (p_vali env) vis] end - | DExport n => box [string "export", - space, - p_enamed env n] + | DExport (ek, n) => box [string "export", + space, + p_export_kind ek, + space, + p_enamed env n, + space, + string "as", + space, + p_con env (#2 (E.lookupENamed env n))] fun p_file env file = let diff -r 4b9c2bd6157c -r f0d3402184d1 src/corify.sml --- a/src/corify.sml Sun Jul 20 13:30:19 2008 -0400 +++ b/src/corify.sml Tue Jul 22 15:12:20 2008 -0400 @@ -496,7 +496,7 @@ e), loc) :: wds, (fn st => case #1 (corifyExp st (L.EModProj (en, [], "wrap_" ^ s), loc)) of - L'.ENamed n => (L'.DExport n, loc) + L'.ENamed n => (L'.DExport (L'.Link, n), loc) | _ => raise Fail "Corify: Value to export didn't corify properly") :: eds) end diff -r 4b9c2bd6157c -r f0d3402184d1 src/mono.sml --- a/src/mono.sml Sun Jul 20 13:30:19 2008 -0400 +++ b/src/mono.sml Tue Jul 22 15:12:20 2008 -0400 @@ -62,7 +62,7 @@ datatype decl' = DVal of string * int * typ * exp * string | DValRec of (string * int * typ * exp * string) list - | DExport of string * int * typ list + | DExport of Core.export_kind * string * int * typ list withtype decl = decl' located diff -r 4b9c2bd6157c -r f0d3402184d1 src/mono_print.sml --- a/src/mono_print.sml Sun Jul 20 13:30:19 2008 -0400 +++ b/src/mono_print.sml Tue Jul 22 15:12:20 2008 -0400 @@ -178,17 +178,19 @@ p_list_sep (box [newline, string "and", space]) (p_vali env) vis] end - | DExport (s, n, ts) => box [string "export", - space, - p_enamed env n, - space, - string "as", - space, - string s, - p_list_sep (string "") (fn t => box [space, - string "(", - p_typ env t, - string ")"]) ts] + | DExport (ek, s, n, ts) => box [string "export", + space, + CorePrint.p_export_kind ek, + space, + p_enamed env n, + space, + string "as", + space, + string s, + p_list_sep (string "") (fn t => box [space, + string "(", + p_typ env t, + string ")"]) ts] fun p_file env file = let diff -r 4b9c2bd6157c -r f0d3402184d1 src/mono_shake.sml --- a/src/mono_shake.sml Sun Jul 20 13:30:19 2008 -0400 +++ b/src/mono_shake.sml Tue Jul 22 15:12:20 2008 -0400 @@ -44,7 +44,7 @@ fun shake file = let val page_es = List.foldl - (fn ((DExport (_, n, _), _), page_es) => n :: page_es + (fn ((DExport (_, _, n, _), _), page_es) => n :: page_es | (_, page_es) => page_es) [] file val (cdef, edef) = foldl (fn ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e))) diff -r 4b9c2bd6157c -r f0d3402184d1 src/mono_util.sml --- a/src/mono_util.sml Sun Jul 20 13:30:19 2008 -0400 +++ b/src/mono_util.sml Tue Jul 22 15:12:20 2008 -0400 @@ -266,10 +266,10 @@ S.map2 (ListUtil.mapfold (mfvi ctx) vis, fn vis' => (DValRec vis', loc)) - | DExport (s, n, ts) => + | DExport (ek, s, n, ts) => S.map2 (ListUtil.mapfold mft ts, fn ts' => - (DExport (s, n, ts'), loc)) + (DExport (ek, s, n, ts'), loc)) and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, diff -r 4b9c2bd6157c -r f0d3402184d1 src/monoize.sml --- a/src/monoize.sml Sun Jul 20 13:30:19 2008 -0400 +++ b/src/monoize.sml Tue Jul 22 15:12:20 2008 -0400 @@ -383,7 +383,7 @@ SOME (env, (L'.DValRec (map (fn (x, n, t, e, s) => (x, n, monoType env t, monoExp env e, s)) vis), loc)) end - | L.DExport n => + | L.DExport (ek, n) => let val (_, t, _, s) = Env.lookupENamed env n @@ -394,7 +394,7 @@ val ts = map (monoType env) (unwind t) in - SOME (env, (L'.DExport (s, n, ts), loc)) + SOME (env, (L'.DExport (ek, s, n, ts), loc)) end end diff -r 4b9c2bd6157c -r f0d3402184d1 src/shake.sml --- a/src/shake.sml Sun Jul 20 13:30:19 2008 -0400 +++ b/src/shake.sml Tue Jul 22 15:12:20 2008 -0400 @@ -44,7 +44,7 @@ fun shake file = let val page_es = List.foldl - (fn ((DExport n, _), page_es) => n :: page_es + (fn ((DExport (_, n), _), page_es) => n :: page_es | (_, page_es) => page_es) [] file val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, c), edef) diff -r 4b9c2bd6157c -r f0d3402184d1 src/tag.sml --- a/src/tag.sml Sun Jul 20 13:30:19 2008 -0400 +++ b/src/tag.sml Tue Jul 22 15:12:20 2008 -0400 @@ -66,7 +66,7 @@ val (xets, s) = ListUtil.foldlMap (fn ((x, e, t), (count, tags, byTag, newTags)) => let - fun tagIt newAttr = + fun tagIt (ek, newAttr) = let fun unravel (e, _) = case e of @@ -88,20 +88,25 @@ case IM.find (tags, f) of NONE => (count, count + 1, IM.insert (tags, f, count), - (f, count) :: newTags) + (ek, f, count) :: newTags) | SOME cn => (cn, count, tags, newTags) val (_, _, _, s) = E.lookupENamed env f val byTag = case SM.find (byTag, s) of - NONE => SM.insert (byTag, s, f) - | SOME f' => + NONE => SM.insert (byTag, s, (ek, f)) + | SOME (ek', f') => (if f = f' then () else ErrorMsg.errorAt loc ("Duplicate HTTP tag " ^ s); + if ek = ek' then + () + else + ErrorMsg.errorAt loc + "Function needed as both a link and a form "; byTag) val e = (EClosure (cn, args), loc) @@ -112,8 +117,8 @@ end in case x of - (CName "Link", _) => tagIt "Href" - | (CName "Action", _) => tagIt "Action" + (CName "Link", _) => tagIt (Link, "Href") + | (CName "Action", _) => tagIt (Action, "Action") | _ => ((x, e, t), (count, tags, byTag, newTags)) end) s xets @@ -154,13 +159,18 @@ fun doDecl (d as (d', loc), (env, count, tags, byTag)) = case d' of - DExport n => + DExport (ek, n) => let val (_, _, _, s) = E.lookupENamed env n in case SM.find (byTag, s) of NONE => ([d], (env, count, tags, byTag)) - | SOME n' => ([], (env, count, tags, byTag)) + | SOME (ek', n') => + (if ek = ek' then + () + else + ErrorMsg.errorAt loc "Function needed for both a link and a form"; + ([], (env, count, tags, byTag))) end | _ => let @@ -179,7 +189,7 @@ val env = env' val newDs = map - (fn (f, cn) => + (fn (ek, f, cn) => let fun unravel (all as (t, _)) = case t of @@ -225,7 +235,7 @@ end in (("wrap_" ^ fnam, cn, t, abs, tag), - (DExport cn, loc)) + (DExport (ek, cn), loc)) end) newTags val (newVals, newExports) = ListPair.unzip newDs diff -r 4b9c2bd6157c -r f0d3402184d1 tests/form2.lac --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/form2.lac Tue Jul 22 15:12:20 2008 -0400 @@ -0,0 +1,25 @@ +val handler1 = fn r => +

Name: {cdata r.Nam}

Word: {cdata r.Word}

+ + +val handler2 = fn r => +

Name: {cdata r.Nam}

Ward: {cdata r.Ward}

+ + +val main : unit -> page = fn () => + + Name:
+ Word:
+ + + + + + Name:
+ Word:
+ + + + diff -r 4b9c2bd6157c -r f0d3402184d1 tests/form3.lac --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/form3.lac Tue Jul 22 15:12:20 2008 -0400 @@ -0,0 +1,39 @@ +val handler1 = fn r => +

Name: {cdata r.Nam}

Word: {cdata r.Word}

+ + +val handler2 = fn r => +

Name: {cdata r.Nam}

Ward: {cdata r.Ward}

+ + +val handler3 = fn r => +

Name: {cdata r.Nam}

Ward: {cdata r.Ward}

Words: {cdata r.Words}

+ + +val main : unit -> page = fn () => + + Name:
+ Word:
+ + + + + + Name:
+ Word:
+ + + + + + Name:
+ Ward:
+ Words:
+ + + + diff -r 4b9c2bd6157c -r f0d3402184d1 tests/link.lac --- a/tests/link.lac Sun Jul 20 13:30:19 2008 -0400 +++ b/tests/link.lac Tue Jul 22 15:12:20 2008 -0400 @@ -1,7 +1,7 @@ -val ancillary : {} -> xhtml = fn () => +val ancillary = fn () => Welcome to the ancillary page! -val main : {} -> xhtml = fn () => +val main : unit -> page = fn () => Enter the unknown! diff -r 4b9c2bd6157c -r f0d3402184d1 tests/plink.lac --- a/tests/plink.lac Sun Jul 20 13:30:19 2008 -0400 +++ b/tests/plink.lac Tue Jul 22 15:12:20 2008 -0400 @@ -2,7 +2,7 @@ Hello World! -val main = fn () => +val main : unit -> page = fn () =>

Size 5

Size 10