lib/whenexpr.ml

   1 (* whenjobs
   2  * Copyright (C) 2012 Red Hat Inc.
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation; either version 2 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License along
  15  * with this program; if not, write to the Free Software Foundation, Inc.,
  16  * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17  *)
  18
  19 open Camlp4.PreCast
  20 open Ast
  21
  22 open CalendarLib
  23
  24 open Whenutils
  25
  26 open Big_int
  27 open Unix
  28 open Printf
  29
  30 type whenexpr =
  31   | Expr_unit
  32   | Expr_bool of bool
  33   | Expr_str of string
  34   | Expr_int of Big_int.big_int
  35   | Expr_float of float
  36   | Expr_var of string
  37   | Expr_and of whenexpr * whenexpr
  38   | Expr_or of whenexpr * whenexpr
  39   | Expr_lt of whenexpr * whenexpr
  40   | Expr_le of whenexpr * whenexpr
  41   | Expr_eq of whenexpr * whenexpr
  42   | Expr_ge of whenexpr * whenexpr
  43   | Expr_gt of whenexpr * whenexpr
  44   | Expr_not of whenexpr
  45   | Expr_add of whenexpr * whenexpr
  46   | Expr_sub of whenexpr * whenexpr
  47   | Expr_mul of whenexpr * whenexpr
  48   | Expr_div of whenexpr * whenexpr
  49   | Expr_mod of whenexpr * whenexpr
  50   | Expr_len of whenexpr
  51   | Expr_changes of string
  52   | Expr_increases of string
  53   | Expr_decreases of string
  54   | Expr_prev of string
  55   | Expr_reloaded
  56
  57 (* This internal type is used during conversion of the OCaml AST
  58  * to the whenexpr type.
  59  *)
  60 type whenexpr_int =
  61   | IExpr_unit
  62   | IExpr_bool of bool
  63   | IExpr_str of string
  64   | IExpr_int of Big_int.big_int
  65   | IExpr_float of float
  66   | IExpr_var of string
  67   | IExpr_app of string * whenexpr_int list
  68
  69 (* Note that days are not necessarily expressible in seconds (because
  70  * of leap seconds), months are not expressible in days (because months
  71  * have different lengths), and years are not expressible in days
  72  * (because of leap days) although we could save a case here by
  73  * expressing years in months.
  74  *)
  75 type periodexpr =
  76   | Every_seconds of int
  77   | Every_days of int
  78   | Every_months of int
  79   | Every_years of int
  80
  81 type shell_script = {
  82   sh_loc : Loc.t;
  83   sh_script : string;
  84 }
  85
  86 type result = {
  87   res_job_name : string;
  88   res_serial : Big_int.big_int;
  89   res_code : int;
  90   res_tmpdir : string;
  91   res_output : string;
  92 }
  93
  94 type cleanup = result -> unit
  95
  96 type variable =
  97   | T_unit
  98   | T_bool of bool
  99   | T_string of string
 100   | T_int of big_int
 101   | T_float of float
 102
 103 let variable_of_rpc = function
 104   | `unit_t -> T_unit
 105   | `bool_t b -> T_bool b
 106   | `string_t s -> T_string s
 107   | `int_t i -> T_int (big_int_of_string i)
 108   | `float_t f -> T_float f
 109
 110 let rpc_of_variable = function
 111   | T_unit -> `unit_t
 112   | T_bool b -> `bool_t b
 113   | T_string s -> `string_t s
 114   | T_int i -> `int_t (string_of_big_int i)
 115   | T_float f -> `float_t f
 116
 117 type variables = variable StringMap.t
 118
 119 type job_cond =
 120   | When_job of whenexpr
 121   | Every_job of periodexpr
 122
 123 type job = {
 124   job_loc : Loc.t;
 125   job_name : string;
 126   job_cleanup : cleanup option;
 127   job_cond : job_cond;
 128   job_script : shell_script;
 129 }
 130
 131 let rec expr_of_ast _loc ast =
 132   expr_of_iexpr _loc (iexpr_of_ast _loc ast)
 133
 134 and iexpr_of_ast _loc = function
 135   | ExId (_, IdUid (_, "()")) -> IExpr_unit
 136   | ExId (_, IdUid (_, "True")) -> IExpr_bool true
 137   | ExId (_, IdUid (_, "False")) -> IExpr_bool false
 138   | ExStr (_, str) -> IExpr_str str
 139   | ExInt (_, i) -> IExpr_int (big_int_of_string i) (* XXX too large? *)
 140   | ExFlo (_, f) -> IExpr_float (float_of_string f)
 141   | ExId (_, IdLid (_, id)) -> IExpr_var id
 142
 143   (* In the OCaml AST, functions are curried right to left, so we
 144    * must uncurry to get the list of arguments.
 145    *)
 146   | ExApp (_, left_tree, right_arg) ->
 147     let f, left_args = uncurry_app_tree _loc left_tree in
 148     IExpr_app (f, List.rev_map (iexpr_of_ast _loc) (right_arg :: left_args))
 149
 150   | e ->
 151     (* https://groups.google.com/group/fa.caml/browse_thread/thread/f35452d085654bd6 *)
 152     eprintf "expr_of_ast: invalid expression: %!";
 153     let e = Ast.StExp (_loc, e) in
 154     Printers.OCaml.print_implem ~output_file:"/dev/stderr" e;
 155
 156     invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
 157
 158 and uncurry_app_tree _loc = function
 159   | ExId (_, IdLid (_, f)) -> f, []
 160   | ExApp (_, left_tree, right_arg) ->
 161     let f, left_args = uncurry_app_tree _loc left_tree in
 162     f, (right_arg :: left_args)
 163   | e ->
 164     eprintf "uncurry_app_tree: invalid expression: %!";
 165     let e = Ast.StExp (_loc, e) in
 166     Printers.OCaml.print_implem ~output_file:"/dev/stderr" e;
 167
 168     invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
 169
 170 and expr_of_iexpr _loc = function
 171   | IExpr_unit -> Expr_unit
 172   | IExpr_bool b -> Expr_bool b
 173   | IExpr_str s -> Expr_str s
 174   | IExpr_int i -> Expr_int i
 175   | IExpr_float f -> Expr_float f
 176   | IExpr_var v -> Expr_var v
 177
 178   | IExpr_app ("&&", exprs) ->
 179     two_params _loc "&&" exprs (fun e1 e2 -> Expr_and (e1, e2))
 180
 181   | IExpr_app ("||", exprs) ->
 182     two_params _loc "||" exprs (fun e1 e2 -> Expr_or (e1, e2))
 183
 184   | IExpr_app ("<", exprs) ->
 185     two_params _loc "<" exprs (fun e1 e2 -> Expr_lt (e1, e2))
 186
 187   | IExpr_app ("<=", exprs) ->
 188     two_params _loc "<=" exprs (fun e1 e2 -> Expr_le (e1, e2))
 189
 190   | IExpr_app (("="|"=="), exprs) ->
 191     two_params _loc "=" exprs (fun e1 e2 -> Expr_eq (e1, e2))
 192
 193   | IExpr_app (">=", exprs) ->
 194     two_params _loc ">=" exprs (fun e1 e2 -> Expr_ge (e1, e2))
 195
 196   | IExpr_app (">", exprs) ->
 197     two_params _loc ">" exprs (fun e1 e2 -> Expr_gt (e1, e2))
 198
 199   | IExpr_app ("!", exprs) ->
 200     one_param _loc "!" exprs (fun e1 -> Expr_not e1)
 201
 202   | IExpr_app ("+", exprs) ->
 203     two_params _loc "+" exprs (fun e1 e2 -> Expr_add (e1, e2))
 204
 205   | IExpr_app ("-", exprs) ->
 206     two_params _loc "+" exprs (fun e1 e2 -> Expr_sub (e1, e2))
 207
 208   | IExpr_app ("*", exprs) ->
 209     two_params _loc "+" exprs (fun e1 e2 -> Expr_mul (e1, e2))
 210
 211   | IExpr_app ("/", exprs) ->
 212     two_params _loc "+" exprs (fun e1 e2 -> Expr_div (e1, e2))
 213
 214   | IExpr_app ("mod", exprs) ->
 215     two_params _loc "+" exprs (fun e1 e2 -> Expr_mod (e1, e2))
 216
 217   | IExpr_app (("len"|"length"|"size"), exprs) ->
 218     one_param _loc "len" exprs (fun e1 -> Expr_len e1)
 219
 220   | IExpr_app (("change"|"changes"|"changed"), [IExpr_var v]) ->
 221     Expr_changes v
 222
 223   | IExpr_app (("inc"|"increase"|"increases"|"increased"), [IExpr_var v]) ->
 224     Expr_increases v
 225
 226   | IExpr_app (("dec"|"decrease"|"decreases"|"decreased"), [IExpr_var v]) ->
 227     Expr_decreases v
 228
 229   | IExpr_app (("prev"|"previous"), [IExpr_var v]) ->
 230     Expr_prev v
 231
 232   | IExpr_app (("change"|"changes"|"changed"|"inc"|"increase"|"increases"|"increased"|"dec"|"decrease"|"decreases"|"decreased"|"prev"|"previous") as op, _) ->
 233     invalid_arg (sprintf "%s: '%s' operator must be followed by a variable name"
 234                    (Loc.to_string _loc) op)
 235
 236   | IExpr_app ("reloaded", [IExpr_unit]) ->
 237     Expr_reloaded
 238
 239   | IExpr_app ("reloaded", _) ->
 240     invalid_arg (sprintf "%s: you must use 'reloaded ()'" (Loc.to_string _loc))
 241
 242   | IExpr_app (op, _) ->
 243     invalid_arg (sprintf "%s: unknown operator in expression: %s"
 244                    (Loc.to_string _loc) op)
 245
 246 and two_params _loc op exprs f =
 247   match exprs with
 248   | [e1; e2] -> f (expr_of_iexpr _loc e1) (expr_of_iexpr _loc e2)
 249   | _ ->
 250     invalid_arg (sprintf "%s: %s operator must be applied to two parameters"
 251                    op (Loc.to_string _loc))
 252
 253 and one_param _loc op exprs f =
 254   match exprs with
 255   | [e1] -> f (expr_of_iexpr _loc e1)
 256   | _ ->
 257     invalid_arg (sprintf "%s: %s operator must be applied to one parameter"
 258                    op (Loc.to_string _loc))
 259
 260 let rec string_of_whenexpr = function
 261   | Expr_unit -> "()"
 262   | Expr_bool b -> sprintf "%b" b
 263   | Expr_str s -> sprintf "%S" s
 264   | Expr_int i -> sprintf "%s" (string_of_big_int i)
 265   | Expr_float f -> sprintf "%f" f
 266   | Expr_var v -> sprintf "%s" v
 267   | Expr_and (e1, e2) ->
 268     sprintf "%s && %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 269   | Expr_or (e1, e2) ->
 270     sprintf "%s || %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 271   | Expr_lt (e1, e2) ->
 272     sprintf "%s < %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 273   | Expr_le (e1, e2) ->
 274     sprintf "%s <= %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 275   | Expr_eq (e1, e2) ->
 276     sprintf "%s == %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 277   | Expr_ge (e1, e2) ->
 278     sprintf "%s >= %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 279   | Expr_gt (e1, e2) ->
 280     sprintf "%s > %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 281   | Expr_not e -> sprintf "! %s" (string_of_whenexpr e)
 282   | Expr_add (e1, e2) ->
 283     sprintf "%s + %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 284   | Expr_sub (e1, e2) ->
 285     sprintf "%s - %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 286   | Expr_mul (e1, e2) ->
 287     sprintf "%s * %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 288   | Expr_div (e1, e2) ->
 289     sprintf "%s / %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 290   | Expr_mod (e1, e2) ->
 291     sprintf "%s mod %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
 292   | Expr_len e -> sprintf "len %s" (string_of_whenexpr e)
 293   | Expr_changes v -> sprintf "changes %s" v
 294   | Expr_increases v -> sprintf "increases %s" v
 295   | Expr_decreases v -> sprintf "decreases %s" v
 296   | Expr_prev v -> sprintf "prev %s" v
 297   | Expr_reloaded -> "reloaded ()"
 298
 299 let string_of_periodexpr = function
 300   | Every_seconds 1 -> "1 second"
 301   | Every_seconds i -> sprintf "%d seconds" i
 302   | Every_days 1 -> "1 day"
 303   | Every_days i -> sprintf "%d days" i
 304   | Every_months 1 -> "1 month"
 305   | Every_months i -> sprintf "%d months" i
 306   | Every_years 1 -> "1 year"
 307   | Every_years i -> sprintf "%d years" i
 308
 309 let rec dependencies_of_whenexpr = function
 310   | Expr_unit -> []
 311   | Expr_bool _ -> []
 312   | Expr_str _ -> []
 313   | Expr_int _ -> []
 314   | Expr_float _ -> []
 315   | Expr_var v -> [v]
 316   | Expr_and (e1, e2)
 317   | Expr_or (e1, e2)
 318   | Expr_lt (e1, e2)
 319   | Expr_le (e1, e2)
 320   | Expr_eq (e1, e2)
 321   | Expr_ge (e1, e2)
 322   | Expr_gt (e1, e2)
 323   | Expr_add (e1, e2)
 324   | Expr_sub (e1, e2)
 325   | Expr_mul (e1, e2)
 326   | Expr_div (e1, e2)
 327   | Expr_mod (e1, e2) ->
 328     dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
 329   | Expr_not e
 330   | Expr_len e ->
 331     dependencies_of_whenexpr e
 332   | Expr_changes v
 333   | Expr_increases v
 334   | Expr_decreases v
 335   | Expr_prev v -> [v]
 336   | Expr_reloaded -> []
 337
 338 let dependencies_of_job = function
 339   | { job_cond = When_job whenexpr } -> dependencies_of_whenexpr whenexpr
 340   | { job_cond = Every_job _ } -> []
 341
 342 let rec eval_whenexpr variables prev_variables onload = function
 343   | Expr_unit -> T_unit
 344   | Expr_bool b -> T_bool b
 345   | Expr_str s -> T_string s
 346   | Expr_int i -> T_int i
 347   | Expr_float f -> T_float f
 348
 349   | Expr_var v ->
 350     get_variable variables v
 351
 352   | Expr_and (e1, e2) ->
 353     if eval_whenexpr_as_bool variables prev_variables onload e1 &&
 354        eval_whenexpr_as_bool variables prev_variables onload e2 then
 355       T_bool true
 356     else
 357       T_bool false
 358
 359   | Expr_or (e1, e2) ->
 360     if eval_whenexpr_as_bool variables prev_variables onload e1 ||
 361        eval_whenexpr_as_bool variables prev_variables onload e2 then
 362       T_bool true
 363     else
 364       T_bool false
 365
 366   | Expr_lt (e1, e2) ->
 367     let e1 = eval_whenexpr variables prev_variables onload e1
 368     and e2 = eval_whenexpr variables prev_variables onload e2 in
 369     if compare_values e1 e2 < 0 then
 370       T_bool true
 371     else
 372       T_bool false
 373
 374   | Expr_le (e1, e2) ->
 375     let e1 = eval_whenexpr variables prev_variables onload e1
 376     and e2 = eval_whenexpr variables prev_variables onload e2 in
 377     if compare_values e1 e2 <= 0 then
 378       T_bool true
 379     else
 380       T_bool false
 381
 382   | Expr_eq (e1, e2) ->
 383     let e1 = eval_whenexpr variables prev_variables onload e1
 384     and e2 = eval_whenexpr variables prev_variables onload e2 in
 385     if compare_values e1 e2 = 0 then
 386       T_bool true
 387     else
 388       T_bool false
 389
 390   | Expr_ge (e1, e2) ->
 391     let e1 = eval_whenexpr variables prev_variables onload e1
 392     and e2 = eval_whenexpr variables prev_variables onload e2 in
 393     if compare_values e1 e2 >= 0 then
 394       T_bool true
 395     else
 396       T_bool false
 397
 398   | Expr_gt (e1, e2) ->
 399     let e1 = eval_whenexpr variables prev_variables onload e1
 400     and e2 = eval_whenexpr variables prev_variables onload e2 in
 401     if compare_values e1 e2 > 0 then
 402       T_bool true
 403     else
 404       T_bool false
 405
 406   | Expr_not e ->
 407     if not (eval_whenexpr_as_bool variables prev_variables onload e) then
 408       T_bool true
 409     else
 410       T_bool false
 411
 412   | Expr_add (e1, e2) ->
 413     let e1 = eval_whenexpr variables prev_variables onload e1
 414     and e2 = eval_whenexpr variables prev_variables onload e2 in
 415     add_values e1 e2
 416
 417   | Expr_sub (e1, e2) ->
 418     let e1 = eval_whenexpr variables prev_variables onload e1
 419     and e2 = eval_whenexpr variables prev_variables onload e2 in
 420     sub_values e1 e2
 421
 422   | Expr_mul (e1, e2) ->
 423     let e1 = eval_whenexpr variables prev_variables onload e1
 424     and e2 = eval_whenexpr variables prev_variables onload e2 in
 425     mul_values e1 e2
 426
 427   | Expr_div (e1, e2) ->
 428     let e1 = eval_whenexpr variables prev_variables onload e1
 429     and e2 = eval_whenexpr variables prev_variables onload e2 in
 430     div_values e1 e2
 431
 432   | Expr_mod (e1, e2) ->
 433     let e1 = eval_whenexpr variables prev_variables onload e1
 434     and e2 = eval_whenexpr variables prev_variables onload e2 in
 435     mod_values e1 e2
 436
 437   | Expr_len e ->
 438     let e = eval_whenexpr variables prev_variables onload e in
 439     let e = string_of_variable e in
 440     T_int (big_int_of_int (String.length e))
 441
 442   | Expr_changes v ->
 443     let prev_value, curr_value = get_prev_curr_value variables prev_variables v in
 444     if compare_values prev_value curr_value <> 0 then
 445       T_bool true
 446     else
 447       T_bool false
 448
 449   | Expr_increases v ->
 450     let prev_value, curr_value = get_prev_curr_value variables prev_variables v in
 451     if compare_values prev_value curr_value < 0 then
 452       T_bool true
 453     else
 454       T_bool false
 455
 456   | Expr_decreases v ->
 457     let prev_value, curr_value = get_prev_curr_value variables prev_variables v in
 458     if compare_values prev_value curr_value > 0 then
 459       T_bool true
 460     else
 461       T_bool false
 462
 463   | Expr_prev v ->
 464     get_prev_variable prev_variables v
 465
 466   | Expr_reloaded ->
 467     T_bool onload
 468
 469 and get_prev_curr_value variables prev_variables v =
 470   let prev_value = get_prev_variable prev_variables v in
 471   let curr_value = get_variable variables v in
 472   prev_value, curr_value
 473
 474 and get_variable variables v =
 475   try StringMap.find v variables with Not_found -> T_string ""
 476
 477 and get_prev_variable prev_variables v =
 478   match prev_variables with
 479   | None ->
 480     (* Job has never run.  XXX Should do better here. *)
 481     T_string ""
 482   | Some prev_variables ->
 483     get_variable prev_variables v
 484
 485 (* Call {!eval_whenexpr} and cast the result to a boolean. *)
 486 and eval_whenexpr_as_bool variables prev_variables onload expr =
 487   match eval_whenexpr variables prev_variables onload expr with
 488   | T_unit -> false
 489   | T_bool r -> r
 490   | T_string s -> s <> ""
 491   | T_int i -> sign_big_int i <> 0
 492   | T_float f -> f <> 0.
 493
 494 (* Do a comparison on two typed values and return -1/0/+1.  If the
 495  * types are different then we compare the values as strings.  The user
 496  * can avoid this by specifying types.
 497  *)
 498 and compare_values value1 value2 =
 499   match value1, value2 with
 500   | T_bool b1, T_bool b2 -> compare b1 b2
 501   | T_string s1, T_string s2 -> compare s1 s2
 502   | T_int i1, T_int i2 -> compare_big_int i1 i2
 503   | T_float f1, T_float f2 -> compare f1 f2
 504     (* XXX BUG: int should be promoted to float in mixed numeric comparison *)
 505   | _ ->
 506     let value1 = string_of_variable value1
 507     and value2 = string_of_variable value2 in
 508     compare value1 value2
 509
 510 (* + operator is addition or string concatenation. *)
 511 and add_values value1 value2 =
 512   match value1, value2 with
 513   | T_int i1, T_int i2 -> T_int (add_big_int i1 i2)
 514   | T_float i1, T_float i2 -> T_float (i1 +. i2)
 515   | T_int i1, T_float i2 -> T_float (float_of_big_int i1 +. i2)
 516   | T_float i1, T_int i2 -> T_float (i1 +. float_of_big_int i2)
 517   | T_string i1, T_string i2 -> T_string (i1 ^ i2)
 518   | _ ->
 519     invalid_arg
 520       (sprintf "incompatible types in addition: %s + %s"
 521          (printable_string_of_variable value1)
 522          (printable_string_of_variable value2))
 523
 524 and sub_values value1 value2 =
 525   match value1, value2 with
 526   | T_int i1, T_int i2 -> T_int (sub_big_int i1 i2)
 527   | T_float i1, T_float i2 -> T_float (i1 -. i2)
 528   | T_int i1, T_float i2 -> T_float (float_of_big_int i1 -. i2)
 529   | T_float i1, T_int i2 -> T_float (i1 -. float_of_big_int i2)
 530   | _ ->
 531     invalid_arg
 532       (sprintf "incompatible types in subtraction: %s - %s"
 533          (printable_string_of_variable value1)
 534          (printable_string_of_variable value2))
 535
 536 and mul_values value1 value2 =
 537   match value1, value2 with
 538   | T_int i1, T_int i2 -> T_int (mult_big_int i1 i2)
 539   | T_float i1, T_float i2 -> T_float (i1 *. i2)
 540   | T_int i1, T_float i2 -> T_float (float_of_big_int i1 *. i2)
 541   | T_float i1, T_int i2 -> T_float (i1 *. float_of_big_int i2)
 542   | _ ->
 543     invalid_arg
 544       (sprintf "incompatible types in multiplication: %s * %s"
 545          (printable_string_of_variable value1)
 546          (printable_string_of_variable value2))
 547
 548 and div_values value1 value2 =
 549   match value1, value2 with
 550   | T_int i1, T_int i2 -> T_int (div_big_int i1 i2)
 551   | T_float i1, T_float i2 -> T_float (i1 /. i2)
 552   | T_int i1, T_float i2 -> T_float (float_of_big_int i1 /. i2)
 553   | T_float i1, T_int i2 -> T_float (i1 /. float_of_big_int i2)
 554   | _ ->
 555     invalid_arg
 556       (sprintf "incompatible types in division: %s / %s"
 557          (printable_string_of_variable value1)
 558          (printable_string_of_variable value2))
 559
 560 and mod_values value1 value2 =
 561   match value1, value2 with
 562   | T_int i1, T_int i2 -> T_int (mod_big_int i1 i2)
 563   | T_float i1, T_float i2 -> T_float (mod_float i1 i2)
 564   | T_int i1, T_float i2 -> T_float (mod_float (float_of_big_int i1) i2)
 565   | T_float i1, T_int i2 -> T_float (mod_float i1 (float_of_big_int i2))
 566   | _ ->
 567     invalid_arg
 568       (sprintf "incompatible types in modulo: %s mod %s"
 569          (printable_string_of_variable value1)
 570          (printable_string_of_variable value2))
 571
 572 and string_of_variable = function
 573   | T_unit -> "" (* for string_of_variable, we don't want () here *)
 574   | T_bool b -> string_of_bool b
 575   | T_string s -> s
 576   | T_int i -> string_of_big_int i
 577   | T_float f -> string_of_float f
 578
 579 and printable_string_of_variable = function
 580   | T_unit -> "()"
 581   | T_bool b -> string_of_bool b
 582   | T_string s -> sprintf "%S" s
 583   | T_int i -> string_of_big_int i
 584   | T_float f -> string_of_float f
 585
 586 let next_periodexpr =
 587   (* Round up 'a' to the next multiple of 'i'. *)
 588   let round_up_float a i =
 589     let r = mod_float a i in
 590     if r = 0. then a +. i else a +. (i -. r)
 591   and round_up a i =
 592     let r = a mod i in
 593     if r = 0 then a + i else a + (i - r)
 594   in
 595
 596   fun t -> function
 597   | Every_seconds i ->
 598     let i = float_of_int i in
 599     round_up_float t i
 600
 601   | Every_years i ->
 602     let tm = gmtime t in
 603
 604     (* Round 'tm' up to the first day of the next year. *)
 605     let year = round_up tm.tm_year i in
 606     let tm = { tm with tm_sec = 0; tm_min = 0; tm_hour = 0;
 607                        tm_mday = 1; tm_mon = 0; tm_year = year } in
 608     fst (mktime tm)
 609
 610   | Every_days i ->
 611     let t = Date.from_unixfloat t in
 612     let t0 = Date.make 1970 1 1 in
 613
 614     (* Number of whole days since Unix Epoch. *)
 615     let nb_days = Date.Period.safe_nb_days (Date.sub t t0) in
 616
 617     let nb_days = round_up nb_days i in
 618     let t' = Date.add t0 (Date.Period.day nb_days) in
 619     Date.to_unixfloat t'
 620
 621   | Every_months i ->
 622     (* Calculate number of whole months since Unix Epoch. *)
 623     let tm = gmtime t in
 624     let months = 12 * (tm.tm_year - 70) + tm.tm_mon in
 625
 626     let months = round_up months i in
 627     let t0 = Date.make 1970 1 1 in
 628     let t' = Date.add t0 (Date.Period.month months) in
 629     Date.to_unixfloat t'
 630
 631 let check_valid_variable_name name =
 632   (* Don't permit certain names. *)
 633   if name = "JOBSERIAL" then
 634     failwith "JOBSERIAL variable cannot be set";
 635
 636   let len = String.length name in
 637   if len = 0 then
 638     failwith "variable name is an empty string";
 639   if name.[0] <> '_' && not (isalpha name.[0]) then
 640     failwith "variable name must start with alphabetic character or underscore";
 641
 642   let rec loop i =
 643     if i >= len then ()
 644     else if name.[i] <> '_' && not (isalnum name.[i]) then
 645       failwith "variable name contains non-alphanumeric non-underscore character"
 646     else loop (i+1)
 647   in
 648   loop 1