src/Tools/Code/code_target.ML
changeset 37840 a3632a0b7d6c
parent 37825 adc1143bc1a8
child 37844 f26becedaeb1
equal deleted inserted replaced
37839:b77e521e9f50 37840:a3632a0b7d6c
   423   (cert_class thy class, cert_tyco thy tyco);
   423   (cert_class thy class, cert_tyco thy tyco);
   424 
   424 
   425 fun read_inst thy (raw_tyco, raw_class) =
   425 fun read_inst thy (raw_tyco, raw_class) =
   426   (read_class thy raw_class, read_tyco thy raw_tyco);
   426   (read_class thy raw_class, read_tyco thy raw_tyco);
   427 
   427 
   428 fun gen_add_syntax upd del mapp check_x check_raw_syn prep_syn prep_x target raw_x some_raw_syn thy =
   428 fun gen_add_syntax (mapp, upd, del) prep_x prep_syn check target raw_x some_raw_syn thy =
   429   let
   429   let
   430     val x = prep_x thy raw_x |> tap (check_x thy);
   430     val x = prep_x thy raw_x;
   431     fun prep_check raw_syn = prep_syn (raw_syn |> tap (check_raw_syn thy target));
   431     fun make_syn raw_syn = (check thy x raw_syn: unit; prep_syn raw_syn);
   432   in case some_raw_syn
   432   in case some_raw_syn
   433    of SOME raw_syn => (map_name_syntax target o mapp) (upd (x, prep_check raw_syn)) thy
   433    of SOME raw_syn => (map_name_syntax target o mapp) (upd (x, make_syn raw_syn)) thy
   434     | NONE => (map_name_syntax target o mapp) (del x) thy
   434     | NONE => (map_name_syntax target o mapp) (del x) thy
   435   end;
   435   end;
   436 
   436 
   437 fun gen_add_syntax_class prep_class =
   437 fun gen_add_syntax_class prep_class =
   438   gen_add_syntax Symtab.update Symtab.delete_safe (apfst o apfst) (K I) ((K o K o K) ()) I prep_class;
   438   gen_add_syntax (apfst o apfst, Symtab.update, Symtab.delete_safe) prep_class I ((K o K o K) ());
   439 
   439 
   440 fun gen_add_syntax_inst prep_inst =
   440 fun gen_add_syntax_inst prep_inst =
   441   gen_add_syntax Symreltab.update Symreltab.delete_safe (apfst o apsnd) (K I) ((K o K o K) ()) I prep_inst;
   441   gen_add_syntax (apfst o apsnd, Symreltab.update, Symreltab.delete_safe) prep_inst I ((K o K o K) ());
   442 
   442 
   443 fun gen_add_syntax_tyco prep_tyco =
   443 fun gen_add_syntax_tyco prep_tyco =
   444   gen_add_syntax Symtab.update Symtab.delete_safe (apsnd o apfst)
   444   gen_add_syntax (apsnd o apfst, Symtab.update, Symtab.delete_safe) prep_tyco I
   445     (fn thy => fn tyco => fn (n, _) => if n <> Sign.arity_number thy tyco
   445     (fn thy => fn tyco => fn (n, _) => if n <> Sign.arity_number thy tyco
   446       then error ("Number of arguments mismatch in syntax for type constructor " ^ quote tyco)
   446       then error ("Number of arguments mismatch in syntax for type constructor " ^ quote tyco)
   447       else ()) ((K o K o K) ()) I prep_tyco;
   447       else ());
   448 
   448 
   449 fun gen_add_syntax_const prep_const check_raw_syn prep_syn =
   449 fun gen_add_syntax_const prep_const prep_syn check_raw_syn =
   450   gen_add_syntax Symtab.update Symtab.delete_safe (apsnd o apsnd)
   450   gen_add_syntax (apsnd o apsnd, Symtab.update, Symtab.delete_safe) prep_const prep_syn
   451     (fn thy => fn c => fn (n, _) => if n > Code.args_number thy c
   451     (fn thy => fn c => fn (n, _) => if n > Code.args_number thy c
   452       then error ("Too many arguments in syntax for constant " ^ quote c)
   452       then error ("Too many arguments in syntax for constant " ^ quote c)
   453       else ()) check_raw_syn prep_syn prep_const;
   453       else ()) check_raw_syn;
   454 
   454 
   455 fun add_reserved target =
   455 fun add_reserved target =
   456   let
   456   let
   457     fun add sym syms = if member (op =) syms sym
   457     fun add sym syms = if member (op =) syms sym
   458       then error ("Reserved symbol " ^ quote sym ^ " already declared")
   458       then error ("Reserved symbol " ^ quote sym ^ " already declared")
   508 in
   508 in
   509 
   509 
   510 val add_syntax_class = gen_add_syntax_class cert_class;
   510 val add_syntax_class = gen_add_syntax_class cert_class;
   511 val add_syntax_inst = gen_add_syntax_inst cert_inst;
   511 val add_syntax_inst = gen_add_syntax_inst cert_inst;
   512 val add_syntax_tyco = gen_add_syntax_tyco cert_tyco;
   512 val add_syntax_tyco = gen_add_syntax_tyco cert_tyco;
   513 val add_syntax_const_simple = gen_add_syntax_const (K I) ((K o K o K) ()) Code_Printer.simple_const_syntax;
   513 val add_syntax_const_simple = gen_add_syntax_const (K I) Code_Printer.simple_const_syntax;
   514 val add_syntax_const = gen_add_syntax_const (K I) ((K o K o K) ()) I;
   514 val add_syntax_const = gen_add_syntax_const (K I) I;
   515 val allow_abort = gen_allow_abort (K I);
   515 val allow_abort = gen_allow_abort (K I);
   516 val add_reserved = add_reserved;
   516 val add_reserved = add_reserved;
   517 val add_include = add_include;
   517 val add_include = add_include;
   518 
   518 
   519 val add_syntax_class_cmd = gen_add_syntax_class read_class;
   519 val add_syntax_class_cmd = gen_add_syntax_class read_class;
   520 val add_syntax_inst_cmd = gen_add_syntax_inst read_inst;
   520 val add_syntax_inst_cmd = gen_add_syntax_inst read_inst;
   521 val add_syntax_tyco_cmd = gen_add_syntax_tyco read_tyco;
   521 val add_syntax_tyco_cmd = gen_add_syntax_tyco read_tyco;
   522 val add_syntax_const_simple_cmd = gen_add_syntax_const Code.read_const ((K o K o K) ()) Code_Printer.simple_const_syntax;
   522 val add_syntax_const_simple_cmd = gen_add_syntax_const Code.read_const Code_Printer.simple_const_syntax;
   523 val add_syntax_const_cmd = gen_add_syntax_const Code.read_const ((K o K o K) ()) I;
   523 val add_syntax_const_cmd = gen_add_syntax_const Code.read_const I;
   524 
   524 
   525 val allow_abort_cmd = gen_allow_abort Code.read_const;
   525 val allow_abort_cmd = gen_allow_abort Code.read_const;
   526 
   526 
   527 fun parse_args f args =
   527 fun parse_args f args =
   528   case Scan.read Token.stopper f args
   528   case Scan.read Token.stopper f args