Skip to content

Commit c34c6e0

Browse files
madman-bobgallais
madman-bob
authored and
gallais
committed
Complete RefC standard String support
- Fix off-by-one error in String reverse - Correct order of arguments in strSubstr - Actually use start index of strSubstr - Reduce memory usage of strSubstr in case of overrunning string end - Add fastPack/fastUnpack/fastConcat - Use unsigned chars for character comparisons - Fix generated C character encodings
1 parent 978d86f commit c34c6e0

File tree

9 files changed

+165
-49
lines changed

9 files changed

+165
-49
lines changed

‎libs/prelude/Prelude/Types.idr

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -416,6 +416,7 @@ Traversable List where
416416
-- If you need to concatenate strings at compile time, use Prelude.concat.
417417
%foreign
418418
"scheme:string-concat"
419+
"C:fastConcat"
419420
"javascript:lambda:(xs)=>''.concat(...__prim_idris2js_array(xs))"
420421
export
421422
fastConcat : List String -> String
@@ -543,6 +544,7 @@ pack (x :: xs) = strCons x (pack xs)
543544

544545
%foreign
545546
"scheme:string-pack"
547+
"C:fastPack"
546548
"javascript:lambda:(xs)=>''.concat(...__prim_idris2js_array(xs))"
547549
export
548550
fastPack : List Char -> String
@@ -569,6 +571,7 @@ unpack str = unpack' (prim__cast_IntegerInt (natToInteger (length str)) - 1) str
569571
-- If you need to unpack strings at compile time, use Prelude.unpack.
570572
%foreign
571573
"scheme:string-unpack"
574+
"C:fastUnpack"
572575
"javascript:lambda:(str)=>__prim_js2idris_array(Array.from(str))"
573576
export
574577
fastUnpack : String -> List Char

‎src/Compiler/RefC/RefC.idr

Lines changed: 4 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -75,46 +75,15 @@ cName n = assert_total $ idris_crash ("INTERNAL ERROR: Unsupported name in C bac
7575
-- not really total but this way this internal error does not contaminate everything else
7676

7777
escapeChar : Char -> String
78-
escapeChar '\DEL' = "127"
79-
escapeChar '\NUL' = "0"
80-
escapeChar '\SOH' = "1"
81-
escapeChar '\STX' = "2"
82-
escapeChar '\ETX' = "3"
83-
escapeChar '\EOT' = "4"
84-
escapeChar '\ENQ' = "5"
85-
escapeChar '\ACK' = "6"
86-
escapeChar '\BEL' = "7"
87-
escapeChar '\BS' = "8"
88-
escapeChar '\HT' = "9"
89-
escapeChar '\LF' = "10"
90-
escapeChar '\VT' = "11"
91-
escapeChar '\FF' = "12"
92-
escapeChar '\CR' = "13"
93-
escapeChar '\SO' = "14"
94-
escapeChar '\SI' = "15"
95-
escapeChar '\DLE' = "16"
96-
escapeChar '\DC1' = "17"
97-
escapeChar '\DC2' = "18"
98-
escapeChar '\DC3' = "19"
99-
escapeChar '\DC4' = "20"
100-
escapeChar '\NAK' = "21"
101-
escapeChar '\SYN' = "22"
102-
escapeChar '\ETB' = "23"
103-
escapeChar '\CAN' = "24"
104-
escapeChar '\EM' = "25"
105-
escapeChar '\SUB' = "26"
106-
escapeChar '\ESC' = "27"
107-
escapeChar '\FS' = "28"
108-
escapeChar '\GS' = "29"
109-
escapeChar '\RS' = "30"
110-
escapeChar '\US' = "31"
111-
escapeChar c = show c
78+
escapeChar c = if isAlphaNum c || isNL c
79+
then show c
80+
else "(char)" ++ show (ord c)
11281

11382
cStringQuoted : String -> String
11483
cStringQuoted cs = strCons '"' (showCString (unpack cs) "\"")
11584
where
11685
showCChar : Char -> String -> String
117-
showCChar '\\' = ("bkslash" ++)
86+
showCChar '\\' = ("\\\\" ++)
11887
showCChar c
11988
= if c < chr 32
12089
then (("\\x" ++ leftPad '0' 2 (asHex (cast c))) ++ "\"\"" ++)

‎support/refc/datatypes.h

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -76,7 +76,7 @@ typedef struct
7676
typedef struct
7777
{
7878
Value_header header;
79-
char c;
79+
unsigned char c;
8080
} Value_Char;
8181

8282
typedef struct

‎support/refc/stringOps.c

Lines changed: 97 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -45,7 +45,7 @@ Value *reverse(Value *str)
4545
memset(retVal->str, 0, l + 1);
4646
char *p = retVal->str;
4747
char *q = input->str + (l - 1);
48-
for (int i = 1; i < l; i++)
48+
for (int i = 0; i < l; i++)
4949
{
5050
*p++ = *q--;
5151
}
@@ -85,18 +85,103 @@ Value *strAppend(Value *a, Value *b)
8585
return (Value *)retVal;
8686
}
8787

88-
Value *strSubstr(Value *s, Value *start, Value *len)
88+
Value *strSubstr(Value *start, Value *len, Value *s)
8989
{
90-
Value_String *retVal;
91-
switch (len->header.tag)
90+
char *input = ((Value_String *)s)->str;
91+
int offset = extractInt(start);
92+
int l = extractInt(len);
93+
94+
int tailLen = strlen(input);
95+
if (tailLen < l)
9296
{
93-
case INT64_TAG:
94-
retVal = makeEmptyString(((Value_Int64 *)len)->i64 + 1);
95-
memcpy(retVal->str, ((Value_String *)s)->str, ((Value_Int64 *)len)->i64);
96-
return (Value *)retVal;
97-
default:
98-
retVal = makeEmptyString(((Value_Int32 *)len)->i32 + 1);
99-
memcpy(retVal->str, ((Value_String *)s)->str, ((Value_Int32 *)len)->i32);
100-
return (Value *)retVal;
97+
l = tailLen;
98+
}
99+
100+
Value_String *retVal = makeEmptyString(l + 1);
101+
memcpy(retVal->str, input + offset, l);
102+
103+
return (Value *)retVal;
104+
}
105+
106+
char *fastPack(Value *charList)
107+
{
108+
Value_Constructor *current;
109+
110+
int l = 0;
111+
current = (Value_Constructor *)charList;
112+
while (current->total == 2)
113+
{
114+
l ++;
115+
current = (Value_Constructor *)current->args[1];
116+
}
117+
118+
char *retVal = malloc(l + 1);
119+
retVal[l] = 0;
120+
121+
int i = 0;
122+
current = (Value_Constructor *)charList;
123+
while (current->total == 2)
124+
{
125+
retVal[i++] = ((Value_Char *)current->args[0])->c;
126+
current = (Value_Constructor *)current->args[1];
101127
}
128+
129+
return retVal;
130+
}
131+
132+
Value *fastUnpack(char *str)
133+
{
134+
if (str[0] == '\0') {
135+
return (Value *)newConstructor(0, 0, "Prelude_Types_Nil");
136+
}
137+
138+
Value_Constructor *retVal = newConstructor(2, 1, "Prelude_Types__colon_colon");
139+
retVal->args[0] = (Value *)makeChar(str[0]);
140+
141+
int i = 1;
142+
Value_Constructor *current = retVal;
143+
Value_Constructor *next;
144+
while (str[i] != '\0') {
145+
next = newConstructor(2, 1, "Prelude_Types__colon_colon");
146+
next->args[0] = (Value *)makeChar(str[i]);
147+
current->args[1] = (Value *)next;
148+
149+
i ++;
150+
current = next;
151+
}
152+
current->args[1] = (Value *)newConstructor(0, 0, "Prelude_Types_Nil");
153+
154+
return (Value *)retVal;
155+
}
156+
157+
char *fastConcat(Value *strList)
158+
{
159+
Value_Constructor *current;
160+
161+
int totalLength = 0;
162+
current = (Value_Constructor *)strList;
163+
while (current->total == 2)
164+
{
165+
totalLength += strlen(((Value_String *)current->args[0])->str);
166+
current = (Value_Constructor *)current->args[1];
167+
}
168+
169+
char *retVal = malloc(totalLength + 1);
170+
retVal[totalLength + 1] = '\0';
171+
172+
char *currentStr;
173+
int currentStrLen;
174+
int offset = 0;
175+
current = (Value_Constructor *)strList;
176+
while (current->total == 2)
177+
{
178+
currentStr = ((Value_String *)current->args[0])->str;
179+
currentStrLen = strlen(currentStr);
180+
memcpy(retVal + offset, currentStr, currentStrLen);
181+
182+
offset += currentStrLen;
183+
current = (Value_Constructor *)current->args[1];
184+
}
185+
186+
return retVal;
102187
}

‎support/refc/stringOps.h

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,5 +11,8 @@ Value *strIndex(Value *str, Value *i);
1111
Value *strCons(Value *c, Value *str);
1212
Value *strAppend(Value *a, Value *b);
1313
Value *strSubstr(Value *s, Value *start, Value *len);
14+
char *fastPack(Value *charList);
15+
Value *fastUnpack(char *str);
16+
char *fastConcat(Value *strList);
1417

1518
#endif

‎tests/Main.idr

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -222,7 +222,9 @@ chezTests = MkTestPool "Chez backend" [Chez]
222222

223223
refcTests : TestPool
224224
refcTests = MkTestPool "Reference counting C backend" [C]
225-
[ "refc001" , "refc002" ]
225+
[ "refc001" , "refc002"
226+
, "strings"
227+
]
226228

227229
racketTests : TestPool
228230
racketTests = MkTestPool "Racket backend" [Racket]

‎tests/refc/strings/TestStrings.idr

Lines changed: 32 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,32 @@
1+
module TestStrings
2+
3+
import Data.String
4+
5+
main : IO ()
6+
main = do
7+
let helloWorld = "Hello, " ++ "world"
8+
9+
putStrLn helloWorld
10+
putStrLn $ show $ length helloWorld
11+
12+
putStrLn $ reverse helloWorld
13+
putStrLn $ substr 1 2 helloWorld
14+
putStrLn $ show $ assert_total $ strIndex helloWorld 1
15+
16+
putStrLn $ strCons 'a' "bc"
17+
putStrLn $ show $ strUncons "abc"
18+
19+
putStrLn $ fastPack ['p', 'a', 'c', 'k']
20+
putStrLn $ show $ fastUnpack "unpack"
21+
putStrLn $ fastConcat ["con", "cat", "en", "ate"]
22+
23+
let chars = ['a', 'A', '~', '0', ' ', '\n', '\x9f']
24+
putStrLn $ show $ map isUpper chars
25+
putStrLn $ show $ map isLower chars
26+
putStrLn $ show $ map isDigit chars
27+
putStrLn $ show $ map isSpace chars
28+
putStrLn $ show $ map isNL chars
29+
putStrLn $ show $ map isControl chars
30+
31+
putStrLn $ show $ map chr [97, 65, 126, 48, 32, 10, 159]
32+
putStrLn $ show $ map ord chars

‎tests/refc/strings/expected

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
Hello, world
2+
12
3+
dlrow ,olleH
4+
el
5+
'e'
6+
abc
7+
Just ('a', "bc")
8+
pack
9+
['u', 'n', 'p', 'a', 'c', 'k']
10+
concatenate
11+
[False, True, False, False, False, False, False]
12+
[True, False, False, False, False, False, False]
13+
[False, False, False, True, False, False, False]
14+
[False, False, False, False, True, True, False]
15+
[False, False, False, False, False, True, False]
16+
[False, False, False, False, False, True, True]
17+
['a', 'A', '~', '0', ' ', '\LF', '\159']
18+
[97, 65, 126, 48, 32, 10, 159]

‎tests/refc/strings/run

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
$1 --no-banner --no-color --console-width 0 --cg refc -o refc_strings TestStrings.idr > /dev/null
2+
./build/exec/refc_strings
3+
4+
rm -rf build

0 commit comments

Comments
 (0)