1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
|
#include "share/atspre_staload.hats"
staload "kernel/writer.sats"
%{^
#define get_buffer() ((void *) 0xB8000)
%}
extern fun get_buffer():<> buffer = "mac#"
extern prfun eat_buffer (pf: buffer): void
staload WRITER = {
staload "kernel/writer.sats"
extern fun getref (): [l:addr] vtakeoutptr (writer)
fun color_value(c : color): uint8 =
case+ c of
| Black() => i2u8 0
| Blue() => i2u8 1
| Green() => i2u8 2
| Cyan() => i2u8 3
| Red() => i2u8 4
| Magenta() => i2u8 5
| Brown() => i2u8 6
| LightGray() => i2u8 7
| DarkGray() => i2u8 8
| LightBlue() => i2u8 9
| LightGreen() => i2u8 10
| LightCyan() => i2u8 11
| LightRed() => i2u8 12
| Pink() => i2u8 13
| Yellow() => i2u8 14
| White() => i2u8 15
fun code_value(foreground: color, background:color): uint8 =
(color_value(background) << 4) lor color_value(foreground)
local
var _val: writer = @{position = 0, color_code = code_value(White,Black)} : writer
val p_val = addr@(_val)
in
implement getref () = let
extern praxi __assert{l:addr} (ptr: ptr (l)): vtakeout0 (writer@l)
prval (pf, fpf) = __assert (p_val)
in
(pf, fpf | p_val)
end
end
}
fun put_char (c : char, writer: &writer) : void = let
val buf = get_buffer()
val pos = writer.position
in
if (c = '\n') then
let
val new_pos = (pos / BUFFER_WIDTH + 1) * BUFFER_WIDTH
in
if (new_pos < N) then
writer.position := new_pos
else
clear_screen()
end
else (
buf.1->[writer.position] := @{ ascii_character = c, color_code = writer.color_code};
if (pos < N - 1) then
writer.position := succ(pos)
else
clear_screen());
let prval() = eat_buffer buf in () end
end
implement put_string (str : string) : void = let
val (pf, fpf | p_val) = $WRITER.getref()
implement string_foreach$fwork<writer> (c,env) = put_char(c,env)
val _ = string_foreach_env<writer> (g1ofg0(str),!p_val)
prval() = fpf(pf)
in end
implement clear_screen() : void = let
val (pf, fpf | p_val) = $WRITER.getref()
fun loop {n : nat | n < N - 1} .<N-n>. (i : int n, wr : &writer) : void =
(put_char('\0', wr); if (i < N - 2) then loop(i+1,wr))
in
!p_val.position := 0;
loop(0,!p_val);
!p_val.position := 0;
let prval() = fpf(pf) in () end
end
|
