From 672512b0a2b3b4ae88f204293f4379c1fbb79850 Mon Sep 17 00:00:00 2001
From: Aleksey Veresov <aleksey@veresov.pro>
Date: Wed, 6 Jan 2021 01:37:05 +0300
Subject: Added interpreter.

---
 examples/generated.csx   |   2 +-
 examples/interpreter.csx | 211 +++++++++++++++++++++++++++++++++++++++++++++++
 examples/translator.c    |  36 ++++----
 src/csx.c                |  33 +++++++-
 4 files changed, 265 insertions(+), 17 deletions(-)
 create mode 100644 examples/interpreter.csx

diff --git a/examples/generated.csx b/examples/generated.csx
index 62fd2eb..574152f 100644
--- a/examples/generated.csx
+++ b/examples/generated.csx
@@ -59,7 +59,7 @@
 
 { The Program }
 
-[output "Hello, I am Casey Shawn Exton.  " "What is your name?" newline]
+[output "Hello, I am Casey Shawn Exton.  What is your name?" newline]
 [output "> "]
 [set name [instr]]
 [output "Nice to meet you, " name "." newline]
diff --git a/examples/interpreter.csx b/examples/interpreter.csx
new file mode 100644
index 0000000..f4e22dc
--- /dev/null
+++ b/examples/interpreter.csx
@@ -0,0 +1,211 @@
+{ Base Utilities }
+
+[set no [fn [x] [same x []]]]
+[set id [fn [arg] arg]]
+[set list [fn args args]]
+
+[set catrev [fn [a b] [if a [catrev [tail a] [pair [head a] b]] b]]]
+[set rev [fn [l] [catrev l []]]]
+[set cat [fn [a b] [catrev [rev a] b]]]
+
+[set map [fn [f l] [if l [pair [f [head l]] [map f [tail l]]]]]]
+[set reduce [fn [f l] [if [no l] [] [if [no [tail l]] [head l]
+  [f [head l] [reduce f [tail l]]]
+]]]]
+
+
+{ Input-Output }
+
+[set newline [str [list 10]]]
+
+[set outint [fn [n]
+  [set zero 48]
+  [set minus 45]
+  [if [< n 0]
+    [do [out minus] [outint [neg n]]]
+    [if [< n 10]
+      [out [+ zero n]]
+      [do
+        [outint [div n 10]]
+        [out [+ zero [mod n 10]]]
+      ]
+    ]
+  ]
+]]
+
+[set outstr [fn [str]
+  [set outstrat [fn [str i len] [if [no [same i len]] [do
+    [out [str i]]
+    [outstrat str [+ i 1] len]
+  ]]]]
+  [outstrat str 0 [len str]]
+]]
+
+[set output [fn objs [map [fn [obj] [if
+  [same [type obj] 'int] [outint obj]
+  [same [type obj] 'str] [outstr obj]
+]] objs]]]
+
+[set instrlist [fn []
+  [set c [in]]
+  [if [no [same c 10]] [pair c [instrlist]]]
+]]
+[set instr [fn [] [str [instrlist]]]]
+
+
+{ The Program }
+
+[set screenstr [fn [str]
+  [set outstrat [fn [str i len] [if [no [same i len]] [do
+    [if [same [str i] ["\\" 0]] [output "\\"]]
+    [if [same [str i] ["\"" 0]] [output "\\"]]
+    [out [str i]]
+    [outstrat str [+ i 1] len]
+  ]]]]
+  [outstrat str 0 [len str]]
+]]
+
+[set screenname [fn [str]
+  [set outstrat [fn [str i len] [if [no [same i len]] [do
+    [if [same [str i] ["\\" 0]] [output "\\"]]
+    [if [same [str i] [" " 0]] [output "\\"]]
+    [if [same [str i] ["[" 0]] [output "\\"]]
+    [if [same [str i] ["]" 0]] [output "\\"]]
+    [out [str i]]
+    [outstrat str [+ i 1] len]
+  ]]]]
+  [outstrat str 0 [len str]]
+]]
+
+[set writeeach [fn [l] [if l [do
+  [write [head l]]
+  [if [tail l] [do
+    [output " "]
+    [writeeach [tail l]]
+  ]]
+]]]]
+
+[set write [fn [obj] [if
+  [no obj] [output "[]"]
+  [same [type obj] 'int] [outint obj]
+  [same [type obj] 'str] [do [output "\""] [screenstr obj] [output "\""]]
+  [same [type obj] 'pair] [do [output "["] [writeeach obj] [output "]"]]
+  [same [type obj] 'name] [screenname [str obj]]
+  [same [type obj] 'base] [output "<base>"]
+  [same [type obj] 'int] [output obj]
+  [same [type obj] 'fn] [output "<fn>"]
+  [same [type obj] 'sx] [output "<sx>"]
+]]]
+
+
+[set linep [pair [] []]]
+
+[set readcomment [fn [] [if
+  [same [head [head linep]] ["}" 0]] [sethead linep [tail [head linep]]]
+  [same [head [head linep]] ["{" 0]] [do
+    [sethead linep [tail [head linep]]]
+    [readcomment]
+    [readcomment]
+  ]
+  [do
+    [sethead linep [tail [head linep]]]
+    [readcomment]
+  ]
+]]]
+
+[set pairlist [fn [l] [if l [if [tail l]
+  [pair [head l] [pairlist [tail l]]]
+  [head l]
+]]]]
+
+[set readlist [fn [] [if
+  [same [head [head linep]] ["]" 0]] [sethead linep [tail [head linep]]]
+  [same [head [head linep]] [" " 0]] [do
+    [sethead linep [tail [head linep]]]
+    [readlist]
+  ]
+  [do
+    [set res [readobj]]
+    [pair res [readlist]]
+  ]
+]]]
+
+[set readint [fn [num]
+  [if [head [head linep]] [if [< 47 [head [head linep]] 58] [do
+    [set newnum [+ [* 10 num] [head [head linep]] -48]]
+    [sethead linep [tail [head linep]]]
+    [readint newnum]
+  ] num] num]
+]]
+
+[set readname [fn []
+  [if [head [head linep]] [if [no [same [head [head linep]] [" " 0]]]
+    [if [no [same [head [head linep]] ["[" 0]]] [if [no [same [head [head linep]] ["]" 0]]] [do
+      [if [same [head [head linep]] ["\\" 0]] [sethead linep [tail [head linep]]]]
+      [set res [head [head linep]]]
+      [sethead linep [tail [head linep]]]
+      [pair res [readname]]
+    ]]]
+  ]]
+]]
+
+[set readstr [fn []
+  [if [head [head linep]] [if [no [same [head [head linep]] ["\"" 0]]][do
+    [if [same [head [head linep]] ["\\" 0]] [sethead linep [tail [head linep]]]]
+    [set res [head [head linep]]]
+    [sethead linep [tail [head linep]]]
+    [pair res [readstr]]
+  ] [sethead linep [tail [head linep]]]]]
+]]
+
+[set readobj [fn [] [if
+  [same [head [head linep]] ["{" 0]] [do
+    [sethead linep [tail [head linep]]]
+    [readcomment]
+    [readobj]
+  ]
+  [same [head [head linep]] [" " 0]] [do
+    [sethead linep [tail [head linep]]]
+    [readobj]
+  ]
+  [same [head [head linep]] ["[" 0]] [do
+    [sethead linep [tail [head linep]]]
+    [readlist]
+  ]
+  [same [head [head linep]] ["=" 0]] [if
+    [same [head [tail [head linep]]] ["[" 0]] [do
+      [sethead linep [tail [tail [head linep]]]]
+      [pairlist [readlist]]
+    ]
+    [name [str [readname]]]
+  ]
+  [same [head [head linep]] ["-" 0]] [if
+    [< 47 [head [tail [head linep]]] 58] [do
+      [sethead linep [tail [head linep]]]
+      [neg [readint 0]]
+    ]
+    [name [str [readname]]]
+  ]
+  [same [head [head linep]] ["'" 0]] [do
+    [sethead linep [tail [head linep]]]
+    [list quote [readobj]]
+  ]
+  [same [head [head linep]] ["\"" 0]] [do
+    [sethead linep [tail [head linep]]]
+    [str [readstr]]
+  ]
+  [< 47 [head [head linep]] 58] [readint 0]
+  [name [str [readname line]]]
+]]]
+
+[set read [fn [usercontext]
+  [output "> "]
+  [sethead linep [instrlist]]
+  [set res [run [readobj] usercontext]]
+  [write [head res]]
+  [output newline]
+  [read [tail res]]
+]]
+
+[output "-= CSX interpreter loaded =-" newline]
+[read [newcontext]]
diff --git a/examples/translator.c b/examples/translator.c
index 01920c9..26bd5ac 100644
--- a/examples/translator.c
+++ b/examples/translator.c
@@ -20,10 +20,11 @@ void name(char a)
     printf("\")");
 }
 
-void num(char a)
+void num(char a, char b)
 {
     printf("csx_int(");
     if (a) putchar(a);
+    if (b) putchar(b);
     c = getchar();
     while (c != EOF && isdigit(c)) {
         putchar(c);
@@ -32,6 +33,14 @@ void num(char a)
     printf(")");
 }
 
+void list()
+{
+    printf("csx_list(");
+    items();
+    printf("0)");
+    c = getchar();
+}
+
 void pair()
 {
     if ((c = getchar()) == '[') {
@@ -42,12 +51,15 @@ void pair()
     } else name('=');
 }
 
-void list()
+void quote()
 {
-    printf("csx_list(");
-    items();
-    printf("0)");
+    printf("csx_list(csx_name(\"quote\"),");
     c = getchar();
+    if (c == '[') list();
+    else if (c == '=') pair();
+    else if (c == '\'') quote();
+    else name(0);
+    printf(",0)");
 }
 
 void skip()
@@ -75,9 +87,9 @@ void items()
         if (first) first = 0; else putchar(',');
         if (c == '[') list();
         else if (c == '-')
-            if (isdigit(c = getchar())) num('-');
+            if (isdigit(c = getchar())) num('-', c);
             else name('-');
-        else if (isdigit(c)) num(c);
+        else if (isdigit(c)) num(c, 0);
         else if (c == '=') pair();
         else if (c == '"') {
             printf("csx_str(\"");
@@ -90,14 +102,8 @@ void items()
             }
             printf("\")");
             c = getchar();
-        } else if (c == '\'') {
-            printf("csx_list(csx_name(\"quote\"),");
-            c = getchar();
-            if (c == '[') list();
-            else if (c == '=') pair();
-            else name(0);
-            printf(",0)");
-        } else name(0);
+        } else if (c == '\'') quote();
+        else name(0);
         skip();
     }
     if (!first) putchar(',');
diff --git a/src/csx.c b/src/csx.c
index 0f07713..f114114 100644
--- a/src/csx.c
+++ b/src/csx.c
@@ -190,6 +190,7 @@ static void *base_is_set(void *arg)
 
 static void *base_sethead(void *arg)
 {
+    arg = run_each(arg);
     pair_data *p = head(arg);
     p->head = head(tail(arg));
     return null;
@@ -197,6 +198,7 @@ static void *base_sethead(void *arg)
 
 static void *base_settail(void *arg)
 {
+    arg = run_each(arg);
     pair_data *p = head(arg);
     p->tail = head(tail(arg));
     return null;
@@ -421,6 +423,18 @@ static void *base_len(void *arg)
     return csx_int(len);
 }
 
+static void *base_run(void *arg)
+{
+    arg = run_each(arg);
+    if (type(tail(arg)) == type_null) return csx_run(head(arg));
+    void *saved = context;
+    context = head(tail(arg));
+    void *res = csx_run(head(arg));
+    void *rescontext = context;
+    context = saved;
+    return new_pair(res, rescontext);
+}
+
 
 static void *zip(void *params, void *values)
 {
@@ -485,6 +499,21 @@ tailcall:
 }
 
 
+static void *base_context(void *args)
+{
+    return context;
+}
+
+static void new_context();
+static void *base_newcontext(void *args)
+{
+    void *saved = context;
+    new_context();
+    void *res = context;
+    context = saved;
+    return res;
+}
+
 static void new_context()
 {
     context = new_pair(null, null);
@@ -515,7 +544,9 @@ static void new_context()
     base_set(csx_list(csx_name("name"), csx_base(base_name), 0));
     base_set(csx_list(csx_name("str"), csx_base(base_str), 0));
     base_set(csx_list(csx_name("len"), csx_base(base_len), 0));
-    base_set(csx_list(csx_name("run"), csx_base(csx_run), 0));
+    base_set(csx_list(csx_name("run"), csx_base(base_run), 0));
+    base_set(csx_list(csx_name("context"), csx_base(base_context), 0));
+    base_set(csx_list(csx_name("newcontext"), csx_base(base_newcontext), 0));
 }
 
 static void init()
-- 
cgit v1.2.3