Mercurial > urweb

comparison src/mono_util.sml @ 1612:7bb8c560f23d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Announce sidedness errors with source locations
author Adam Chlipala <adam@chlipala.net>
date Fri, 25 Nov 2011 11:08:51 -0500
parents 02fc16faecf3
children 0577be31a435
comparison
equal deleted inserted replaced
1611:217384f4b8ea 1612:7bb8c560f23d
464 case mapfoldB {typ = fn t => fn s => S.Continue (t, typ (t, s)), 464 case mapfoldB {typ = fn t => fn s => S.Continue (t, typ (t, s)),
465 exp = fn ctx => fn e => fn s => S.Continue (e, exp (ctx, e, s)), 465 exp = fn ctx => fn e => fn s => S.Continue (e, exp (ctx, e, s)),
466 bind = bind} ctx e s of 466 bind = bind} ctx e s of
467 S.Continue (_, s) => s 467 S.Continue (_, s) => s
468 | S.Return _ => raise Fail "MonoUtil.Exp.foldB: Impossible" 468 | S.Return _ => raise Fail "MonoUtil.Exp.foldB: Impossible"
469
470 fun appLoc f =
471 let
472 fun appl e =
473 (f e;
474 case #1 e of
475 EPrim _ => ()
476 | ERel _ => ()
477 | ENamed _ => ()
478 | ECon (_, _, eo) => Option.app appl eo
479 | ENone _ => ()
480 | ESome (_, e) => appl e
481 | EFfi _ => ()
482 | EFfiApp (_, _, es) => app appl es
483 | EApp (e1, e2) => (appl e1; appl e2)
484 | EAbs (_, _, _, e1) => appl e1
485 | EUnop (_, e1) => appl e1
486 | EBinop (_, _, e1, e2) => (appl e1; appl e2)
487 | ERecord xets => app (appl o #2) xets
488 | EField (e1, _) => appl e1
489 | ECase (e1, pes, _) => (appl e1; app (appl o #2) pes)
490 | EStrcat (e1, e2) => (appl e1; appl e2)
491 | EError (e1, _) => appl e1
492 | EReturnBlob {blob = e1, mimeType = e2, ...} => (appl e1; appl e2)
493 | ERedirect (e1, _) => appl e1
494 | EWrite e1 => appl e1
495 | ESeq (e1, e2) => (appl e1; appl e2)
496 | ELet (_, _, e1, e2) => (appl e1; appl e2)
497 | EClosure (_, es) => app appl es
498 | EQuery {query = e1, body = e2, initial = e3, ...} => (appl e1; appl e2; appl e3)
499 | EDml (e1, _) => appl e1
500 | ENextval e1 => appl e1
501 | ESetval (e1, e2) => (appl e1; appl e2)
502 | EUnurlify (e1, _, _) => appl e1
503 | EJavaScript (_, e1) => appl e1
504 | ESignalReturn e1 => appl e1
505 | ESignalBind (e1, e2) => (appl e1; appl e2)
506 | ESignalSource e1 => appl e1
507 | EServerCall (e1, _, _) => appl e1
508 | ERecv (e1, _) => appl e1
509 | ESleep e1 => appl e1
510 | ESpawn e1 => appl e1)
511 in
512 appl
513 end
469 514
470 end 515 end
471 516
472 structure Decl = struct 517 structure Decl = struct
473 518
701 | DStyle _ => count 746 | DStyle _ => count
702 | DTask _ => count 747 | DTask _ => count
703 | DPolicy _ => count 748 | DPolicy _ => count
704 | DOnError _ => count) 0 749 | DOnError _ => count) 0
705 750
751 fun appLoc f =
752 let
753 val eal = Exp.appLoc f
754
755 fun appl (d : decl) =
756 case #1 d of
757 DDatatype _ => ()
758 | DVal (_, _, _, e1, _) => eal e1
759 | DValRec vis => app (eal o #4) vis
760 | DExport _ => ()
761 | DTable (_, _, e1, e2) => (eal e1; eal e2)
762 | DSequence _ => ()
763 | DView (_, _, e1) => eal e1
764 | DDatabase _ => ()
765 | DJavaScript _ => ()
766 | DCookie _ => ()
767 | DStyle _ => ()
768 | DTask (e1, e2) => (eal e1; eal e2)
769 | DPolicy pol => applPolicy pol
770 | DOnError _ => ()
771
772 and applPolicy p =
773 case p of
774 PolClient e1 => eal e1
775 | PolInsert e1 => eal e1
776 | PolDelete e1 => eal e1
777 | PolUpdate e1 => eal e1
778 | PolSequence e1 => eal e1
779 in
780 app appl
781 end
782
706 end 783 end
707 784
708 end 785 end