blob: 533e92f98a565056008b26d7c5882d8bbc98b904 (
plain)
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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
|
#include "stdlib.lisp"
; string -> string
(define string-escape (str)
(let ((hexdigit (lambda (n) (substr n 1 "0123456789abcdef")))
(go (lambdarec rec (str yet)
(if (= str "") yet
(let ((ch (substr 0 1 str))
(n (ord ch))
(out (cond
(= ch "\n") "\\n"
(= ch "\r") "\\r"
(= ch "\t") "\\t"
(= ch "\0") "\\0"
(= ch "\"") "\\\""
(= ch "\\") "\\\\"
(< n 32) (concat "\\x" (concat (hexdigit (/ n 16)) (hexdigit (mod n 16))))
ch)))
(rec (substr 1 -1 str) (concat yet out)))))))
(go str "")))
; tag string -> string
(define ansi-color (clr str)
(let ((style (cond
(= clr 'red) "31"
(= clr 'yellow) "33"
(= clr 'blue) "34;1"
(error "Unknown color in ansi-color" clr))))
(concat (concat "\x1B[" (concat style "m")) (concat str "\x1B[0m"))))
; char string -> bool
(define str-elem (ch str)
(if (= str "") 0
(if (= ch (substr 0 1 str)) 1
(str-elem ch (substr 1 -1 str)))))
; char -> bool
(define isspace? (ch)
(str-elem ch " \n\t\r"))
; char -> bool
(define isdigit? (ch)
(let ((n (ord ch))) (and (<= 48 n) (<= n 57))))
; char -> bool
(define lowercase? (ch)
(let ((n (ord ch))) (and (<= 97 n) (<= n 122))))
; char -> bool
(define uppercase? (ch)
(let ((n (ord ch))) (and (<= 65 n) (<= n 90))))
; char -> bool
(define iswordchar? (ch)
(or (str-elem ch "-_?+/*")
(or (lowercase? ch) (uppercase? ch))))
; char -> bool
(define isrestwordchar? (ch)
(or (iswordchar? ch) (isdigit? ch)))
; string -> int (does not perform any checking)
(define parse-int (str)
(let ((helper (lambdarec rec (str n)
(let ((ch (substr 0 1 str))
(rest (substr 1 -1 str)))
(if (isdigit? ch)
(rec rest (+ (* 10 n) (- (ord ch) 48)))
n)))))
(helper str 0)))
; char -> int
(define parse-hex-digit (ch)
(let ((n (ord ch)))
(cond
(and (<= 48 n) (<= n 57))
(- n 48)
(and (<= 97 n) (<= n 102))
(- n 87)
(and (<= 65 n) (<= n 70))
(- n 55)
(error "Invalid hex escape digit " ch))))
; string -> (string[parsed escape] string[rest])
(define parse-string-escape (str)
(let ((ch (substr 0 1 str)))
(cond
(= ch "n")
(list "\n" (substr 1 -1 str))
(= ch "r")
(list "\r" (substr 1 -1 str))
(= ch "t")
(list "\t" (substr 1 -1 str))
(= ch "0")
(list "\0" (substr 1 -1 str))
(= ch "\"")
(list "\"" (substr 1 -1 str))
(= ch "\\")
(list "\\" (substr 1 -1 str))
(= ch "x")
(let ((h1 (parse-hex-digit (substr 1 1 str)))
(h2 (parse-hex-digit (substr 2 1 str))))
(list (chr (16 * h1 + h2)) (substr 3 -1 str)))
(error "Invalid string escape character " ch))))
; string[input] string[string to prepend to result] -> string[parsed till bare "]
(define parse-string-contents (str yet)
(let ((ch (substr 0 1 str))
(rest (substr 1 -1 str)))
(cond
(= ch "")
(error "Non-terminated string in source")
(= ch "\"")
yet
(= ch "\\")
(let ((pair (parse-string-escape rest)))
(parse-string-contents (cadr pair) (concat yet (car pair))))
(parse-string-contents rest (concat yet ch)))))
; deftype token = ('tag <field>), where the type of <field> depends on the tag
; string -> (token string[rest])
(define next-token (str)
(let ((ch (substr 0 1 str))
(rest (substr 1 -1 str)))
(cond
(= ch "")
'()
(isspace? ch)
(next-token rest)
(= ch ";")
(next-token (drop-while (lambda (c) (not (= c "\n"))) rest))
(= ch "(")
(list (list 'open '()) rest)
(= ch ")")
(list (list 'close '()) rest)
(= ch "\"")
(let ((text (parse-string-contents rest "")))
(list (list 'string text) (substr (+ (length text) 1) -1 rest)))
(or (iswordchar? ch) (isdigit? ch))
(let ((restword (take-while isrestwordchar? rest))
(rest2 (substr (length restword) -1 rest)))
(if (and (all isdigit? restword)
(or (isdigit? ch) (and (= ch "-") (> (length restword) 0))))
(list (list 'number (parse-int (concat ch restword))) rest2)
(list (list 'name (concat ch restword)) rest2)))
(error "Invalid token" ch))))
; token -> string
(define pretty-token (token)
(let ((tag (car token))
(field (cadr token)))
(cond
(= tag 'open)
(ansi-color 'red "(")
(= tag 'close)
(ansi-color 'red ")")
(= tag 'string)
(ansi-color 'yellow (concat "\"" (concat (string-escape field) "\"")))
(= tag 'number)
(ansi-color 'blue (number->string field))
(= tag 'name)
field
(error "Invalid token tag in pretty-token" tag))))
(define go (lambdarec rec (str)
(let ((pair (next-token str)))
(if (null? pair)
'()
(let ((token (car pair))
(rest (cadr pair)))
(do
(sys-put-string stdout (pretty-token token))
(sys-put-string stdout " ")
(rec rest)))))))
(go (read-file "tests/f.lisp"))
(print)
|
