Merge pull request #937 from andrew-johnson-4/smart-string-1

Smart string 1

Cargo.toml

@@ -1,6 +1,6 @@
 [package]
 name = "lambda_mountain"
-version = "1.19.8"
+version = "1.19.9"
 authors = ["Andrew <andrew@subarctic.org>"]
 license = "MIT"
 description = "Typed Macro Assembler (backed by Coq proofs-of-correctness)"

Makefile

@@ -1,6 +1,6 @@
 
 dev: install-production
-	lm EXAMPLES/control-flow.lsts
+	lm tests/regress/smart-string.lm
 	cc tmp.c
 	./a.out
 

PLATFORM/C/LIB/array.lm

@@ -22,6 +22,15 @@ const-cons := λ: Blob(: v x)(: i L). (: (
 (declare-binop( [] Array<base-type,?> U64 base-type ('\[_l x '[_l y ']\]_l) ));
 (declare-ternop( set[] Array<base-type,?> U64 base-type base-type ('\[_l x '[_l y ']=_l z \]_l) ));
 (declare-binop( + Array<base-type,?> U64 Array<base-type,?> ('\[_l x '+_l y '\]_l) ));
+(declare-binop( + Array<base-type,?> I64 Array<base-type,?> ('\[_l x '+_l y '\]_l) ));
+
+(declare-binop( == Array<base-type,?> Array<base-type,?> U64 ('\[_l x '==_l y '\]_l) ));
+(declare-binop( != Array<base-type,?> Array<base-type,?> U64 ('\[_l x '!=_l y '\]_l) ));
+(declare-binop( < Array<base-type,?> Array<base-type,?> U64 ('\[_l x '<_l y '\]_l) ));
+(declare-binop( <= Array<base-type,?> Array<base-type,?> U64 ('\[_l x '<=_l y '\]_l) ));
+(declare-binop( > Array<base-type,?> Array<base-type,?> U64 ('\[_l x '>_l y '\]_l) ));
+(declare-binop( >= Array<base-type,?> Array<base-type,?> U64 ('\[_l x '>=_l y '\]_l) ));
+(declare-binop( - Array<base-type,?> Array<base-type,?> U64 ('\[_l x '-_l y '\]_l) ));
 
 close := λ(: x p). (: (
    (let r (as (malloc(sizeof p)) p[]))

PLATFORM/C/LIB/default.lm

@@ -16,6 +16,7 @@ import PLATFORM/C/LIB/i64.lm;
 import PLATFORM/C/LIB/f64.lm;
 import PLATFORM/C/LIB/buffer.lm;
 import PLATFORM/C/LIB/string.lm;
+import PLATFORM/C/LIB/smart-string.lm;
 import PLATFORM/C/LIB/s.lm;
 import PLATFORM/C/LIB/tuple.lm;
 import PLATFORM/C/LIB/list.lm;

PLATFORM/C/LIB/io.lm

@@ -23,13 +23,6 @@ fork := λ: FFI().(: () PID);
 
 exit := λ(: x U64).(: (exit(as x U32)) Nil);
 
-print := λ(: x String). (: (
-   (while (!=( (head-string x) 0_u8 )) (
-      (putchar( (as (head-string x) U32) ))
-      (set x (tail-string x))
-   ))
-) Nil);
-
 fail := λ(: msg String)(: loc String). (: (
    (print msg)(print '\sat\s_s)(print loc)
    (exit 1_u32)

PLATFORM/C/LIB/smart-string.lm

@@ -0,0 +1,142 @@
+
+type SmartString (SmartString( data:U8[] , start:U8[] , end:U8[] ));
+
+intern := λ(: s String). (: (
+   (SmartString( (as s U8[]) (as s U8[]) (+( (as s U8[]) (.length s) )) ))
+) SmartString);
+
+intern := λ(: s SmartString). (: (
+   s
+) SmartString);
+
+untern := λ(: s SmartString). (: (
+   (let r SNil)
+   (let s-start (.start s))
+   (while (<( s-start (.end s) )) (
+      (set r (+(
+         r (SAtom(clone-rope([]( s-start 0_u64 ))))
+      )))
+      (set s-start (+( s-start 1_u64 )))
+   ))
+   (clone-rope r)
+) String);
+
+.length := λ(: x SmartString). (: (
+   (-( (.end x) (.start x) ))
+) U64);
+
+== := λ(: x SmartString)(: y String). (: (
+   (==( x (intern y) ))
+) U64);
+
+== := λ(: x SmartString)(: y SmartString). (: (
+   (let r 0_u64)
+   (if (is( x y )) (set r 1_u64) (
+      (let x-start (.start x))
+      (let y-start (.start y))
+      (set r 1_u64)
+      (while (&&(
+         (<( x-start (.end x) ))
+         (<( y-start (.end y) ))
+      )) (
+         (if (==( ([]( x-start 0_u64 )) ([]( y-start 0_u64 )) )) (
+            (set x-start (+( x-start 1_u64 )))
+            (set y-start (+( y-start 1_u64 )))
+         ) (
+            (set r 0_u64)
+            (set x-start (.end x))
+            (set y-start (.end y))
+         ))
+      ))
+      (if (||(
+         (<( x-start (.end x) ))
+         (<( y-start (.end y) ))
+      )) (set r 0_u64) ())
+   ))
+   r
+) U64);
+
+print := λ(: x SmartString). (: (
+   (let start (.start x))
+   (while (!=( start (.end x) )) (
+      (putchar(as ([]( start 0_u64 )) U32))
+      (set start (+( start 1_u64 )))
+   ))
+) Nil);
+
+[:] := λ(: x SmartString)(: low I64)(: hi I64). (: (
+   (if (<( low 0_i64 )) (
+      (set low (+( (as (.length x) I64) low )))
+   ) ())
+   (if (<( hi 0_i64 )) (
+      (set hi (+( (as (.length x) I64) hi )))
+   ) ())
+   (let lowp (+( (.start x) low )))
+   (let hip (+( (.start x) hi )))
+   (if (<( hip lowp )) (
+      (fail 'Index\sOut\sOf\sBounds:\sSmartString.[:]_s)
+   ) ())
+   (if (<( lowp (.start x) )) (
+      (fail 'Index\sOut\sOf\sBounds:\sSmartString.[:]_s)
+   ) ())
+   (if (>( hip (.end x) )) (
+      (fail 'Index\sOut\sOf\sBounds:\sSmartString.[:]_s)
+   ) ())
+   (SmartString( (.data x) lowp hip ))
+) SmartString);
+
+tail-string := λ(: x SmartString). (: (
+   ([:]( x 1_i64 (as (.length x) I64) ))
+) SmartString);
+
+[] := λ(: x SmartString)(: low I64). (: (
+   (if (<( low 0_i64 )) (
+      (set low (+( (as (.length x) I64) low )))
+   ) ())
+   (let lowp (+( (.start x) low )))
+   (if (<( lowp (.start x) )) (
+      (fail 'Index\sOut\sOf\sBounds:\sSmartString.[]_s)
+   ) ())
+   (if (>=( lowp (.end x) )) (
+      (fail 'Index\sOut\sOf\sBounds:\sSmartString.[]_s)
+   ) ())
+   ([]( lowp 0_u64 ))
+) U8);
+
+head-string := λ(: x SmartString). (: (
+   ([]( x 0_i64 ))
+) U8);
+
+has-suffix := λ(: base SmartString)(: sfx SmartString). (: (
+   (==(
+      ([:]( base (as (-( (.length base) (.length sfx) )) I64) (as (.length base) I64) ))
+      sfx ))
+) U64);
+
+remove-suffix := λ(: base SmartString)(: sfx SmartString). (: (
+   ([:]( base 0_i64 (as (-( (.length base) (.length sfx) )) I64) ))
+) SmartString);
+
+has-prefix := λ(: base SmartString)(: pfx SmartString). (: (
+   (==(
+      ([:]( base 0_i64 (as (.length pfx) I64) ))
+      pfx ))
+) U64);
+
+remove-prefix := λ(: base SmartString)(: sfx SmartString). (: (
+   ([:]( base (as (.length sfx) I64) (as (.length base) I64) ))
+) SmartString);
+
+.replace := λ(: base SmartString)(: pat SmartString)(: n SmartString). (: (
+   (let r SNil)
+   (while (>( (.length base) 0_u64 )) (
+      (if (has-prefix( base pat )) (
+         (set base (remove-prefix( base pat )))
+         (set r (+( r (SAtom(untern n)) )))
+      ) (
+         (set r (+( r (SAtom(clone-rope(head-string base))) )))
+         (set base (tail-string base))
+      ))
+   ))
+   (clone-rope r)
+) String);

PLATFORM/C/LIB/string.lm

@@ -165,3 +165,11 @@ remove-suffix := λ(: base String)(: sfx String). (: (
 + := λ(: l String)(: r String). (: (
    (clone-rope(+( (SAtom l) (SAtom r) )))
 ) String);
+
+print := λ(: x String). (: (
+   (while (!=( (head-string x) 0_u8 )) (
+      (putchar( (as (head-string x) U32) ))
+      (set x (tail-string x))
+   ))
+) Nil);
+

tests/regress/smart-string.lm

@@ -0,0 +1,7 @@
+
+import LIB/default.lm;
+
+main := λ. (: (
+   (print (intern 'ABC_s))
+   (print ([:]( (intern 'ABC_s) 1_i64 -1_i64 )))
+) Nil);

tests/regress/smart-string.lm.out

@@ -0,0 +1 @@
+ABCB