Commit | Line | Data |
---|---|---|
59038a10 C |
1 | require types.fs |
2 | require printer.fs | |
3 | ||
4 | \ Drop a char off the front of string by advancing the addr and | |
5 | \ decrementing the length, and fetch next char | |
6 | : adv-str ( str-addr str-len -- str-addr str-len char ) | |
7 | swap 1+ swap 1- | |
8 | dup 0= if 0 ( eof ) | |
9 | else over c@ endif ; | |
10 | ||
59038a10 C |
11 | : mal-digit? ( char -- flag ) |
12 | dup [char] 9 <= if | |
13 | [char] 0 >= | |
14 | else | |
15 | drop 0 | |
16 | endif ; | |
17 | ||
18 | : char-in-str? ( char str-addr str-len ) | |
19 | rot { needle } | |
bf6a574e C |
20 | false -rot |
21 | over + swap ?do | |
22 | i c@ needle = if drop true leave endif | |
23 | loop ; | |
24 | ||
25 | : sym-char? ( char -- flag ) | |
26 | s\" \n\r\t\000[]{}()'\"`,; " char-in-str? 0= ; | |
27 | ||
28 | : skip-spaces ( str-addr str-len char -- str-addr str-len non-space-char ) | |
29 | begin | |
30 | begin | |
31 | dup s\" \n\r\t, " char-in-str? | |
32 | while ( str-addr str-len space-char ) | |
33 | drop adv-str | |
34 | repeat | |
35 | dup [char] ; = if | |
36 | drop | |
37 | begin | |
38 | adv-str s\" \n\r\000" char-in-str? | |
39 | until | |
40 | adv-str false | |
59038a10 | 41 | else |
bf6a574e | 42 | true |
59038a10 C |
43 | endif |
44 | until ; | |
45 | ||
59038a10 C |
46 | defer read-form ( str-addr str-len -- str-addr str-len mal-obj ) |
47 | ||
48 | : read-int ( str-addr str-len digit-char -- str-addr str-len non-digit-char mal-int ) | |
49 | 0 { int } | |
50 | begin ( str-addr str-len digit-char ) | |
51 | [char] 0 - int 10 * + to int ( str-addr str-len ) | |
52 | adv-str dup mal-digit? 0= ( str-addr str-len digit-char ) | |
53 | until | |
54 | int MalInt. ; | |
55 | ||
168fb5dc | 56 | : read-symbol-str ( str-addr str-len sym-char -- str-addr str-len char sym-addr sym-len ) |
59038a10 | 57 | new-str { sym-addr sym-len } |
168fb5dc | 58 | begin ( str-addr str-len sym-char ) |
59038a10 C |
59 | sym-addr sym-len rot str-append-char to sym-len to sym-addr |
60 | adv-str dup sym-char? 0= | |
61 | until | |
62 | sym-addr sym-len ; | |
63 | ||
168fb5dc C |
64 | : read-string-literal ( in-addr in-len quote-char -- in-addr in-len mal-string ) |
65 | new-str { out-addr out-len } | |
66 | drop \ drop leading quote | |
67 | begin ( in-addr in-len ) | |
68 | adv-str over 0= if | |
580c4eef | 69 | 2drop 0 0 s\" expected '\"', got EOF" ...throw-str |
168fb5dc C |
70 | endif |
71 | dup [char] " <> | |
72 | while | |
73 | dup [char] \ = if | |
74 | drop adv-str | |
75 | dup [char] n = if drop 10 endif | |
76 | dup [char] r = if drop 13 endif | |
77 | endif | |
78 | out-addr out-len rot str-append-char to out-len to out-addr | |
79 | repeat | |
80 | drop adv-str \ skip trailing quote | |
81 | out-addr out-len MalString. ; | |
82 | ||
9da223a3 | 83 | : read-list ( str-addr str-len open-paren-char close-paren-char |
c05d35e8 | 84 | -- str-addr str-len non-paren-char mal-list ) |
9da223a3 C |
85 | here { close-char old-here } |
86 | drop adv-str | |
87 | begin ( str-addr str-len char ) | |
88 | skip-spaces ( str-addr str-len non-space-char ) | |
89 | over 0= if | |
580c4eef C |
90 | drop 2drop 0 0 s" ', got EOF" |
91 | close-char pad ! pad 1 | |
92 | s" expected '" ...throw-str | |
9da223a3 C |
93 | endif |
94 | dup close-char <> | |
95 | while ( str-addr str-len non-space-non-paren-char ) | |
96 | read-form , | |
97 | repeat | |
98 | drop adv-str | |
bf6a574e | 99 | old-here here>MalList ; |
59038a10 | 100 | |
794bfca1 C |
101 | s" deref" MalSymbol. constant deref-sym |
102 | s" quote" MalSymbol. constant quote-sym | |
103 | s" quasiquote" MalSymbol. constant quasiquote-sym | |
104 | s" splice-unquote" MalSymbol. constant splice-unquote-sym | |
105 | s" unquote" MalSymbol. constant unquote-sym | |
106 | ||
168fb5dc | 107 | : read-wrapped ( buf-addr buf-len quote-char sym-addr sym-len -- buf-addr buf-len char mal-list ) |
69972a83 | 108 | here { old-here } |
794bfca1 | 109 | , ( buf-addr buf-len char ) |
69972a83 | 110 | read-form , ( buf-addr buf-len char ) |
c05d35e8 | 111 | old-here here>MalList ; |
168fb5dc C |
112 | |
113 | : read-form2 ( str-addr str-len char -- str-addr str-len char mal-obj ) | |
bf6a574e C |
114 | skip-spaces |
115 | dup mal-digit? if read-int else | |
116 | dup [char] ( = if [char] ) read-list else | |
117 | dup [char] [ = if [char] ] read-list MalVector new tuck MalVector/list ! else | |
118 | dup [char] { = if [char] } read-list MalMap new tuck MalMap/list ! else | |
119 | dup [char] " = if read-string-literal else | |
120 | dup [char] : = if drop adv-str read-symbol-str MalKeyword. else | |
794bfca1 C |
121 | dup [char] @ = if drop adv-str deref-sym read-wrapped else |
122 | dup [char] ' = if drop adv-str quote-sym read-wrapped else | |
123 | dup [char] ` = if drop adv-str quasiquote-sym read-wrapped else | |
bf6a574e C |
124 | dup [char] ~ = if |
125 | drop adv-str | |
794bfca1 C |
126 | dup [char] @ = if drop adv-str splice-unquote-sym read-wrapped |
127 | else unquote-sym read-wrapped | |
bf6a574e C |
128 | endif |
129 | else | |
130 | dup [char] ^ = if | |
131 | drop adv-str | |
132 | read-form { meta } read-form { obj } | |
133 | meta mal-nil conj | |
134 | obj swap conj | |
135 | s" with-meta" MalSymbol. swap conj | |
136 | else | |
137 | read-symbol-str | |
138 | 2dup s" true" str= if 2drop mal-true | |
139 | else 2dup s" false" str= if 2drop mal-false | |
140 | else 2dup s" nil" str= if 2drop mal-nil | |
168fb5dc | 141 | else |
bf6a574e C |
142 | MalSymbol. |
143 | endif endif endif endif endif endif endif endif endif endif endif endif endif endif ; | |
59038a10 C |
144 | ' read-form2 is read-form |
145 | ||
146 | : read-str ( str-addr str-len - mal-obj ) | |
168fb5dc | 147 | over c@ read-form { obj } drop 2drop obj ; |