Commit | Line | Data |
---|---|---|
59038a10 C |
1 | require types.fs |
2 | ||
3 | : safe-type ( str-addr str-len -- ) | |
4 | dup 256 > if | |
5 | drop 256 type ." ...<lots more>" type | |
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 ) | |
55 | ||
56 | : pr-str { obj } | |
57 | new-str obj pr-buf ; | |
58 | ||
59 | \ Examples of extending existing protocol methods to existing type | |
60 | MalDefault | |
61 | extend pr-buf | |
62 | { this } | |
63 | s" #<MalObject" str-append a-space | |
64 | this int>str str-append | |
65 | s" >" str-append ;; | |
66 | drop | |
67 | ||
68 | MalNil | |
69 | extend pr-buf | |
70 | drop s" nil" str-append ;; | |
71 | drop | |
72 | ||
2e78e94e C |
73 | : pr-buf-list-item ( list str-addr str-len -- list str-addr str-len) |
74 | rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf ; | |
75 | ||
168fb5dc | 76 | : pr-buf-list ( list str-addr str-len -- str-addr str-len) |
2e78e94e | 77 | pr-buf-list-item |
59038a10 C |
78 | begin ( list str-addr str-len ) |
79 | 2 pick mal-nil <> | |
80 | while | |
2e78e94e | 81 | a-space pr-buf-list-item |
59038a10 | 82 | repeat |
168fb5dc C |
83 | rot drop ; |
84 | ||
168fb5dc C |
85 | MalList |
86 | extend pr-buf | |
87 | -rot s" (" str-append ( list str-addr str-len ) | |
88 | pr-buf-list | |
89 | s" )" str-append ;; | |
90 | drop | |
91 | ||
92 | MalVector | |
93 | extend pr-buf | |
94 | MalVector/list @ | |
95 | -rot s" [" str-append ( list str-addr str-len ) | |
96 | pr-buf-list | |
97 | s" ]" str-append ;; | |
59038a10 C |
98 | drop |
99 | ||
2e78e94e C |
100 | MalMap |
101 | extend pr-buf | |
102 | MalMap/list @ | |
103 | -rot s" {" str-append ( list str-addr str-len ) | |
104 | pr-buf-list-item a-space pr-buf-list-item | |
105 | begin ( list str-addr str-len ) | |
106 | 2 pick mal-nil <> | |
107 | while | |
108 | s" , " str-append | |
109 | pr-buf-list-item a-space pr-buf-list-item | |
110 | repeat | |
111 | rot drop | |
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 | ||
120 | MalSymbol | |
121 | extend pr-buf | |
122 | dup MalSymbol/sym-addr @ | |
123 | swap MalSymbol/sym-len @ | |
124 | str-append ;; | |
125 | drop | |
50e417ff C |
126 | |
127 | : insert-\ ( str-addr str-len insert-idx -- str-addr str-len ) | |
128 | -rot 0 str-append-char { addr len } | |
129 | dup dup addr + dup 1+ ( i i from to ) | |
130 | rot len swap - cmove> ( i ) \ shift " etc to the right | |
131 | addr + [char] \ swap c! \ escape it! | |
132 | addr len | |
133 | ; | |
134 | ||
135 | MalString | |
136 | extend pr-buf | |
137 | dup MalString/str-addr @ | |
138 | swap MalString/str-len @ | |
139 | { addr len } | |
140 | ||
141 | s\" \"" str-append | |
142 | 0 ( i ) | |
143 | begin | |
168fb5dc C |
144 | dup len < |
145 | while | |
50e417ff C |
146 | dup addr + c@ ( i char ) |
147 | dup [char] " = over [char] \ = or if ( i char ) | |
148 | drop dup addr len rot insert-\ to len to addr | |
149 | 1+ | |
150 | else | |
168fb5dc C |
151 | dup 10 = if ( i ) \ newline? |
152 | drop dup addr len rot insert-\ to len to addr | |
50e417ff C |
153 | dup addr + 1+ [char] n swap c! |
154 | 1+ | |
168fb5dc C |
155 | else |
156 | 13 = if ( i ) \ return? | |
157 | dup addr len rot insert-\ to len to addr | |
158 | dup addr + 1+ [char] r swap c! | |
159 | 1+ | |
160 | endif | |
50e417ff C |
161 | endif |
162 | endif | |
163 | 1+ | |
168fb5dc | 164 | repeat |
50e417ff C |
165 | drop addr len str-append |
166 | s\" \"" str-append ;; | |
167 | drop |