*)
35 | val socket-close = descriptor-close
36 |
37 | fun socket-is-ipaddr s =
38 | let
39 | val fs = string-fields (fn ?. => true | _ => false) s
40 | fun is-non-integer x = case int-fromstring x of
41 | SOME y => false
42 | | NONE => true
43 | in
44 | ( (list-length fs) = 4 andalso
45 | list-exists (not o is-non-integer) fs )
46 | end
47 |
--------------------------------------------------------------------------------
/stdlib/std.uh:
--------------------------------------------------------------------------------
1 |
2 | val provide-std = ()
3 |
4 | (* install top-level exception handler. *)
5 |
6 | val () =
7 | letcc out
8 | in
9 | letcc toplevel
10 | in
11 | sethandler_ toplevel;
12 | throw () to out
13 | end;
14 |
15 | putc ?u; putc ?n; putc ?c;
16 | putc ?a; putc ?u; putc ?g;
17 | putc ?h; putc ?t; putc ? ;
18 | putc ?e; putc ?x; putc ?n;
19 | putc ?!; putc ?\n;
20 |
21 | halt ()
22 | end
23 |
24 | datatype (a, b) sum = LEFT of a | RIGHT of b
25 | datatype a option = SOME of a | NONE
26 |
27 | fun ignore _ = ()
28 |
29 | fun option-map f (SOME x) = SOME (f x)
30 | | option-map _ NONE = NONE
31 |
32 | fun isSome (SOME _) = true
33 | | isSome NONE = false
34 |
35 | fun valOf (SOME x) = x
36 | | valOf NONE = raise Match
37 |
38 | datatype order = LESS | GREATER | EQUAL
39 |
40 | fun order-equals (LESS, LESS) = true
41 | | order-equals (GREATER, GREATER) = true
42 | | order-equals (EQUAL, EQUAL) = true
43 | | order-equals (_, _) = false
44 |
45 | fun not true = false
46 | | not false = true
47 |
48 | fun o (f, g) x = f(g(x))
49 | infix o
50 |
51 | fun flip f x y = f y x
52 |
53 | (* wrap primitives *)
54 |
55 | exception Radix
56 |
57 | fun chr n =
58 | (* use unsigned comparison *)
59 | if n chk 256
60 | then raise Radix
61 | else chr_ n
62 |
63 | (* arrays *)
64 | exception Subscript
65 |
66 | fun sub (a, x) =
67 | (* use unsigned comparison *)
68 | if x chk length a
69 | then raise Subscript
70 | else sub_(a, x)
71 |
72 | fun update (a, x, e) =
73 | (* use unsigned comparison *)
74 | if x chk length a
75 | then raise Subscript
76 | else update_(a, x, e)
77 |
78 | (* numbers *)
79 |
80 | exception Div
81 |
82 | fun div (a,0) = raise Div
83 | | div (a,b) = div_ (a,b)
84 | infix div
85 |
86 | fun divs (a,0) = raise Div
87 | | divs (a,b) = sdiv_ (a,b)
88 | infix divs
89 |
90 | fun mod (a, b) =
91 | let val q = a div b
92 | in
93 | a - (b * q)
94 | end
95 |
96 | infix mod
97 |
98 |
--------------------------------------------------------------------------------
/stdlib/stream.uh:
--------------------------------------------------------------------------------
1 |
2 | val provide-stream = ()
3 |
4 | type a susp = unit -> a
5 |
6 | datatype a front = Nil | Cons of a * front susp
7 | type a stream = a front susp
8 |
9 | fun stream-delay s =
10 | let
11 | val r = ref (fn () => raise Match)
12 | in
13 | r := (fn () =>
14 | let val ss = s ()
15 | in
16 | r := (fn () => ss);
17 | ss
18 | end);
19 | (fn () => (!r) ())
20 | end
21 |
22 | fun stream-force s = s ()
23 |
24 | (* SUSP workaround generalization/unification bug
25 | (it's probably because let fun f () = e
26 | in f end isn't a value)
27 | *)
28 | (* val stream-empty = (fn () => Nil) *)
29 | fun stream-empty () = Nil
30 |
31 | (* no memoization; there's no point *)
32 | fun stream-fromlist nil = stream-empty
33 | | stream-fromlist (h :: t) = (fn () => Cons (h, stream-fromlist t))
34 |
35 | (* ditto. *)
36 | fun stream-fromstring s =
37 | let
38 | fun rs n () =
39 | if n chk length s
40 | then Nil
41 | (* PERF sub_ *)
42 | else Cons(sub(s, n), rs (n + 1))
43 | in
44 | rs 0
45 | end
46 |
47 | fun stream-app f =
48 | let
49 | fun sa s =
50 | case stream-force s of
51 | Nil => ()
52 | | Cons (h, s') => (f h; sa s')
53 | in
54 | sa
55 | end
56 |
57 |
--------------------------------------------------------------------------------
/stdlib/tasks.uh:
--------------------------------------------------------------------------------
1 | val provide-tasks = ()
2 | val require-threads = provide-threads
3 | val require-messagequeues = provide-messagequeues
4 |
5 | (* arguments: message queue, function to call, initial state *)
6 | (* function fu should return just the next state *)
7 | fun task-create mq fu st =
8 | let
9 | fun looper s () =
10 | let
11 | val x = mq-receive mq
12 | val s' = case x of NONE => s
13 | | SOME m => fu s m
14 | in
15 | ( yield () ;
16 | looper s' () )
17 | end
18 | in
19 | fork (looper st)
20 | end
21 |
--------------------------------------------------------------------------------
/stdlib/threads.uh:
--------------------------------------------------------------------------------
1 | val provide-threads = ()
2 |
3 | val threads = ref nil
4 |
5 | fun yield () =
6 | letcc k
7 | in
8 | case !threads
9 | of nil => ()
10 | | t::rest => ( threads := rest @ ((fn () => throw () to k ) :: nil) ;
11 | t () )
12 | end
13 |
14 | fun resched () =
15 | case !threads of nil => ()
16 | | t :: rest => ( threads := rest ;
17 | t () )
18 |
19 | fun fork t =
20 | let
21 | fun harness () = ( t () ; resched () )
22 | in
23 | threads := (harness :: !threads)
24 | end
25 |
--------------------------------------------------------------------------------
/stdlib/time.uh:
--------------------------------------------------------------------------------
1 | val provide-time = ()
2 | val require-array = provide-array
3 | val require-string = provide-string
4 |
5 | (* *)
6 | type timedata =
7 | {
8 | seconds : int,
9 | minutes : int,
10 | hours : int,
11 | date : int,
12 | month : int,
13 | year : int,
14 | unix_time : int
15 | }
16 |
17 | (* *)
18 | fun time-tostring timerec =
19 | let
20 | val month = int-tostring (#month/timedata timerec)
21 | val day = int-tostring (#date/timedata timerec)
22 | val year = int-tostring (#year/timedata timerec)
23 | val h = int-tostring (#hours/timedata timerec)
24 | val m = int-tostring (#minutes/timedata timerec)
25 | val s = int-tostring (#seconds/timedata timerec)
26 |
27 | fun format v =
28 | if (length v) = 1
29 | then ("0" ^ v)
30 | else v
31 | in
32 | [[month]/[day]/[year] [h]:[(format m)]:[(format s)]]
33 | end
34 |
35 | (* *)
36 | fun time-to-seconds timerec =
37 | let
38 | (* compute delta time from 00:00:00 jan 1, 1970 *)
39 | val dsec = #seconds/timedata timerec
40 | val dmin = #minutes/timedata timerec
41 | val dhour = #hours/timedata timerec
42 | val ddate = (#date/timedata timerec) - 1
43 | val month = #month/timedata timerec
44 | val year = #year/timedata timerec
45 |
46 | val seconds_per_hour = 3600
47 | val seconds_per_day = 24 * seconds_per_hour
48 | val seconds_per_year = 365 * seconds_per_day
49 |
50 | fun is-leap-year year =
51 | let
52 | val y4 = (year mod 4) = 0
53 | val y100 = (year mod 100) <> 0
54 | val y400 = (year mod 400) = 0
55 | in
56 | (y4 andalso y100) orelse y400
57 | end
58 |
59 | fun year-seconds y =
60 | let
61 | fun leap-seconds-per-year y i acc =
62 | if i >= y then acc
63 | else (if is-leap-year i
64 | then leap-seconds-per-year y (i+1) (acc + seconds_per_day)
65 | else leap-seconds-per-year y (i+1) acc)
66 | in
67 | ( (y - 1970) * seconds_per_year +
68 | (leap-seconds-per-year y 1970 0) )
69 | end
70 |
71 | fun month-seconds y m =
72 | let
73 | val days = {| 0, 31, (if is-leap-year y then 29 else 28), 31, 30,
74 | 31, 30, 31, 31, 30, 31, 30, 31 |}
75 |
76 | fun secs m i acc =
77 | let
78 | val secs_for_month = sub(days, i) * seconds_per_day
79 | in
80 | if i >= m then acc
81 | else secs m (i+1) (acc + secs_for_month)
82 | end
83 | in
84 | secs m 1 0
85 | end
86 |
87 | in
88 | (dsec +
89 | (dmin * 60) +
90 | (dhour * seconds_per_hour) +
91 | (ddate * seconds_per_day) +
92 | (month-seconds year month) +
93 | (year-seconds year))
94 | end
95 |
96 |
97 |
98 |
99 |
100 |
101 |
--------------------------------------------------------------------------------
/stdlib/timer.uh:
--------------------------------------------------------------------------------
1 | (* support for timers *)
2 |
3 | val provide-timers = ()
4 | val require-list = provide-list
5 | val require-clock = provide-clock
6 |
7 | (* timer-list is (next available timer id,
8 | last checked time,
9 | list of (id, deltatime, callback) *)
10 | val timer-list = (0, clock-gettime(), nil)
11 |
12 | fun timer-list-tostring (nextid, last-check, nil) acc = acc ^ "\n"
13 | | timer-list-tostring (nextid, last-check, (i, d, f) :: xs) acc =
14 | timer-list-tostring (nextid, last-check, xs) (acc ^ "," ^ "[id=" ^ int-tostring i ^ " " ^ clock-tostring d ^ "]")
15 |
16 | fun timer-create ls t =
17 | let
18 | fun timer-create' (nextid, last-check, nil) (dt, f') acc =
19 | (nextid, (nextid + 1,
20 | last-check,
21 | acc @ ((nextid, dt, f') :: nil)))
22 | | timer-create' (nextid, last-check, x :: xs) (dt, f') acc =
23 | let
24 | val (i, d, f) = x
25 | in
26 | if clock-lt dt d
27 | then (nextid, (nextid + 1,
28 | last-check,
29 | acc @ ((nextid, dt, f') :: (i, clock-sub d dt, f) :: xs)))
30 | else timer-create' (nextid, last-check, xs) (clock-sub dt d, f') (acc @ (x :: nil))
31 | end
32 | in
33 | timer-create' ls t nil
34 | end
35 |
36 | fun timer-delete id (n, l, xs) =
37 | let
38 | fun timer-delete' id (n, l, nil) acc = (n, l, acc)
39 | | timer-delete' id (n, l, x :: nil) acc =
40 | let
41 | val (i, d, f) = x
42 | in
43 | if i = id then (n, l, acc) else (n, l, acc @ (x :: nil))
44 | end
45 | | timer-delete' id (n, l, x :: x' :: xs) acc =
46 | let
47 | val (i, d, f) = x
48 | in
49 | if i = id
50 | then
51 | let
52 | val (i', d', f') = x'
53 | in
54 | (n, l, acc @ ((i', clock-add d d', f') :: xs))
55 | end
56 | else timer-delete' id (n, l, x' :: xs) (acc @ (x :: nil))
57 | end
58 | in
59 | timer-delete' id (n, l, xs) nil
60 | end
61 |
62 | fun timer-scan (nextid, last-check, nil) = (nextid, last-check, nil)
63 | | timer-scan (nextid, last-check, (i, d, f) :: xs) =
64 | let
65 | val curr = clock-gettime ()
66 | val delta = clock-sub curr last-check
67 | val diff = clock-sub d delta
68 | in
69 | if clock-lt diff (0, 0)
70 | then ( f ();
71 | timer-scan (nextid, curr, xs) )
72 | else ( (nextid, curr, (i, diff, f) :: xs) )
73 | end
74 |
75 |
--------------------------------------------------------------------------------
/stdlib/util.uh:
--------------------------------------------------------------------------------
1 | val provide-util = ()
2 |
3 | (* puzzles *)
4 | fun for lo hi f =
5 | if lo > hi then ()
6 | else (f lo; for (lo + 1) hi f)
7 | fun ford lo hi b f =
8 | if lo > hi then b
9 | else (ford (lo + 1) hi (f (lo, b)) f)
10 |
--------------------------------------------------------------------------------
/tests/BUG-notag-noncarrier.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | datatype t = A
4 | in
5 | A
6 | end
7 |
--------------------------------------------------------------------------------
/tests/Makefile:
--------------------------------------------------------------------------------
1 |
2 | HUMLOCK = ../humlock
3 |
4 | %.um: %.uml ${HUMLOCK}
5 | time ${HUMLOCK} @MLton max-heap 300m -- -iloptstop 200 -sequence-unit $<;
6 |
--------------------------------------------------------------------------------
/tests/aa/exn.aa:
--------------------------------------------------------------------------------
1 |
2 | let
3 | exception X of int
4 | in
5 |
6 | print
7 | ((if raise X 3 then "no-1" else "no-2")
8 | handle X n => (if n = 3 then "yes" else "noooo")
9 | | _ => "no")
10 | end
--------------------------------------------------------------------------------
/tests/aa/expmatch.aa:
--------------------------------------------------------------------------------
1 | let
2 | datatype t = A | B
3 | fun f x =
4 | (case x of
5 | (A,A,_,_,_,_,_,_) => 0
6 | | (_,_,A,A,_,_,_,_) => 1
7 | | (_,_,_,_,A,A,_,_) => 2
8 | | (_,_,_,_,_,_,A,A) => 3
9 | | (A,B,A,B,A,B,A,B) => 999)
10 | in
11 | f
12 | end
13 |
--------------------------------------------------------------------------------
/tests/aa/expmatch3.aa:
--------------------------------------------------------------------------------
1 | let
2 | datatype t = A | B
3 | fun f x =
4 | (case x of
5 | (A,A,_,_,_,_) => 0
6 | | (_,_,A,A,_,_) => 1
7 | | (_,_,_,_,A,A) => 2
8 | | (A,B,A,B,A,B) => 999)
9 | in
10 | f
11 | end
12 |
--------------------------------------------------------------------------------
/tests/aa/jointext.aa:
--------------------------------------------------------------------------------
1 |
2 | let
3 | fun a () = [hello[[ ]]world]
4 | fun b () = [] ^ [well, oh well[[]]]
5 | fun c x = [first[x], then [[[x]this[x]]] that]
6 | in
7 | (itos 100 ^ (a () ^ "" ^ b () ^ c [hello]) ^ "")
8 | end
--------------------------------------------------------------------------------
/tests/aa/list2.aa:
--------------------------------------------------------------------------------
1 |
2 | let
3 | (* minimal list library *)
4 |
5 | (* datatype a list = Nil of unit | :: of a * list *)
6 |
7 | infixr ::
8 |
9 |
10 | fun list-rev l =
11 | let
12 | fun revv (nil (), acc) = acc
13 | | revv (h::t, acc) = revv (t, h::acc)
14 | in
15 | revv (l, nil ())
16 | end
17 |
18 | (*
19 | fun @ (h::t, l2) = h :: @(t, l2)
20 | | @ (nil, l2) = l2
21 |
22 | infixr @
23 |
24 | fun list-eq _ (nil (), nil ()) = true ()
25 | | list-eq f (a :: at, b :: bt) =
26 | if f (a, b)
27 | then list-eq f (at, bt)
28 | else false()
29 | | list-eq _ _ = false ()
30 | *)
31 |
32 | fun list-map f (nil ()) = nil ()
33 | | list-map f (h :: t) = f h :: list-map f t
34 |
35 | (*
36 | fun list-length l =
37 | let
38 | fun ll (nil (), acc) = acc
39 | | ll (_ :: t, acc) = ll (t, acc + 1)
40 | in
41 | ll (l, 0)
42 | end
43 | *)
44 | (*
45 | fun list-foldr f b =
46 | let
47 | fun fr (h::t) = f(h, fr t)
48 | | fr (nil ()) = b
49 | in
50 | fr
51 | end
52 |
53 | fun list-foldl f b l =
54 | let
55 | fun fl (x, nil ()) = x
56 | | fl (x, h :: t) = fl(f(h, x), t)
57 | in
58 | fl (b, l)
59 | end
60 |
61 | fun list-concat ll = list-foldr op@ (nil ()) ll
62 |
63 | fun list-filter f =
64 | let
65 | fun fi (nil ()) = nil ()
66 | | fi (h :: t) = if f h
67 | then f :: fi t
68 | else fi t
69 | in
70 | fi
71 | end
72 |
73 | fun list-exists f =
74 | let
75 | fun ex (nil ()) = false ()
76 | | ex (h :: t) = if f h
77 | then true ()
78 | else ex t
79 | in
80 | ex
81 | end
82 |
83 | fun list-all f =
84 | let
85 | fun al (nil ()) = true ()
86 | | al (h :: t) = if f h
87 | then al t
88 | else false ()
89 | in
90 | al
91 | end
92 |
93 | fun list-tabulate (i, f) =
94 | let
95 | fun go n =
96 | if n < i
97 | then f n :: go (n + 1)
98 | else nil ()
99 | in
100 | go 0
101 | end
102 | *)
103 | (*
104 | val length = list-length
105 | val rev = list-rev
106 | val map = list-map
107 | val foldr = list-foldr
108 | val foldl = list-foldl
109 | *)
110 | in
111 |
112 | list-map (fn x => (print x; print "\n"))
113 | (list-rev ("world"::"hello"::nil ()))
114 | end
--------------------------------------------------------------------------------
/tests/aa/nullary.aa:
--------------------------------------------------------------------------------
1 |
2 | let datatype tt = A | B
3 | fun ++(x : tt, y : tt) = B
4 | infix ++
5 | in
6 | A ++ B;
7 |
8 | (A : tt, B : tt) : tt * tt
9 | end
--------------------------------------------------------------------------------
/tests/aa/opt.aa:
--------------------------------------------------------------------------------
1 |
2 | let
3 |
4 | val a = 3
5 | val b = 4
6 |
7 | val c = 1 + 2
8 | val d = c
9 | in
10 | (* itos (a + b) ^ "hello" ^ *) itos d ^ itos d ^ itos d
11 |
12 | end
--------------------------------------------------------------------------------
/tests/aa/parsetype.aa:
--------------------------------------------------------------------------------
1 | let
2 | datatype a thing = Yes of a
3 | datatype b funny = No of b
4 | datatype (a, b) zoo = Zoo of a * b
5 |
6 | fun f(x : (int, int) zoo thing funny,
7 | z : int funny thing
8 | ) = x
9 | in
10 | f (No (Yes( Zoo(0, 0))), Yes(No(1)))
11 | end
12 |
--------------------------------------------------------------------------------
/tests/aa/pconst.aa:
--------------------------------------------------------------------------------
1 | let
2 |
3 | fun f 11 111 = "one"
4 | | f 22 222 = "two"
5 | | f 22 333 = "twentythree"
6 | | f 33 333 = "three"
7 | | f _ _ = "other"
8 | in
9 |
10 | f 22 333
11 | end
--------------------------------------------------------------------------------
/tests/aa/refs.aa:
--------------------------------------------------------------------------------
1 | let
2 | fun printp s = print [[s]]
3 |
4 | val r0 = ref "hello"
5 | val r1 = ref "zero"
6 | in
7 | printp (! r0);
8 | printp (! r1);
9 | r1 := "one";
10 | printp (! r1);
11 | printp (! r0);
12 | r0 := ! r1;
13 | printp (! r1);
14 | printp (! r0)
15 | end
--------------------------------------------------------------------------------
/tests/aa/text.aa:
--------------------------------------------------------------------------------
1 |
2 | let
3 | val x = [this is my awesome text.
4 | it shouldn't have any space before each line.
5 | well, except this line. but I put that there.
6 | okay see you!]
7 |
8 | val y = [here's another test. It has ["embedded text"]!
9 | but it should still work as above.]
10 |
11 | val z = [there should be a warning if you use
12 | tab characters to indent.]
13 |
14 | val a = [also there should be a warning
15 | if you have text in the indentation.]
16 |
17 | val b = [this text should have a newline in it,
18 |
19 | but that shouldn't be a warning, even though
20 | the blank line is not indented. right?]
21 |
22 | val c = [this text does NOT have a newline in, though\
23 | it spans several lines.\
24 | right?]
25 | in
26 | print x;
27 | print y;
28 | print z;
29 | print a;
30 | print b;
31 | print c
32 | end
--------------------------------------------------------------------------------
/tests/activeobject.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "array.uh"
7 | import "char.uh"
8 | import "tasks.uh"
9 | import "queues.uh"
10 | import "messagequeues.uh"
11 | import "futures.uh"
12 | import "activeobject.uh"
13 |
14 | fun task-a-hook (st, m, fu) =
15 | ( print [message is: [m] and state is [int-tostring st]\n] ;
16 | future-complete fu () ;
17 | st+1 )
18 |
19 | val ao = activeobject-create task-a-hook 1
20 |
21 | fun task1 () = ( future-force (ao ("greetings")) ;
22 | future-force (ao ("goodbye!")) ;
23 | future-force (ao ("hihihi")) )
24 |
25 | val () = fork task1
26 | in
27 | resched ()
28 | end
29 |
--------------------------------------------------------------------------------
/tests/app_test2.uml:
--------------------------------------------------------------------------------
1 | let
2 | fun g x = x + 1
3 | val a = g 3
4 | val b = g 4
5 | do putc (chr_ (a + b))
6 | in
7 | ()
8 | end
9 |
--------------------------------------------------------------------------------
/tests/arduino-test.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "arduino.uh"
7 |
8 | fun looper (x) =
9 | ( arduino-digital-write (13, x mod 2) ;
10 | arduino-delay 500 ;
11 | looper (x + 1) )
12 |
13 | in
14 | ( arduino-pin-mode (13, 1) ;
15 | looper 0 )
16 | end
17 |
--------------------------------------------------------------------------------
/tests/arith.sml:
--------------------------------------------------------------------------------
1 | let
2 |
3 | val ls = 10 :: 7 :: 5 :: nil
4 | val r1 = foldr (op +) 0 ls
5 | val r2 = foldr (op -) 0 ls
6 | val r3 = r1 - 23
7 | val r4 = r1 div 2
8 | val r5 = r1 div (0 - 2)
9 |
10 |
11 | in
12 | print ((Int.toString r1) ^ "\n");
13 | print ((Int.toString r2) ^ "\n");
14 | print ((Int.toString r3) ^ "\n");
15 | print ((Int.toString r4) ^ "\n");
16 | print ((Int.toString r5) ^ "\n")
17 | end
18 |
19 |
--------------------------------------------------------------------------------
/tests/arith.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | import "int.uh"
5 | import "list.uh"
6 |
7 | val ls = 10 :: 7 :: 5 :: nil
8 | val r1 = list-foldr (op +) 0 ls
9 | val r2 = list-foldr (op -) 0 ls
10 | val r3 = r1 - 23
11 | val r4 = r1 div 2
12 | val r5 = r1 divs (0 - 2)
13 |
14 | in
15 | print ((int-tostring r1) ^ "\n");
16 | print ((int-tostring r2) ^ "\n");
17 | print ((int-tostring r3) ^ "\n");
18 | print ((int-tostring r4) ^ "\n");
19 | print ((int-tostring r5) ^ "\n")
20 | end
21 |
22 |
--------------------------------------------------------------------------------
/tests/arith_negative.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | import "int.uh"
5 |
6 | val x = 63
7 | val y = 1000
8 |
9 | val () = if 5 > (0-10) then (print "correct") else (print "incorrect")
10 | val () = if (0-2) > (0-30) then (print "correct") else (print "incorrect")
11 |
12 | in
13 | (print (int-tostring (x - y)))
14 | handle Subscript => print "subscript"
15 | | Match => print "match"
16 | | Div => print "div"
17 | | Radix => print "radix"
18 | | _ => print "something else"
19 | end
20 |
21 |
--------------------------------------------------------------------------------
/tests/arr.uml:
--------------------------------------------------------------------------------
1 | (* Tests array primitives. (these are unsafe.)
2 | for checked prims see arrays.uml. *)
3 |
4 | let
5 | val _ = (putc ?0; putc ?\n)
6 |
7 | val a = array(10, ?a)
8 |
9 | val _ = (putc ?1; putc ?\n)
10 |
11 | fun go 10 = ()
12 | | go n =
13 | let in
14 | update_(a, n, chr_ (2 + n + ord (sub_(a, n))));
15 | go (n + 1)
16 | end
17 |
18 | fun pr 10 = ()
19 | | pr n =
20 | let in
21 | putc (sub_(a, n));
22 | pr (n + 1)
23 | end
24 | in
25 | go 0;
26 | (putc ?2; putc ?\n);
27 | pr 0;
28 | putc ?\n
29 | end
--------------------------------------------------------------------------------
/tests/array-st.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "array.uh"
7 |
8 | fun f (i, s) = ( s, s ^ (int-tostring i) )
9 |
10 | val (a, sf) = array-tabulate-st 9 f "start:"
11 |
12 | fun pf ar = array-app print ar
13 |
14 | fun g (x, s) = ( print [[x]...[int-tostring s]\n] ;
15 | s + 1 )
16 | in
17 | ( pf a ;
18 | print [\n\n\n] ;
19 | array-app-st g a 0)
20 | end
21 |
--------------------------------------------------------------------------------
/tests/array-tabulate-st.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "array.uh"
7 |
8 | fun f (i, s) = ( s, s ^ (int-tostring i) )
9 |
10 | val (a, sf) = array-tabulate-st 9 f "start:"
11 |
12 | fun pf ar = array-app print ar
13 | in
14 | pf a
15 | end
16 |
--------------------------------------------------------------------------------
/tests/array0.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "list.uh"
7 | import "array.uh"
8 | in
9 | print "Should be 0: ";
10 | print (int-tostring (length (array0 ())));
11 | print "\n"
12 | end
--------------------------------------------------------------------------------
/tests/arrays.uml:
--------------------------------------------------------------------------------
1 |
2 | (* Test the checked (poly)array primitives
3 | from the standard library. *)
4 | let
5 | import "std.uh"
6 |
7 | val n = 6
8 |
9 | val _ = (putc ?0; putc ?\n)
10 |
11 | val a = array(n, ?a)
12 |
13 | val _ = (putc ?1; putc ?\n)
14 |
15 | val _ = (putc ?l; putc ?e; putc ?n;
16 | putc ?:; putc ? ;
17 | putc (chr (ord ?0 + length a));
18 | putc ?\n)
19 |
20 | val _ = (if length a = n
21 | then (putc ?O; putc ?K; putc ?!;
22 | putc ? ; putc ?@; putc ?\n)
23 | else (putc ?N; putc ?O; putc ?!;
24 | putc ? ; putc ?@; putc ?\n))
25 |
26 | val _ = (putc ?2; putc ?\n)
27 |
28 | fun oob_hi () =
29 | (sub(a, n);
30 | putc ?N;
31 | putc ?O;
32 | putc ?!;
33 | putc ?\n)
34 | handle Subscript =>
35 | (putc ?O;
36 | putc ?K;
37 | putc ?!;
38 | putc ?\n)
39 |
40 | fun oob_low () =
41 | (sub(a, 0 - 1);
42 | putc ?N;
43 | putc ?O;
44 | putc ?!;
45 | putc ? ;
46 | putc ?*;
47 | putc ?\n)
48 | handle Subscript =>
49 | (putc ?O;
50 | putc ?K;
51 | putc ?!;
52 | putc ? ;
53 | putc ?*;
54 | putc ?\n)
55 |
56 | fun go m =
57 | if m = n then ()
58 | else
59 | let in
60 | update(a, m, chr (2 + m + ord (sub(a, m))));
61 | go (m + 1)
62 | end
63 |
64 | fun pr m =
65 | if m = n then ()
66 | else
67 | let in
68 | putc (sub(a, m));
69 | pr (m + 1)
70 | end
71 | in
72 | oob_hi ();
73 | (putc ?3; putc ?\n);
74 | oob_low ();
75 | (putc ?4; putc ?\n);
76 | go 0;
77 | (putc ?5; putc ?\n);
78 | (putc ?s; putc ?h; putc ?o; putc ?u; putc ?l; putc ?d; putc ? ;
79 | putc ?s; putc ?e; putc ?e; putc ? ;
80 | putc ?c; putc ?d; putc ?e; putc ?f; putc ?g; putc ?h; putc ?:;
81 | putc ?\n);
82 | pr 0;
83 | putc ?\n
84 | end handle _ =>
85 | let in
86 | putc ?e; putc ?x; putc ?n; putc ?\n
87 | end
88 |
--------------------------------------------------------------------------------
/tests/badjump.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | fun ^ (a, b) = "X"
4 | infix ^
5 |
6 | fun list-map f =
7 | let
8 | fun m nil = nil
9 | | m (h::t) = f h :: m t
10 | in
11 | m
12 | end
13 |
14 | datatype goggles =
15 | EnglishGoggles
16 | | XMLGoggles
17 |
18 | fun goggles-tostring EnglishGoggles = "English"
19 | | goggles-tostring XMLGoggles = "XML"
20 |
21 | val all-goggles = EnglishGoggles ::
22 | XMLGoggles ::
23 | nil
24 |
25 | fun format-list start empty sep sepN en nil = empty
26 | | format-list start empty sep sepN en l =
27 | let fun f (x::nil) = x
28 | | f (x::y::nil) = x ^ sepN ^ y
29 | | f (x::l) = x ^ sep ^ (f l)
30 | in
31 | start ^ (f l) ^ en
32 | end
33 |
34 |
35 | (* parses user input *)
36 | do putc ?G
37 | do putc ?\n
38 |
39 | val goggles_description =
40 | format-list "According to the markings on your goggles, "
41 | "Impossible!"
42 | ", " ", and " "."
43 | (list-map goggles-tostring all-goggles)
44 |
45 | do (putc ?O; putc ?K; putc ?\n)
46 |
47 | in
48 | ()
49 | end
50 |
--------------------------------------------------------------------------------
/tests/base64.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "array.uh"
7 | import "char.uh"
8 | import "base64.uh"
9 |
10 | fun tos ars = array-map chr ars
11 |
12 | val s = "hello world!"
13 | val s1 = base64-encode s
14 |
15 | val s2 = valOf (base64-decode s1)
16 |
17 | val corrupted = "aGVsbG8gd29yb)Qh"
18 | val s3 = base64-decode corrupted
19 | in
20 | print [[s1]\n\r] ;
21 | print [[s2]\n\r] ;
22 | case s3 of
23 | NONE => print [corruption test successful\n\r]
24 | | SOME s => print [corruption test FAILED. actually got [s]\n\r]
25 | end
26 |
--------------------------------------------------------------------------------
/tests/bigint.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | import "int.uh"
5 | import "list.uh"
6 | import "bigint.uh"
7 |
8 | val y2 = bi-fromint 175
9 | val y1 = bi-fromint 150
10 | val x2 = bi-fromint 10
11 | val x1 = bi-fromint 350
12 |
13 | val value = bi-fromint 280
14 |
15 | do print [[bi-tostring (bi-subt (y2, y1))]
16 | ]
17 |
18 | do print [[bi-tostring (bi-subt (x2, x1))]
19 | ]
20 |
21 | do print [[bi-tostring (bi-mult (bi-subt (y2, y1), value))]
22 | ]
23 |
24 | do print [[bi-tostring (#1/2 bi-divmod (bi-mult (bi-subt (y2, y1), value),
25 | bi-subt (x2, x1)))]
26 | ]
27 | in
28 | ()
29 | end
30 |
31 |
--------------------------------------------------------------------------------
/tests/bitops.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 | import "list.uh"
5 | import "string.uh"
6 | import "int.uh"
7 |
8 | val tests = 0x00000000 :: 0xFFFFFFFF ::
9 | 0xFF00FF00 :: 0x00FF00FF ::
10 | 0xF0F0F0F0 :: 0x0F0F0F0F :: nil
11 |
12 | fun horiz () =
13 | let
14 | in
15 | print " ";
16 | list-app (fn x =>
17 | (print (int-tohexstring x);
18 | print " ")) tests;
19 | print "\n";
20 | print " ";
21 | list-app (fn _ =>
22 | print "-------- ") tests;
23 | print "\n"
24 | end
25 |
26 |
27 | fun testbin (s, f) =
28 | let
29 | in
30 | print ("\n" ^ s ^ ":\n");
31 | horiz ();
32 | list-app (fn x =>
33 | (print (int-tohexstring x);
34 | print ": ";
35 | list-app (fn y =>
36 | (print (int-tohexstring (f(x, y)));
37 | print " ")) tests;
38 | print "\n")) tests
39 | end
40 |
41 | fun testmono (s, f) =
42 | let
43 | val s = s ^ ":"
44 | in
45 | print s;
46 | print (array(10 - length s, ? ));
47 | list-app (fn x =>
48 | (print (int-tohexstring (f x));
49 | print " ")) tests;
50 | print "\n"
51 | end
52 |
53 | in
54 | list-app testbin (("and", op andb) ::
55 | ("or", op orb) ::
56 | ("xor", op xorb) :: nil);
57 | print "\n";
58 | horiz ();
59 | list-app testmono (("not", notb) ::
60 | ("shl 8", fn x => x shl 8) ::
61 | ("shr 8", fn x => x shr 8) ::
62 | ("shl 32", fn x => x shl 32) ::
63 | ("shl 32", fn x => x shr 32) ::
64 | ("shl 0", fn x => x shl 0) ::
65 | ("shl 0", fn x => x shr 0) ::
66 | ("shl 4", fn x => x shl 4) ::
67 | ("shr 4", fn x => x shr 4) ::
68 | nil);
69 |
70 | ()
71 | end
--------------------------------------------------------------------------------
/tests/bug-avoid-or-exhaust.uml:
--------------------------------------------------------------------------------
1 | let
2 | fun list-zip (l1, l2) =
3 | let
4 | fun f (x1::l1, x2::l2, acc) = f (l1, l2, (x1, x2)::acc)
5 | | f (nil, _, acc) = acc
6 | | f (_, nil, acc) = acc
7 | (* Uncomment for compiler error
8 | | f (nil, nil, acc) = acc *)
9 | in
10 | f (l1, l2, nil)
11 | end
12 | in
13 | list-zip (nil, nil)
14 | end
15 |
--------------------------------------------------------------------------------
/tests/bug-avoid.uml:
--------------------------------------------------------------------------------
1 | let
2 |
3 | datatype t = A
4 |
5 | in
6 | case A of
7 | _ => 111
8 | | A => 222
9 |
10 | end
--------------------------------------------------------------------------------
/tests/bug-exhaust.uml:
--------------------------------------------------------------------------------
1 | let
2 | datatype a exp =
3 | Int of int
4 | | Plus of exp * exp
5 | | Times of exp * exp
6 | | Minus of exp * exp
7 | | Fn of string * string list * exp
8 | | Var of string
9 | | Pair of exp * exp
10 | | Pi1 of exp
11 | | Pi2 of exp
12 | | App of exp * exp list
13 | | True
14 | | False
15 | | If of exp * exp * exp
16 | | Less of exp * exp
17 | | Case of exp * string * exp * exp
18 | | Inl of exp
19 | | Inr of exp
20 | | Unit
21 | | Let of string * exp * exp
22 |
23 |
24 | (* obviously not exhaustive; why no warning? *)
25 | fun minml-eval (Int i) = Int i
26 | | minml-eval (Inl e) = Inl (minml-eval e)
27 | in
28 | 0
29 | end
30 |
--------------------------------------------------------------------------------
/tests/bug-internalerror.uml:
--------------------------------------------------------------------------------
1 | let
2 | fun f (UNBOUND_CONSTRUCTOR _) = 222
3 | in
4 | ()
5 | end
--------------------------------------------------------------------------------
/tests/bug-patterns.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 |
5 | datatype t =
6 | A of { a : t, b : char }
7 | | B
8 |
9 | val x =
10 | A { a = A { b = ?e, a = A { b = ?s, a = B } }, b = ?y }
11 |
12 |
13 | fun pr y =
14 | (case y of
15 | A { a, b = c } => (putc c; pr a)
16 | | A { a = B, b } => (putc b; putc ?!; putc ?\n)
17 | | B => (putc ?n; putc ?o))
18 | in
19 | pr x
20 | end
21 |
--------------------------------------------------------------------------------
/tests/bug-roman.uml:
--------------------------------------------------------------------------------
1 | let
2 | (* WARNING! *)
3 |
4 | val () =
5 | letcc out
6 | in
7 | letcc toplevel
8 | in
9 | sethandler_ toplevel;
10 | throw () to out
11 | end;
12 |
13 | putc ?!; putc ?\n;
14 |
15 | halt ()
16 | end
17 |
18 | infix 2 parse-wth
19 | fun parse-succeed x () = x
20 | fun parse-wth (p, f) () = f (p ())
21 |
22 | (* ******************* this is it ******************** *)
23 |
24 | datatype a lis = YES of a * unit | NO
25 |
26 | do YES ((length "("; ()), ())
27 |
28 | datatype exp1 = A | B
29 | datatype exp = APPLY of unit * exp1 lis
30 |
31 | fun qbasic-etos e =
32 | let
33 | (* this is apparently what fails--
34 | the jump is way out of bounds,
35 | because the value passed to qbe is NULL!
36 | *)
37 | fun qbe A = putc ?#
38 | | qbe B = halt ()
39 |
40 | fun la (YES (h, _)) = (putc ?:; qbe h; halt ())
41 | | la NO = halt ()
42 | in
43 | putc ?W;
44 | (case e of
45 | APPLY ((), el) => la el);
46 | halt ()
47 | end
48 |
49 | val exp =
50 | (parse-succeed ( ( B, ()))
51 | parse-wth op YES)
52 | parse-wth (fn el => APPLY((), el))
53 |
54 | in
55 | qbasic-etos (exp ())
56 | halt
57 | end
58 |
--------------------------------------------------------------------------------
/tests/bugknots.uml:
--------------------------------------------------------------------------------
1 | let
2 |
3 | (*
4 | val () =
5 | letcc out
6 | in
7 | letcc toplevel
8 | in
9 | sethandler_ toplevel;
10 | throw () to out
11 | end;
12 |
13 | putc ?!;
14 |
15 | halt ()
16 | end
17 | *)
18 |
19 | fun list-app (f, l) =
20 | let
21 | fun a nil = halt ()
22 | | a (h :: _) = (f h; ())
23 | in
24 | a l
25 | end
26 |
27 | val bi-zero = {sign = 999, digits = nil}
28 |
29 | val { bi-fromint, bi-tostring } =
30 | let
31 |
32 | val bn-hsgnextmask = notb 0
33 |
34 | fun bi-tostring ({sign, digits}) = ()
35 |
36 | fun bi-fromint _ = bi-zero
37 | in
38 | { bi-tostring = bi-tostring,
39 | bi-fromint = bi-fromint }
40 | end
41 |
42 |
43 | val bk-sol-machines =
44 | {name = (), sol = {| (5555, 1111) |} } :: nil
45 |
46 | val thePromotionScores =
47 | (* -- magic line -- *)
48 | (bi-fromint ()) ::
49 | nil
50 |
51 | do list-app (fn {name=_,sol} =>
52 | let
53 | in
54 | length sol;
55 | ()
56 | end, bk-sol-machines)
57 | in
58 | list-app (fn _ => (), thePromotionScores);
59 | halt ()
60 | end
61 |
--------------------------------------------------------------------------------
/tests/bugmix.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 |
6 | type bignat = int list
7 | datatype bi-sign = POS | NEG
8 | datatype bigint = BI of {sign : bi-sign, digits : bignat}
9 |
10 | exception Negative
11 | exception DivideByZero
12 |
13 | val bi-zero = BI {sign = POS, digits = nil}
14 |
15 | val { bi-fromint, bi-tostring } =
16 | let
17 |
18 | val bn-hmask = 0x7FFF
19 | val bn-hsgnextmask = notb bn-hmask
20 |
21 | fun bi-tostring (BI {sign, digits}) = "hey"
22 |
23 | fun bi-fromint _ = bi-zero
24 | in
25 | { bi-tostring = bi-tostring,
26 | bi-fromint = bi-fromint }
27 | end
28 |
29 |
30 | val bk-sol-machines =
31 | {name = "000",
32 | sol =
33 | {|
34 | (3, 4),
35 | (2, 3),
36 | (1, 1) |} } ::
37 |
38 | nil
39 |
40 | fun bk-find-prob-by-width width =
41 | list-find (fn {name=_,sol} =>
42 | let val n = length sol
43 | in
44 | putc (chr (ord ?0 + n));
45 | putc ?\n;
46 | n = width
47 | end) bk-sol-machines
48 |
49 | val thePromotionScores =
50 | (* -- magic line -- *)
51 | (0, bi-fromint ()) ::
52 | nil
53 |
54 | fun assessPubs () : unit =
55 | list-app (fn (r, s) =>
56 | print ( bi-tostring s ^ "\n"))
57 | thePromotionScores
58 |
59 | do (case bk-find-prob-by-width 3 of
60 | NONE => print "FIXME XXX no\n"
61 | | SOME _ => print "ok, found\n")
62 |
63 | in
64 | ref (assessPubs ());
65 | print "umix deleted sorry\n"
66 | end
67 |
--------------------------------------------------------------------------------
/tests/bugmix3.uml:
--------------------------------------------------------------------------------
1 | let
2 | fun @ r =
3 | (putc ?@; showval_ r;
4 | case r of
5 | (h::t, l2) => h :: @(t, l2)
6 | | (nil, l2) => (showval_ 10000; showval_ l2; l2))
7 |
8 | infixr @
9 |
10 | fun FFF a = (showval_ 12345; showval_ a; (*length "";*) a)
11 |
12 | in
13 | showval_
14 | (
15 | (FFF ?O :: nil) @
16 |
17 | (nil @
18 |
19 | (FFF ?X :: nil)
20 | )
21 | )
22 |
23 | end
24 |
--------------------------------------------------------------------------------
/tests/caret.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 |
5 | val g = "hey"
6 |
7 | val s = "first-" ^ g ^ "second" ^ g ^ "-third"
8 | in
9 | putc ?!;
10 | print s;
11 | putc ?\n
12 | end
--------------------------------------------------------------------------------
/tests/cat.uml:
--------------------------------------------------------------------------------
1 | let
2 | val EOF = 0 - 1
3 |
4 | fun cat () =
5 | let val c = getc_ ()
6 | in
7 | (* putc ?-; *)
8 | if c = EOF then ()
9 | else (putc (chr_ c); cat ())
10 | end
11 | in
12 | cat ()
13 | end
14 |
--------------------------------------------------------------------------------
/tests/charcase.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 |
4 | fun rot5 c =
5 | (case c of
6 | ?0 => ?5
7 | | ?1 => ?6
8 | | ?2 => ?7
9 | | ?3 => ?8
10 | | ?4 => ?9
11 | | ?5 => ?0
12 | | ?6 => ?1
13 | | ?7 => ?2
14 | | ?8 => ?3
15 | | ?9 => ?4
16 | | x => x)
17 |
18 | in
19 | rot5 ?3
20 | end
--------------------------------------------------------------------------------
/tests/clock.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "clock.uh"
7 |
8 | val (s, ns) = clock-gettime ()
9 | in
10 | print [The time is [int-tostring s] seconds, [int-tostring ns] nanoseconds.\n]
11 | end
12 |
--------------------------------------------------------------------------------
/tests/cmp.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | fun my () = 2
4 |
5 | fun not true = false
6 | | not false = true
7 | in
8 |
9 | (* XXX also should check negative/positive
10 | stuff since those are separate cases in
11 | the backend! *)
12 | if (putc ?a; my () < (my () + 1))
13 | andalso
14 | (putc ?b; not ((my () + 1) < my ()))
15 | andalso
16 | (putc ?c; my() + 1 > my ())
17 | andalso
18 | (putc ?d; my () <= my ())
19 | andalso
20 | (putc ?e; my () >= my ())
21 | andalso
22 | (putc ?f; my() + 1 >= my ())
23 | andalso
24 | (putc ?g; my () = my ())
25 | andalso
26 | (putc ?h; not (my () + 1 = my ()))
27 | andalso
28 | (putc ?i; not (my () >= my () + 1))
29 | andalso
30 | (putc ?j; not (my () + 1 <= my ()))
31 | then
32 | let in
33 | putc ?\n;
34 | putc ?o; putc ?k;
35 | putc ?!;
36 | ()
37 | end
38 | else
39 | let in
40 | putc ?\n;
41 | putc ?n; putc ?o;
42 | putc ?!;
43 | ()
44 | end;
45 |
46 | putc ?\n
47 | end
48 |
49 | (* easier
50 | let
51 | fun my () = 2
52 | in
53 |
54 | if (my () + 1) < my ()
55 | then
56 | let in
57 | putc ?n; putc ?o; ()
58 | end
59 | else
60 | let in
61 | putc ?o; putc ?k; ()
62 | end;
63 |
64 | putc ?\n
65 | end
66 | *)
67 |
--------------------------------------------------------------------------------
/tests/cmpopt.uml:
--------------------------------------------------------------------------------
1 | let
2 |
3 | val c = getc_ ()
4 |
5 | in
6 | putc (chr_
7 | (if c > 999
8 | then 5555
9 | else 6666))
10 | end
--------------------------------------------------------------------------------
/tests/cntrl-test.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 |
6 | import "control.uh"
7 |
8 |
9 | fun pr s = cntrl-do (fn () => print s)
10 | val imp = implode
11 | fun % s = cntrl-satisfy (fn x =>
12 | (print [trying [imp (x::nil)] = [imp (s::nil)] = [
13 | if ord x = ord s then "t" else "f"]\n];
14 | ord x = ord s))
15 | >> pr (imp (s :: ?! :: nil))
16 |
17 | val a = % ?A
18 | val b = % ?B
19 | val d = % ?D
20 | val e = % ?E
21 |
22 | val athenb = a >> ^^ b
23 | val all = cntrl-repeat ( !! ( athenb >> ^^ athenb >> ^^ d >> pr "#" cntrl-return "ababd "
24 | || (a || e) ** d >> pr "@" cntrl-return "ad "
25 | || athenb >> pr "$" cntrl-return "ab "
26 | || d cntrl-return "d "
27 | || b cntrl-return "b ") )
28 |
29 | val input = ref (explode "ABABABDDABABDD")
30 | fun read () =
31 | let
32 | val (h, t) = case !input of h :: t => (h, t)
33 | | nil => (?X, nil)
34 | do input := t
35 | do print [\nread: [imp (h::nil)]\n]
36 | in
37 | h
38 | end
39 |
40 | val res = cntrl-run read all
41 | do case res of NONE => print "NONE"
42 | | SOME nil => print "nil"
43 | | SOME l => list-app (fn s => print s) l
44 | do print "\n"
45 | in
46 | ()
47 | end
48 |
--------------------------------------------------------------------------------
/tests/compare.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 |
5 | fun gtnf x = x > ~4
6 |
7 | fun gtf x = x > 4
8 |
9 | fun fgt x = 4 > x
10 |
11 | fun nfgt x = ~4 > x
12 |
13 | fun ltz x = x < 0
14 |
15 | fun lez x = x <= 0
16 |
17 | fun zlt x = 0 < x
18 |
19 | fun zle x = 0 <= x
20 |
21 | fun should_be true true = print "yes\n"
22 | | should_be false false = print "yes\n"
23 | | should_be _ _ = print "no\n"
24 | in
25 | should_be true (gtnf 3);
26 | should_be true (gtnf 0);
27 | should_be true (gtnf ~2);
28 | should_be false (gtnf ~4);
29 | should_be false (gtnf ~10);
30 |
31 | should_be true (gtf 5);
32 | should_be false (gtf 4);
33 | should_be false (gtf 2);
34 | should_be false (gtf 0);
35 | should_be false (gtf ~2);
36 |
37 | should_be false (fgt 5);
38 | should_be false (fgt 4);
39 | should_be true (fgt 2);
40 | should_be true (fgt 0);
41 | should_be true (fgt ~2);
42 |
43 | should_be false (nfgt 2);
44 | should_be false (nfgt 0);
45 | should_be false (nfgt ~2);
46 | should_be false (nfgt ~4);
47 | should_be true (nfgt ~10);
48 |
49 | should_be false (ltz 2);
50 | should_be false (ltz 0);
51 | should_be true (ltz ~2);
52 |
53 | should_be false (lez 2);
54 | should_be true (lez 0);
55 | should_be true (lez ~2);
56 |
57 | should_be true (zlt 2);
58 | should_be false (zlt 0);
59 | should_be false (zlt ~2);
60 |
61 | should_be true (zle 2);
62 | should_be true (zle 0);
63 | should_be false (zle ~2)
64 |
65 | end
66 |
--------------------------------------------------------------------------------
/tests/compress.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 | import "string.uh"
5 | in
6 | print
7 | "
8 | ****************************************************************
9 | ****************************************************************
10 | ************************* ****************************
11 | ************************* SUCCESS ****************************
12 | ************************* ****************************
13 | ****************************************************************
14 | ****************************************************************
15 | "
16 | end
17 |
--------------------------------------------------------------------------------
/tests/cord.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "cord.uh"
7 |
8 | val c = cord-create "hello "
9 | val c1 = cord-append (c, "world.")
10 | val c2 = cord-prepend (c1, "oh! ")
11 | val hell = {| cord-sub (c2, 1),
12 | cord-sub (c2, 5),
13 | cord-sub (c2, 13),
14 | cord-sub (c2, 13),
15 | cord-sub (c2, 15) |}
16 | in
17 | print hell
18 | end
19 |
--------------------------------------------------------------------------------
/tests/dec.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | import "des.uh"
5 | import "growarray.uh"
6 | import "io.uh"
7 | in
8 | print "****************** DECOMPRESSION!!!!!! is awesome **********\n";
9 |
10 | putc ?Y; putc ?O; putc ?U; putc ? ;
11 | putc ?W; putc ?I; putc ?N; putc ?\n
12 | end
--------------------------------------------------------------------------------
/tests/des.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "des.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "growarray.uh"
7 |
8 | fun test (k as (ka, kb)) (p as (pa, pb)) =
9 | let
10 | val key = des-key k
11 | val (a, b) = des-encrypt key p
12 | in
13 | int-tohexstring ka ^ "/" ^ int-tohexstring kb ^ " " ^
14 | int-tohexstring pa ^ "/" ^ int-tohexstring pb ^ " = " ^
15 | int-tohexstring a ^ "/" ^ int-tohexstring b
16 | end
17 | in
18 | (* a few nist test vectors...
19 | http://www.skepticfiles.org/faq/testdes.htm
20 | *)
21 | print (test (0, 0) (0, 0) ^ "\n");
22 | print (test (0x11111111, 0x11111111)
23 | (0x01234567, 0x89ABCDEF) ^ "\n")
24 | end
25 |
--------------------------------------------------------------------------------
/tests/desbug.uml:
--------------------------------------------------------------------------------
1 | let
2 | val subkeys = array (32, 0x0)
3 |
4 | fun loop (9999, _) = ()
5 | | loop (round, left) =
6 | let
7 | in
8 | update_(subkeys,
9 | 0,
10 | left + 0
11 | (*left shl 4 *));
12 |
13 | loop (round + 1, left)
14 | end
15 | in
16 | loop (0, 0)
17 | end
18 |
--------------------------------------------------------------------------------
/tests/dynamic.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | in
7 | print (int-tohexstring (dynamic_ 0));
8 | putc ?\n;
9 |
10 | print (int-tohexstring (dynamic_ 1));
11 | putc ?\n;
12 |
13 | print (int-tohexstring (dynamic_ 2));
14 | putc ?\n;
15 |
16 | ()
17 | end
--------------------------------------------------------------------------------
/tests/emptycase.uml:
--------------------------------------------------------------------------------
1 | case 0 of
2 |
--------------------------------------------------------------------------------
/tests/emptydatatype.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | (* datatype with NO constructors *)
4 | datatype void
5 | in
6 | ()
7 | end
8 |
--------------------------------------------------------------------------------
/tests/emptyfn.uml:
--------------------------------------------------------------------------------
1 | (* yes, this should be a legal function that always raises match *)
2 |
3 | ( fn )
4 |
5 |
--------------------------------------------------------------------------------
/tests/example-arduino/Makefile:
--------------------------------------------------------------------------------
1 | sandmark: sandmark.uml
2 | ../../mlc.exe -cbackend sandmark.uml
3 |
4 | clean:
5 | rm -f a.out *.~ *.o sandmark.c sandmark.h *.cps *.cpsa runtime-c.c runtime-c.h
6 |
--------------------------------------------------------------------------------
/tests/example-arduino/example-arduino.ino:
--------------------------------------------------------------------------------
1 | #include "runtime-c.h"
2 | #include "sandmark.h"
3 |
4 | uint32_t my_availc()
5 | {
6 | return Serial.available();
7 | }
8 |
9 | uint32_t my_getc()
10 | {
11 | static uint32_t just_returned_cr = 0;
12 | uint32_t c;
13 |
14 | /* Wait for data */
15 | while (Serial.available() < 1)
16 | {
17 | ;
18 | }
19 |
20 | /*
21 | * When we see a carriage return, send a linefeed too
22 | */
23 | if (just_returned_cr == 1)
24 | {
25 | c = Serial.read();
26 | c = 10;
27 | just_returned_cr = 0;
28 | }
29 | else
30 | {
31 | c = Serial.peek();
32 | if (c == 13)
33 | {
34 | just_returned_cr = 1;
35 | }
36 | else
37 | {
38 | c = Serial.read();
39 | }
40 | }
41 |
42 | Serial.write(c); /* local echo */
43 | return c;
44 | }
45 |
46 | uint32_t my_putc(uint32_t c)
47 | {
48 | Serial.write(c);
49 |
50 | /* send a carriage return after a linefeed */
51 | if (c == 10)
52 | {
53 | Serial.write(13);
54 | }
55 |
56 | return 0;
57 | }
58 |
59 | void heap_error(Heap_error_t e) {
60 | digitalWrite(13, HIGH);
61 | Serial.write("Got heap error");
62 | Serial.write(e);
63 | Serial.write("\n");
64 | }
65 |
66 | void*(*next_f)();
67 |
68 |
69 | void setup() {
70 | IO_functions_type io;
71 |
72 | io.availc = my_availc;
73 | io.getc = my_getc;
74 | io.putc = my_putc;
75 |
76 | initializeIO(&io);
77 | initializeHeap(heap_error);
78 |
79 | next_f = _mainentry;
80 |
81 | pinMode(13, OUTPUT);
82 | digitalWrite(13, LOW);
83 |
84 | Serial.begin(9600);
85 | }
86 |
87 | void loop() {
88 | next_f = (void* (*)()) next_f();
89 | }
90 |
--------------------------------------------------------------------------------
/tests/example-arduino/sandmark.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 | import "list.uh"
5 | import "string.uh"
6 | import "int.uh"
7 | import "des.uh"
8 | import "bigint.uh"
9 | (* import "publications.uh" *)
10 | import "random.uh"
11 | import "growarray.uh"
12 | import "io.uh"
13 | import "util.uh"
14 |
15 | val keys =
16 | {|
17 | des-key (0xa07c632a, 0xd14ecf73),
18 | des-key (0x0380e70d, 0x16e1c73e),
19 | des-key (0x55e1b670, 0x450127b9),
20 | des-key (0x89561969, 0x594fd688),
21 | des-key (0x58f6b317, 0xdf18fe7b),
22 | des-key (0x52ea4288, 0xd47df04e),
23 | des-key (0x0b66e785, 0xeff0d38a),
24 | des-key (0xf74389eb, 0x1f081a2d),
25 | des-key (0x6f1fd2a8, 0xa9433129),
26 | des-key (0xbdc6d457, 0x4d4d3988),
27 | des-key (0xdba544e9, 0xfdb25834),
28 | des-key (0x8a09265a, 0xde9db7d6),
29 | des-key (0xd0a35a32, 0x1dca7ed0),
30 | des-key (0x3ba82ffc, 0xe3a6be41),
31 | des-key (0x92a23f55, 0xbdcacc2e),
32 | des-key (0xc2c1e3ff, 0x4ed7a512),
33 | des-key (0xee6598a6, 0x504c67b1),
34 | des-key (0x020c63ac, 0xfb35e841)
35 | |}
36 | (* run the encryption loop for N cycles *)
37 | val N = 10000
38 |
39 | do print [ == SANDmark 19107 beginning stress test / benchmark.. ==\n\r]
40 |
41 | val kr = ref 0
42 | fun getkey () =
43 | let in
44 | kr := !kr + 1;
45 | if !kr >= length keys
46 | then kr := 0
47 | else ();
48 | sub(keys, 0)
49 | end
50 |
51 | fun pwp (w1, w2) = [[int-tohexstring w1].[int-tohexstring w2]]
52 |
53 | fun loop () =
54 | ford 0 N (0x12345678, 0x09ABCDEF)
55 | (fn (i, ws) =>
56 | (if i mod 100 = 0
57 | then print ([[string-pad(4, [[int-tostring ((N - i) div 100)].])] [pwp ws]\n\r])
58 | else ();
59 | des-encrypt3(getkey (), getkey (), getkey ()) ws))
60 |
61 | val ws = loop ()
62 | in
63 | print [SANDmark complete.\n\r]
64 | end
65 |
--------------------------------------------------------------------------------
/tests/example/Makefile:
--------------------------------------------------------------------------------
1 | sandmark: main.c
2 | ../../mlc.exe -cbackend sandmark.uml
3 | gcc -Wall -Wno-parentheses-equality runtime-c.c sandmark.c main.c
4 |
5 | clean:
6 | rm -f a.out *.~ *.o sandmark.c sandmark.h *.cps *.cpsa runtime-c.c runtime-c.h
7 |
--------------------------------------------------------------------------------
/tests/example/main.c:
--------------------------------------------------------------------------------
1 | #include
2 | #include
3 | #include
4 | #include
5 | #include
6 | #include
7 | #include
8 |
9 | #include "runtime-c.h"
10 | #include "sandmark.h"
11 |
12 | unsigned long my_availc() {
13 | unsigned long bytes;
14 | ioctl(0, FIONREAD, &bytes);
15 | return bytes;
16 | }
17 |
18 | unsigned long my_getc() {
19 | return getc(stdin);
20 | }
21 |
22 | unsigned long my_putc(unsigned long x) {
23 | return putc(x, stdout);
24 | }
25 |
26 | void heap_error(Heap_error_t e) {
27 | printf("Got heap error %d\n", e);
28 | }
29 |
30 | struct termios old_stdin_tio, new_stdin_tio;
31 | struct termios old_stdout_tio, new_stdout_tio;
32 | int setup_terminal()
33 | {
34 | /*
35 | * First change the buffering scheme related to stdio.
36 | */
37 | setvbuf(stdin, NULL, _IONBF, 0);
38 | setvbuf(stdout, NULL, _IONBF, 0);
39 |
40 | /*
41 | * Next change the terminal driver buffering scheme.
42 | */
43 | /* get the terminal settings for stdin and stdout */
44 | tcgetattr(0, &old_stdin_tio);
45 | tcgetattr(1, &old_stdout_tio);
46 |
47 | /* we want to keep the old setting to restore them at the end */
48 | new_stdin_tio=old_stdin_tio;
49 | new_stdout_tio=old_stdout_tio;
50 |
51 | /* disable canonical mode (buffered i/o) and local echo */
52 | new_stdin_tio.c_lflag &=(~ICANON);
53 | new_stdout_tio.c_lflag &=(~ICANON);
54 |
55 | /* set the new settings immediately */
56 | tcsetattr(0, TCSANOW, &new_stdin_tio);
57 | tcsetattr(1, TCSANOW, &new_stdout_tio);
58 |
59 | return 0;
60 | }
61 |
62 | int restore_terminal()
63 | {
64 | /* restore the former terminal settings */
65 | tcsetattr(0, TCSANOW, &old_stdin_tio);
66 | tcsetattr(1, TCSANOW, &old_stdout_tio);
67 |
68 | return 0;
69 | }
70 |
71 | int main(int argc, char **argv) {
72 | void*(*f)();
73 | IO_functions_type io;
74 |
75 | io.availc = my_availc;
76 | io.getc = my_getc;
77 | io.putc = my_putc;
78 |
79 | setup_terminal();
80 |
81 | /*
82 | * Now run the main program.
83 | */
84 | initializeIO(&io);
85 | initializeHeap(heap_error);
86 | f = _mainentry;
87 | while (f != 0)
88 | {
89 | f = (void* (*)()) f();
90 | }
91 |
92 | restore_terminal();
93 |
94 | return 0;
95 | }
96 |
97 |
--------------------------------------------------------------------------------
/tests/example/sandmark.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 | import "list.uh"
5 | import "string.uh"
6 | import "int.uh"
7 | import "des.uh"
8 | import "bigint.uh"
9 | (* import "publications.uh" *)
10 | import "random.uh"
11 | import "growarray.uh"
12 | import "io.uh"
13 | import "util.uh"
14 |
15 | val keys =
16 | {|
17 | des-key (0xa07c632a, 0xd14ecf73),
18 | des-key (0x0380e70d, 0x16e1c73e),
19 | des-key (0x55e1b670, 0x450127b9),
20 | des-key (0x89561969, 0x594fd688),
21 | des-key (0x58f6b317, 0xdf18fe7b),
22 | des-key (0x52ea4288, 0xd47df04e),
23 | des-key (0x0b66e785, 0xeff0d38a),
24 | des-key (0xf74389eb, 0x1f081a2d),
25 | des-key (0x6f1fd2a8, 0xa9433129),
26 | des-key (0xbdc6d457, 0x4d4d3988),
27 | des-key (0xdba544e9, 0xfdb25834),
28 | des-key (0x8a09265a, 0xde9db7d6),
29 | des-key (0xd0a35a32, 0x1dca7ed0),
30 | des-key (0x3ba82ffc, 0xe3a6be41),
31 | des-key (0x92a23f55, 0xbdcacc2e),
32 | des-key (0xc2c1e3ff, 0x4ed7a512),
33 | des-key (0xee6598a6, 0x504c67b1),
34 | des-key (0x020c63ac, 0xfb35e841)
35 | |}
36 | (* run the encryption loop for N cycles *)
37 | val N = 10000
38 |
39 | do print [ == SANDmark 19107 beginning stress test / benchmark.. ==\n\r]
40 |
41 | val kr = ref 0
42 | fun getkey () =
43 | let in
44 | kr := !kr + 1;
45 | if !kr >= length keys
46 | then kr := 0
47 | else ();
48 | sub(keys, 0)
49 | end
50 |
51 | fun pwp (w1, w2) = [[int-tohexstring w1].[int-tohexstring w2]]
52 |
53 | fun loop () =
54 | ford 0 N (0x12345678, 0x09ABCDEF)
55 | (fn (i, ws) =>
56 | (if i mod 100 = 0
57 | then print ([[string-pad(4, [[int-tostring ((N - i) div 100)].])] [pwp ws]\n\r])
58 | else ();
59 | des-encrypt3(getkey (), getkey (), getkey ()) ws))
60 |
61 | val ws = loop ()
62 | in
63 | print [SANDmark complete.\n\r]
64 | end
65 |
--------------------------------------------------------------------------------
/tests/exhaust.uml:
--------------------------------------------------------------------------------
1 | let
2 | datatype t = A | B | C
3 |
4 |
5 | fun inexhaustive A = (putc ?A; inexhaustive B)
6 | | inexhaustive B = putc ?B
7 | in
8 | (* exhaustive *)
9 | (case B of
10 | A => putc ?a
11 | | B => putc ?b
12 | | C => putc ?c);
13 |
14 | inexhaustive A;
15 | inexhaustive B
16 | end
--------------------------------------------------------------------------------
/tests/exn_test.uml:
--------------------------------------------------------------------------------
1 | let
2 | exception E of int
3 | exception F
4 |
5 | fun f x = if x = 0 then raise (E 88) else ()
6 |
7 | fun g x = f x
8 | handle E y => putc ?G
9 | in
10 | g 1;
11 | f 0
12 | handle E y => putc (chr_ y)
13 | | F => putc ?F
14 | end
15 |
--------------------------------------------------------------------------------
/tests/exnmatch.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | exception Y
4 | exception X
5 | in
6 | putc ?g; putc ?o; putc ?:; putc ? ;
7 | ((raise X)
8 | handle Y => (putc ?n; putc ?o; putc ? ; putc ?1)
9 | | X => (putc ?o; putc ?k)
10 | | _ => (putc ?n; putc ?o; putc ? ; putc ?2));
11 | putc ?.; putc ?\n
12 | end
13 |
--------------------------------------------------------------------------------
/tests/fact.uml:
--------------------------------------------------------------------------------
1 | let
2 | fun fact n acc =
3 | if n = 0 then acc
4 | else fact (n - 1) (acc * n)
5 | in
6 | fact 2000 1
7 | end
8 |
--------------------------------------------------------------------------------
/tests/fact_small.uml:
--------------------------------------------------------------------------------
1 | let
2 | fun fact n acc =
3 | if n = 0 then acc
4 | else fact (n - 1) (acc * n)
5 | in
6 | putc (chr_ (fact 5 1))
7 | end
8 |
--------------------------------------------------------------------------------
/tests/fastmark.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 | import "list.uh"
5 | import "string.uh"
6 | import "int.uh"
7 | import "des.uh"
8 | import "bigint.uh"
9 | import "random.uh"
10 | import "growarray.uh"
11 | import "io.uh"
12 | import "util.uh"
13 |
14 | val keys =
15 | {|
16 | des-key (0xa07c632a, 0xd14ecf73),
17 | des-key (0x0380e70d, 0x16e1c73e),
18 | des-key (0x55e1b670, 0x450127b9) |}
19 | (* run the encryption loop for N cycles *)
20 | val N = 200
21 |
22 | do print [\n\r == FASTmark 19106 beginning stress test / benchmark.. ==\n\r]
23 |
24 | val kr = ref 0
25 | fun getkey () =
26 | let in
27 | kr := !kr + 1;
28 | if !kr >= length keys
29 | then kr := 0
30 | else ();
31 | sub(keys, 0)
32 | end
33 |
34 | fun pwp (w1, w2) = [[int-tohexstring w1].[int-tohexstring w2]]
35 |
36 | fun loop () =
37 | ford 0 N (0x12345678, 0x09ABCDEF)
38 | (fn (i, ws) =>
39 | (print ([[string-pad(4, [[int-tostring ((N - i))].])] [pwp ws]\n\r]);
40 | des-encrypt3(getkey (), getkey (), getkey ()) ws))
41 |
42 | val ws = loop ()
43 | in
44 | print [FASTmark complete.\n\r]
45 | end
46 |
--------------------------------------------------------------------------------
/tests/filters.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | import "int.uh"
5 | import "array.uh"
6 | import "filter.uh"
7 |
8 | val f = filter-create 3
9 | fun p () = print ((int-tostring (filter-average f)) ^ " ")
10 |
11 | do filter-insert f 5000
12 | do p ()
13 | do filter-insert f 4800
14 | do p ()
15 | do filter-insert f 4300
16 | do p ()
17 | do filter-insert f 4100
18 | do p ()
19 | in
20 | ()
21 | end
22 |
--------------------------------------------------------------------------------
/tests/flip.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | import "int.uh"
5 |
6 | fun f a b = print [got [int-tostring a] then [int-tostring b]\n\r]
7 |
8 | val () = flip f 7 10
9 | in
10 | ()
11 | end
12 |
--------------------------------------------------------------------------------
/tests/fn.uml:
--------------------------------------------------------------------------------
1 | let
2 | fun f1 () = ?a
3 | in
4 | putc (f1 ()); putc (f1 ())
5 | end
--------------------------------------------------------------------------------
/tests/forth_addition.uml:
--------------------------------------------------------------------------------
1 | let
2 | val x = 5
3 | fun incr x = x + 1
4 | val y = (incr x) + 10
5 | in
6 | y
7 | end
8 |
--------------------------------------------------------------------------------
/tests/forth_addition_not_so_simple.uml:
--------------------------------------------------------------------------------
1 | let
2 | val z = 6 + 4
3 | val y = 5 + 1
4 | in
5 | if y > 10 then y + z else y - z
6 | end
7 |
--------------------------------------------------------------------------------
/tests/forth_addition_really_simple.uml:
--------------------------------------------------------------------------------
1 | let
2 | in
3 | 1 + 5
4 | end
5 |
--------------------------------------------------------------------------------
/tests/forth_addition_simple.uml:
--------------------------------------------------------------------------------
1 | let
2 | val y = 1 + 5
3 | in
4 | y
5 | end
6 |
--------------------------------------------------------------------------------
/tests/forth_arith.uml:
--------------------------------------------------------------------------------
1 | (* Tests array primitives. (these are unsafe.)
2 | for checked prims see arrays.uml. *)
3 |
4 | let
5 | val _ = (putc ?0; putc ?\n)
6 |
7 | val a = array(10, ?a)
8 |
9 | val _ = (putc (chr_ (2 + 3 + ord (sub_(a, 2)))); putc ?\n)
10 | in
11 | putc ?\n
12 | end
13 |
--------------------------------------------------------------------------------
/tests/forth_arithuml:
--------------------------------------------------------------------------------
1 | (* Tests array primitives. (these are unsafe.)
2 | for checked prims see arrays.uml. *)
3 |
4 | let
5 | val _ = (putc ?0; putc ?\n)
6 |
7 | val a = array(10, ?a)
8 |
9 | val _ = (putc ?1; putc ?\n)
10 |
11 |
12 | fun go 10 = ()
13 | | go n =
14 | let in
15 | update_(a, n, chr_ (2 + n + ord (sub_(a, n))));
16 | go (n + 1)
17 | end
18 |
19 | fun pr 10 = ()
20 | | pr n =
21 | let in
22 | putc (sub_(a, n));
23 | pr (n + 1)
24 | end
25 |
26 | in
27 | go 0;
28 | (putc ?2; putc ?\n);
29 | pr 0;
30 | putc ?\n
31 | end
32 |
--------------------------------------------------------------------------------
/tests/forth_arr.uml:
--------------------------------------------------------------------------------
1 | (* Tests array primitives. (these are unsafe.)
2 | for checked prims see arrays.uml. *)
3 |
4 | let
5 | val _ = (putc ?0; putc ?\n)
6 |
7 | val a = array(10, ?a)
8 |
9 | val _ = (putc ?1; putc ?\n)
10 |
11 |
12 | fun go 10 = ()
13 | | go n =
14 | let in
15 | update_(a, n, chr_ (2 + n + ord (sub_(a, n))));
16 | go (n + 1)
17 | end
18 |
19 | fun pr 10 = ()
20 | | pr n =
21 | let in
22 | putc (sub_(a, n));
23 | pr (n + 1)
24 | end
25 |
26 | in
27 | go 0;
28 | (putc ?2; putc ?\n);
29 | pr 0;
30 | putc ?\n
31 | end
32 |
--------------------------------------------------------------------------------
/tests/forth_arr_simple.uml:
--------------------------------------------------------------------------------
1 | (* Tests array primitives. (these are unsafe.)
2 | for checked prims see arrays.uml. *)
3 |
4 | let
5 | val _ = (putc ?0; putc ?\n)
6 |
7 | val a = array(10, ?a)
8 |
9 | val _ = (putc ?1; putc ?\n)
10 |
11 |
12 | fun go 10 = ()
13 | | go n =
14 | let in
15 | update_(a, n, chr_ (2 + n + 65));
16 | go (n + 1)
17 | end
18 |
19 | fun pr 10 = ()
20 | | pr n =
21 | let in
22 | putc (sub_(a, n));
23 | pr (n + 1)
24 | end
25 |
26 | in
27 | go 0;
28 | (putc ?2; putc ?\n);
29 | pr 0;
30 | putc ?\n
31 | end
32 |
--------------------------------------------------------------------------------
/tests/forth_hello_world.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | in
5 | print "hello world\n"
6 | end
7 |
--------------------------------------------------------------------------------
/tests/forth_simple_list_ops.uml:
--------------------------------------------------------------------------------
1 | (* Build a tuple and print out the second component *)
2 | putc (chr_ (#2/6 (65, 110, 100, 114, 101, 119)))
3 |
--------------------------------------------------------------------------------
/tests/futures.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "threads.uh"
7 | import "futures.uh"
8 | import "queues.uh"
9 | import "messagequeues.uh"
10 | import "tasks.uh"
11 |
12 | val f = future-create ()
13 |
14 | val task-a-mq = mq-create ()
15 |
16 | exception Command-message of (char array * int future)
17 | fun task-a-rx-f s m =
18 | case m of Command-message (a, f) =>
19 | ( print [got command: [a]\n\r];
20 | future-complete f 1 ;
21 | s )
22 | | _ => s
23 |
24 | fun send-command c =
25 | let
26 | val f = future-create ()
27 | do mq-send task-a-mq (Command-message (c, f))
28 | in
29 | f
30 | end
31 |
32 | fun task0 () =
33 | let
34 | val f = send-command "bzzt"
35 | val () = print "ste 1 is here\n\r"
36 | val () = print [wh! got [int-tostring (future-force f)]\n\r]
37 | val () = print "ste 2 is here\n\r"
38 | in
39 | ()
40 | end
41 |
42 | fun task1 () =
43 | let
44 | val () = print "step 1 is here\n\r"
45 | val () = print [woho! got [int-tostring (future-force f)]\n\r]
46 | val () = print "step 2 is here\n\r"
47 | in
48 | ()
49 | end
50 |
51 | fun task1a () =
52 | let
53 | val () = print "gott here\n\r"
54 | in
55 | ()
56 | end
57 |
58 | fun task2 () =
59 | let
60 | val () = print "stepp 1 is here\n\r"
61 | val cf = future-complete f
62 | val () = print "stepp 2 is here\n\r"
63 | in
64 | cf 69
65 | end
66 |
67 | do fork task2
68 | do fork task1a
69 | do fork task1
70 | do fork task0
71 |
72 | fun idle () = ( yield () ; idle () )
73 | in
74 | ( task-create task-a-mq task-a-rx-f () ;
75 | idle () )
76 | end
77 |
78 |
--------------------------------------------------------------------------------
/tests/hello.uml:
--------------------------------------------------------------------------------
1 | let in
2 | putc ?h;
3 | putc ?e;
4 | putc ?l;
5 | putc ?l;
6 | putc ?o;
7 | putc ? ;
8 | putc ?w;
9 | putc ?o;
10 | putc ?r;
11 | putc ?l;
12 | putc ?d;
13 | putc ?\n;
14 |
15 | ()
16 | end
--------------------------------------------------------------------------------
/tests/if.uml:
--------------------------------------------------------------------------------
1 | let in
2 | if true then
3 | (if false then
4 | let in
5 | putc ?n;
6 | putc ?o;
7 | ()
8 | end
9 | else
10 | let in
11 | putc ?o;
12 | putc ?k;
13 | ()
14 | end)
15 | else
16 | let in
17 | putc ?n;
18 | putc ?o;
19 | ()
20 | end;
21 |
22 | putc ?\n
23 | end
--------------------------------------------------------------------------------
/tests/inline-ctor.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | datatype t = A | B of int * t
4 | infixr B
5 | in
6 | 0 B 1 B 2 B A
7 | end
--------------------------------------------------------------------------------
/tests/inlinestring.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 |
5 | val s = "this is my cool string"
6 |
7 | fun loop 0 = ()
8 | | loop n = putc (sub_ (s, n))
9 | in
10 | loop 10
11 | end
--------------------------------------------------------------------------------
/tests/int_hash_test.c:
--------------------------------------------------------------------------------
1 | #include
2 |
3 | unsigned int hash( unsigned int a)
4 | {
5 | a = (a+0x7ed55d16) + (a<<12);
6 | a = (a^0xc761c23c) ^ (a>>19);
7 | a = (a+0x165667b1) + (a<<5);
8 | a = (a+0xd3a2646c) ^ (a<<9);
9 | a = (a+0xfd7046c5) + (a<<3);
10 | a = (a^0xb55a4f09) ^ (a>>16);
11 | return a;
12 | }
13 |
14 | int main (int argc, char **argv)
15 | {
16 | printf("Hash results are %x, %x, %x\n",
17 | hash(0xdeadbeef),
18 | hash(0x00000001),
19 | hash(0x00000130));
20 | return 0;
21 | }
22 |
23 |
--------------------------------------------------------------------------------
/tests/int_hash_test.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | import "int.uh"
5 | import "list.uh"
6 | import "array.uh"
7 | import "hash.uh"
8 |
9 | val h1 = (int-tohexstring o int-hash) 0xdeadbeef
10 | val h2 = (int-tohexstring o int-hash) 0x00000001
11 | val h3 = (int-tohexstring o int-hash) 0x00000130
12 |
13 | in
14 | print [Hash results are: [h1], [h2], [h3]]
15 | end
16 |
--------------------------------------------------------------------------------
/tests/intcase.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 |
4 | fun rot5 c =
5 | (case c of
6 | 0 => 5
7 | | 1 => 6
8 | | 2 => 7
9 | | 3 => 8
10 | | 4 => 9
11 | | 5 => 0
12 | | 6 => 1
13 | | 7 => 2
14 | | 8 => 3
15 | | 9 => 4
16 | | x => x)
17 |
18 | in
19 | rot5 3
20 | end
--------------------------------------------------------------------------------
/tests/join_test_2.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 | import "string.uh"
5 |
6 | val int-hexdigs = "0123456789abcdef"
7 |
8 | fun int-tohexstringx nibbles x =
9 | let
10 | fun digtos x = array(1, sub (int-hexdigs, x))
11 | fun pitos 0 _ = ""
12 | | pitos n x = pitos (n - 1) (x div 16) ^ digtos(x mod 16)
13 | in
14 | pitos nibbles x
15 | end
16 |
17 | val int-tohexstring = int-tohexstringx 8
18 |
19 | in
20 | print [[int-tohexstring 0x12345678].[int-tohexstring 0xabababab]]
21 | end
22 |
--------------------------------------------------------------------------------
/tests/jointext.aa:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | import "int.uh"
5 |
6 | val x = 6
7 | val s = "hello"
8 | in
9 | print [This is a test of jointext.
10 | The numeral is [int-tostring 6],
11 | and the string is "[s]".
12 | What do you [ [think] ]?]
13 | end
--------------------------------------------------------------------------------
/tests/jointext.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | import "int.uh"
5 |
6 | val x = 6
7 | val s = "hello"
8 | in
9 | print [This is a test of jointext.
10 | The numeral is [int-tostring 6],
11 | and the string is "[s]".
12 | What do you [ [think] ]?]
13 | end
--------------------------------------------------------------------------------
/tests/jointext_test.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 | import "list.uh"
5 | import "string.uh"
6 | import "int.uh"
7 | import "des.uh"
8 | import "bigint.uh"
9 | (* import "publications.uh" *)
10 | import "random.uh"
11 | import "growarray.uh"
12 | import "io.uh"
13 | import "util.uh"
14 |
15 | fun pwp (w1, w2) = [[int-tohexstring w1].[int-tohexstring w2]]
16 | val N = 2
17 | val i = 1
18 | val ws = (0x12345678, 0x09ABCDEF)
19 | in
20 | print ([[string-pad(4, [[int-tostring ((N - i) div 100)].])] [pwp ws]\n])
21 | end
22 |
--------------------------------------------------------------------------------
/tests/jumptable.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 |
4 | datatype dt = A | B | C | D | E | F | G | H | I | J | K
5 |
6 | fun pr A = putc ?A
7 | | pr B = putc ?B
8 | (* | pr C = putc ?C*)
9 | | pr D = putc ?D
10 | | pr E = putc ?E
11 | | pr F = putc ?F
12 | (* | pr G = putc ?G *)
13 | | pr H = putc ?H
14 | (* | pr I = putc ?I *)
15 | | pr J = putc ?J
16 | | pr K = putc ?K
17 | | pr _ = putc ?X
18 |
19 | in
20 | pr F; pr E; pr E; pr D;
21 | putc ?\n;
22 | pr C; pr C; pr C
23 | end
--------------------------------------------------------------------------------
/tests/kermit_setup.kmt:
--------------------------------------------------------------------------------
1 | set line /dev/ttyUSB0
2 | set carrier-watch off
3 | set flow-control none
4 | set baud 19200
5 |
6 |
--------------------------------------------------------------------------------
/tests/knowncase.uml:
--------------------------------------------------------------------------------
1 | let
2 | datatype t = A | B
3 | in
4 | case A of
5 | A => 999
6 | | B => 888
7 |
8 | end
--------------------------------------------------------------------------------
/tests/largelit.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | val x = 0xf0f0f0f
4 | in
5 | putc (chr_ ((x shr 24) andb 255));
6 | putc (chr_ ((x shr 16) andb 255));
7 | putc (chr_ ((x shr 8) andb 255));
8 | putc (chr_ (x andb 255))
9 | end
10 |
--------------------------------------------------------------------------------
/tests/lessthan.uml:
--------------------------------------------------------------------------------
1 | (* Attempt at comprehensive tests for
2 | the less-than operator (whose
3 | implementation is not trivial). This is
4 | mildly complicated by the fact that
5 | the optimizer will fold tests if
6 | they are known. So we use functions
7 | to return the numbers we're interested
8 | in. In order to avoid inlining those,
9 | each one has to be called at least
10 | twice (however, future versions of
11 | the inliner may notice that the body
12 | is trivial, at which point this trick
13 | won't work...). *)
14 |
15 | let
16 | fun fact 0 = 1
17 | | fact n = n * fact (n - 1)
18 |
19 | val six = fact 3
20 | val negone = six - 7
21 |
22 | val zero = negone + 1
23 |
24 | fun ok () =
25 | let in
26 | putc ?o;
27 | putc ?k;
28 | putc ?\n
29 | end
30 |
31 | fun bad () =
32 | let in
33 | putc ?n;
34 | putc ?o;
35 | putc ?\n
36 | end
37 |
38 | in
39 | (if six < 6
40 | then bad ()
41 | else ok ());
42 |
43 | (if 6 < six
44 | then bad ()
45 | else ok ());
46 |
47 | (if negone < 1
48 | then ok ()
49 | else bad ());
50 |
51 | (if 1 < negone
52 | then bad ()
53 | else ok ());
54 |
55 | (if negone < zero
56 | then ok ()
57 | else bad ());
58 |
59 | (if zero < negone
60 | then bad ()
61 | else ok ());
62 |
63 | (if zero < zero
64 | then bad ()
65 | else ok ());
66 |
67 | (if negone < negone
68 | then bad ()
69 | else ok ())
70 |
71 | (* XXX more... *)
72 | end
--------------------------------------------------------------------------------
/tests/letcc.uml:
--------------------------------------------------------------------------------
1 | let
2 |
3 | datatype ex =
4 | A of int
5 | | NA of (int -> int)
6 |
7 | val ans =
8 | letcc u
9 | in
10 | NA (fn x => throw A x to u)
11 | end
12 | in
13 | (case ans of
14 | NA f =>
15 | (putc ?O;
16 | putc ?K;
17 | putc ?1;
18 | putc ?\n;
19 | f 1000;
20 | ())
21 | | A i =>
22 | if i = 1000
23 | then
24 | (putc ?O;
25 | putc ?K;
26 | putc ?2;
27 | putc ?\n)
28 | else
29 | (putc ?N;
30 | putc ?O;
31 | putc ?!;
32 | putc ?\n))
33 | end
--------------------------------------------------------------------------------
/tests/list.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "array.uh"
7 | import "char.uh"
8 |
9 | fun list-print nil = print "\n"
10 | | list-print (h :: t) = ( print [<[int-tostring h]>] ;
11 | list-print t )
12 |
13 | val xs = 1 :: 2 :: 3 :: 4 :: 3 :: 2 :: 2 :: 1 :: nil
14 | in
15 | ( list-print xs ;
16 | list-print (list-unique (fn x y => x = y) xs) )
17 | end
18 |
--------------------------------------------------------------------------------
/tests/map.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "array.uh"
7 | import "char.uh"
8 | import "growarray.uh"
9 | import "map.uh"
10 |
11 | val initial-map = map-create (fn desiredk (k1, d1) => desiredk = k1)
12 |
13 | val m = map-add (1, 100) initial-map
14 | val m = map-add (1, 101) m
15 | val m = map-add (1, 102) m
16 | val m = map-add (2, 200) m
17 |
18 | val t1 = map-lookup 1 m
19 |
20 | fun test t =
21 | case t of
22 | SOME ns => print [[int-tostring ns]\n]
23 | | NONE => print [nothing found\n]
24 |
25 | in
26 | (test (map-lookup 1 m) ;
27 | test (map-lookup 2 m) ;
28 | test (map-lookup 3 m) )
29 | end
30 |
--------------------------------------------------------------------------------
/tests/marshall.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "array.uh"
7 | import "char.uh"
8 | import "growarray.uh"
9 | import "marshall.uh"
10 |
11 | val ws = { readbuffer = {| chr 0, chr 0, chr 0, chr 0, chr 0, chr 0, chr 0, chr 0 |},
12 | writebuffer = growarray-new (chr 0),
13 | byte_offset = 0,
14 | bit_offset = 0 }
15 |
16 | val ws = marshall-writenextinteger(ws, 4, 0, 0xdeadbeef)
17 | val ws = marshall-writenextinteger(ws, 1, 0, 0x69)
18 | val ws = marshall-writenextinteger(ws, 2, 0, 0x102)
19 | val ws = marshall-writenextinteger(ws, 2, 0, 0xffaa)
20 | val ws = marshall-writenextinteger(ws, 0, 5, 0x16)
21 | val ws = marshall-writenextinteger(ws, 0, 3, 0x5)
22 | val ws = marshall-writenextinteger(ws, 0, 2, 0x1)
23 | val ws = marshall-writenextinteger(ws, 0, 4, 0x6)
24 | val ws = marshall-writenextinteger(ws, 0, 1, 0x1)
25 | val ws = marshall-writenextinteger(ws, 0, 1, 0x1)
26 | (* val ws = marshall-writenextinteger(ws, 0, 4, 0xa)
27 | val ws = marshall-writenextinteger(ws, 0, 4, 0x5)
28 | val ws = marshall-writenextinteger(ws, 0, 4, 0xc)
29 | val ws = marshall-writenextinteger(ws, 0, 4, 0xd) *)
30 | val ws = marshall-writenextinteger(ws, 2, 0, 0xbbcc)
31 | val ws = marshall-writenextstring(ws, {| chr 0x10, chr 0x11, chr 0x12, chr 0x13, chr 0x14, chr 0x15, chr 0x16|})
32 |
33 | val () = print [result = [chars-tohexstring (growarray-array (#writebuffer/marshall_type ws))]\n]
34 |
35 | val s = { readbuffer = {| chr 69, chr 1, chr 2, chr 0xa5, ?h, ?i, ?t, ?h, ?e, ?r, ?e, chr 0, chr 0xfe |},
36 | writebuffer = growarray-new (chr 0),
37 | byte_offset = 0,
38 | bit_offset = 0 }
39 |
40 | val (i1, s) = marshall-readnextinteger(s, 1, 0)
41 | val (i2, s) = marshall-readnextinteger(s, 2, 0)
42 | val (i3, s) = marshall-readnextinteger(s, 0, 4)
43 | val (i4, s) = marshall-readnextinteger(s, 0, 4)
44 | val (st, s) = marshall-readnextstring s
45 | val (i5, s) = marshall-readnextinteger(s, 1, 0)
46 |
47 | in
48 | print [[st] [int-tostring i1], [int-tostring i2], [int-tostring i3], [int-tostring i4], [int-tostring i5]\n]
49 | end
50 |
--------------------------------------------------------------------------------
/tests/matchbug.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | (*
4 | import "std.uh"
5 | import "string.uh"
6 | *)
7 |
8 | fun iis i i' = i = i'
9 |
10 | fun mkabsolute () =
11 | let
12 | val parts = 999 :: nil
13 |
14 | fun readpath (p, nil) = ?X
15 | (* attempting to ascend above root. pretend root is parent of root *)
16 | | readpath (nil, ((iis 999) _) :: more) = ?r
17 | (* pop off one level *)
18 | | readpath (h :: rest, ((iis 999) _) :: more) = ?.
19 | | readpath (_, h :: t) = ?Q
20 |
21 | in
22 | putc (readpath (0xFEEF :: nil, parts))
23 | end handle Match =>
24 | let in
25 | putc ?x; putc ?\n;
26 | halt ()
27 | end
28 |
29 |
30 | in
31 | mkabsolute ();
32 |
33 | putc ?o; putc ?k; putc ?\n
34 | end
--------------------------------------------------------------------------------
/tests/math_test.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | import "growarray.uh"
5 | import "random.uh"
6 | import "io.uh"
7 | import "list.uh"
8 | import "int.uh"
9 | import "math.uh"
10 |
11 | val x = FP(15, 0x23B) (* 2*pi/360 *)
12 | val y = FP(8, 0x394B) (* 360/2*pi *)
13 | val z = FP(15, 0x1333) (* 0.15 *)
14 | val z2 = FP(15, 0x170A) (* 0.18 *)
15 | val a = FP(13, 0x2800) (* 1.25 *)
16 | val b = FP(15, 0x2666) (* .3 *)
17 | val c = FP(15, 0xD99A) (* -.3 *)
18 | val d = FP(13, 0x6000) (* 3 *)
19 | val e = FP(12, 0x7000) (* 7 *)
20 |
21 | fun neg_str x = if fp_is_negative(x) then "it's negative" else "it's positive"
22 |
23 | val () = print (fp_to_string (fp_negate(b)) ^ "\n\r")
24 | val () = print (fp_to_string (b fp_subtract a) ^ "\n\r")
25 | val () = print (fp_to_string (b fp_subtract c) ^ "\n\r")
26 | val () = print (fp_to_string (c fp_subtract b) ^ "\n\r")
27 | val () = print (fp_to_string (b fp_add c) ^ "\n\r")
28 | val () = print ("multiplies \n\r")
29 | val () = print (fp_to_string (fp_to_single((b fp_multiply d))) ^ "\n\r")
30 | val () = print ((fp_to_string (fp_to_single(b fp_multiply c)) handle FP-exn(s) => s) ^ "\n\r")
31 | val () = print ("divisions \n\r")
32 | val () = print (fp_to_string (a fp_divide d) ^ "\n\r")
33 | val () = print (fp_to_string (fp_to_single (e fp_divide d)) ^ "\n\r")
34 | val () = print ((fp_to_string (fp_to_single (b fp_divide c)) handle FP-exn(s) => s) ^ "\n\r")
35 | val () = print ((fp_to_string (fp_to_single (z fp_divide z2)) handle FP-exn(s) => s) ^ "\n\r")
36 |
37 | in
38 | ()
39 | end
40 |
--------------------------------------------------------------------------------
/tests/mismatch.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 |
4 | datatype file =
5 | Text of string
6 | | Directory of (string * int * file) list ref
7 |
8 | fun search ((!) l) = 0
9 |
10 | (*
11 | fun f x =
12 | case x of
13 | Text x => 999
14 | *)
15 | in
16 | 0
17 | end
--------------------------------------------------------------------------------
/tests/monorec.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | datatype nat =
4 | Succ of nat
5 | | Zero
6 |
7 | in
8 | Succ Zero : nat
9 | end
10 |
--------------------------------------------------------------------------------
/tests/monovarbug.uml:
--------------------------------------------------------------------------------
1 | let
2 | fun resolve _ = 1
3 | and next _ = 0
4 | in
5 | next ()
6 | end
--------------------------------------------------------------------------------
/tests/mrec.uml:
--------------------------------------------------------------------------------
1 | (* test mutual recursion *)
2 |
3 | let
4 |
5 | import "std.uh"
6 | import "string.uh"
7 | import "int.uh"
8 |
9 | fun counte 0 = 0
10 | | counte n = (print (int-tostring n);
11 | print "\n";
12 | counto (n - 1, n div 2))
13 |
14 | and counto (a, b) = counte ((a + b) div 2)
15 |
16 | in
17 | counte 1111
18 | end
19 |
--------------------------------------------------------------------------------
/tests/mrecd-pattern.uml:
--------------------------------------------------------------------------------
1 | (* test mutual recursion on datatypes *)
2 | let
3 | datatype a even = Succ of odd
4 | | Zero
5 | and odd = Next of even
6 |
7 | in
8 | case raise Match of
9 | Next e => Next e
10 | end
11 |
--------------------------------------------------------------------------------
/tests/mrecd.uml:
--------------------------------------------------------------------------------
1 | (* test mutual recursion on datatypes *)
2 | let
3 | import "std.uh"
4 | import "string.uh"
5 | import "int.uh"
6 |
7 | datatype even =
8 | Succ of odd
9 | | Zero
10 | and odd = Next of even
11 |
12 | fun counte (Succ d) = 1 + counto d
13 | | counte (Zero) = 0
14 |
15 | and counto (Next e) = 1 + counte e
16 |
17 | val six = Succ (Next (Succ (Next (Succ (Next Zero)))))
18 |
19 | in
20 | print "Should be 6:\n";
21 | print (int-tostring (counte six));
22 | print "\n"
23 | end
24 |
--------------------------------------------------------------------------------
/tests/native.uml:
--------------------------------------------------------------------------------
1 | let
2 | native pm = "printme" : int -> unit
3 |
4 | native am = "addme" : ( int * int ) -> int
5 |
6 | native gv = "getglobal" : unit -> int
7 |
8 | fun g z = z ()
9 | fun gg () = g gv
10 | val x = gg ()
11 |
12 | fun a z x = z x
13 | fun aa t = a am t
14 | val z = aa (3, 4)
15 |
16 | in
17 | ( pm x ;
18 | pm z )
19 | end
20 |
--------------------------------------------------------------------------------
/tests/newstring-BUG.uml:
--------------------------------------------------------------------------------
1 | let in
2 | putc (sub_("hello world", 0))
3 | end
--------------------------------------------------------------------------------
/tests/newstring.uml:
--------------------------------------------------------------------------------
1 | let
2 | val s = "hello world"
3 |
4 | (* val s = {|?h, ?i, ?!|} *)
5 | in
6 | update_(s, 0, ?H);
7 | putc (sub_(s, 0));
8 | putc (sub_(s, 1))
9 | end
10 |
--------------------------------------------------------------------------------
/tests/nfib.txt:
--------------------------------------------------------------------------------
1 | NFIB NFIB NFIB NFIB
2 |
3 | #### C version #############################################
4 | #include
5 |
6 | int nfib( int n )
7 | {
8 | if (n <= 1)
9 | {
10 | return 1;
11 | }
12 | else
13 | {
14 | return 1 + nfib(n-1) + nfib(n-2);
15 | }
16 | }
17 |
18 | int main(int argc, char **argv)
19 | {
20 | nfib(32);
21 | return (0);
22 | }
23 |
24 | #### python version ########################################
25 | def nfib(n):
26 | if (n <= 1):
27 | return 1
28 | else:
29 | return 1 + nfib(n-1) + nfib(n-2)
30 |
31 | nfib(32)
32 |
33 | #### uml version ###########################################
34 | let
35 | import "std.uh"
36 | import "string.uh"
37 | import "int.uh"
38 |
39 | fun nfib n =
40 | if (n <= 1)
41 | then 1
42 | else 1 + (nfib (n - 1)) + (nfib (n - 2))
43 | in
44 | nfib 32
45 | end
46 |
47 |
48 | nfib(32) value is 7049155
49 |
50 | c time is .110 seconds
51 | uml time is 1.7 seconds
52 | python time is 3.5 seconds
53 |
54 | C calls per second = 7049155/.110 = 64083227
55 | uml calls per second = 7049155/1.7 = 4146561
56 | python calls per second = 7049155/3.5 = 2014044
57 |
58 | performance relative to uml
59 | C = 15
60 | uml = 1
61 | python = 0.49
62 |
--------------------------------------------------------------------------------
/tests/nfib.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | import "int.uh"
5 |
6 | fun nfib n =
7 | if (n <= 1)
8 | then 1
9 | else 1 + (nfib (n - 1)) + (nfib (n - 2))
10 | in
11 | nfib 32
12 | end
13 |
14 |
--------------------------------------------------------------------------------
/tests/nothing.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | in
5 | print (string-wordwrap 20 "hey\n")
6 | end
--------------------------------------------------------------------------------
/tests/nullary.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 |
4 | datatype t = A | B | C of unit | D of int
5 | in
6 | case (A, B, C (), D 5) of
7 | (A, B, C (), D 6) => putc ?*
8 | | (A, B, C (), _) => putc ?\n
9 | end
10 |
--------------------------------------------------------------------------------
/tests/obs.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 | import "string.uh"
5 | import "array.uh"
6 | import "des.uh"
7 | import "obfuscate.uh"
8 |
9 | val s = ObsString{"encrypted string--cool!\n"}
10 |
11 | (* val s = obs-fromstring (42, 100) "HELLO WORLD !!!" *)
12 |
13 | val () = obs-update (s, 1, ?X)
14 |
15 | val s' = obs-tostring s
16 | in
17 | print s'
18 | end
19 |
--------------------------------------------------------------------------------
/tests/opcons.uml:
--------------------------------------------------------------------------------
1 | let
2 |
3 | val l = (1, nil) :: nil
4 |
5 | fun la (f, h::_) = f h
6 | | la (f, nil) = halt ()
7 |
8 | in
9 | la (op::, l);
10 | la (op::, l)
11 | end
--------------------------------------------------------------------------------
/tests/parray.uml:
--------------------------------------------------------------------------------
1 | let
2 | fun f x = x + 1
3 | val a = f 5
4 | val b = f 3
5 | in
6 | array (a, ? )
7 | end
8 |
--------------------------------------------------------------------------------
/tests/parray2.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | import "growarray.uh"
5 | import "random.uh"
6 | import "io.uh"
7 | import "list.uh"
8 |
9 | val d = "0123456789"
10 | fun c y x = y ^ (array (1, (sub_ (d, x))))
11 |
12 | val r = c "~" 4
13 | val s = c "~" 5
14 | in
15 | print r
16 | end
17 |
--------------------------------------------------------------------------------
/tests/phidgets.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "phidgets.uh"
7 |
8 | val serno = 68132
9 |
10 | val lcd_h = phidgets-lcd-open serno
11 | val ik_h = phidgets-ik-open serno
12 |
13 | val () = phidgets-set-output-state (ik_h, 0, 0)
14 | val () = phidgets-set-display-string (lcd_h, 0, "12345678901234567890")
15 |
16 | val () = phidgets-set-output-state (ik_h, 0, 1)
17 | val () = phidgets-set-display-string (lcd_h, 1, "yo mama")
18 |
19 | val () = phidgets-set-output-state (ik_h, 0, 0)
20 | val () = phidgets-set-display-string (lcd_h, 0, "adfadsfasfd")
21 |
22 | val hs = int-tostring lcd_h
23 |
24 | val () = phidgets-close lcd_h
25 | val () = phidgets-close ik_h
26 | in
27 | print [Phidget Handle is: [hs]\n\r]
28 | end
29 |
--------------------------------------------------------------------------------
/tests/printlist.uml:
--------------------------------------------------------------------------------
1 | let
2 | val l = ?h :: ?e :: ?l :: ?l :: ?o :: ? :: ?w :: ?o :: ?r :: ?l :: ?d :: ?\n :: nil
3 |
4 | fun pl nil = ()
5 | | pl (c :: rest) =
6 | (putc c;
7 | pl rest)
8 | in
9 | pl l
10 | end
11 |
--------------------------------------------------------------------------------
/tests/proj.uml:
--------------------------------------------------------------------------------
1 | let
2 | val r = ("hello", 1, ?6, true)
3 | in
4 | #2/4 r
5 | end
--------------------------------------------------------------------------------
/tests/pub-graph.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 | import "list.uh"
5 | import "string.uh"
6 | import "int.uh"
7 | import "bigint.uh"
8 | import "des.uh"
9 | import "publications.uh"
10 | in
11 |
12 | let
13 | val f = sigmoid-score { min-score = bi-fromint 30,
14 | par-score = bi-fromint 150,
15 | max-score = bi-fromint 175,
16 | correct= bi-fromint 1000,
17 | par= bi-fromint 360,
18 | hole-in-one= bi-fromint 100}
19 |
20 | in
21 |
22 | list-app (fn (x,y) => print [[bi-tostring x] [bi-tostring y]\n])
23 | (list-tabulate (1100,
24 | fn x => (bi-fromint x, f (bi-fromint x))))
25 | end
26 |
27 |
28 | end
29 |
--------------------------------------------------------------------------------
/tests/queue_test.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 | import "queues.uh"
6 |
7 | fun pr m = case m of SOME s => print [message is: [s]\n]
8 | | NONE => print [no message: \n]
9 |
10 | fun t () =
11 | let
12 | val q' = queue-create ()
13 | val q' = queue-send q' "greetings"
14 | val q' = queue-send q' "my name is andrew"
15 | val q' = queue-send q' "what is yours"
16 | val q' = queue-send q' "how are you"
17 | val (x1, q') = queue-receive q'
18 | val (x2, q') = queue-receive q'
19 | val (x3, q') = queue-receive q'
20 | val (x4, q') = queue-receive q'
21 | val (x5, q') = queue-receive q'
22 | val () = (pr x1; pr x2; pr x3; pr x4; pr x5)
23 | in
24 | ()
25 | end
26 | in
27 | t ()
28 | end
29 |
--------------------------------------------------------------------------------
/tests/quicksort.uml:
--------------------------------------------------------------------------------
1 | let
2 | fun append (x::xs) ys =
3 | x::(append xs ys)
4 | | append nil ys = ys
5 |
6 | fun partition x (y::ys) (accl, accg) =
7 | if y < x then partition x ys (y::accl, accg)
8 | else partition x ys (accl, y::accg)
9 | | partition x nil acc = acc
10 |
11 | fun print (x::xs) = (putc (chr_ (x + 65)); putc ? ; print xs)
12 | | print nil = putc ?\n
13 |
14 | fun qsort (x::xs) =
15 | let
16 | val (l, g) = partition x xs (nil, nil)
17 | val l' = qsort l
18 | val () = print l'
19 | val g' = qsort g
20 | val () = print g'
21 | val () = putc ?\n
22 | val () = putc ?\n
23 | in
24 | append l' (x::g')
25 | end
26 | | qsort nil = nil
27 |
28 | fun test (x1::x2::xs) = x1 <= x2 andalso test (x2::xs)
29 | | test _ = true
30 |
31 | fun buildlist 0 = nil
32 | | buildlist n = n::(buildlist (n - 1))
33 |
34 | val l = buildlist 50
35 |
36 | val l' = qsort l
37 | in
38 | putc ?:;
39 | if test l' then putc ?) else putc ?(;
40 | putc ?\n
41 | ;
42 | print l
43 | ;
44 | print l'
45 | end
46 |
--------------------------------------------------------------------------------
/tests/quine.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | in
5 | print datafile "quine.uml"
6 | end
7 |
--------------------------------------------------------------------------------
/tests/records.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 |
5 | datatype t =
6 | A of { a : t, b : char }
7 | | B
8 |
9 | val x =
10 | A { a = A { b = ?e, a = A { b = ?s, a = B } }, b = ?y }
11 |
12 |
13 | fun pr y =
14 | (case y of
15 | A { a, b = c } => (putc c; pr a)
16 | | B => (putc ?!; putc ?\n))
17 | in
18 | pr x
19 | end
20 |
--------------------------------------------------------------------------------
/tests/reftest.uml:
--------------------------------------------------------------------------------
1 | let
2 |
3 | val x = ref ?N
4 | val y = ref ?O
5 | do x := ?O
6 | do y := ?K
7 | in
8 | putc (! x);
9 | putc (! y);
10 | putc ?\n
11 | end
12 |
--------------------------------------------------------------------------------
/tests/sandmark.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 | import "list.uh"
5 | import "string.uh"
6 | import "int.uh"
7 | import "des.uh"
8 | import "bigint.uh"
9 | (* import "publications.uh" *)
10 | import "random.uh"
11 | import "growarray.uh"
12 | import "io.uh"
13 | import "util.uh"
14 |
15 | val keys =
16 | {|
17 | des-key (0xa07c632a, 0xd14ecf73),
18 | des-key (0x0380e70d, 0x16e1c73e),
19 | des-key (0x55e1b670, 0x450127b9),
20 | des-key (0x89561969, 0x594fd688),
21 | des-key (0x58f6b317, 0xdf18fe7b),
22 | des-key (0x52ea4288, 0xd47df04e),
23 | des-key (0x0b66e785, 0xeff0d38a),
24 | des-key (0xf74389eb, 0x1f081a2d),
25 | des-key (0x6f1fd2a8, 0xa9433129),
26 | des-key (0xbdc6d457, 0x4d4d3988),
27 | des-key (0xdba544e9, 0xfdb25834),
28 | des-key (0x8a09265a, 0xde9db7d6),
29 | des-key (0xd0a35a32, 0x1dca7ed0),
30 | des-key (0x3ba82ffc, 0xe3a6be41),
31 | des-key (0x92a23f55, 0xbdcacc2e),
32 | des-key (0xc2c1e3ff, 0x4ed7a512),
33 | des-key (0xee6598a6, 0x504c67b1),
34 | des-key (0x020c63ac, 0xfb35e841)
35 | |}
36 | (* run the encryption loop for N cycles *)
37 | val N = 10000
38 |
39 | do print [ == SANDmark 19107 beginning stress test / benchmark.. ==\n\r]
40 |
41 | val kr = ref 0
42 | fun getkey () =
43 | let in
44 | kr := !kr + 1;
45 | if !kr >= length keys
46 | then kr := 0
47 | else ();
48 | sub(keys, 0)
49 | end
50 |
51 | fun pwp (w1, w2) = [[int-tohexstring w1].[int-tohexstring w2]]
52 |
53 | fun loop () =
54 | ford 0 N (0x12345678, 0x09ABCDEF)
55 | (fn (i, ws) =>
56 | (if i mod 100 = 0
57 | then print ([[string-pad(4, [[int-tostring ((N - i) div 100)].])] [pwp ws]\n\r])
58 | else ();
59 | des-encrypt3(getkey (), getkey (), getkey ()) ws))
60 |
61 | val ws = loop ()
62 | in
63 | print [SANDmark complete.\n\r]
64 | end
65 |
--------------------------------------------------------------------------------
/tests/self.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | import "growarray.uh"
5 | import "io.uh"
6 | in
7 | print "okay!\n"
8 | end
--------------------------------------------------------------------------------
/tests/sequnit.uml:
--------------------------------------------------------------------------------
1 |
2 | (0; 1)
3 |
--------------------------------------------------------------------------------
/tests/sethandler.uml:
--------------------------------------------------------------------------------
1 | (* this tests the unsafe(?) sethandler primitive *)
2 |
3 | let
4 | val _ =
5 | letcc out
6 | in
7 | letcc u
8 | in
9 | sethandler_ u;
10 | throw () to out
11 | end;
12 | putc ?o;
13 | putc ?k;
14 | putc ?\n;
15 | halt ()
16 | end
17 |
18 | exception X
19 | in
20 | putc ?.; putc ?.; putc ?.; putc ? ;
21 |
22 | raise X;
23 |
24 | putc ?n;
25 | putc ?o;
26 | putc ?\n
27 |
28 | end
--------------------------------------------------------------------------------
/tests/sha.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "array.uh"
7 | import "char.uh"
8 | import "sha.uh"
9 |
10 | val ds1 = {| |}
11 | (* ds2 = "dead" sha1 = 5eb965dd8c804a3a2833ac61fe1d1f6b1960735a *)
12 | val ds2 = {| 0x64656164 |}
13 | (* ds3 = "dead men dont eat meats!" sha1 = aedf5ca68b1ed191db7520d1ba7a99048c8b3746 *)
14 | val ds3 = {| 0x64656164, 0x206d656e, 0x20646f6e, 0x74206561, 0x74206d65, 0x61747321 |}
15 |
16 | val s = "dead men dont eat meats!"
17 | val s1 = ints-fromchars s
18 |
19 | fun printer ds = array-app (fn x => ( print [[x]] )) (array-map int-tohexstring ds)
20 |
21 | (* k should be 49cc1301b06653144e3203afdbbbe917f3a76445 *)
22 | val k = "But the scientific cast of mind examines the world critically as if many alternative worlds might exist, as if other things might be here which are not. Then we are forced to ask why what we see is present and not something else. Why are the Sun and the Moon and the planets spheres? Why not pyramids, or cubes, or dodecahedra? Why not irregular, jumbly shapes? Why so symmetrical worlds? If you spend any time spinning hypotheses, checking to see whether they make sense, whether they conform to what else we know, thinking of tests you can pose to substantiate or deflate your hypotheses, you will find yourself doing science."
23 | val k' = ints-fromchars k
24 |
25 | in
26 | ( (* printer ( sha-hash ds1 ) ; print [\n\r] ;
27 | printer ( sha-hash ds2 ) ; print [\n\r] ;
28 | printer ( sha-hash ds3 ) ; print [\n\r] ; *)
29 | printer ( sha-hash k' ) ; print [\n\r] )
30 | end
31 |
--------------------------------------------------------------------------------
/tests/sha1_in_c/sha1.h:
--------------------------------------------------------------------------------
1 | /**
2 | * \file sha1.h
3 | */
4 | #ifndef XYSSL_SHA1_H
5 | #define XYSSL_SHA1_H
6 |
7 | /**
8 | * \brief SHA-1 context structure
9 | */
10 | typedef struct
11 | {
12 | unsigned long total[2]; /*!< number of bytes processed */
13 | unsigned long state[5]; /*!< intermediate digest state */
14 | unsigned char buffer[64]; /*!< data block being processed */
15 |
16 | unsigned char ipad[64]; /*!< HMAC: inner padding */
17 | unsigned char opad[64]; /*!< HMAC: outer padding */
18 | }
19 | sha1_context;
20 |
21 | #ifdef __cplusplus
22 | extern "C" {
23 | #endif
24 |
25 | /**
26 | * \brief SHA-1 context setup
27 | *
28 | * \param ctx context to be initialized
29 | */
30 | void sha1_starts( sha1_context *ctx );
31 |
32 | /**
33 | * \brief SHA-1 process buffer
34 | *
35 | * \param ctx SHA-1 context
36 | * \param input buffer holding the data
37 | * \param ilen length of the input data
38 | */
39 | void sha1_update( sha1_context *ctx, unsigned char *input, int ilen );
40 |
41 | /**
42 | * \brief SHA-1 final digest
43 | *
44 | * \param ctx SHA-1 context
45 | * \param output SHA-1 checksum result
46 | */
47 | void sha1_finish( sha1_context *ctx, unsigned char output[20] );
48 |
49 | /**
50 | * \brief Output = SHA-1( input buffer )
51 | *
52 | * \param input buffer holding the data
53 | * \param ilen length of the input data
54 | * \param output SHA-1 checksum result
55 | */
56 | void sha1( unsigned char *input, int ilen, unsigned char output[20] );
57 |
58 | /**
59 | * \brief Output = SHA-1( file contents )
60 | *
61 | * \param path input file name
62 | * \param output SHA-1 checksum result
63 | *
64 | * \return 0 if successful, 1 if fopen failed,
65 | * or 2 if fread failed
66 | */
67 | int sha1_file( char *path, unsigned char output[20] );
68 |
69 | /**
70 | * \brief SHA-1 HMAC context setup
71 | *
72 | * \param ctx HMAC context to be initialized
73 | * \param key HMAC secret key
74 | * \param keylen length of the HMAC key
75 | */
76 | void sha1_hmac_starts( sha1_context *ctx, unsigned char *key, int keylen );
77 |
78 | /**
79 | * \brief SHA-1 HMAC process buffer
80 | *
81 | * \param ctx HMAC context
82 | * \param input buffer holding the data
83 | * \param ilen length of the input data
84 | */
85 | void sha1_hmac_update( sha1_context *ctx, unsigned char *input, int ilen );
86 |
87 | /**
88 | * \brief SHA-1 HMAC final digest
89 | *
90 | * \param ctx HMAC context
91 | * \param output SHA-1 HMAC checksum result
92 | */
93 | void sha1_hmac_finish( sha1_context *ctx, unsigned char output[20] );
94 |
95 | /**
96 | * \brief Output = HMAC-SHA-1( hmac key, input buffer )
97 | *
98 | * \param key HMAC secret key
99 | * \param keylen length of the HMAC key
100 | * \param input buffer holding the data
101 | * \param ilen length of the input data
102 | * \param output HMAC-SHA-1 result
103 | */
104 | void sha1_hmac( unsigned char *key, int keylen,
105 | unsigned char *input, int ilen,
106 | unsigned char output[20] );
107 |
108 | /**
109 | * \brief Checkup routine
110 | *
111 | * \return 0 if successful, or 1 if the test failed
112 | */
113 | int sha1_self_test( int verbose );
114 |
115 | #ifdef __cplusplus
116 | }
117 | #endif
118 |
119 | #endif /* sha1.h */
120 |
--------------------------------------------------------------------------------
/tests/sha1_in_c/sha1_c_main.c:
--------------------------------------------------------------------------------
1 | #include
2 | #include
3 | #include "sha1.h"
4 |
5 | int main ( int argc, char **argv )
6 | {
7 |
8 | char *s = "But the scientific cast of mind examines the world critically as if many alternative worlds might exist, as if other things might be here which are not. Then we are forced to ask why what we see is present and not something else. Why are the Sun and the Moon and the planets spheres? Why not pyramids, or cubes, or dodecahedra? Why not irregular, jumbly shapes? Why so symmetrical worlds? If you spend any time spinning hypotheses, checking to see whether they make sense, whether they conform to what else we know, thinking of tests you can pose to substantiate or deflate your hypotheses, you will find yourself doing science.";
9 | unsigned char result[20];
10 | int i;
11 | int j;
12 |
13 | for( j = 0; j < 100; j ++ )
14 | {
15 | sha1( (unsigned char *) s, strlen(s), result );
16 | }
17 |
18 | for( i = 0; i < 20; i++ )
19 | {
20 | printf("%02x", result[i]);
21 | }
22 | printf("\n", result[i]);
23 |
24 | return 0;
25 | }
26 |
--------------------------------------------------------------------------------
/tests/simple_fastmark.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 | import "list.uh"
5 | import "string.uh"
6 | import "int.uh"
7 | import "des.uh"
8 | import "bigint.uh"
9 | (* import "publications.uh" *)
10 | import "random.uh"
11 | import "growarray.uh"
12 | import "io.uh"
13 | import "util.uh"
14 |
15 | val keys =
16 | {|
17 | des-key (0xa07c632a, 0xd14ecf73),
18 | des-key (0x0380e70d, 0x16e1c73e),
19 | des-key (0x55e1b670, 0x450127b9)
20 | |}
21 | (* run the encryption loop for N cycles *)
22 | val N = 16
23 |
24 | do print [ == FASTmark 19106 beginning stress test / benchmark.. ==\n]
25 |
26 | val kr = ref 0
27 |
28 | fun getkey () =
29 | let in
30 | kr := !kr + 1;
31 | if !kr >= length keys
32 | then kr := 1
33 | else ();
34 | sub(keys, 0)
35 | end
36 |
37 | fun pwp (w1, w2) = [[int-tohexstring w1].[int-tohexstring w2]]
38 |
39 | fun loop () =
40 | ford 0 N (0x12345678, 0x09ABCDEF)
41 | (fn (i, ws) =>
42 | (if i mod 2 = 0
43 | then print ([[string-pad(4, [[int-tostring ((N - i) div 2)].])] [pwp ws]\n])
44 | else ();
45 | des-encrypt3(getkey (), getkey (), getkey ()) ws))
46 |
47 | val ws = loop ()
48 | in
49 | print [FASTmark complete.\n]
50 | end
51 |
--------------------------------------------------------------------------------
/tests/simple_pub.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 | import "list.uh"
5 | import "string.uh"
6 | import "int.uh"
7 | import "bigint.uh"
8 | import "des.uh"
9 | import "publications.uh"
10 | in
11 | print (gen-publication { problem = "TESTX",
12 | task = "ONE",
13 | (* hi-score!! *)
14 | score = bi-fromint 1000000 } ^ "\n")
15 | end
16 |
--------------------------------------------------------------------------------
/tests/simple_threads.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 | import "list.uh"
5 | import "string.uh"
6 | import "priothreads.uh"
7 |
8 | fun pr s () =
9 | (print s ;
10 | yield ();
11 | pr s ())
12 |
13 | do fork (32, pr "D")
14 | do fork (32, pr "C")
15 | in
16 | resched ()
17 | end
18 |
--------------------------------------------------------------------------------
/tests/small_bigint.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | import "int.uh"
5 | import "list.uh"
6 | import "bigint.uh"
7 |
8 | val x1 = bi-tostring (bi-subt (bi-fromint 10, bi-fromint 350) handle _ => ( (print "whoah nelly") ; (bi-fromint 667) )) handle Div => "got div exception" | _ => "got exception"
9 |
10 | in
11 | print x1
12 | end
13 |
14 |
--------------------------------------------------------------------------------
/tests/small_bigint2.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | import "int.uh"
5 | import "list.uh"
6 | import "bigint.uh"
7 |
8 | val x1 = bi-tostring (bi-subt (bi-fromint 10, bi-fromint 350))
9 |
10 | in
11 | ()
12 | end
13 |
14 |
--------------------------------------------------------------------------------
/tests/socket.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "descriptorio.uh"
7 | import "socket.uh"
8 |
9 | fun udp-client () =
10 | let
11 | val s = socket-open-udp ()
12 | val () = socket-connect (s, "192.168.1.5", 51423)
13 | in
14 | ( descriptor-write (s, "hi from udp land") ;
15 | socket-close s )
16 | end
17 |
18 | fun udp-sentence-client () =
19 | let
20 | val s = socket-open-udp ()
21 | val () = socket-bind (s, 6970)
22 | val s2 = socket-open-udp ()
23 | val () = socket-bind (s2, 6970)
24 | val () = socket-connect (s, "andrewha-laptop", 6969)
25 | val () = socket-connect (s2, "andrewha-laptop", 6980)
26 |
27 | fun get-new-sentence s =
28 | let
29 | val b = descriptor-bytes-avail s
30 | in
31 | if b > 0 then print [got: <[descriptor-read (s, b)]>\n] else get-new-sentence s
32 | end
33 |
34 | in
35 | ( descriptor-write (s, "hi from udp land") ;
36 | socket-close s ;
37 | (* get-new-sentence s ; *)
38 | descriptor-write (s2, "hi again from udp land") ;
39 | get-new-sentence s2 ;
40 | get-new-sentence s2 ;
41 | socket-close s2 )
42 | end
43 |
44 | fun tcp-client () =
45 | let
46 | val s = socket-open-tcp ()
47 | val () = socket-connect (s, "127.0.0.1", 40004)
48 |
49 | fun ploop i =
50 | let
51 | val b = descriptor-bytes-avail s
52 | in
53 | if b > 0
54 | then print [<[descriptor-read (s, b)]>\n]
55 | else ploop (i + 1)
56 | end
57 | in
58 | ( ploop 1 ;
59 | socket-close s )
60 | end
61 |
62 | fun tcp-server () =
63 | let
64 | val s = socket-open-tcp ()
65 | val () = socket-bind (s, 40005)
66 | val () = socket-listen (s, 1)
67 | val s2 = socket-accept s
68 | in
69 | ( descriptor-write (s2, "greetings from FP land. I'm glad to see you.") ;
70 | socket-close s ;
71 | socket-close s2 )
72 | end
73 |
74 | fun bool-tostring b = if b then "true" else "false"
75 |
76 | in
77 | ( print [ip address of andrewha-laptop is: [socket-gethostbyname "andrewha-laptop"]\n] ;
78 | print [hhihihih\n] ;
79 | print [ip address of cnn is: [socket-gethostbyname "www.cnn.com"]\n] ;
80 | print [ip address of google is: [socket-gethostbyname "www.google.com"]\n] ;
81 | print [[bool-tostring (socket-is-ipaddr "www.google.com")]\n] ;
82 | print [[bool-tostring (socket-is-ipaddr "127.0.0.1")]\n] ;
83 | print [[bool-tostring (socket-is-ipaddr "www.127.com")]\n] ;
84 | print [[bool-tostring (socket-is-ipaddr "1232132")]\n] ;
85 | udp-sentence-client () ;
86 | print [[bool-tostring (socket-is-ipaddr "1.2.3.4.5")]\n] )
87 | (* udp-client () *)
88 | (* udp-sentence-client () *)
89 | end
90 |
--------------------------------------------------------------------------------
/tests/somenil.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | datatype a opt =
4 | Some of a
5 | | None
6 |
7 | datatype a lis =
8 | Cons of a * lis
9 | | Nil
10 |
11 | fun pr x =
12 | (case x of
13 | None => putc ?X
14 | | Some Nil => putc ?O
15 | | Some (Cons(c, l)) => (putc c; pr (Some l)))
16 |
17 | in
18 | putc ?X; putc ?=; putc ?f; putc ?a; putc ?i; putc ?l; putc ?\n;
19 |
20 | pr (Some Nil); putc ?\n;
21 | pr (Some (Cons (?A, Cons (?B, Cons (?C, Nil))))); putc ?\n
22 | end
--------------------------------------------------------------------------------
/tests/string.uml:
--------------------------------------------------------------------------------
1 | (* tests string constants and the string library *)
2 | let
3 | import "std.uh"
4 | import "string.uh"
5 | in
6 | print ("hello, " ^ "world!\n");
7 |
8 | putc (chr_ (65 + (length "AWESOME coolies ;-)")))
9 | end
10 |
--------------------------------------------------------------------------------
/tests/string0.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | fun f 1 = ""
4 | | f _ = "z"
5 | in
6 | (f 0, f 1)
7 | end
8 |
--------------------------------------------------------------------------------
/tests/string1.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 |
5 | fun f 1 = ""
6 | | f _ = "z"
7 | in
8 | (print (f 0), print (f 1))
9 | end
10 |
--------------------------------------------------------------------------------
/tests/stringexntest-jcreed.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | exception Fail
5 | in
6 |
7 | (* in sml implementation of um: *)
8 | (* 48 .s results in array out of bounds error *)
9 | (* 47 .s results in infinite dot-printing loop (!?) *)
10 | (* 46 .s correctly prints unhandled exception *)
11 | (* 1 2 3 4 5 *)
12 | (* 012345678901234567890123456789012345678901234567890 *)
13 | print "..............................................\n";
14 | raise Fail
15 | end
16 |
--------------------------------------------------------------------------------
/tests/stringtype.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 | in
5 | "hello" : string
6 | end
--------------------------------------------------------------------------------
/tests/sum_test3.uml:
--------------------------------------------------------------------------------
1 | let
2 | datatype d = A of int | B of int | C
3 |
4 | fun g (A x) = putc (chr_ x)
5 | | g (B y) = putc ?B
6 | | g (C) = putc ?C
7 |
8 | val _ = g (B 10)
9 | val _ = g (A 120)
10 | val _ = g (C)
11 | in
12 | ()
13 | end
14 |
--------------------------------------------------------------------------------
/tests/sumrep_list.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | in
5 | list-app putc (?H :: ?E :: ?L :: ?L :: ?O :: ? ::
6 | ?W :: ?H :: ?I :: ?R :: ?L :: ?E :: ?D :: ?\n :: nil)
7 | end
--------------------------------------------------------------------------------
/tests/sumrep_none.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | datatype t = A of int * int
4 |
5 | fun swap (A (a, b)) = A (b, a)
6 | in
7 | swap (swap (A (1, 2)))
8 | end
9 |
--------------------------------------------------------------------------------
/tests/sumrep_option.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | datatype optional = A of int | B
4 |
5 | fun swippy (A i) = B
6 | | swippy B = A 5
7 | in
8 | swippy (A 2)
9 | end
10 |
--------------------------------------------------------------------------------
/tests/tasks.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | import "list.uh"
5 | import "int.uh"
6 | import "threads.uh"
7 | import "queues.uh"
8 | import "messagequeues.uh"
9 | import "tasks.uh"
10 |
11 | val a-queue = mq-create ()
12 | val b-queue = mq-create ()
13 | val c-queue = mq-create ()
14 |
15 | fun task-hook (name, mq) m =
16 | let
17 | val () = print [[name]: message is: [m]\n]
18 | val () = mq-send mq m
19 | in
20 | (name, mq)
21 | end
22 |
23 | fun terminal-hook name m = ( print [[name](terminal): message is [m]\n] ;
24 | name )
25 |
26 | fun main (i, mq) () =
27 | let
28 | fun f () = mq-send mq (int-tostring (mq-length mq))
29 | val () = if (i mod 1000000) = 0
30 | then (f (); f (); f ())
31 | else ()
32 | in
33 | ( yield () ;
34 | main (i+1, mq) () )
35 | end
36 | in
37 | ( task-create c-queue terminal-hook "taskC" ;
38 | task-create b-queue task-hook ("taskB", c-queue) ;
39 | task-create a-queue task-hook ("taskA", b-queue) ;
40 | main (0, a-queue) () )
41 | end
42 |
--------------------------------------------------------------------------------
/tests/telemetry.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "array.uh"
7 | import "hash.uh"
8 | import "char.uh"
9 | import "telemetry.uh"
10 |
11 | val () = telemetry-add ("element1", UINT8 (ref 13))
12 | val () = telemetry-add ("element2", UINT16 (ref 512))
13 | val () = telemetry-add ("thatthirdelement", UINT32 (ref 0xfffff))
14 | val () = telemetry-add ("quattro", BOOL (ref true))
15 |
16 | val names = {|
17 | "element1",
18 | "element2",
19 | "thatthirdelement",
20 | "quattro"
21 | |}
22 |
23 | val pkt = (telemetry-define-packet names)
24 |
25 | val telemetry-stream = telemetry-generate-packet pkt
26 |
27 | in
28 | print (chars-tohexstring telemetry-stream)
29 | end
30 |
--------------------------------------------------------------------------------
/tests/threads.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 | import "list.uh"
5 | import "string.uh"
6 | import "threads.uh"
7 |
8 | fun pr s () =
9 | (print [[s]\n];
10 | yield ();
11 | pr s ())
12 |
13 | fun prt s () =
14 | (print [[s]\n];
15 | yield ())
16 |
17 | do fork (pr "D")
18 | do fork (pr "C")
19 | do fork (prt "B")
20 | in
21 | pr "A" ()
22 | end
23 |
--------------------------------------------------------------------------------
/tests/timer.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "threads.uh"
7 | import "clock.uh"
8 | import "timer.uh"
9 |
10 | fun pr () =
11 | ( yield ();
12 | pr ())
13 |
14 | fun timer-task ts () =
15 | let
16 | val ts' = timer-scan ts
17 | in
18 | ( yield ();
19 | timer-task ts' () )
20 | end
21 |
22 | val () = print (timer-list-tostring timer-list "")
23 | val (i1, t2) = timer-create timer-list ((5, 0), (fn () => print "ding\n"))
24 | val () = print (timer-list-tostring t2 "")
25 | val (i2, t3) = timer-create t2 ((10, 500), (fn () => print "dong\n"))
26 | val () = print (timer-list-tostring t3 "")
27 | val (i3, t4) = timer-create t3 ((2, 600), (fn () => print "dooey\n"))
28 | val () = print (timer-list-tostring t4 "")
29 | val (i10, t10) = timer-create t4 ((7, 0), (fn () => print "louis\n"))
30 | val () = print (timer-list-tostring t10 "")
31 | val t5 = timer-delete i3 t10
32 | val () = print (timer-list-tostring t5 "")
33 |
34 | val () = fork pr
35 | val () = fork (timer-task t5)
36 | in
37 | pr ()
38 | end
39 |
--------------------------------------------------------------------------------
/tests/tinycmp.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | fun my () = 2
4 |
5 | fun not true = false
6 | | not false = true
7 | in
8 |
9 | if (putc ?a; my () < (my () + 1))
10 | then
11 | let in
12 | putc ?\n;
13 | putc ?o; putc ?k;
14 | putc ?!;
15 | ()
16 | end
17 | else
18 | let in
19 | putc ?\n;
20 | putc ?n; putc ?o;
21 | putc ?!;
22 | ()
23 | end;
24 |
25 | putc ?\n
26 | end
27 |
--------------------------------------------------------------------------------
/tests/toplevel.uml:
--------------------------------------------------------------------------------
1 | (* should invoke toplevel exception handler,
2 | printing something like "uncaught exn!" *)
3 | let
4 | import "std.uh"
5 |
6 | exception Whatever
7 | in
8 | raise Whatever;
9 | putc ?n; putc ?o; putc ?\n
10 | end
--------------------------------------------------------------------------------
/tests/trivial.uml:
--------------------------------------------------------------------------------
1 | let
2 | in
3 | putc ?*
4 | end
--------------------------------------------------------------------------------
/tests/ttolex-simple.uml:
--------------------------------------------------------------------------------
1 | let
2 |
3 | datatype zool = A | B
4 |
5 | datatype mytype =
6 | Constructor1 of unit
7 | | Constructor2 of { 1 : int } * int
8 | | SomethingElse
9 | | Whatever of { 0 : int , food : int -> int }
10 | and notthis = Avoid of unit
11 |
12 | in
13 |
14 | A : unit -> unit
15 |
16 | end
--------------------------------------------------------------------------------
/tests/ttolex.uml:
--------------------------------------------------------------------------------
1 | let
2 | datatype (a, b) mytype =
3 | Constructor1 of a
4 | | Constructor2 of b * a * int
5 | | SomethingElse
6 | | Whatever of b
7 | and notthis = Avoid of b
8 |
9 | in
10 |
11 | Avoid 0 : unit -> unit
12 |
13 | end
--------------------------------------------------------------------------------
/tests/tty.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "random.uh"
4 | import "string.uh"
5 | import "int.uh"
6 | import "array.uh"
7 | import "growarray.uh"
8 | import "char.uh"
9 | import "time.uh"
10 | import "io.uh"
11 | import "list.uh"
12 |
13 | fun looper () =
14 | if availc0 () > 0
15 | then print [got a key [int-tohexstringx 2 (ord (getc ()))]\n]
16 | else looper ()
17 | in
18 | looper ()
19 | end
20 |
--------------------------------------------------------------------------------
/tests/uncaught.uml:
--------------------------------------------------------------------------------
1 |
2 | raise Match
3 |
--------------------------------------------------------------------------------
/tests/when.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 | import "std.uh"
4 | import "list.uh"
5 | import "string.uh"
6 | import "io.uh"
7 |
8 | (* matcher for values within
9 | the range lo-hi, inclusive *)
10 | fun -- (lo, hi) x = if ord x >= ord lo andalso ord x <= ord hi then x
11 | else raise Match
12 |
13 | infix --
14 |
15 | fun test n =
16 | case n of
17 | ((?A -- ?Z) x) => chr (ord x - ord ?A + ord ?a)
18 | | ((?a -- ?z) y) => y
19 | | v => ?-
20 |
21 | do
22 | let in
23 | print ("*******************************************************\n");
24 | print ("This is a test of WHEN patterns in Humlock.\n" ^
25 | "To play, enter a string with capital and lowercase\n" ^
26 | "letters and press enter. The string will be made\n" ^
27 | "lowercase and any other characters will be rewritten\n" ^
28 | "to the dash character.\n");
29 | print ("*******************************************************\n")
30 | end
31 |
32 | val l = getline ()
33 | val l = explode l
34 | in
35 | print (implode ((list-map test) l))
36 | end
37 |
--------------------------------------------------------------------------------
/tests/when2.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "list.uh"
4 | import "string.uh"
5 | import "io.uh"
6 |
7 | fun prefix s x =
8 | if string-prefix (s, x)
9 | then substring' (x, length s)
10 | else raise Match
11 |
12 | fun take thing = print ("You got the " ^ thing ^ "\n")
13 |
14 | fun parse ((prefix "take ") s) = take s
15 | | parse ((prefix "get ") s) = take s
16 | | parse (other) = print ("I don't know how to " ^ other ^ "\n")
17 |
18 | do print "What do you want to do? "
19 | val l = getline ()
20 | in
21 | parse l
22 | end
--------------------------------------------------------------------------------
/tests/whenopt.uml:
--------------------------------------------------------------------------------
1 |
2 | let
3 |
4 | fun is x y = if x = y then () else raise Match
5 |
6 | in
7 | putc ( chr_
8 | (case getc_ () of
9 | ((is 555) _) => 666
10 | | _ => 777))
11 |
12 | end
--------------------------------------------------------------------------------
/tests/wrap.uml:
--------------------------------------------------------------------------------
1 | let
2 | import "std.uh"
3 | import "string.uh"
4 | in
5 |
6 | print (string-wordwrap 20 "Well, this is a piece of text that I would like to be word-wrapped. That means breaking it such that it fits across several lines in an aesthetic way, with no line exceeding the specified character length, unless it is impossible to fit a word because it is longer than the line length. An example of such a word would be QWERTYUIOPASDFGHJKLZXCVBNM, which means \"keyboard\". We aren't doing anything fancy about layout like with tex's dynamic programming algorithm or something like that. But at least we shouldn't screw up when the input contains newlines, like\nthese\nshould\nbe\non\nseparate\nlines.\nRight? And here's some text that comes after those words to see if word-wrap is messed up by their presence, but it won't be because this is an excellent implementation of word-wrap.\n")
7 |
8 | end
--------------------------------------------------------------------------------
/util/des-sig.sml:
--------------------------------------------------------------------------------
1 |
2 | (* DES, the Data Encryption Standard.
3 |
4 | (DES is considered weak because of its short key length.
5 | Triple-DES or "3DES" is a better choice.
6 |
7 | I wanted to support 3DES here, but it turns out that there
8 | are a number of different 3DES "standards," generally having
9 | to do with the feedback mode.) *)
10 |
11 | signature DES =
12 | sig
13 |
14 | type key
15 |
16 | (* this does a significant amount of initialization *)
17 | val key : Word32.word * Word32.word -> key
18 |
19 | (* a single block *)
20 | val encrypt :
21 | key ->
22 | Word32.word * Word32.word ->
23 | Word32.word * Word32.word
24 |
25 | val decrypt :
26 | key ->
27 | Word32.word * Word32.word ->
28 | Word32.word * Word32.word
29 |
30 | end
--------------------------------------------------------------------------------
/util/hmutil.sml:
--------------------------------------------------------------------------------
1 | structure HumlockUtil =
2 | struct
3 | infixr 9 `
4 | fun a ` b = a b
5 |
6 | val itos = Int.toString
7 |
8 | local val ctr = ref 0
9 | in
10 | fun newstring sep s =
11 | let in
12 | ctr := (!ctr + 1);
13 | itos ` !ctr ^ sep ^ s
14 | end
15 |
16 | val newstr = newstring "$"
17 | end
18 |
19 | (* any legal comparison that puts ints (encoded in ascii)
20 | in the correct order *)
21 | fun labelcompare (l1, l2) =
22 | (case (Int.fromString l1, Int.fromString l2) of
23 | (NONE, NONE) => String.compare (l1, l2)
24 | | (SOME _, NONE) => LESS
25 | | (NONE, SOME _) => GREATER
26 | | (SOME x, SOME y) =>
27 | (case Int.compare (x, y) of
28 | LESS => LESS
29 | | GREATER => GREATER
30 | | EQUAL => String.compare (l1, l2)))
31 |
32 | fun pathcompare (a, b) =
33 | Util.lex_order (Util.option_compare String.compare)
34 | String.compare (a, b)
35 |
36 | local
37 | (* DES gives a pretty good source of randomness *)
38 | val r = ref (0wxBEEFDEAD : Word32.word)
39 | val k = DES.key (0wxABCD1234, 0wxe707f312)
40 | in
41 | fun randomword () =
42 | let
43 | in
44 | r := !r * 0wx31337;
45 | r := (Word32.xorb (!r, 0wxFEED9876));
46 | r := #1 (DES.encrypt k (0wx00001111, !r));
47 | !r
48 | end
49 | end
50 | end
51 |
52 | structure ModuleMap =
53 | SplayMapFn(type ord_key = string option * string
54 | val compare = HumlockUtil.pathcompare)
55 | structure StringMap =
56 | SplayMapFn(type ord_key = string val compare = String.compare)
57 | structure StringMapUtil = MapUtil(structure M = StringMap)
58 | structure ModuleMapUtil = MapUtil(structure M = ModuleMap)
59 | structure IntMap = SplayMapFn(type ord_key = int val compare = Int.compare)
60 | structure IntMapUtil = MapUtil(structure M = IntMap)
61 |
62 |
--------------------------------------------------------------------------------
/util/stringonce.sml:
--------------------------------------------------------------------------------
1 |
2 | structure StringOnce :> STRINGONCE =
3 | struct
4 |
5 | structure SM =
6 | SplayMapFn(type ord_key = string val compare = String.compare)
7 |
8 |
9 | type stringarena =
10 | { sep : string,
11 | ctr : int ref,
12 | table : (int ref) SM.map ref }
13 |
14 | fun arena () = { sep = "", ctr = ref 0, table = ref SM.empty }
15 |
16 | fun arenaex sep = { sep = sep, ctr = ref 0, table = ref SM.empty }
17 |
18 | fun clear ({ ctr, table, ... } : stringarena) =
19 | let in
20 | table := SM.empty;
21 | ctr := 0
22 | end
23 |
24 | fun ++ x = (x := !x + 1; !x)
25 |
26 | val uniqid = ref 0
27 |
28 | (* XXX this is not optimal.
29 | the best behavior would be to delay the
30 | choice of who gets to be 's' (without
31 | digits) to the first one whose f is
32 | called. *)
33 |
34 | fun symbol { sep, ctr, table } s =
35 | let
36 | val s = (StringUtil.replace "`" "_b_" s)
37 | val s = (StringUtil.replace "|" "_o_" s)
38 | val s = (StringUtil.replace "&" "_a_" s)
39 | val s = (StringUtil.replace "<" "_l_" s)
40 | val s = (StringUtil.replace ">" "_g_" s)
41 | val s = (StringUtil.replace "$" "_d_" s)
42 | val s = (StringUtil.replace "@" "_t_" s)
43 | val s = (StringUtil.replace "%" "_e_" s)
44 | val s = (StringUtil.replace "'" "_q_" s)
45 | val s = (StringUtil.replace "+" "_p_" s)
46 | val s = (StringUtil.replace "*" "_s_" s)
47 | val s = (StringUtil.replace "-" "_m_" s)
48 | val s = (StringUtil.replace ":" "_c_" s)
49 | val s = (String.implode o (map Char.toLower) o String.explode) s
50 | val n = ( ++ uniqid ;
51 | Int.toString(!uniqid) )
52 | val s = if s = "mainentry" then s else "f" ^ n
53 | in
54 | (case SM.find (!table, s) of
55 | NONE =>
56 | let
57 | val ir = ref 0
58 | in
59 | (* first var with this name.
60 | it will always be called 's'
61 | *)
62 | table := SM.insert(!table, s, ir);
63 | (++ ctr,
64 | fn () => s)
65 | (*
66 | if !ir = 0
67 | then s
68 | else s ^ sep ^ "0") *)
69 | end
70 | | SOME ir =>
71 | let
72 | val me = ++ ir
73 | in
74 |
75 |
76 | (++ ctr,
77 | fn () =>
78 | Int.toString me ^ sep ^ s)
79 | end)
80 | end
81 | end
82 |
--------------------------------------------------------------------------------
/util/symboldb-sig.sml:
--------------------------------------------------------------------------------
1 |
2 | signature SYMBOLDB =
3 | sig
4 |
5 | val clear : unit -> unit
6 |
7 | (* push category n name *)
8 | val push : string -> int -> string -> unit
9 |
10 | (* write to a file *)
11 | val tofile : string -> unit
12 |
13 |
14 | end
15 |
--------------------------------------------------------------------------------
/util/symboldb.sml:
--------------------------------------------------------------------------------
1 |
2 | (* keep track of symbol -> name mappings,
3 | so that looking at debug dumps can be made
4 | more pleasant *)
5 | structure SymbolDB =
6 | struct
7 | (*
8 | structure SSMap =
9 | SplayMapFn(type ord_key = string * string
10 | fun compare ((a, b), (aa, bb)) =
11 | case String.compare (a, aa) of
12 | EQUAL => String.compare (b, bb)
13 | | c => c)
14 |
15 | val db = ref SSMap.empty : (int SSMap.map) ref
16 | *)
17 | structure SM = StringMap
18 | structure IM = IntMap
19 |
20 | val db = ref SM.empty : string IM.map ref SM.map ref
21 |
22 | fun clear () = db := SM.empty
23 |
24 | fun push cat n s =
25 | (case SM.find (!db, cat) of
26 | NONE => db := SM.insert (!db, cat,
27 | ref (IM.insert(IM.empty, n, s)))
28 | | SOME ib => ib := IM.insert(!ib, n, s))
29 |
30 | fun tofile f =
31 | let
32 | val ff = TextIO.openOut f
33 |
34 | val ims = SM.listItemsi (!db)
35 | val all = map (fn (cat, im) =>
36 | (cat, IM.listItemsi (!im))) ims
37 |
38 | fun oneitem (i, s) =
39 | TextIO.output(ff, " " ^ Int.toString i ^ " " ^ s ^ "\n")
40 | fun onecat (c, ism) =
41 | let in
42 | TextIO.output (ff, c ^ ":\n");
43 | app oneitem ism;
44 | TextIO.output (ff, "\n")
45 | end
46 |
47 | in
48 | app onecat all;
49 | TextIO.closeOut ff
50 | end
51 |
52 | end
53 |
--------------------------------------------------------------------------------
/util/variable-sig.sml:
--------------------------------------------------------------------------------
1 |
2 | signature VARIABLE =
3 | sig
4 | exception Variable of string
5 |
6 | type var
7 |
8 | val newvar : unit -> var
9 | val namedvar : string -> var
10 |
11 | (* fails on special vars *)
12 | val alphavary : var -> var
13 |
14 | (* Some variables are really external references. They have to
15 | be printed with a specific name that is agreed upon with
16 | the runtime. They may also be qualified by a module name.
17 |
18 | this distinction probably deserves to be made explicit
19 | in the types, but isn't currently. *)
20 | val special : string option -> string -> var
21 |
22 | (* a special var *)
23 | val getspecial : var -> (string option * string) option
24 |
25 | val eq : var * var -> bool
26 | val compare : var * var -> order
27 |
28 | val basename : var -> string
29 |
30 | (* fails on special vars *)
31 | val tostring : var -> string
32 |
33 | (* works for any var, just for printing *)
34 | val show : var -> string
35 |
36 | structure Map : ORD_MAP where type Key.ord_key = var
37 | end
38 |
--------------------------------------------------------------------------------
/util/variable.sml:
--------------------------------------------------------------------------------
1 |
2 | structure Variable :> VARIABLE =
3 | struct
4 |
5 | exception Variable of string
6 |
7 | datatype var =
8 | Special of string option * string
9 | | Regular of int * string * (unit -> string)
10 |
11 | val arena = StringOnce.arenaex "_"
12 |
13 | fun namedvar s =
14 | let val (i, f) = StringOnce.symbol arena s
15 | in Regular(i, s, f)
16 | end
17 |
18 | fun special so s =
19 | let in
20 | (* if unqualified,
21 | prevent others from printing with this
22 | name by incrementing its reference count *)
23 | if isSome so
24 | then ()
25 | else ignore (StringOnce.symbol arena s);
26 |
27 | Special(so, s)
28 | end
29 |
30 | fun getspecial (Special(so, s)) = SOME (so, s)
31 | | getspecial _ = NONE
32 |
33 | fun newvar () = namedvar "vv"
34 |
35 | fun basename (Regular(_, s, _)) = s
36 | | basename (Special(_, s)) = s
37 |
38 | fun alphavary (v as Regular _) = namedvar (basename v)
39 | | alphavary _ = raise Variable "can't alphavary special"
40 |
41 | fun eq (Regular(n1, _, _), Regular(n2, _, _)) = n1 = n2
42 | | eq (Special _, Regular _) = false
43 | | eq (Regular _, Special _) = false
44 | | eq (Special (so, s), Special (sso, ss)) = so = sso andalso s = ss
45 |
46 | fun compare (Regular(n1, _, _), Regular(n2, _, _)) = Int.compare (n1, n2)
47 | | compare (Regular _, Special _) = LESS
48 | | compare (Special _, Regular _) = GREATER
49 | | compare (Special (so, s), Special (sso, ss)) =
50 | HumlockUtil.pathcompare ((so, s), (sso, ss))
51 |
52 | fun tostring (Regular(_, _, f)) = f ()
53 | | tostring (Special _) = raise Variable "can't tostring special"
54 |
55 | fun show (Regular(_, _, f)) = f()
56 | | show (Special (NONE, s)) = "." ^ s
57 | | show (Special (SOME modu, s)) = modu ^ "." ^ s
58 |
59 | structure Map = SplayMapFn (struct
60 | type ord_key = var
61 | val compare = compare
62 | end)
63 | end
64 |
--------------------------------------------------------------------------------