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 )
11 : mal
-digit
? ( char -- flag
)
18 : char-in-str
? ( char str
-addr str
-len
)
22 i c
@ needle
= if drop
true leave endif
25 : sym
-char? ( char -- flag
)
26 s
\" \n\r\t\000[]{}()'\"`,; " char-in-str? 0= ;
28 : skip-spaces ( str-addr str-len char -- str-addr str-len non-space-char )
31 dup s\" \n\r\t, " char-in-str?
32 while ( str-addr str-len space-char )
38 adv-str s\" \n\r\000" char-in-str?
46 defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
48 : read-int ( str-addr str-len digit-char -- str-addr str-len non-digit-char mal-int )
51 dup [char] - = if drop adv-str 1 to neg endif
52 begin ( str-addr str-len digit-char )
53 [char] 0 - int 10 * + to int ( str-addr str-len )
54 adv-str dup mal-digit? 0= ( str-addr str-len digit-char )
56 neg if 0 int - to int endif
59 : read-symbol-str ( str-addr str-len sym-char -- str-addr str-len char sym-addr sym-len )
60 new-str { sym-addr sym-len }
61 begin ( str-addr str-len sym-char )
62 sym-addr sym-len rot str-append-char to sym-len to sym-addr
63 adv-str dup sym-char? 0=
67 : read-string-literal ( in-addr in-len quote-char -- in-addr in-len mal-string )
68 new-str { out-addr out-len }
69 drop \ drop leading quote
70 begin ( in-addr in-len )
72 2drop 0 0 s\" expected '\"', got EOF" ...throw-str
78 dup [char] n = if drop 10 endif
79 dup [char] r = if drop 13 endif
81 out-addr out-len rot str-append-char to out-len to out-addr
83 drop adv-str \ skip trailing quote
84 out-addr out-len MalString. ;
86 : read-list ( str-addr str-len open-paren-char close-paren-char
87 -- str-addr str-len non-paren-char mal-list )
88 here { close-char old-here }
90 begin ( str-addr str-len char )
91 skip-spaces ( str-addr str-len non-space-char )
93 drop 2drop 0 0 s" ', got
EOF"
94 close-char pad ! pad 1
95 s" expected
'" ...throw-str
98 while ( str-addr str-len non-space-non-paren-char )
102 old-here here>MalList ;
104 s" deref" MalSymbol. constant deref-sym
105 s" quote" MalSymbol. constant quote-sym
106 s" quasiquote" MalSymbol. constant quasiquote-sym
107 s" splice-unquote" MalSymbol. constant splice-unquote-sym
108 s" unquote" MalSymbol. constant unquote-sym
110 : read-wrapped ( buf-addr buf-len quote-char sym-addr sym-len -- buf-addr buf-len char mal-list )
112 , ( buf-addr buf-len char )
113 read-form , ( buf-addr buf-len char )
114 old-here here>MalList ;
116 : read-form2 ( str-addr str-len char -- str-addr str-len char mal-obj )
118 dup [char] - = 3 pick 1 + c@ mal-digit? and if read-int else
119 dup mal-digit? if read-int else
120 dup [char] ( = if [char] ) read-list else
121 dup [char] [ = if [char] ] read-list MalVector new tuck MalVector/list ! else
122 dup [char] { = if [char] } read-list MalMap new tuck MalMap/list ! else
123 dup [char] " = if read-string-literal else
124 dup [char] : = if drop adv-str read-symbol-str MalKeyword. else
125 dup [char] @ = if drop adv-str deref-sym read-wrapped else
126 dup [char] ' = if drop adv
-str quote-sym read
-wrapped
else
127 dup
[char] `
= if drop adv
-str quasiquote-sym read
-wrapped
else
130 dup
[char] @ = if drop adv
-str splice-unquote-sym read
-wrapped
131 else unquote-sym read
-wrapped
136 read
-form
{ meta
} read
-form
{ obj
}
139 s
" with-meta" MalSymbol. swap
conj
142 2dup s
" true" str= if 2drop mal
-true
143 else 2dup s
" false" str= if 2drop mal
-false
144 else 2dup s
" nil" str= if 2drop mal
-nil
147 endif endif endif endif endif endif endif endif endif endif endif endif endif endif endif ;
148 ' read-form2 is read-form
150 : read-str ( str-addr str-len - mal-obj )
151 over c@ read-form { obj } drop 2drop obj ;