home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Caml Light 0.7 / examples / asl / main.ml < prev    next >
Encoding:
Text File  |  1995-06-01  |  2.8 KB  |  107 lines  |  [TEXT/MPS ]
  1. (* $Id: main.ml,v 1.3 1994/11/10 09:57:21 xleroy Exp $ *)
  2.  
  3. #open "stream";;
  4. #open "asl";;
  5. #open "token";;
  6. #open "parser";;
  7. #open "semant";;
  8. #open "typing";;
  9.  
  10. let input_stream = ref std_in;;
  11. let trace_parsing = ref false;;
  12.  
  13. let print_prompt() =
  14.   print_string ">> "; flush std_out
  15. ;;
  16.  
  17. let read_fun =
  18.   let bol = ref true in
  19. fun() ->
  20.   if !bol then print_prompt();
  21.   let c = input_char !input_stream in
  22.   if !input_stream != std_in then print_char c;
  23.   bol := c == `\n`;
  24.   c
  25. ;;
  26.  
  27. let except_nth = except_l_n
  28.   where rec except_l_n = fun
  29.     [] _ -> []
  30.   | (elem::l) n -> if n = 0 then l else elem::except_l_n l (n-1)
  31. ;;
  32.  
  33. let replace_decl (Decl(s, _)) sm sigma =
  34.   begin try
  35.     let i = index s !global_env in
  36.     global_env := except_nth !global_env i;
  37.     global_sem := except_nth !global_sem i;
  38.     global_typing_env := except_nth !global_typing_env i
  39.   with _ -> ()
  40.   end;
  41.   global_env := s::!global_env;
  42.   global_sem := sm::!global_sem;
  43.   global_typing_env := sigma::!global_typing_env
  44. ;;
  45.  
  46. exception Break;;
  47.  
  48. let go() =
  49.   try
  50.     let cstrm = stream_from read_fun in
  51.     let strm = stream_from (fun _ -> next_token cstrm) in
  52.     while true do
  53.       try
  54.         let ta = top strm in
  55.         print_newline();
  56.         let (Decl(s,_)) = ta in
  57.         if !trace_parsing then (
  58.           print_string "   ";
  59.           do_stream print_string (print_top ta); print_newline()
  60.         );
  61.         let sigma = typing ta in
  62.         print_string "   "; print_string s; print_string " : ";
  63.         print_type_scheme sigma; print_newline();
  64.         let sm = semant_asl ta in
  65.         print_string "   "; print_string s; print_string " = ";
  66.         print_semval sm; print_newline();
  67.         replace_decl ta sm sigma
  68.       with
  69.         Parse_failure ->
  70.           print_newline();
  71.           raise Break
  72.       | Parse_error ->
  73.           print_newline();
  74.           print_string "*** Syntax error."; print_newline();
  75.           reset_lexer cstrm; stream_next strm; ()
  76.       | Unbound s ->
  77.           print_newline();
  78.           print_string "*** Unbound ASL identifier: ";
  79.           print_string s; print_newline();
  80.           reset_lexer cstrm (* ; stream_next strm; () *)
  81.       | Illtyped ->
  82.           print_newline();
  83.           print_string "*** Ill typed"; print_newline()
  84.       | Error s ->
  85.           print_newline();
  86.           print_string "*** Error: "; print_string s; print_newline();
  87.           raise Break
  88.       | Failure s ->
  89.           print_newline();
  90.           print_string "*** Failed: "; print_string s; print_newline()
  91.     done
  92.   with
  93.     Break ->
  94.       ()
  95.   | Failure s ->
  96.       print_string "*** Failed: "; print_string s; print_newline()
  97. ;;
  98.  
  99. global_env := "magic"::!global_env;;
  100. global_sem := (Funval(function x -> x))::!global_sem;;
  101. global_typing_env :=
  102.   Forall(
  103.     [1;2],
  104.     Arrow(TypeVar{Index=1; Value=Unknown},TypeVar{Index=2; Value=Unknown})
  105.   )::!global_typing_env;;
  106.  
  107.