Commit | Line | Data |
---|---|---|
59038a10 C |
1 | require types.fs |
2 | ||
3 | : safe-type ( str-addr str-len -- ) | |
4 | dup 256 > if | |
9da223a3 | 5 | drop 256 type ." ...<lots more>" |
59038a10 C |
6 | else |
7 | type | |
8 | endif ; | |
9 | ||
10 | \ === mutable string buffer === / | |
11 | \ string buffer that maintains an allocation larger than the current | |
12 | \ string size. When appending would cause the string size exceed the | |
13 | \ current allocation, resize is used to double the allocation. The | |
14 | \ current allocation is not stored anywhere, but computed based on | |
15 | \ current string size or str-base-size, whichever is larger. | |
16 | 64 constant str-base-size | |
17 | ||
18 | : new-str ( -- addr length ) | |
19 | str-base-size allocate throw 0 ; | |
20 | ||
21 | : round-up ( n -- n ) | |
22 | 2 | |
23 | begin | |
24 | 1 lshift 2dup < | |
25 | until | |
50e417ff | 26 | nip ; |
59038a10 C |
27 | |
28 | : str-append { buf-addr buf-str-len str-addr str-len } | |
29 | buf-str-len str-len + | |
30 | { new-len } | |
31 | new-len str-base-size > if | |
32 | buf-str-len new-len xor buf-str-len > if | |
33 | buf-addr new-len round-up resize throw | |
34 | to buf-addr | |
35 | endif | |
36 | endif | |
37 | str-addr buf-addr buf-str-len + str-len cmove | |
38 | buf-addr new-len ; | |
39 | ||
40 | \ define a-space, to append a space char to a string | |
41 | bl c, | |
42 | here constant space-str | |
43 | : a-space space-str 1 str-append ; | |
44 | ||
45 | : str-append-char ( buf-addr buf-str-len char -- buf-addr buf-str-len ) | |
50e417ff | 46 | pad ! pad 1 str-append ; |
59038a10 C |
47 | |
48 | : int>str ( num -- str-addr str-len ) | |
49 | s>d <# #s #> ; | |
50 | ||
51 | ||
52 | \ === printer protocol and implementations === / | |
53 | ||
54 | def-protocol-method pr-buf ( str-addr str-len this -- str-addr str-len ) | |
9da223a3 C |
55 | def-protocol-method pr-seq-buf ( str-addr str-len this -- str-addr str-len ) |
56 | def-protocol-method pr-pairs-buf ( str-addr str-len this -- str-addr str-len ) | |
59038a10 C |
57 | |
58 | : pr-str { obj } | |
59 | new-str obj pr-buf ; | |
60 | ||
61 | \ Examples of extending existing protocol methods to existing type | |
62 | MalDefault | |
63 | extend pr-buf | |
64 | { this } | |
65 | s" #<MalObject" str-append a-space | |
66 | this int>str str-append | |
67 | s" >" str-append ;; | |
68 | drop | |
69 | ||
60801ed6 C |
70 | MalNil extend pr-buf drop s" nil" str-append ;; drop |
71 | MalTrue extend pr-buf drop s" true" str-append ;; drop | |
72 | MalFalse extend pr-buf drop s" false" str-append ;; drop | |
59038a10 | 73 | |
9da223a3 C |
74 | MalList |
75 | extend pr-buf | |
76 | -rot s" (" str-append ( list str-addr str-len ) | |
77 | rot pr-seq-buf | |
78 | s" )" str-append ;; | |
c05d35e8 | 79 | extend pr-seq-buf { list } |
60801ed6 C |
80 | list MalList/count @ 0 > if |
81 | list MalList/start @ { start } | |
82 | start @ pr-buf | |
83 | list MalList/count @ 1 ?do | |
84 | a-space | |
85 | start i cells + @ pr-buf | |
86 | loop | |
87 | endif ;; | |
c05d35e8 C |
88 | extend pr-pairs-buf { list } |
89 | list MalList/start @ { start } | |
9da223a3 | 90 | start @ pr-buf a-space start cell+ @ pr-buf |
c05d35e8 | 91 | list MalList/count @ 2 / 1 ?do |
9da223a3 C |
92 | s" , " str-append |
93 | a-space | |
94 | start i 2 * cells + @ pr-buf a-space | |
95 | start i 2 * 1+ cells + @ pr-buf | |
96 | loop ;; | |
168fb5dc C |
97 | drop |
98 | ||
99 | MalVector | |
100 | extend pr-buf | |
101 | MalVector/list @ | |
102 | -rot s" [" str-append ( list str-addr str-len ) | |
9da223a3 | 103 | rot pr-seq-buf |
168fb5dc | 104 | s" ]" str-append ;; |
59038a10 C |
105 | drop |
106 | ||
2e78e94e C |
107 | MalMap |
108 | extend pr-buf | |
109 | MalMap/list @ | |
110 | -rot s" {" str-append ( list str-addr str-len ) | |
9da223a3 | 111 | rot pr-pairs-buf |
2e78e94e C |
112 | s" }" str-append ;; |
113 | drop | |
114 | ||
59038a10 C |
115 | MalInt |
116 | extend pr-buf | |
117 | MalInt/int @ int>str str-append ;; | |
118 | drop | |
119 | ||
9da223a3 C |
120 | MalFn |
121 | extend pr-buf | |
122 | drop s" #<fn>" str-append ;; | |
123 | drop | |
124 | ||
69972a83 C |
125 | SpecialOp |
126 | extend pr-buf | |
127 | drop s" #<op>" str-append ;; | |
128 | drop | |
129 | ||
59038a10 C |
130 | MalSymbol |
131 | extend pr-buf | |
9da223a3 C |
132 | unpack-sym str-append ;; |
133 | drop | |
134 | ||
135 | MalKeyword | |
136 | extend pr-buf { kw } | |
137 | s" :" str-append | |
138 | kw unpack-keyword str-append ;; | |
59038a10 | 139 | drop |
50e417ff C |
140 | |
141 | : insert-\ ( str-addr str-len insert-idx -- str-addr str-len ) | |
142 | -rot 0 str-append-char { addr len } | |
143 | dup dup addr + dup 1+ ( i i from to ) | |
144 | rot len swap - cmove> ( i ) \ shift " etc to the right | |
145 | addr + [char] \ swap c! \ escape it! | |
146 | addr len | |
147 | ; | |
148 | ||
149 | MalString | |
150 | extend pr-buf | |
151 | dup MalString/str-addr @ | |
152 | swap MalString/str-len @ | |
153 | { addr len } | |
154 | ||
155 | s\" \"" str-append | |
156 | 0 ( i ) | |
157 | begin | |
168fb5dc C |
158 | dup len < |
159 | while | |
50e417ff C |
160 | dup addr + c@ ( i char ) |
161 | dup [char] " = over [char] \ = or if ( i char ) | |
162 | drop dup addr len rot insert-\ to len to addr | |
163 | 1+ | |
164 | else | |
168fb5dc C |
165 | dup 10 = if ( i ) \ newline? |
166 | drop dup addr len rot insert-\ to len to addr | |
50e417ff C |
167 | dup addr + 1+ [char] n swap c! |
168 | 1+ | |
168fb5dc C |
169 | else |
170 | 13 = if ( i ) \ return? | |
171 | dup addr len rot insert-\ to len to addr | |
172 | dup addr + 1+ [char] r swap c! | |
173 | 1+ | |
174 | endif | |
50e417ff C |
175 | endif |
176 | endif | |
177 | 1+ | |
168fb5dc | 178 | repeat |
50e417ff C |
179 | drop addr len str-append |
180 | s\" \"" str-append ;; | |
181 | drop |