blob: 7ff46fd83488d13e473bdf6d86cf0a91c427ff3e (
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
|
require types.fs
require printer.fs
-2 constant skip-elem
\ Drop a char off the front of string by advancing the addr and
\ decrementing the length, and fetch next char
: adv-str ( str-addr str-len -- str-addr str-len char )
swap 1+ swap 1-
dup 0= if 0 ( eof )
else over c@ endif ;
: skip-spaces ( str-addr str-len char -- str-addr str-len non-space-char )
begin
dup bl = if
-1
else
dup [char] , =
endif
while ( str-addr str-len space-char )
drop adv-str
repeat ;
: mal-digit? ( char -- flag )
dup [char] 9 <= if
[char] 0 >=
else
drop 0
endif ;
: char-in-str? ( char str-addr str-len )
rot { needle }
begin ( str-addr str-len )
adv-str needle = if
2drop -1 -1 \ success! drop and exit
else
dup 0= if
2drop 0 -1 \ str consumed, char not found.
else
0 \ continue
endif
endif
until ;
s\" []{}()'\"`,; " constant non-sym-chars-len constant non-sym-chars
: sym-char? ( char -- flag )
non-sym-chars non-sym-chars-len char-in-str? 0= ;
defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
: read-int ( str-addr str-len digit-char -- str-addr str-len non-digit-char mal-int )
0 { int }
begin ( str-addr str-len digit-char )
[char] 0 - int 10 * + to int ( str-addr str-len )
adv-str dup mal-digit? 0= ( str-addr str-len digit-char )
until
int MalInt. ;
: read-comment ( str-addr str-len sym-char -- str-addr str-len char skim-elem )
drop
begin
adv-str = 10
until
adv-str skip-elem ;
: read-symbol-str ( str-addr str-len sym-char -- str-addr str-len char sym-addr sym-len )
new-str { sym-addr sym-len }
begin ( str-addr str-len sym-char )
sym-addr sym-len rot str-append-char to sym-len to sym-addr
adv-str dup sym-char? 0=
until
sym-addr sym-len ;
: read-string-literal ( in-addr in-len quote-char -- in-addr in-len mal-string )
new-str { out-addr out-len }
drop \ drop leading quote
begin ( in-addr in-len )
adv-str over 0= if
2drop s\" expected '\"', got EOF\n" safe-type 1 throw
endif
dup [char] " <>
while
dup [char] \ = if
drop adv-str
dup [char] n = if drop 10 endif
dup [char] r = if drop 13 endif
endif
out-addr out-len rot str-append-char to out-len to out-addr
repeat
drop adv-str \ skip trailing quote
out-addr out-len MalString. ;
: read-list ( str-addr str-len open-paren-char -- str-addr str-len non-paren-char mal-list )
\ push objects onto "dictionary" -- maybe not the best stack for this?
0 { close-char len }
drop adv-str
begin ( str-addr str-len char )
skip-spaces ( str-addr str-len non-space-char )
over 0= if
drop 2drop
s\" expected '" close-char str-append-char
s\" ', got EOF" str-append safe-type 1 throw
endif
dup close-char <>
while ( str-addr str-len non-space-non-paren-char )
read-form , len 1+ to len
repeat
drop adv-str
\ pop objects out of "dictionary" into MalList
mal-nil
len 0 ?do
0 cell - allot
here @ swap conj
loop
;
: read-wrapped ( buf-addr buf-len quote-char sym-addr sym-len -- buf-addr buf-len char mal-list )
MalSymbol. { sym } ( buf-addr buf-len char )
read-form mal-nil conj ( buf-addr buf-len char mal-list )
sym swap conj ;
: read-form2 ( str-addr str-len char -- str-addr str-len char mal-obj )
begin
skip-spaces
dup mal-digit? if read-int else
dup [char] ( = if [char] ) read-list else
dup [char] [ = if [char] ] read-list MalVector new tuck MalVector/list ! else
dup [char] { = if [char] } read-list MalMap new tuck MalMap/list ! else
dup [char] " = if read-string-literal else
dup [char] ; = if read-comment else
dup [char] @ = if drop adv-str s" deref" read-wrapped else
dup [char] ' = if drop adv-str s" quote" read-wrapped else
dup [char] ` = if drop adv-str s" quasiquote" read-wrapped else
dup [char] ~ = if
drop adv-str
dup [char] @ = if drop adv-str s" splice-unquote" read-wrapped
else s" unquote" read-wrapped
endif
else
dup [char] ^ = if
drop adv-str
read-form { meta } read-form { obj }
meta mal-nil conj
obj swap conj
s" with-meta" MalSymbol. swap conj
else
read-symbol-str MalSymbol.
endif endif endif endif endif endif endif endif endif endif endif
dup skip-elem =
while drop repeat ;
' read-form2 is read-form
: read-str ( str-addr str-len - mal-obj )
over c@ read-form { obj } drop 2drop obj ;
|
