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 | |
26 | swap drop ; | |
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 ) | |
46 | pad ! pad 1 str-append ; \ refactoring str-append could perhaps make this faster | |
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 | ||
73 | MalList | |
74 | extend pr-buf | |
75 | -rot s" (" str-append ( list str-addr str-len ) | |
76 | rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf | |
77 | begin ( list str-addr str-len ) | |
78 | 2 pick mal-nil <> | |
79 | while | |
80 | a-space | |
81 | rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf | |
82 | repeat | |
83 | s" )" str-append rot drop ;; | |
84 | drop | |
85 | ||
86 | MalInt | |
87 | extend pr-buf | |
88 | MalInt/int @ int>str str-append ;; | |
89 | drop | |
90 | ||
91 | MalSymbol | |
92 | extend pr-buf | |
93 | dup MalSymbol/sym-addr @ | |
94 | swap MalSymbol/sym-len @ | |
95 | str-append ;; | |
96 | drop |