├── .gitignore
├── README.md
├── Vagrantfile
├── ats-sds
    ├── .gitignore
    ├── LICENSE
    ├── README.md
    ├── sds.dats
    ├── sds.sats
    ├── sds
    │   ├── .gitignore
    │   ├── LICENSE
    │   ├── Makefile
    │   ├── README.md
    │   ├── sds.c
    │   ├── sds.h
    │   └── testhelp.h
    └── test.dats
├── cps
    ├── Makefile
    ├── atsparcc.hats
    ├── libatsparcc.a
    ├── parcc.dats
    ├── parcc.sats
    ├── parcc_dats.o
    ├── parcc_sats.o
    ├── parser.dats
    ├── parser.sats
    ├── parser_dats.o
    ├── sexp.dats
    ├── sexp.sats
    ├── simple.dats
    ├── test1.sexp
    └── testall.dats
├── file
    ├── file.dats
    ├── file.sats
    ├── location.dats
    └── location.sats
├── old
    ├── continuation.sats
    ├── input.sats
    ├── interface.sats
    ├── lexcc.dats
    ├── lexcc.sats
    ├── trampoline.dats
    └── trampoline.sats
├── sexp
    ├── LamLite.g4
    ├── lexer.dats
    ├── lexer.sats
    ├── syntax.sats
    ├── token.dats
    └── token.sats
├── simple
    └── parcc.sats
├── test
    ├── 1.test
    ├── test.dats
    └── test2.dats
└── untyped
    ├── 1.test
    ├── parser.dats
    └── parser.sats


/.gitignore:
--------------------------------------------------------------------------------
1 | .vagrant
2 | .c9
3 | *_dats.c
4 | *_sats.c
5 | *.out
6 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | ats-parcc
2 | =========
3 | 
4 | A cps parser combinator library.
5 | 


--------------------------------------------------------------------------------
/Vagrantfile:
--------------------------------------------------------------------------------
  1 | # -*- mode: ruby -*-
  2 | # vi: set ft=ruby :
  3 | 
  4 | $script = <<SCRIPT
  5 |   echo installing ATS ...
  6 |   mkdir /ats2 
  7 |   cd /ats2
  8 |   sed -ri 's/#force_color_prompt=yes/force_color_prompt=yes/g' /home/vagrant/.bashrc
  9 |   sed -ri 's/force_color_prompt=no/#force_color_prompt=no/g' /home/vagrant/.bashrc
 10 |   apt-get update
 11 |   apt-get install -y libgmp3-dev make gcc build-essential wget bash gdb git
 12 |   export PATSHOME=$PWD
 13 |  
 14 |   wget http://sourceforge.net/projects/ats2-lang/files/latest/download?source=files -O - | tar -zvx --strip-components=1 -f -       
 15 |   ./configure
 16 |   make all
 17 |  
 18 |   echo export PATSHOME=$PWD >> /home/vagrant/.bashrc
 19 |   echo export PATH=$PATH:$PWD/bin >> /home/vagrant/.bashrc
 20 | SCRIPT
 21 | 
 22 | # Vagrantfile API/syntax version. Don't touch unless you know what you're doing!
 23 | VAGRANTFILE_API_VERSION = "2"
 24 | 
 25 | Vagrant.configure(VAGRANTFILE_API_VERSION) do |config|
 26 |   # All Vagrant configuration is done here. The most common configuration
 27 |   # options are documented and commented below. For a complete reference,
 28 |   # please see the online documentation at vagrantup.com.
 29 | 
 30 |   # Every Vagrant virtual environment requires a box to build off of.
 31 |   config.vm.box = "ubuntu/trusty64"
 32 | 
 33 |   # Disable automatic box update checking. If you disable this, then
 34 |   # boxes will only be checked for updates when the user runs
 35 |   # `vagrant box outdated`. This is not recommended.
 36 |   # config.vm.box_check_update = false
 37 | 
 38 |   # Create a forwarded port mapping which allows access to a specific port
 39 |   # within the machine from a port on the host machine. In the example below,
 40 |   # accessing "localhost:8080" will access port 80 on the guest machine.
 41 |   # config.vm.network "forwarded_port", guest: 80, host: 8080
 42 | 
 43 |   # Create a private network, which allows host-only access to the machine
 44 |   # using a specific IP.
 45 |   # config.vm.network "private_network", ip: "192.168.33.10"
 46 | 
 47 |   # Create a public network, which generally matched to bridged network.
 48 |   # Bridged networks make the machine appear as another physical device on
 49 |   # your network.
 50 |   # config.vm.network "public_network"
 51 | 
 52 |   # If true, then any SSH connections made will enable agent forwarding.
 53 |   # Default value: false
 54 |   # config.ssh.forward_agent = true
 55 | 
 56 |   # Share an additional folder to the guest VM. The first argument is
 57 |   # the path on the host to the actual folder. The second argument is
 58 |   # the path on the guest to mount the folder. And the optional third
 59 |   # argument is a set of non-required options.
 60 |   # config.vm.synced_folder "../data", "/vagrant_data"
 61 | 
 62 |   # Provider-specific configuration so you can fine-tune various
 63 |   # backing providers for Vagrant. These expose provider-specific options.
 64 |   # Example for VirtualBox:
 65 |   #
 66 |   # config.vm.provider "virtualbox" do |vb|
 67 |   #   # Don't boot with headless mode
 68 |   #   vb.gui = true
 69 |   #
 70 |   #   # Use VBoxManage to customize the VM. For example to change memory:
 71 |   #   vb.customize ["modifyvm", :id, "--memory", "1024"]
 72 |   # end
 73 |   #
 74 |   # View the documentation for the provider you're using for more
 75 |   # information on available options.
 76 | 
 77 |   # Enable provisioning with CFEngine. CFEngine Community packages are
 78 |   # automatically installed. For example, configure the host as a
 79 |   # policy server and optionally a policy file to run:
 80 |   #
 81 |   # config.vm.provision "cfengine" do |cf|
 82 |   #   cf.am_policy_hub = true
 83 |   #   # cf.run_file = "motd.cf"
 84 |   # end
 85 |   #
 86 |   # You can also configure and bootstrap a client to an existing
 87 |   # policy server:
 88 |   #
 89 |   # config.vm.provision "cfengine" do |cf|
 90 |   #   cf.policy_server_address = "10.0.2.15"
 91 |   # end
 92 | 
 93 |   # Enable provisioning with Puppet stand alone.  Puppet manifests
 94 |   # are contained in a directory path relative to this Vagrantfile.
 95 |   # You will need to create the manifests directory and a manifest in
 96 |   # the file default.pp in the manifests_path directory.
 97 |   #
 98 |   # config.vm.provision "puppet" do |puppet|
 99 |   #   puppet.manifests_path = "manifests"
100 |   #   puppet.manifest_file  = "site.pp"
101 |   # end
102 | 
103 |   # Enable provisioning with chef solo, specifying a cookbooks path, roles
104 |   # path, and data_bags path (all relative to this Vagrantfile), and adding
105 |   # some recipes and/or roles.
106 |   #
107 |   # config.vm.provision "chef_solo" do |chef|
108 |   #   chef.cookbooks_path = "../my-recipes/cookbooks"
109 |   #   chef.roles_path = "../my-recipes/roles"
110 |   #   chef.data_bags_path = "../my-recipes/data_bags"
111 |   #   chef.add_recipe "mysql"
112 |   #   chef.add_role "web"
113 |   #
114 |   #   # You may also specify custom JSON attributes:
115 |   #   chef.json = { mysql_password: "foo" }
116 |   # end
117 | 
118 |   # Enable provisioning with chef server, specifying the chef server URL,
119 |   # and the path to the validation key (relative to this Vagrantfile).
120 |   #
121 |   # The Opscode Platform uses HTTPS. Substitute your organization for
122 |   # ORGNAME in the URL and validation key.
123 |   #
124 |   # If you have your own Chef Server, use the appropriate URL, which may be
125 |   # HTTP instead of HTTPS depending on your configuration. Also change the
126 |   # validation key to validation.pem.
127 |   #
128 |   # config.vm.provision "chef_client" do |chef|
129 |   #   chef.chef_server_url = "https://api.opscode.com/organizations/ORGNAME"
130 |   #   chef.validation_key_path = "ORGNAME-validator.pem"
131 |   # end
132 |   #
133 |   # If you're using the Opscode platform, your validator client is
134 |   # ORGNAME-validator, replacing ORGNAME with your organization name.
135 |   #
136 |   # If you have your own Chef Server, the default validation client name is
137 |   # chef-validator, unless you changed the configuration.
138 |   #
139 |   #   chef.validation_client_name = "ORGNAME-validator"
140 | 
141 | 
142 | 
143 |   config.vm.provision "shell", inline: $script
144 | 
145 | end
146 | 


--------------------------------------------------------------------------------
/ats-sds/.gitignore:
--------------------------------------------------------------------------------
1 | .c9/
2 | 


--------------------------------------------------------------------------------
/ats-sds/README.md:
--------------------------------------------------------------------------------
1 | #ATS SDS Library Wrapper
2 | 
3 | This is a wrapper for [Simple Dynamic String](https://github.com/antirez/sds/) library. Usage examples can be found in `test.dats`.
4 | 


--------------------------------------------------------------------------------
/ats-sds/sds.dats:
--------------------------------------------------------------------------------
1 | staload "sds.sats"
2 | 
3 | #define ATS_DYNLOADFLAG 0


--------------------------------------------------------------------------------
/ats-sds/sds.sats:
--------------------------------------------------------------------------------
 1 | %{#
 2 | #include "sds/sds.h"
 3 | %}
 4 | 
 5 | 
 6 | 
 7 | absvtype sds
 8 | 
 9 | fun sdsnewlen(string, size_t): sds = "mac#"
10 | fun sdsnew(string): sds = "mac#"
11 | fun sdsempty(): sds = "mac#"
12 | fun sdsdup(!sds): sds = "mac#"
13 | fun sdsfree(sds): void = "mac#"
14 | fun sdsgrowzero(sds, size_t): sds = "mac#" 
15 | 
16 | fun sdslen(!sds): size_t = "mac#"
17 | fun sdsavail(!sds): size_t = "mac#"
18 | 
19 | fun sdscatlen(sds, string, size_t): sds = "mac#"
20 | fun sdscat(sds, string): sds = "mac#"
21 | fun sdscatsds(sds, !sds): sds = "mac#"
22 | fun sdscatprintf {ts:t@ype} (sds, string, ts): sds = "mac#"
23 | fun sdscatrepr(sds, string, size_t): sds  = "mac#"
24 | 
25 | fun sdscpylen(sds, string, size_t): sds = "mac#"
26 | fun sdscpy(sds, !sds): sds = "mac#" 
27 | 
28 | fun sdstrim(!sds, string): void = "mac#"
29 | fun sdsrange(!sds, int, int): void = "mac#"
30 | 
31 | fun sdscmp(!sds, !sds): int = "mac#"
32 | 
33 | fun sdssplitlen {n:int} (string, size_t, string, size_t, &int? >> int n): arrayptr (sds, n) = "mac#"
34 | fun sdsfreesplitres {n:int} (arrayptr (sds, n), int n): void = "mac#"
35 | fun sdssplitargs {n:int} (string, &int? >> int n): arrayptr (sds, n) = "mac#"
36 | 
37 | fun sdsmapchars(sds, string, string, size_t): sds  = "mac#"
38 | 
39 | fun sdstolower(sds): sds = "mac#"
40 | fun sdstoupper(sds): sds = "mac#"
41 | 
42 | fun sdsfromlonglong(llint): sds = "mac#"
43 | 
44 | fun sdsjoinsds {n:int} (arrayptr (sds, n), int n, string, size_t): sds  = "mac#"
45 | 
46 | 
47 | 


--------------------------------------------------------------------------------
/ats-sds/sds/.gitignore:
--------------------------------------------------------------------------------
1 | sds-test
2 | 


--------------------------------------------------------------------------------
/ats-sds/sds/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2006-2014, Salvatore Sanfilippo <antirez at gmail dot com>
 2 | 
 3 | All rights reserved.
 4 | 
 5 | Redistribution and use in source and binary forms, with or without
 6 | modification, are permitted provided that the following conditions are met:
 7 | 
 8 | * Redistributions of source code must retain the above copyright notice,
 9 |   this list of conditions and the following disclaimer.
10 | 
11 | * Redistributions in binary form must reproduce the above copyright notice,
12 |   this list of conditions and the following disclaimer in the documentation
13 |   and/or other materials provided with the distribution.
14 | 
15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
18 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
19 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
22 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
25 | 


--------------------------------------------------------------------------------
/ats-sds/sds/Makefile:
--------------------------------------------------------------------------------
1 | all: sds-test
2 | 
3 | sds-test: sds.c sds.h testhelp.h
4 | 	$(CC) -o sds-test sds.c -Wall -std=c99 -pedantic -O2 -DSDS_TEST_MAIN
5 | 	@echo ">>> Type ./sds-test to run the sds.c unit tests."
6 | 
7 | clean:
8 | 	rm -f sds-test
9 | 


--------------------------------------------------------------------------------
/ats-sds/sds/README.md:
--------------------------------------------------------------------------------
  1 | Simple Dynamic Strings
  2 | ===
  3 | 
  4 | SDS is a string library for C designed to augment the limited libc string
  5 | handling functionalities by adding heap allocated strings that are:
  6 | 
  7 | * Simpler to use.
  8 | * Binary safe.
  9 | * Computationally more efficient.
 10 | * But yet... Compatible with normal C string functions.
 11 | 
 12 | This is achieved using an alternative design in which instead of using a C
 13 | structure to represent a string, we use a binary prefix that is stored
 14 | before the actual pointer to the string that is returned by SDS to the user.
 15 | 
 16 |     +--------+-------------------------------+-----------+
 17 |     | Header | Binary safe C alike string... | Null term |
 18 |     +--------+-------------------------------+-----------+
 19 |              |
 20 |              `-> Pointer returned to the user.
 21 | 
 22 | Because of meta data stored before the actual returned pointer as a prefix,
 23 | and because of every SDS string implicitly adding a null term at the end of
 24 | the string regardless of the actual content of the string, SDS strings work
 25 | well together with C strings and the user is free to use them interchangeably
 26 | with real-only functions that access the string in read-only.
 27 | 
 28 | SDS was a C string I developed in the past for my everyday C programming needs,
 29 | later it was moved into Redis where it is used extensively and where it was
 30 | modified in order to be suitable for high performance operations. Now it was
 31 | extracted from Redis and forked as a stand alone project.
 32 | 
 33 | Because of its many years life inside Redis, SDS provides both higher level
 34 | functions for easy strings manipulation in C, but also a set of low level
 35 | functions that make it possible to write high performance code without paying
 36 | a penalty for using an higher level string library.
 37 | 
 38 | Advantages and disadvantages of SDS
 39 | ===
 40 | 
 41 | Normally dynamic string libraries for C are implemented using a structure
 42 | that defines the string. The structure has a pointer field that is managed
 43 | by the string function, so it looks like this:
 44 | 
 45 | ```c
 46 | struct yourAverageStringLibrary {
 47 |     char *buf;
 48 |     size_t len;
 49 |     ... possibly more fields here ...
 50 | };
 51 | ```
 52 | 
 53 | SDS strings are already mentioned don't follow this schema, and are instead
 54 | a single allocation with a prefix that lives *before* the address actually
 55 | returned for the string.
 56 | 
 57 | There are advantages and disadvantages with this approach over the traditional
 58 | approach:
 59 | 
 60 | **Disadvantage #1**: many functions return the new string as value, since sometimes SDS requires to create a new string with more space, so the most SDS API calls look like this:
 61 | 
 62 | ```c
 63 | s = sdscat(s,"Some more data");
 64 | ```
 65 | 
 66 | As you can see `s` is used as input for `sdscat` but is also set to the value
 67 | returned by the SDS API call, since we are not sure if the call modified the
 68 | SDS string we passed or allocated a new one. Not remembering to assign back
 69 | the return value of `sdscat` or similar functions to the variable holding
 70 | the SDS string will result in a bug.
 71 | 
 72 | **Disadvantage #2**: if an SDS string is shared in different places in your program you have to modify all the references when you modify the string. However most of the times when you need to share SDS strings it is much better to encapsulate them into structures with a `reference count` otherwise it is too easy to incur into memory leaks.
 73 | 
 74 | **Advantage #1**: you can pass SDS strings to functions designed for C functions without accessing a struct member or calling a function, like this:
 75 | 
 76 | ```c
 77 | printf("%s\n", sds_string);
 78 | ```
 79 | 
 80 | In most other libraries this will be something like:
 81 | 
 82 | ```c
 83 | printf("%s\n", string->buf);
 84 | ```
 85 | 
 86 | Or:
 87 | 
 88 | ```c
 89 | printf("%s\n", getStringPointer(string));
 90 | ```
 91 | 
 92 | **Advantage #2**: accessing individual chars is straightforward. C is a low level language so this is an important operation in many programs. With SDS strings accessing individual chars is very natural:
 93 | 
 94 | ```c
 95 | printf("%c %c\n", s[0], s[1]);
 96 | ```
 97 | 
 98 | With other libraries your best chance is to assign `string->buf` (or call the function to get the string pointer) to a `char` pointer and work with this. However since the other libraries may reallocate the buffer implicitly every time you call a function that may modify the string you have to get a reference to the buffer again.
 99 | 
100 | **Advantage #3**: single allocation has better cache locality. Usually when you access a string created by a string library using a structure, you have two different allocations for the structure representing the string, and the actual buffer holding the string. Over the time the buffer is reallocated, and it is likely that it ends in a totally different part of memory compared to the structure itself. Since modern programs performances are often dominated by cache misses, SDS may perform better in many workloads.
101 | 
102 | SDS basics
103 | ===
104 | 
105 | The type of SDS strings is just the char pointer `char *`. However SDS defines
106 | an `sds` type as alias of `char *` in its header file: you should use the
107 | `sds` type in order to make sure you remember that a given variable in your
108 | program holds an SDS string and not a C string, however this is not mandatory.
109 | 
110 | This is the simplest SDS program you can write that does something:
111 | 
112 | ```c
113 | sds mystring = sdsnew("Hello World!");
114 | printf("%s\n", mystring);
115 | sdsfree(mystring);
116 | 
117 | output> Hello World!
118 | ```
119 | 
120 | The above small program already shows a few important things about SDS:
121 | 
122 | * SDS strings are created, and heap allocated, via the `sdsnew()` function, or other similar functions that we'll see in a moment.
123 | * SDS strings can be passed to `printf()` like any other C string.
124 | * SDS strings require to be freed with `sdsfree()`, since they are heap allocated.
125 | 
126 | Creating SDS strings
127 | ---
128 | 
129 | ```c
130 | sds sdsnewlen(const void *init, size_t initlen);
131 | sds sdsnew(const char *init);
132 | sds sdsempty(void);
133 | sds sdsdup(const sds s);
134 | ```
135 | 
136 | There are many ways to create SDS strings:
137 | 
138 | * The `sdsnew` function creates an SDS string starting from a C null terminated string. We already saw how it works in the above example.
139 | * The `sdsnewlen` function is similar to `sdsnew` but instead of creating the string assuming that the input string is null terminated, it gets an additional length parameter. This way you can create a string using binary data:
140 | 
141 |     ```c
142 |     char buf[3];
143 |     sds mystring;
144 | 
145 |     buf[0] = 'A';
146 |     buf[1] = 'B';
147 |     buf[2] = 'C';
148 |     mystring = sdsnewlen(buf,3);
149 |     printf("%s of len %d\n", mystring, (int) sdslen(mystring));
150 | 
151 |     output> ABC of len 3
152 |     ```
153 | 
154 |   Note: `sdslen` return value is casted to `int` because it returns a `size_t`
155 | type. You can use the right `printf` specifier instead of casting.
156 | 
157 | * The `sdsempty()` function creates an empty zero-length string:
158 | 
159 |     ```c
160 |     sds mystring = sdsempty();
161 |     printf("%d\n", (int) sdslen(mystring));
162 | 
163 |     output> 0
164 |     ```
165 | 
166 | * The `sdsdup()` function duplicates an already existing SDS string:
167 | 
168 |     ```c
169 |     sds s1, s2;
170 | 
171 |     s1 = sdsnew("Hello");
172 |     s2 = sdsdup(s1);
173 |     printf("%s %s\n", s1, s2);
174 | 
175 |     output> Hello Hello
176 |     ```
177 | 
178 | Obtaining the string length
179 | ---
180 | 
181 | ```c
182 | size_t sdslen(const sds s);
183 | ```
184 | 
185 | In the examples above we already used the `sdslen` function in order to get
186 | the length of the string. This function works like `strlen` of the libc
187 | except that:
188 | 
189 | * It runs in constant time since the length is stored in the prefix of SDS strings, so calling `sdslen` is not expensive even when called with very large strings.
190 | * The function is binary safe like any other SDS string function, so the length is the true length of the string regardless of the content, there is no problem if the string includes null term characters in the middle.
191 | 
192 | As an example of the binary safeness of SDS strings, we can run the following
193 | code:
194 | 
195 | ```c
196 | sds s = sdsnewlen("A\0\0B",4);
197 | printf("%d\n", (int) sdslen(s));
198 | 
199 | output> 4
200 | ```
201 | 
202 | Note that SDS strings are always null terminated at the end, so even in that
203 | case `s[4]` will be a null term, however printing the string with `printf`
204 | would result in just `"A"` to be printed since libc will treat the SDS string
205 | like a normal C string.
206 | 
207 | Destroying strings
208 | ---
209 | 
210 | ```c
211 | void sdsfree(sds s);
212 | ```
213 | 
214 | The destroy an SDS string there is just to call `sdsfree` with the string
215 | pointer. However note that empty strings created with `sdsempty` need to be
216 | destroyed as well otherwise they'll result into a memory leak.
217 | 
218 | The function `sdsfree` does not perform any operation if instead of an SDS
219 | string pointer, `NULL` is passed, so you don't need to check for `NULL` explicitly before calling it:
220 | 
221 | ```c
222 | if (string) sdsfree(string); /* Not needed. */
223 | sdsfree(string); /* Same effect but simpler. */
224 | ```
225 | 
226 | Concatenating strings
227 | ---
228 | 
229 | Concatenating strings to other strings is likely the operation you will end
230 | using the most with a dynamic C string library. SDS provides different
231 | functions to concatenate strings to existing strings.
232 | 
233 | ```c
234 | sds sdscatlen(sds s, const void *t, size_t len);
235 | sds sdscat(sds s, const char *t);
236 | ```
237 | 
238 | The main string concatenation functions are `sdscatlen` and `sdscat` that are
239 | identical, the only difference being that `sdscat` does not have an explicit
240 | length argument since it expects a null terminated string.
241 | 
242 | ```c
243 | sds s = sdsempty();
244 | s = sdscat(s, "Hello ");
245 | s = sdscat(s, "World!");
246 | printf("%s\n", s);
247 | 
248 | output> Hello World!
249 | ```
250 | 
251 | Sometimes you want to cat an SDS string to another SDS string, so you don't
252 | need to specify the length, but at the same time the string does not need to
253 | be null terminated but can contain any binary data. For this there is a
254 | special function:
255 | 
256 | ```c
257 | sds sdscatsds(sds s, const sds t);
258 | ```
259 | 
260 | Usage is straightforward:
261 | 
262 | ```c
263 | sds s1 = sdsnew("aaa");
264 | sds s2 = sdsnew("bbb");
265 | s1 = sdscatsds(s1,s2);
266 | sdsfree(s2);
267 | printf("%s\n", s1);
268 | 
269 | output> aaabbb
270 | ```
271 | 
272 | Sometimes you don't want to append any special data to the string, but you want
273 | to make sure that there are at least a given number of bytes composing the
274 | whole string.
275 | 
276 | ```c
277 | sds sdsgrowzero(sds s, size_t len);
278 | ```
279 | 
280 | The `sdsgrowzero` function will do nothing if the current string length is
281 | already `len` bytes, otherwise it will enlarge the string to `len` just padding
282 | it with zero bytes.
283 | 
284 | ```c
285 | sds s = sdsnew("Hello");
286 | s = sdsgrowzero(s,6);
287 | s[5] = '!'; /* We are sure this is safe because of sdsgrowzero() */
288 | printf("%s\n', s);
289 | 
290 | output> Hello!
291 | ```
292 | 
293 | Formatting strings
294 | ---
295 | 
296 | There is a special string concatenation function that accepts a `printf` alike
297 | format specifier and cats the formatted string to the specified string.
298 | 
299 | ```c
300 | sds sdscatprintf(sds s, const char *fmt, ...) {
301 | ```
302 | 
303 | Example:
304 | 
305 | ```c
306 | sds s;
307 | int a = 10, b = 20;
308 | s = sdsnew("The sum is: ");
309 | s = sdscatprintf(s,"%d+%d = %d",a,b,a+b);
310 | ```
311 | 
312 | Often you need to create SDS string directly from `printf` format specifiers.
313 | Because `sdscatprintf` is actually a function that concatenates strings all
314 | you need is to concatenate your string to an empty string:
315 | 
316 | 
317 | ```c
318 | char *name = "Anna";
319 | int loc = 2500;
320 | sds s;
321 | s = sdscatprintf(sdsempty(), "%s wrote %d lines of LISP\n", name, loc);
322 | ```
323 | 
324 | You can use `sdscatprintf` in order to convert numbers into SDS strings:
325 | 
326 | ```c
327 | int some_integer = 100;
328 | sds num = sdscatprintf(sdsempty(),"%d\n", some_integer);
329 | ```
330 | 
331 | However this is slow and we have a special function to make it efficient.
332 | 
333 | Fast number to string operations
334 | ---
335 | 
336 | Creating an SDS string from an integer may be a common operation in certain
337 | kind of programs, and while you may do this with `sdscatprintf` the performance
338 | hit is big, so SDS provides a specialized function.
339 | 
340 | ```c
341 | sds sdsfromlonglong(long long value);
342 | ```
343 | 
344 | Use it like this:
345 | 
346 | ```c
347 | sds s = sdsfromlonglong(10000);
348 | printf("%d\n", (int) sdslen(s));
349 | 
350 | output> 5
351 | ```
352 | 
353 | Trimming strings and getting ranges
354 | ---
355 | 
356 | String trimming is a common operation where a set of characters are
357 | removed from the left and the right of the string. Another useful operation
358 | regarding strings is the ability to just take a range out of a larger
359 | string.
360 | 
361 | ```c
362 | void sdstrim(sds s, const char *cset);
363 | void sdsrange(sds s, int start, int end);
364 | ```
365 | 
366 | SDS provides both the operations with the `sdstrim` and `sdsrange` functions.
367 | However note that both functions work differently than most functions modifying
368 | SDS strings since the return value is null: basically those functions always
369 | destructively modify the passed SDS string, never allocating a new one, because
370 | both trimming and ranges will never need more room: the operations can only
371 | remove characters from the original strings.
372 | 
373 | Because of this behavior, both functions are fast and don't involve reallocation.
374 | 
375 | This is an example of string trimming where newlines and spaces are removed
376 | from an SDS strings:
377 | 
378 | ```c
379 | sds s = sdsnew("         my string\n\n  ");
380 | sdstrim(s," \n");
381 | printf("-%s-\n",s);
382 | 
383 | output> -my string-
384 | ```
385 | 
386 | Basically `sdstrim` takes the SDS string to trim as first argument, and a
387 | null terminated set of characters to remove from left and right of the string.
388 | The characters are removed as long as they are not interrupted by a character
389 | that is not in the list of characters to trim: this is why the space between
390 | `"my"` and `"string"` was preserved in the above example.
391 | 
392 | Taking ranges is similar, but instead to take a set of characters, it takes
393 | to indexes, representing the start and the end as specified by zero-based
394 | indexes inside the string, to obtain the range that will be retained.
395 | 
396 | ```c
397 | sds s = sdsnew("Hello World!");
398 | sdsrange(s,1,4);
399 | printf("-%s-\n");
400 | 
401 | output> -ello-
402 | ```
403 | 
404 | Indexes can be negative to specify a position starting from the end of the
405 | string, so that `-1` means the last character, `-2` the penultimate, and so forth:
406 | 
407 | ```c
408 | sds s = sdsnew("Hello World!");
409 | sdsrange(s,6,-1);
410 | printf("-%s-\n");
411 | sdsrange(s,0,-2);
412 | printf("-%s-\n");
413 | 
414 | output> -World!-
415 | output> -World-
416 | ```
417 | 
418 | `sdsrange` is very useful when implementing networking servers processing
419 | a protocol or sending messages. For example the following code is used
420 | implementing the write handler of the Redis Cluster message bus between
421 | nodes:
422 | 
423 | ```c
424 | void clusterWriteHandler(..., int fd, void *privdata, ...) {
425 |     clusterLink *link = (clusterLink*) privdata;
426 |     ssize_t nwritten = write(fd, link->sndbuf, sdslen(link->sndbuf));
427 |     if (nwritten <= 0) {
428 |         /* Error handling... */
429 |     }
430 |     sdsrange(link->sndbuf,nwritten,-1);
431 |     ... more code here ...
432 | }
433 | ```
434 | 
435 | Every time the socket of the node we want to send the message to is writable
436 | we attempt to write as much bytes as possible, and we use `sdsrange` in order
437 | to remove from the buffer what was already sent.
438 | 
439 | The function to queue new messages to send to some node in the cluster will
440 | simply use `sdscatlen` in order to put more data in the send buffer.
441 | 
442 | Note that the Redis Cluster bus implements a binary protocol, but since SDS
443 | is binary safe this is not a problem, so the goal of SDS is not just to provide
444 | an high level string API for the C programmer but also dynamically allocated
445 | buffers that are easy to manage.
446 | 
447 | String copying
448 | ---
449 | 
450 | The most dangerous and infamus function of the standard C library is probably
451 | `strcpy`, so perhaps it is funny how in the context of better designed dynamic
452 | string libraries the concept of copying strings is almost irrelevant. Usually
453 | what you do is to create strings with the content you want, or concatenating
454 | more content as needed.
455 | 
456 | However SDS features a string copy function that is useful in performance
457 | critical code sections, however I guess its practical usefulness is limited
458 | as the function never managed to get called in the context of the 50k
459 | lines of code composing the Redis code base.
460 | 
461 | ```c
462 | sds sdscpylen(sds s, const char *t, size_t len);
463 | sds sdscpy(sds s, const char *t);
464 | ```
465 | 
466 | The string copy function of SDS is called `sdscpylen` and works like that:
467 | 
468 | ```c
469 | s = sdsnew("Hello World!");
470 | s = sdscpylen(s,"Hello Superman!",15);
471 | ```
472 | 
473 | As you can see the function receives as input the SDS string `s`, but also
474 | returns an SDS string. This is common to many SDS functions that modify the
475 | string: this way the returned SDS string may be the original one modified
476 | or a newly allocated one (for example if there was not enough room in the
477 | old SDS string).
478 | 
479 | The `sdscpylen` will simply replace what was in the old SDS string with the
480 | new data you pass using the pointer and length argument. There is a similar
481 | function called `sdscpy` that does not need a length but expects a null
482 | terminated string instead.
483 | 
484 | You may wonder why it makes sense to have a string copy function in the
485 | SDS library, since you can simply create a new SDS string from scratch
486 | with the new value instead of copying the value in an existing SDS string.
487 | The reason is efficiency: `sdsnewlen` will always allocate a new string
488 | while `sdscpylen` will try to reuse the existing string if there is enough
489 | room to old the new content specified by the user, and will allocate a new
490 | one only if needed.
491 | 
492 | Quoting strings
493 | ---
494 | 
495 | In order to provide consistent output to the program user, or for debugging
496 | purposes, it is often important to turn a string that may contain binary
497 | data or special characters into a quoted string. Here for quoted string
498 | we mean the common format for String literals in programming source code.
499 | However today this format is also part of the well known serialization formats
500 | like JSON and CSV, so it definitely escaped the simple gaol of representing
501 | literals strings in the source code of programs.
502 | 
503 | An example of quoted string literal is the following:
504 | 
505 | ```c
506 | "\x00Hello World\n"
507 | ```
508 | 
509 | The first byte is a zero byte while the last byte is a newline, so there are
510 | two non alphanumerical characters inside the string.
511 | 
512 | SDS uses a concatenation function for this goal, that concatenates to an
513 | existing string the quoted string representation of the input string.
514 | 
515 | ```c
516 | sds sdscatrepr(sds s, const char *p, size_t len);
517 | ```
518 | 
519 | The `scscatrepr` (where `repr` means *representation*) follows the usualy
520 | SDS string function rules accepting a char pointer and a length, so you can
521 | use it with SDS strings, normal C strings by using strlen() as `len` argument,
522 | or binary data. The following is an example usage:
523 | 
524 | ```c
525 | sds s1 = sdsnew("abcd");
526 | sds s2 = sdsempty();
527 | s[1] = 1;
528 | s[2] = 2;
529 | s[3] = '\n';
530 | s2 = sdscatrepr(s2,s1,sdslen(s1));
531 | printf("%s\n", s2);
532 | 
533 | output> "a\x01\x02\n"
534 | ```
535 | 
536 | This is the rules `sdscatrepr` uses for conversion:
537 | 
538 | * `\` and `"` are quoted with a backslash.
539 | * It quotes special characters `'\n'`, `'\r'`, `'\t'`, `'\a'` and `'\b'`.
540 | * All the other non printable characters not passing the `isprint` test are quoted in `\x..` form, that is: backslash followed by `x` followed by two digit hex number representing the character byte value.
541 | * The function always adds initial and final double quotes characters.
542 | 
543 | There is an SDS function that is able to perform the reverse conversion and is
544 | documented in the *Tokenization* paragraph below.
545 | 
546 | Tokenization
547 | ---
548 | 
549 | Tokenization is the process of splitting a larger string into smaller strings.
550 | In this specific case, the split is performed specifying another string that
551 | acts as separator. For example in the following string there are two substrings
552 | that are separated by the `|-|` separator:
553 | 
554 | ```
555 | foo|-|bar|-|zap
556 | ```
557 | 
558 | A more common separator that consists of a single character is the comma:
559 | 
560 | ```
561 | foo,bar,zap
562 | ```
563 | 
564 | In many progrems it is useful to process a line in order to obtain the sub
565 | strings it is composed of, so SDS provides a function that returns an
566 | array of SDS strings given a string and a separator.
567 | 
568 | ```c
569 | sds *sdssplitlen(const char *s, int len, const char *sep, int seplen, int *count);
570 | void sdsfreesplitres(sds *tokens, int count);
571 | ```
572 | 
573 | As usually the function can work with both SDS strings or normal C strings.
574 | The first two arguments `s` and `len` specify the string to tokenize, and the
575 | other two arguments `sep` and `seplen` the separator to use during the
576 | tokenization. The final argument `count` is a pointer to an integer that will
577 | be set to the number of tokens (sub strings) returned.
578 | 
579 | The return value is a heap allocated array of SDS strings.
580 | 
581 | ```c
582 | sds *tokens;
583 | int count, j;
584 | 
585 | sds line = sdsnew("Hello World!");
586 | tokens = sdssplitlen(line,sdslen(line)," ",1,&count);
587 | 
588 | for (j = 0; j < count; j++)
589 |     printf("%s\n", tokens[j]);
590 | sdsfreesplitres(tokens,count);
591 | 
592 | output> Hello
593 | output> World!
594 | ```
595 | 
596 | The returned array is heap allocated, and the single elements of the array
597 | are normal SDS strings. You can free everything calling `sdsfreesplitres`
598 | as in the example. Alternativey you are free to release the array yourself
599 | using the `free` function and use and/or free the individual SDS strings
600 | as usually.
601 | 
602 | A valid approach is to set the array elements you reused in some way to
603 | `NULL`, and use `sdsfreesplitres` to free all the rest.
604 | 
605 | Command line oriented tokenization
606 | ---
607 | 
608 | Splitting by a separator is a useful operation, but usually it is not enough
609 | to perform one of the most common tasks involving some non trivial string
610 | manipulation, that is, implementing a **Command Line Interface** for a program.
611 | 
612 | This is why SDS also provides an additional function that allows you to split
613 | arguments provided by the user via the keyboard in an interactive manner, or
614 | via a file, network, or any other mean, into tokens.
615 | 
616 | ```c
617 | sds *sdssplitargs(const char *line, int *argc);
618 | ```
619 | 
620 | The `sdssplitargs` function returns an array of SDS strings exactly like
621 | `sdssplitlen`. The function to free the result is also identical, and is
622 | `sdsfreesplitres`. The difference is in the way the tokenization is performed.
623 | 
624 | For example if the input is the following line:
625 | 
626 | ```
627 | call "Sabrina"    and "Mark Smith\n"
628 | ```
629 | 
630 | The function will return the following tokens:
631 | 
632 | * "call"
633 | * "Sabrina"
634 | * "and"
635 | * "Mark Smith\n"
636 | 
637 | Basically different tokens need to be separated by one or more spaces, and
638 | every single token can also be a quoted string in the same format that
639 | `sdscatrepr` is able to emit.
640 | 
641 | String joining
642 | ---
643 | 
644 | There are two functions doing the reverse of tokenization by joining strings
645 | into a single one.
646 | 
647 | ```c
648 | sds sdsjoin(char **argv, int argc, char *sep, size_t seplen);
649 | sds sdsjoinsds(sds *argv, int argc, const char *sep, size_t seplen);
650 | ```
651 | 
652 | The two functions take as input an array of strings of length `argc` and
653 | a separator and its length, and produce as output an SDS string consisting
654 | of all the specified strings separated by the specified separator.
655 | 
656 | The difference between `sdsjoin` and `sdsjoinsds` is that the former accept
657 | C null terminated strings as input while the latter requires all the strings
658 | in the array to be SDS strings. However because of this only `sdsjoinsds` is
659 | able to deal with binary data.
660 | 
661 | ```c
662 | char *tokens[3] = {"foo","bar","zap"};
663 | sds s = sdsjoin(tokens,3,"|",1);
664 | printf("%s\n", s);
665 | 
666 | output> foo|bar|zap
667 | ```
668 | 
669 | Error handling
670 | ---
671 | 
672 | All the SDS functions that return an SDS pointer may also return `NULL` on
673 | out of memory, this is basically the only check you need to perform.
674 | 
675 | However many modern C programs handle out of memory simply aborting the program
676 | so you may want to do this as well by wrapping `malloc` and other related
677 | memory allocation calls directly.
678 | 
679 | SDS internals and advanced usage
680 | ===
681 | 
682 | At the very beginning of this documentation it was explained how SDS strings
683 | are allocated, however the prefix stored before the pointer returned to the
684 | user was classified as an *header* without further details. For an advanced
685 | usage it is better to dig more into the internals of SDS and show the
686 | structure implementing it:
687 | 
688 | ```c
689 | struct sdshdr {
690 |     int len;
691 |     int free;
692 |     char buf[];
693 | };
694 | ```
695 | 
696 | As you can see, the structure may resemble the one of a conventional string
697 | library, however the `buf` field of the structure is different since it is
698 | not a pointer but an array without any length declared, so `buf` actually
699 | points at the first byte just after the `free` integer. So in order to create
700 | an SDS string we just allocate a piece of memory that is as large as the
701 | `sdshdr` structure plus the length of our string, plus an additional byte
702 | for the mandatory null term that every SDS string has.
703 | 
704 | The `len` field of the structure is quite obvious, and is the current length
705 | of the SDS string, always computed every time the string is modified via
706 | SDS function calls. The `free` field instead represents the amount of free
707 | memory in the current allocation that can be used to store more characters.
708 | 
709 | So the actual SDS layout is this one:
710 | 
711 |     +------------+------------------------+-----------+---------------\
712 |     | Len | Free | H E L L O W O R L D \n | Null term |  Free space   \
713 |     +------------+------------------------+-----------+---------------\
714 |                  |
715 |                  `-> Pointer returned to the user.
716 | 
717 | You may wonder why there is some free space at the end of the string, it
718 | looks like a waste. Actually after a new SDS string is created, there is no
719 | free space at the end at all: the allocation will be as small as possible to
720 | just hold the header, string, and null term. However other access patterns
721 | will create extra free space at the end, like in the following program:
722 | 
723 | ```c
724 | s = sdsempty();
725 | s = sdscat(s,"foo");
726 | s = sdscat(s,"bar");
727 | s = sdscat(s,"123");
728 | ```
729 | 
730 | Since SDS tries to be efficient it can't afford to reallocate the string every
731 | time new data is appended, since this would be very inefficient, so it uses
732 | the **preallocation of some free space** every time you enlarge the string.
733 | 
734 | The preallocation algorithm used is the following: every time the string
735 | is reallocated in order to hold more bytes, the actual allocation size performed
736 | is two times the minimum required. So for instance if the string currently
737 | is holding 30 bytes, and we concatenate 2 more bytes, instead of allocating 32
738 | bytes in total SDS will allocate 64 bytes.
739 | 
740 | However there is an hard limit to the allocation it can perform ahead, and is
741 | defined by `SDS_MAX_PREALLOC`. SDS will never allocate more than 1MB of
742 | additional space (by default, you can change this default).
743 | 
744 | Shrinking strings
745 | ---
746 | 
747 | ```c
748 | sds sdsRemoveFreeSpace(sds s);
749 | size_t sdsAllocSize(sds s);
750 | ```
751 | 
752 | Sometimes there are class of programs that require to use very little memory.
753 | After strings concatenations, trimming, ranges, the string may end having
754 | a non trivial amount of additional space at the end.
755 | 
756 | It is possible to resize a string back to its minimal size in order to hold
757 | the current content by using the function `sdsRemoveFreeSpace`.
758 | 
759 | ```c
760 | s = sdsRemoveFreeSpace(s);
761 | ```
762 | 
763 | There is also a function that can be used in order to get the size of the
764 | total allocation for a given string, and is called `sdsAllocSize`.
765 | 
766 | ```c
767 | sds s = sdsnew("Ladies and gentlemen");
768 | s = sdscat(s,"... welcome to the C language.");
769 | printf("%d\n", (int) sdsAllocSize(s));
770 | s = sdsRemoveFreeSpace(s);
771 | printf("%d\n", (int) sdsAllocSize(s));
772 | 
773 | output> 109
774 | output> 59
775 | ```
776 | 
777 | NOTE: SDS Low level API use cammelCase in order to warn you that you are playing with the fire.
778 | 
779 | Manual modifications of SDS strings
780 | ---
781 | 
782 |     void sdsupdatelen(sds s);
783 | 
784 | Sometimes you may want to hack with an SDS string manually, without using
785 | SDS functions. In the following example we implicitly change the length
786 | of the string, however we want the logical length to reflect the null terminated
787 | C string.
788 | 
789 | The function `sdsupdatelen` does just that, updating the internal length
790 | information for the specified string to the length obtained via `strlen`.
791 | 
792 | ```c
793 | sds s = sdsnew("foobar");
794 | s[2] = '\0';
795 | printf("%d\n", sdslen(s));
796 | sdsupdatelen(s);
797 | printf("%d\n", sdslen(s));
798 | 
799 | output> 6
800 | output> 2
801 | ```
802 | 
803 | Sharing SDS strings
804 | ---
805 | 
806 | If you are writing a program in which it is advantageous to share the same
807 | SDS string across different data structures, it is absolutely advised to
808 | encapsulate SDS strings into structures that remember the number of references
809 | of the string, with functions to increment and decrement the number of references.
810 | 
811 | This approach is a memory management technique called *reference counting* and
812 | in the context of SDS has two advantages:
813 | 
814 | * It is less likely that you'll create memory leaks or bugs due to non freeing SDS strings or freeing already freed strings.
815 | * You'll not need to update every reference to an SDS string when you modify it (since the new SDS string may point to a different memory location).
816 | 
817 | While this is definitely a very common programming technique I'll outline
818 | the basic ideas here. You create a structure like that:
819 | 
820 | ```c
821 | struct mySharedStrings {
822 |     int refcount;
823 |     sds string;
824 | }
825 | ```
826 | 
827 | When new strings are created, the structure is allocated and returned with
828 | `refcount` set to 1. The you have two functions to change the reference count
829 | of the shared string:
830 | 
831 | * `incrementStringRefCount` will simply increment `refcount` of 1 in the structure. It will be called every time you add a reference to the string on some new data structure, variable, or whatever.
832 | * `decrementStringRefCount` is used when you remove a reference. This function is however special since when the `refcount` drops to zero, it automatically frees the SDS string, and the `mySharedString` structure as well.
833 | 
834 | Interactions with heap checkers
835 | ---
836 | 
837 | Because SDS returns pointers into the middle of memory chunks allocated with
838 | `malloc`, heap checkers may have issues, however:
839 | 
840 | * The popular Valgrind program will detect SDS strings are *possibly lost* memory and never as *definitely lost*, so it is easy to tell if there is a leak or not. I used Valgrind with Redis for years and every real leak was consistently detected as "definitely lost".
841 | * OSX instrumentation tools don't detect SDS strings as leaks but are able to correctly handle pointers pointing to the middle of memory chunks.
842 | 
843 | Zero copy append from syscalls
844 | ----
845 | 
846 | At this point you should have all the tools to dig more inside the SDS
847 | library by reading the source code, however there is an interesting pattern
848 | you can mount using the low level API exported, that is used inside Redis
849 | in order to improve performances of the networking code.
850 | 
851 | Using `sdsIncrLen()` and `sdsMakeRoomFor()` it is possible to mount the
852 | following schema, to cat bytes coming from the kernel to the end of an
853 | sds string without copying into an intermediate buffer:
854 | 
855 | ```c
856 | oldlen = sdslen(s);
857 | s = sdsMakeRoomFor(s, BUFFER_SIZE);
858 | nread = read(fd, s+oldlen, BUFFER_SIZE);
859 | ... check for nread <= 0 and handle it ...
860 | sdsIncrLen(s, nread);
861 | ```
862 | 
863 | `sdsIncrLen` is documented inside the source code of `sds.c`.
864 | 
865 | Embedding SDS into your project
866 | ===
867 | 
868 | This is as simple as copying the `sds.c` and `sds.h` files inside your
869 | project. The source code is small and every C99 compiler should deal with
870 | it without issues.
871 | 
872 | Credits and license
873 | ===
874 | 
875 | SDS was created by Salvatore Sanfilippo and is released under the BDS two clause license. See the LICENSE file in this source distribution for more information.
876 | 


--------------------------------------------------------------------------------
/ats-sds/sds/sds.c:
--------------------------------------------------------------------------------
  1 | /* SDS (Simple Dynamic Strings), A C dynamic strings library.
  2 |  *
  3 |  * Copyright (c) 2006-2014, Salvatore Sanfilippo <antirez at gmail dot com>
  4 |  * All rights reserved.
  5 |  *
  6 |  * Redistribution and use in source and binary forms, with or without
  7 |  * modification, are permitted provided that the following conditions are met:
  8 |  *
  9 |  *   * Redistributions of source code must retain the above copyright notice,
 10 |  *     this list of conditions and the following disclaimer.
 11 |  *   * Redistributions in binary form must reproduce the above copyright
 12 |  *     notice, this list of conditions and the following disclaimer in the
 13 |  *     documentation and/or other materials provided with the distribution.
 14 |  *   * Neither the name of Redis nor the names of its contributors may be used
 15 |  *     to endorse or promote products derived from this software without
 16 |  *     specific prior written permission.
 17 |  *
 18 |  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 19 |  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 20 |  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 21 |  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
 22 |  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 23 |  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 24 |  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 25 |  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 26 |  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 27 |  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 28 |  * POSSIBILITY OF SUCH DAMAGE.
 29 |  */
 30 | 
 31 | #include <stdio.h>
 32 | #include <stdlib.h>
 33 | #include <string.h>
 34 | #include <ctype.h>
 35 | #include <assert.h>
 36 | 
 37 | #include "sds.h"
 38 | 
 39 | /* Create a new sds string with the content specified by the 'init' pointer
 40 |  * and 'initlen'.
 41 |  * If NULL is used for 'init' the string is initialized with zero bytes.
 42 |  *
 43 |  * The string is always null-termined (all the sds strings are, always) so
 44 |  * even if you create an sds string with:
 45 |  *
 46 |  * mystring = sdsnewlen("abc",3");
 47 |  *
 48 |  * You can print the string with printf() as there is an implicit \0 at the
 49 |  * end of the string. However the string is binary safe and can contain
 50 |  * \0 characters in the middle, as the length is stored in the sds header. */
 51 | sds sdsnewlen(const void *init, size_t initlen) {
 52 |     struct sdshdr *sh;
 53 | 
 54 |     if (init) {
 55 |         sh = malloc(sizeof *sh+initlen+1);
 56 |     } else {
 57 |         sh = calloc(sizeof *sh+initlen+1,1);
 58 |     }
 59 |     if (sh == NULL) return NULL;
 60 |     sh->len = initlen;
 61 |     sh->free = 0;
 62 |     if (initlen && init)
 63 |         memcpy(sh->buf, init, initlen);
 64 |     sh->buf[initlen] = '\0';
 65 |     return (char*)sh->buf;
 66 | }
 67 | 
 68 | /* Create an empty (zero length) sds string. Even in this case the string
 69 |  * always has an implicit null term. */
 70 | sds sdsempty(void) {
 71 |     return sdsnewlen("",0);
 72 | }
 73 | 
 74 | /* Create a new sds string starting from a null termined C string. */
 75 | sds sdsnew(const char *init) {
 76 |     size_t initlen = (init == NULL) ? 0 : strlen(init);
 77 |     return sdsnewlen(init, initlen);
 78 | }
 79 | 
 80 | /* Duplicate an sds string. */
 81 | sds sdsdup(const sds s) {
 82 |     return sdsnewlen(s, sdslen(s));
 83 | }
 84 | 
 85 | /* Free an sds string. No operation is performed if 's' is NULL. */
 86 | void sdsfree(sds s) {
 87 |     if (s == NULL) return;
 88 |     free(s-sizeof(struct sdshdr));
 89 | }
 90 | 
 91 | /* Set the sds string length to the length as obtained with strlen(), so
 92 |  * considering as content only up to the first null term character.
 93 |  *
 94 |  * This function is useful when the sds string is hacked manually in some
 95 |  * way, like in the following example:
 96 |  *
 97 |  * s = sdsnew("foobar");
 98 |  * s[2] = '\0';
 99 |  * sdsupdatelen(s);
100 |  * printf("%d\n", sdslen(s));
101 |  *
102 |  * The output will be "2", but if we comment out the call to sdsupdatelen()
103 |  * the output will be "6" as the string was modified but the logical length
104 |  * remains 6 bytes. */
105 | void sdsupdatelen(sds s) {
106 |     struct sdshdr *sh = (void*) (s-sizeof *sh);;
107 |     int reallen = strlen(s);
108 |     sh->free += (sh->len-reallen);
109 |     sh->len = reallen;
110 | }
111 | 
112 | /* Modify an sds string on-place to make it empty (zero length).
113 |  * However all the existing buffer is not discarded but set as free space
114 |  * so that next append operations will not require allocations up to the
115 |  * number of bytes previously available. */
116 | void sdsclear(sds s) {
117 |     struct sdshdr *sh = (void*) (s-sizeof *sh);;
118 |     sh->free += sh->len;
119 |     sh->len = 0;
120 |     sh->buf[0] = '\0';
121 | }
122 | 
123 | /* Enlarge the free space at the end of the sds string so that the caller
124 |  * is sure that after calling this function can overwrite up to addlen
125 |  * bytes after the end of the string, plus one more byte for nul term.
126 |  * 
127 |  * Note: this does not change the *length* of the sds string as returned
128 |  * by sdslen(), but only the free buffer space we have. */
129 | sds sdsMakeRoomFor(sds s, size_t addlen) {
130 |     struct sdshdr *sh, *newsh;
131 |     size_t free = sdsavail(s);
132 |     size_t len, newlen;
133 | 
134 |     if (free >= addlen) return s;
135 |     len = sdslen(s);
136 |     sh = (void*) (s-sizeof *sh);;
137 |     newlen = (len+addlen);
138 |     if (newlen < SDS_MAX_PREALLOC)
139 |         newlen *= 2;
140 |     else
141 |         newlen += SDS_MAX_PREALLOC;
142 |     newsh = realloc(sh, sizeof *newsh+newlen+1);
143 |     if (newsh == NULL) return NULL;
144 | 
145 |     newsh->free = newlen - len;
146 |     return newsh->buf;
147 | }
148 | 
149 | /* Reallocate the sds string so that it has no free space at the end. The
150 |  * contained string remains not altered, but next concatenation operations
151 |  * will require a reallocation.
152 |  *
153 |  * After the call, the passed sds string is no longer valid and all the
154 |  * references must be substituted with the new pointer returned by the call. */
155 | sds sdsRemoveFreeSpace(sds s) {
156 |     struct sdshdr *sh;
157 | 
158 |     sh = (void*) (s-sizeof *sh);;
159 |     sh = realloc(sh, sizeof *sh+sh->len+1);
160 |     sh->free = 0;
161 |     return sh->buf;
162 | }
163 | 
164 | /* Return the total size of the allocation of the specifed sds string,
165 |  * including:
166 |  * 1) The sds header before the pointer.
167 |  * 2) The string.
168 |  * 3) The free buffer at the end if any.
169 |  * 4) The implicit null term.
170 |  */
171 | size_t sdsAllocSize(sds s) {
172 |     struct sdshdr *sh = (void*) (s-sizeof *sh);;
173 | 
174 |     return sizeof(*sh)+sh->len+sh->free+1;
175 | }
176 | 
177 | /* Increment the sds length and decrements the left free space at the
178 |  * end of the string according to 'incr'. Also set the null term
179 |  * in the new end of the string.
180 |  *
181 |  * This function is used in order to fix the string length after the
182 |  * user calls sdsMakeRoomFor(), writes something after the end of
183 |  * the current string, and finally needs to set the new length.
184 |  *
185 |  * Note: it is possible to use a negative increment in order to
186 |  * right-trim the string.
187 |  *
188 |  * Usage example:
189 |  *
190 |  * Using sdsIncrLen() and sdsMakeRoomFor() it is possible to mount the
191 |  * following schema, to cat bytes coming from the kernel to the end of an
192 |  * sds string without copying into an intermediate buffer:
193 |  *
194 |  * oldlen = sdslen(s);
195 |  * s = sdsMakeRoomFor(s, BUFFER_SIZE);
196 |  * nread = read(fd, s+oldlen, BUFFER_SIZE);
197 |  * ... check for nread <= 0 and handle it ...
198 |  * sdsIncrLen(s, nread);
199 |  */
200 | void sdsIncrLen(sds s, int incr) {
201 |     struct sdshdr *sh = (void*) (s-sizeof *sh);;
202 | 
203 |     assert(sh->free >= incr);
204 |     sh->len += incr;
205 |     sh->free -= incr;
206 |     assert(sh->free >= 0);
207 |     s[sh->len] = '\0';
208 | }
209 | 
210 | /* Grow the sds to have the specified length. Bytes that were not part of
211 |  * the original length of the sds will be set to zero.
212 |  *
213 |  * if the specified length is smaller than the current length, no operation
214 |  * is performed. */
215 | sds sdsgrowzero(sds s, size_t len) {
216 |     struct sdshdr *sh = (void*) (s-sizeof *sh);
217 |     size_t totlen, curlen = sh->len;
218 | 
219 |     if (len <= curlen) return s;
220 |     s = sdsMakeRoomFor(s,len-curlen);
221 |     if (s == NULL) return NULL;
222 | 
223 |     /* Make sure added region doesn't contain garbage */
224 |     sh = (void*)(s-sizeof *sh);
225 |     memset(s+curlen,0,(len-curlen+1)); /* also set trailing \0 byte */
226 |     totlen = sh->len+sh->free;
227 |     sh->len = len;
228 |     sh->free = totlen-sh->len;
229 |     return s;
230 | }
231 | 
232 | /* Append the specified binary-safe string pointed by 't' of 'len' bytes to the
233 |  * end of the specified sds string 's'.
234 |  *
235 |  * After the call, the passed sds string is no longer valid and all the
236 |  * references must be substituted with the new pointer returned by the call. */
237 | sds sdscatlen(sds s, const void *t, size_t len) {
238 |     struct sdshdr *sh;
239 |     size_t curlen = sdslen(s);
240 | 
241 |     s = sdsMakeRoomFor(s,len);
242 |     if (s == NULL) return NULL;
243 |     sh = (void*) (s-sizeof *sh);;
244 |     memcpy(s+curlen, t, len);
245 |     sh->len = curlen+len;
246 |     sh->free = sh->free-len;
247 |     s[curlen+len] = '\0';
248 |     return s;
249 | }
250 | 
251 | /* Append the specified null termianted C string to the sds string 's'.
252 |  *
253 |  * After the call, the passed sds string is no longer valid and all the
254 |  * references must be substituted with the new pointer returned by the call. */
255 | sds sdscat(sds s, const char *t) {
256 |     return sdscatlen(s, t, strlen(t));
257 | }
258 | 
259 | /* Append the specified sds 't' to the existing sds 's'.
260 |  *
261 |  * After the call, the modified sds string is no longer valid and all the
262 |  * references must be substituted with the new pointer returned by the call. */
263 | sds sdscatsds(sds s, const sds t) {
264 |     return sdscatlen(s, t, sdslen(t));
265 | }
266 | 
267 | /* Destructively modify the sds string 's' to hold the specified binary
268 |  * safe string pointed by 't' of length 'len' bytes. */
269 | sds sdscpylen(sds s, const char *t, size_t len) {
270 |     struct sdshdr *sh = (void*) (s-sizeof *sh);;
271 |     size_t totlen = sh->free+sh->len;
272 | 
273 |     if (totlen < len) {
274 |         s = sdsMakeRoomFor(s,len-sh->len);
275 |         if (s == NULL) return NULL;
276 |         sh = (void*) (s-sizeof *sh);;
277 |         totlen = sh->free+sh->len;
278 |     }
279 |     memcpy(s, t, len);
280 |     s[len] = '\0';
281 |     sh->len = len;
282 |     sh->free = totlen-len;
283 |     return s;
284 | }
285 | 
286 | /* Like sdscpylen() but 't' must be a null-termined string so that the length
287 |  * of the string is obtained with strlen(). */
288 | sds sdscpy(sds s, const char *t) {
289 |     return sdscpylen(s, t, strlen(t));
290 | }
291 | 
292 | /* Like sdscatpritf() but gets va_list instead of being variadic. */
293 | sds sdscatvprintf(sds s, const char *fmt, va_list ap) {
294 |     va_list cpy;
295 |     char *buf, *t;
296 |     size_t buflen = 16;
297 | 
298 |     while(1) {
299 |         buf = malloc(buflen);
300 |         if (buf == NULL) return NULL;
301 |         buf[buflen-2] = '\0';
302 |         va_copy(cpy,ap);
303 |         vsnprintf(buf, buflen, fmt, cpy);
304 |         if (buf[buflen-2] != '\0') {
305 |             free(buf);
306 |             buflen *= 2;
307 |             continue;
308 |         }
309 |         break;
310 |     }
311 |     t = sdscat(s, buf);
312 |     free(buf);
313 |     return t;
314 | }
315 | 
316 | /* Append to the sds string 's' a string obtained using printf-alike format
317 |  * specifier.
318 |  *
319 |  * After the call, the modified sds string is no longer valid and all the
320 |  * references must be substituted with the new pointer returned by the call.
321 |  *
322 |  * Example:
323 |  *
324 |  * s = sdsempty("Sum is: ");
325 |  * s = sdscatprintf(s,"%d+%d = %d",a,b,a+b).
326 |  *
327 |  * Often you need to create a string from scratch with the printf-alike
328 |  * format. When this is the need, just use sdsempty() as the target string:
329 |  *
330 |  * s = sdscatprintf(sdsempty(), "... your format ...", args);
331 |  */
332 | sds sdscatprintf(sds s, const char *fmt, ...) {
333 |     va_list ap;
334 |     char *t;
335 |     va_start(ap, fmt);
336 |     t = sdscatvprintf(s,fmt,ap);
337 |     va_end(ap);
338 |     return t;
339 | }
340 | 
341 | /* Remove the part of the string from left and from right composed just of
342 |  * contiguous characters found in 'cset', that is a null terminted C string.
343 |  *
344 |  * After the call, the modified sds string is no longer valid and all the
345 |  * references must be substituted with the new pointer returned by the call.
346 |  *
347 |  * Example:
348 |  *
349 |  * s = sdsnew("AA...AA.a.aa.aHelloWorld     :::");
350 |  * s = sdstrim(s,"A. :");
351 |  * printf("%s\n", s);
352 |  *
353 |  * Output will be just "Hello World".
354 |  */
355 | void sdstrim(sds s, const char *cset) {
356 |     struct sdshdr *sh = (void*) (s-sizeof *sh);;
357 |     char *start, *end, *sp, *ep;
358 |     size_t len;
359 | 
360 |     sp = start = s;
361 |     ep = end = s+sdslen(s)-1;
362 |     while(sp <= end && strchr(cset, *sp)) sp++;
363 |     while(ep > start && strchr(cset, *ep)) ep--;
364 |     len = (sp > ep) ? 0 : ((ep-sp)+1);
365 |     if (sh->buf != sp) memmove(sh->buf, sp, len);
366 |     sh->buf[len] = '\0';
367 |     sh->free = sh->free+(sh->len-len);
368 |     sh->len = len;
369 | }
370 | 
371 | /* Turn the string into a smaller (or equal) string containing only the
372 |  * substring specified by the 'start' and 'end' indexes.
373 |  *
374 |  * start and end can be negative, where -1 means the last character of the
375 |  * string, -2 the penultimate character, and so forth.
376 |  *
377 |  * The interval is inclusive, so the start and end characters will be part
378 |  * of the resulting string.
379 |  *
380 |  * The string is modified in-place.
381 |  *
382 |  * Example:
383 |  *
384 |  * s = sdsnew("Hello World");
385 |  * sdsrange(s,1,-1); => "ello World"
386 |  */
387 | void sdsrange(sds s, int start, int end) {
388 |     struct sdshdr *sh = (void*) (s-sizeof *sh);;
389 |     size_t newlen, len = sdslen(s);
390 | 
391 |     if (len == 0) return;
392 |     if (start < 0) {
393 |         start = len+start;
394 |         if (start < 0) start = 0;
395 |     }
396 |     if (end < 0) {
397 |         end = len+end;
398 |         if (end < 0) end = 0;
399 |     }
400 |     newlen = (start > end) ? 0 : (end-start)+1;
401 |     if (newlen != 0) {
402 |         if (start >= (signed)len) {
403 |             newlen = 0;
404 |         } else if (end >= (signed)len) {
405 |             end = len-1;
406 |             newlen = (start > end) ? 0 : (end-start)+1;
407 |         }
408 |     } else {
409 |         start = 0;
410 |     }
411 |     if (start && newlen) memmove(sh->buf, sh->buf+start, newlen);
412 |     sh->buf[newlen] = 0;
413 |     sh->free = sh->free+(sh->len-newlen);
414 |     sh->len = newlen;
415 | }
416 | 
417 | /* Apply tolower() to every character of the sds string 's'. */
418 | void sdstolower(sds s) {
419 |     int len = sdslen(s), j;
420 | 
421 |     for (j = 0; j < len; j++) s[j] = tolower(s[j]);
422 | }
423 | 
424 | /* Apply toupper() to every character of the sds string 's'. */
425 | void sdstoupper(sds s) {
426 |     int len = sdslen(s), j;
427 | 
428 |     for (j = 0; j < len; j++) s[j] = toupper(s[j]);
429 | }
430 | 
431 | /* Compare two sds strings s1 and s2 with memcmp().
432 |  *
433 |  * Return value:
434 |  *
435 |  *     1 if s1 > s2.
436 |  *    -1 if s1 < s2.
437 |  *     0 if s1 and s2 are exactly the same binary string.
438 |  *
439 |  * If two strings share exactly the same prefix, but one of the two has
440 |  * additional characters, the longer string is considered to be greater than
441 |  * the smaller one. */
442 | int sdscmp(const sds s1, const sds s2) {
443 |     size_t l1, l2, minlen;
444 |     int cmp;
445 | 
446 |     l1 = sdslen(s1);
447 |     l2 = sdslen(s2);
448 |     minlen = (l1 < l2) ? l1 : l2;
449 |     cmp = memcmp(s1,s2,minlen);
450 |     if (cmp == 0) return l1-l2;
451 |     return cmp;
452 | }
453 | 
454 | /* Split 's' with separator in 'sep'. An array
455 |  * of sds strings is returned. *count will be set
456 |  * by reference to the number of tokens returned.
457 |  *
458 |  * On out of memory, zero length string, zero length
459 |  * separator, NULL is returned.
460 |  *
461 |  * Note that 'sep' is able to split a string using
462 |  * a multi-character separator. For example
463 |  * sdssplit("foo_-_bar","_-_"); will return two
464 |  * elements "foo" and "bar".
465 |  *
466 |  * This version of the function is binary-safe but
467 |  * requires length arguments. sdssplit() is just the
468 |  * same function but for zero-terminated strings.
469 |  */
470 | sds *sdssplitlen(const char *s, int len, const char *sep, int seplen, int *count) {
471 |     int elements = 0, slots = 5, start = 0, j;
472 |     sds *tokens;
473 | 
474 |     if (seplen < 1 || len < 0) return NULL;
475 | 
476 |     tokens = malloc(sizeof(sds)*slots);
477 |     if (tokens == NULL) return NULL;
478 | 
479 |     if (len == 0) {
480 |         *count = 0;
481 |         return tokens;
482 |     }
483 |     for (j = 0; j < (len-(seplen-1)); j++) {
484 |         /* make sure there is room for the next element and the final one */
485 |         if (slots < elements+2) {
486 |             sds *newtokens;
487 | 
488 |             slots *= 2;
489 |             newtokens = realloc(tokens,sizeof(sds)*slots);
490 |             if (newtokens == NULL) goto cleanup;
491 |             tokens = newtokens;
492 |         }
493 |         /* search the separator */
494 |         if ((seplen == 1 && *(s+j) == sep[0]) || (memcmp(s+j,sep,seplen) == 0)) {
495 |             tokens[elements] = sdsnewlen(s+start,j-start);
496 |             if (tokens[elements] == NULL) goto cleanup;
497 |             elements++;
498 |             start = j+seplen;
499 |             j = j+seplen-1; /* skip the separator */
500 |         }
501 |     }
502 |     /* Add the final element. We are sure there is room in the tokens array. */
503 |     tokens[elements] = sdsnewlen(s+start,len-start);
504 |     if (tokens[elements] == NULL) goto cleanup;
505 |     elements++;
506 |     *count = elements;
507 |     return tokens;
508 | 
509 | cleanup:
510 |     {
511 |         int i;
512 |         for (i = 0; i < elements; i++) sdsfree(tokens[i]);
513 |         free(tokens);
514 |         *count = 0;
515 |         return NULL;
516 |     }
517 | }
518 | 
519 | /* Free the result returned by sdssplitlen(), or do nothing if 'tokens' is NULL. */
520 | void sdsfreesplitres(sds *tokens, int count) {
521 |     if (!tokens) return;
522 |     while(count--)
523 |         sdsfree(tokens[count]);
524 |     free(tokens);
525 | }
526 | 
527 | /* Create an sds string from a long long value. It is much faster than:
528 |  *
529 |  * sdscatprintf(sdsempty(),"%lld\n", value);
530 |  */
531 | sds sdsfromlonglong(long long value) {
532 |     char buf[32], *p;
533 |     unsigned long long v;
534 | 
535 |     v = (value < 0) ? -value : value;
536 |     p = buf+31; /* point to the last character */
537 |     do {
538 |         *p-- = '0'+(v%10);
539 |         v /= 10;
540 |     } while(v);
541 |     if (value < 0) *p-- = '-';
542 |     p++;
543 |     return sdsnewlen(p,32-(p-buf));
544 | }
545 | 
546 | /* Append to the sds string "s" an escaped string representation where
547 |  * all the non-printable characters (tested with isprint()) are turned into
548 |  * escapes in the form "\n\r\a...." or "\x<hex-number>".
549 |  *
550 |  * After the call, the modified sds string is no longer valid and all the
551 |  * references must be substituted with the new pointer returned by the call. */
552 | sds sdscatrepr(sds s, const char *p, size_t len) {
553 |     s = sdscatlen(s,"\"",1);
554 |     while(len--) {
555 |         switch(*p) {
556 |         case '\\':
557 |         case '"':
558 |             s = sdscatprintf(s,"\\%c",*p);
559 |             break;
560 |         case '\n': s = sdscatlen(s,"\\n",2); break;
561 |         case '\r': s = sdscatlen(s,"\\r",2); break;
562 |         case '\t': s = sdscatlen(s,"\\t",2); break;
563 |         case '\a': s = sdscatlen(s,"\\a",2); break;
564 |         case '\b': s = sdscatlen(s,"\\b",2); break;
565 |         default:
566 |             if (isprint(*p))
567 |                 s = sdscatprintf(s,"%c",*p);
568 |             else
569 |                 s = sdscatprintf(s,"\\x%02x",(unsigned char)*p);
570 |             break;
571 |         }
572 |         p++;
573 |     }
574 |     return sdscatlen(s,"\"",1);
575 | }
576 | 
577 | /* Helper function for sdssplitargs() that returns non zero if 'c'
578 |  * is a valid hex digit. */
579 | int is_hex_digit(char c) {
580 |     return (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f') ||
581 |            (c >= 'A' && c <= 'F');
582 | }
583 | 
584 | /* Helper function for sdssplitargs() that converts a hex digit into an
585 |  * integer from 0 to 15 */
586 | int hex_digit_to_int(char c) {
587 |     switch(c) {
588 |     case '0': return 0;
589 |     case '1': return 1;
590 |     case '2': return 2;
591 |     case '3': return 3;
592 |     case '4': return 4;
593 |     case '5': return 5;
594 |     case '6': return 6;
595 |     case '7': return 7;
596 |     case '8': return 8;
597 |     case '9': return 9;
598 |     case 'a': case 'A': return 10;
599 |     case 'b': case 'B': return 11;
600 |     case 'c': case 'C': return 12;
601 |     case 'd': case 'D': return 13;
602 |     case 'e': case 'E': return 14;
603 |     case 'f': case 'F': return 15;
604 |     default: return 0;
605 |     }
606 | }
607 | 
608 | /* Split a line into arguments, where every argument can be in the
609 |  * following programming-language REPL-alike form:
610 |  *
611 |  * foo bar "newline are supported\n" and "\xff\x00otherstuff"
612 |  *
613 |  * The number of arguments is stored into *argc, and an array
614 |  * of sds is returned.
615 |  *
616 |  * The caller should free the resulting array of sds strings with
617 |  * sdsfreesplitres().
618 |  *
619 |  * Note that sdscatrepr() is able to convert back a string into
620 |  * a quoted string in the same format sdssplitargs() is able to parse.
621 |  *
622 |  * The function returns the allocated tokens on success, even when the
623 |  * input string is empty, or NULL if the input contains unbalanced
624 |  * quotes or closed quotes followed by non space characters
625 |  * as in: "foo"bar or "foo'
626 |  */
627 | sds *sdssplitargs(const char *line, int *argc) {
628 |     const char *p = line;
629 |     char *current = NULL;
630 |     char **vector = NULL;
631 | 
632 |     *argc = 0;
633 |     while(1) {
634 |         /* skip blanks */
635 |         while(*p && isspace(*p)) p++;
636 |         if (*p) {
637 |             /* get a token */
638 |             int inq=0;  /* set to 1 if we are in "quotes" */
639 |             int insq=0; /* set to 1 if we are in 'single quotes' */
640 |             int done=0;
641 | 
642 |             if (current == NULL) current = sdsempty();
643 |             while(!done) {
644 |                 if (inq) {
645 |                     if (*p == '\\' && *(p+1) == 'x' &&
646 |                                              is_hex_digit(*(p+2)) &&
647 |                                              is_hex_digit(*(p+3)))
648 |                     {
649 |                         unsigned char byte;
650 | 
651 |                         byte = (hex_digit_to_int(*(p+2))*16)+
652 |                                 hex_digit_to_int(*(p+3));
653 |                         current = sdscatlen(current,(char*)&byte,1);
654 |                         p += 3;
655 |                     } else if (*p == '\\' && *(p+1)) {
656 |                         char c;
657 | 
658 |                         p++;
659 |                         switch(*p) {
660 |                         case 'n': c = '\n'; break;
661 |                         case 'r': c = '\r'; break;
662 |                         case 't': c = '\t'; break;
663 |                         case 'b': c = '\b'; break;
664 |                         case 'a': c = '\a'; break;
665 |                         default: c = *p; break;
666 |                         }
667 |                         current = sdscatlen(current,&c,1);
668 |                     } else if (*p == '"') {
669 |                         /* closing quote must be followed by a space or
670 |                          * nothing at all. */
671 |                         if (*(p+1) && !isspace(*(p+1))) goto err;
672 |                         done=1;
673 |                     } else if (!*p) {
674 |                         /* unterminated quotes */
675 |                         goto err;
676 |                     } else {
677 |                         current = sdscatlen(current,p,1);
678 |                     }
679 |                 } else if (insq) {
680 |                     if (*p == '\\' && *(p+1) == '\'') {
681 |                         p++;
682 |                         current = sdscatlen(current,"'",1);
683 |                     } else if (*p == '\'') {
684 |                         /* closing quote must be followed by a space or
685 |                          * nothing at all. */
686 |                         if (*(p+1) && !isspace(*(p+1))) goto err;
687 |                         done=1;
688 |                     } else if (!*p) {
689 |                         /* unterminated quotes */
690 |                         goto err;
691 |                     } else {
692 |                         current = sdscatlen(current,p,1);
693 |                     }
694 |                 } else {
695 |                     switch(*p) {
696 |                     case ' ':
697 |                     case '\n':
698 |                     case '\r':
699 |                     case '\t':
700 |                     case '\0':
701 |                         done=1;
702 |                         break;
703 |                     case '"':
704 |                         inq=1;
705 |                         break;
706 |                     case '\'':
707 |                         insq=1;
708 |                         break;
709 |                     default:
710 |                         current = sdscatlen(current,p,1);
711 |                         break;
712 |                     }
713 |                 }
714 |                 if (*p) p++;
715 |             }
716 |             /* add the token to the vector */
717 |             vector = realloc(vector,((*argc)+1)*sizeof(char*));
718 |             vector[*argc] = current;
719 |             (*argc)++;
720 |             current = NULL;
721 |         } else {
722 |             /* Even on empty input string return something not NULL. */
723 |             if (vector == NULL) vector = malloc(sizeof(void*));
724 |             return vector;
725 |         }
726 |     }
727 | 
728 | err:
729 |     while((*argc)--)
730 |         sdsfree(vector[*argc]);
731 |     free(vector);
732 |     if (current) sdsfree(current);
733 |     *argc = 0;
734 |     return NULL;
735 | }
736 | 
737 | /* Modify the string substituting all the occurrences of the set of
738 |  * characters specified in the 'from' string to the corresponding character
739 |  * in the 'to' array.
740 |  *
741 |  * For instance: sdsmapchars(mystring, "ho", "01", 2)
742 |  * will have the effect of turning the string "hello" into "0ell1".
743 |  *
744 |  * The function returns the sds string pointer, that is always the same
745 |  * as the input pointer since no resize is needed. */
746 | sds sdsmapchars(sds s, const char *from, const char *to, size_t setlen) {
747 |     size_t j, i, l = sdslen(s);
748 | 
749 |     for (j = 0; j < l; j++) {
750 |         for (i = 0; i < setlen; i++) {
751 |             if (s[j] == from[i]) {
752 |                 s[j] = to[i];
753 |                 break;
754 |             }
755 |         }
756 |     }
757 |     return s;
758 | }
759 | 
760 | /* Join an array of C strings using the specified separator (also a C string).
761 |  * Returns the result as an sds string. */
762 | sds sdsjoin(char **argv, int argc, char *sep, size_t seplen) {
763 |     sds join = sdsempty();
764 |     int j;
765 | 
766 |     for (j = 0; j < argc; j++) {
767 |         join = sdscat(join, argv[j]);
768 |         if (j != argc-1) join = sdscatlen(join,sep,seplen);
769 |     }
770 |     return join;
771 | }
772 | 
773 | /* Like sdsjoin, but joins an array of SDS strings. */
774 | sds sdsjoinsds(sds *argv, int argc, const char *sep, size_t seplen) {
775 |     sds join = sdsempty();
776 |     int j;
777 | 
778 |     for (j = 0; j < argc; j++) {
779 |         join = sdscatsds(join, argv[j]);
780 |         if (j != argc-1) join = sdscatlen(join,sep,seplen);
781 |     }
782 |     return join;
783 | }
784 | 
785 | #ifdef SDS_TEST_MAIN
786 | #include <stdio.h>
787 | #include "testhelp.h"
788 | 
789 | int main(void) {
790 |     {
791 |         struct sdshdr *sh;
792 |         sds x = sdsnew("foo"), y;
793 | 
794 |         test_cond("Create a string and obtain the length",
795 |             sdslen(x) == 3 && memcmp(x,"foo\0",4) == 0)
796 | 
797 |         sdsfree(x);
798 |         x = sdsnewlen("foo",2);
799 |         test_cond("Create a string with specified length",
800 |             sdslen(x) == 2 && memcmp(x,"fo\0",3) == 0)
801 | 
802 |         x = sdscat(x,"bar");
803 |         test_cond("Strings concatenation",
804 |             sdslen(x) == 5 && memcmp(x,"fobar\0",6) == 0);
805 | 
806 |         x = sdscpy(x,"a");
807 |         test_cond("sdscpy() against an originally longer string",
808 |             sdslen(x) == 1 && memcmp(x,"a\0",2) == 0)
809 | 
810 |         x = sdscpy(x,"xyzxxxxxxxxxxyyyyyyyyyykkkkkkkkkk");
811 |         test_cond("sdscpy() against an originally shorter string",
812 |             sdslen(x) == 33 &&
813 |             memcmp(x,"xyzxxxxxxxxxxyyyyyyyyyykkkkkkkkkk\0",33) == 0)
814 | 
815 |         sdsfree(x);
816 |         x = sdscatprintf(sdsempty(),"%d",123);
817 |         test_cond("sdscatprintf() seems working in the base case",
818 |             sdslen(x) == 3 && memcmp(x,"123\0",4) ==0)
819 | 
820 |         sdsfree(x);
821 |         x = sdsnew("xxciaoyyy");
822 |         sdstrim(x,"xy");
823 |         test_cond("sdstrim() correctly trims characters",
824 |             sdslen(x) == 4 && memcmp(x,"ciao\0",5) == 0)
825 | 
826 |         y = sdsdup(x);
827 |         sdsrange(y,1,1);
828 |         test_cond("sdsrange(...,1,1)",
829 |             sdslen(y) == 1 && memcmp(y,"i\0",2) == 0)
830 | 
831 |         sdsfree(y);
832 |         y = sdsdup(x);
833 |         sdsrange(y,1,-1);
834 |         test_cond("sdsrange(...,1,-1)",
835 |             sdslen(y) == 3 && memcmp(y,"iao\0",4) == 0)
836 | 
837 |         sdsfree(y);
838 |         y = sdsdup(x);
839 |         sdsrange(y,-2,-1);
840 |         test_cond("sdsrange(...,-2,-1)",
841 |             sdslen(y) == 2 && memcmp(y,"ao\0",3) == 0)
842 | 
843 |         sdsfree(y);
844 |         y = sdsdup(x);
845 |         sdsrange(y,2,1);
846 |         test_cond("sdsrange(...,2,1)",
847 |             sdslen(y) == 0 && memcmp(y,"\0",1) == 0)
848 | 
849 |         sdsfree(y);
850 |         y = sdsdup(x);
851 |         sdsrange(y,1,100);
852 |         test_cond("sdsrange(...,1,100)",
853 |             sdslen(y) == 3 && memcmp(y,"iao\0",4) == 0)
854 | 
855 |         sdsfree(y);
856 |         y = sdsdup(x);
857 |         sdsrange(y,100,100);
858 |         test_cond("sdsrange(...,100,100)",
859 |             sdslen(y) == 0 && memcmp(y,"\0",1) == 0)
860 | 
861 |         sdsfree(y);
862 |         sdsfree(x);
863 |         x = sdsnew("foo");
864 |         y = sdsnew("foa");
865 |         test_cond("sdscmp(foo,foa)", sdscmp(x,y) > 0)
866 | 
867 |         sdsfree(y);
868 |         sdsfree(x);
869 |         x = sdsnew("bar");
870 |         y = sdsnew("bar");
871 |         test_cond("sdscmp(bar,bar)", sdscmp(x,y) == 0)
872 | 
873 |         sdsfree(y);
874 |         sdsfree(x);
875 |         x = sdsnew("aar");
876 |         y = sdsnew("bar");
877 |         test_cond("sdscmp(bar,bar)", sdscmp(x,y) < 0)
878 | 
879 |         sdsfree(y);
880 |         sdsfree(x);
881 |         x = sdsnewlen("\a\n\0foo\r",7);
882 |         y = sdscatrepr(sdsempty(),x,sdslen(x));
883 |         test_cond("sdscatrepr(...data...)",
884 |             memcmp(y,"\"\\a\\n\\x00foo\\r\"",15) == 0)
885 | 
886 |         {
887 |             int oldfree;
888 | 
889 |             sdsfree(x);
890 |             x = sdsnew("0");
891 |             sh = (void*) (x-(sizeof(struct sdshdr)));
892 |             test_cond("sdsnew() free/len buffers", sh->len == 1 && sh->free == 0);
893 |             x = sdsMakeRoomFor(x,1);
894 |             sh = (void*) (x-(sizeof(struct sdshdr)));
895 |             test_cond("sdsMakeRoomFor()", sh->len == 1 && sh->free > 0);
896 |             oldfree = sh->free;
897 |             x[1] = '1';
898 |             sdsIncrLen(x,1);
899 |             test_cond("sdsIncrLen() -- content", x[0] == '0' && x[1] == '1');
900 |             test_cond("sdsIncrLen() -- len", sh->len == 2);
901 |             test_cond("sdsIncrLen() -- free", sh->free == oldfree-1);
902 |         }
903 |     }
904 |     test_report()
905 |     return 0;
906 | }
907 | #endif
908 | 


--------------------------------------------------------------------------------
/ats-sds/sds/sds.h:
--------------------------------------------------------------------------------
  1 | /* SDS (Simple Dynamic Strings), A C dynamic strings library.
  2 |  *
  3 |  * Copyright (c) 2006-2014, Salvatore Sanfilippo <antirez at gmail dot com>
  4 |  * All rights reserved.
  5 |  *
  6 |  * Redistribution and use in source and binary forms, with or without
  7 |  * modification, are permitted provided that the following conditions are met:
  8 |  *
  9 |  *   * Redistributions of source code must retain the above copyright notice,
 10 |  *     this list of conditions and the following disclaimer.
 11 |  *   * Redistributions in binary form must reproduce the above copyright
 12 |  *     notice, this list of conditions and the following disclaimer in the
 13 |  *     documentation and/or other materials provided with the distribution.
 14 |  *   * Neither the name of Redis nor the names of its contributors may be used
 15 |  *     to endorse or promote products derived from this software without
 16 |  *     specific prior written permission.
 17 |  *
 18 |  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 19 |  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 20 |  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 21 |  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
 22 |  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 23 |  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 24 |  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 25 |  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 26 |  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 27 |  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 28 |  * POSSIBILITY OF SUCH DAMAGE.
 29 |  */
 30 | 
 31 | #ifndef __SDS_H
 32 | #define __SDS_H
 33 | 
 34 | #define SDS_MAX_PREALLOC (1024*1024)
 35 | 
 36 | #include <sys/types.h>
 37 | #include <stdarg.h>
 38 | 
 39 | typedef char *sds;
 40 | 
 41 | struct sdshdr {
 42 |     int len;
 43 |     int free;
 44 |     char buf[];
 45 | };
 46 | 
 47 | static inline size_t sdslen(const sds s) {
 48 |     struct sdshdr *sh = (void*)(s-sizeof *sh);
 49 |     return sh->len;
 50 | }
 51 | 
 52 | static inline size_t sdsavail(const sds s) {
 53 |     struct sdshdr *sh = (void*)(s-sizeof *sh);
 54 |     return sh->free;
 55 | }
 56 | 
 57 | sds sdsnewlen(const void *init, size_t initlen);
 58 | sds sdsnew(const char *init);
 59 | sds sdsempty(void);
 60 | size_t sdslen(const sds s);
 61 | sds sdsdup(const sds s);
 62 | void sdsfree(sds s);
 63 | size_t sdsavail(const sds s);
 64 | sds sdsgrowzero(sds s, size_t len);
 65 | sds sdscatlen(sds s, const void *t, size_t len);
 66 | sds sdscat(sds s, const char *t);
 67 | sds sdscatsds(sds s, const sds t);
 68 | sds sdscpylen(sds s, const char *t, size_t len);
 69 | sds sdscpy(sds s, const char *t);
 70 | 
 71 | sds sdscatvprintf(sds s, const char *fmt, va_list ap);
 72 | #ifdef __GNUC__
 73 | sds sdscatprintf(sds s, const char *fmt, ...)
 74 |     __attribute__((format(printf, 2, 3)));
 75 | #else
 76 | sds sdscatprintf(sds s, const char *fmt, ...);
 77 | #endif
 78 | 
 79 | void sdstrim(sds s, const char *cset);
 80 | void sdsrange(sds s, int start, int end);
 81 | void sdsupdatelen(sds s);
 82 | void sdsclear(sds s);
 83 | int sdscmp(const sds s1, const sds s2);
 84 | sds *sdssplitlen(const char *s, int len, const char *sep, int seplen, int *count);
 85 | void sdsfreesplitres(sds *tokens, int count);
 86 | void sdstolower(sds s);
 87 | void sdstoupper(sds s);
 88 | sds sdsfromlonglong(long long value);
 89 | sds sdscatrepr(sds s, const char *p, size_t len);
 90 | sds *sdssplitargs(const char *line, int *argc);
 91 | sds sdsmapchars(sds s, const char *from, const char *to, size_t setlen);
 92 | sds sdsjoin(char **argv, int argc, char *sep, size_t seplen);
 93 | sds sdsjoinsds(sds *argv, int argc, const char *sep, size_t seplen);
 94 | 
 95 | /* Low level functions exposed to the user API */
 96 | sds sdsMakeRoomFor(sds s, size_t addlen);
 97 | void sdsIncrLen(sds s, int incr);
 98 | sds sdsRemoveFreeSpace(sds s);
 99 | size_t sdsAllocSize(sds s);
100 | 
101 | #endif
102 | 


--------------------------------------------------------------------------------
/ats-sds/sds/testhelp.h:
--------------------------------------------------------------------------------
 1 | /* This is a really minimal testing framework for C.
 2 |  *
 3 |  * Example:
 4 |  *
 5 |  * test_cond("Check if 1 == 1", 1==1)
 6 |  * test_cond("Check if 5 > 10", 5 > 10)
 7 |  * test_report()
 8 |  *
 9 |  * ----------------------------------------------------------------------------
10 |  *
11 |  * Copyright (c) 2010-2012, Salvatore Sanfilippo <antirez at gmail dot com>
12 |  * All rights reserved.
13 |  *
14 |  * Redistribution and use in source and binary forms, with or without
15 |  * modification, are permitted provided that the following conditions are met:
16 |  *
17 |  *   * Redistributions of source code must retain the above copyright notice,
18 |  *     this list of conditions and the following disclaimer.
19 |  *   * Redistributions in binary form must reproduce the above copyright
20 |  *     notice, this list of conditions and the following disclaimer in the
21 |  *     documentation and/or other materials provided with the distribution.
22 |  *   * Neither the name of Redis nor the names of its contributors may be used
23 |  *     to endorse or promote products derived from this software without
24 |  *     specific prior written permission.
25 |  *
26 |  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
27 |  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
28 |  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
29 |  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
30 |  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
31 |  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
32 |  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
33 |  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
34 |  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
35 |  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
36 |  * POSSIBILITY OF SUCH DAMAGE.
37 |  */
38 | 
39 | #ifndef __TESTHELP_H
40 | #define __TESTHELP_H
41 | 
42 | int __failed_tests = 0;
43 | int __test_num = 0;
44 | #define test_cond(descr,_c) do { \
45 |     __test_num++; printf("%d - %s: ", __test_num, descr); \
46 |     if(_c) printf("PASSED\n"); else {printf("FAILED\n"); __failed_tests++;} \
47 | } while(0);
48 | #define test_report() do { \
49 |     printf("%d tests, %d passed, %d failed\n", __test_num, \
50 |                     __test_num-__failed_tests, __failed_tests); \
51 |     if (__failed_tests) { \
52 |         printf("=== WARNING === We have failed tests here...\n"); \
53 |         exit(1); \
54 |     } \
55 | } while(0);
56 | 
57 | #endif
58 | 


--------------------------------------------------------------------------------
/ats-sds/test.dats:
--------------------------------------------------------------------------------
  1 | #include "share/atspre_staload.hats"
  2 | staload "sds.sats"
  3 | staload UN = "prelude/SATS/unsafe.sats"
  4 | 
  5 | assume sds = string
  6 | #define assert assert_errmsg
  7 | 
  8 | implement main0 () = () where {
  9 |     val x = sdsnew("foo")
 10 |     val () = assert(sdslen(x) = 3, "sdsnew, sdslen")
 11 |     val () = println! x
 12 |     val _ = sdsfree(x)
 13 |     
 14 |     val x = sdsnewlen("foo", i2sz 2)
 15 |     val () = assert(sdslen(x) = 2, "sdsnewlen")
 16 |     val () = println! x
 17 | 
 18 |     
 19 |     val x = sdscat(x, "bar")
 20 |     val () = assert(sdslen(x) = 5, "sdscat")
 21 |     val () = println! x
 22 | 
 23 |     val x = sdscpy(x, "a")
 24 |     val () = assert(sdslen(x) = 1, "sdscpy")
 25 |     val () = println! x
 26 |     
 27 |     val x = sdscpy(x, "xyzxxxxxxxxxxyyyyyyyyyykkkkkkkkkk")
 28 |     val () = assert(sdslen(x) = 33, "sdscpy")
 29 |     val () = println! x
 30 |     val () = sdsfree(x)    
 31 |     
 32 |     val x = sdscatprintf(sdsempty(), "%d", @(123))
 33 |     val () = assert(sdslen(x) = 3, "sdscatprintf")
 34 |     val () = println! x
 35 |     val () = sdsfree(x)
 36 |     
 37 |     val x = sdsnew("xxciaoyyy")
 38 |     val () = sdstrim(x, "xy")
 39 |     val () = assert(sdslen(x) = 4, "sdstrim")
 40 |     val () = println! x
 41 |     
 42 |     val y = sdsdup(x)
 43 |     val () = sdsrange(y, 1, 1)
 44 |     val () = assert(sdslen(y) = 1, "sdsrange")
 45 |     val () = println! y
 46 |     val () = sdsfree(y)
 47 |     
 48 |     val y = sdsdup(x)
 49 |     val () = sdsrange(y, 1, ~1)
 50 |     val () = assert(sdslen(y) = 3, "sdsrange")
 51 |     val () = println! y
 52 |     val () = sdsfree(y)
 53 |     
 54 |     val y = sdsdup(x)
 55 |     val () = sdsrange(y, ~2, ~1)
 56 |     val () = assert(sdslen(y) = 2, "sdsrange")
 57 |     val () = println! y
 58 |     val () = sdsfree(y)
 59 |     
 60 |     val y = sdsdup(x)
 61 |     val () = sdsrange(y, 2, 1)
 62 |     val () = assert(sdslen(y) = 0, "sdsrange")
 63 |     val () = println! y
 64 |     val () = sdsfree(y)
 65 |     
 66 |     val y = sdsdup(x)
 67 |     val () = sdsrange(y, 1, 100)
 68 |     val () = assert(sdslen(y) = 3, "sdsrange")
 69 |     val () = println! y
 70 |     val () = sdsfree(y)
 71 |     
 72 |     val y = sdsdup(x)
 73 |     val () = sdsrange(y, 100, 100)
 74 |     val () = assert(sdslen(y) = 0, "sdsrange")
 75 |     val () = println! y
 76 |     val () = sdsfree(y)
 77 |     
 78 |     val () = sdsfree(x)
 79 |     
 80 |     val x = sdsnew("bar")
 81 |     val y = sdsnew("bar")
 82 |     val () = assert(sdscmp(x, y) = 0, "sdscmp")
 83 |     val () = sdsfree(x)
 84 |     val () = sdsfree(y)
 85 |     
 86 |     val x = sdsnew("aar")
 87 |     val y = sdsnew("bar")
 88 |     val () = assert(sdscmp(x, y) < 0, "sdscmp")
 89 |     val () = sdsfree(x)
 90 |     val () = sdsfree(y)
 91 |     
 92 |     val x = sdsnewlen("\a\n\0foo\r", i2sz 7)
 93 |     val y = sdscatrepr(sdsempty(), x, sdslen(x))
 94 |     val () = println! y
 95 |     val () = assert(sdslen(y) = 14, "sdscatrepr")
 96 |     val () = sdsfree(y)
 97 |     val () = sdsfree(x)
 98 |     
 99 |     var count = 0
100 |     val p = sdssplitlen("val x = sdsnew(\"aar\")", strlen("val x = sdsnew(\"aar\")"), " ", i2sz 1, count)
101 |     val () = println! count
102 |     val () = assert (count = 4, "sdssplitlen")
103 |     val () = fprint_arrayptr_sep<string> (stdout_ref, p, i2sz count, "\n")
104 |     val () = sdsfreesplitres(p, count)
105 |     
106 |     var count = 0
107 |     val p = sdssplitlen("val x = sdsnew(\"aar\")", strlen("val x = sdsnew(\"aar\")"), " ", i2sz 1, count)
108 |     val () = println! count
109 |     val () = assert (count = 4, "sdssplitlen")
110 |     val x = p[1]
111 |     val _ = p[1] := sdsnew("hello")
112 |     val () = println! x
113 |     val () = fprint_arrayptr_sep<string> (stdout_ref, p, i2sz count, "\n")
114 |     val () = sdsfreesplitres(p, count)
115 | 
116 | }


--------------------------------------------------------------------------------
/cps/Makefile:
--------------------------------------------------------------------------------
 1 | 
 2 | #LIBPATH = -L${PATSHOME}/ccomp/atslib/lib -L${PATSHOME}/ccomp/atslib/lib64
 3 | 
 4 | #SRC := location.sats parcc.sats file.sats string.sats token.sats list.sats stream.sats pair.sats 
 5 | 
 6 | # SRC := util/*.dats sexp/*.dats file/*.dats parcc.dats lexcc.dats #dynload.dats 
 7 | 
 8 | # SRC := util/*.dats parcc.dats  untyped/*.dats
 9 | 
10 | # DEL := *_dats.c *_sats.c *.out main
11 | 
12 | 
13 | # -latslib -lm
14 | UTIL=$(HOME)/Git/ats-utils
15 | AR=ar -rcs
16 | PATSOPT=patsopt -IATS $(UTIL)
17 | PATSCC=patscc -DATS_MEMALLOC_LIBC -IATS $(UTIL) -lm -latslib -L$(UTIL) -latsutils 
18 | CC=gcc -DATS_MEMALLOC_LIBC -I$(PATSHOME) -I$(PATSHOME)/ccomp/runtime -g
19 | CCFLAGS=-fPIC -O2
20 | RMF=rm -rf
21 | 
22 | 
23 | all: libatsparcc.a
24 | 	
25 | %_sats.c: %.sats 
26 | 	$(PATSOPT) -o $@ -s $^
27 | 
28 | %_dats.c: %.dats
29 | 	$(PATSOPT) -o $@ -d $^
30 | 
31 | %.o: %.c 
32 | 	$(CC) $(CCFLAGS) -c $^ -o $@
33 | 
34 | libatsparcc.a: parcc_dats.o parcc_sats.o parser_dats.o 
35 | 	$(AR) $@ $^
36 | 
37 | tc: 
38 | 	$(PATSCC) -tcats parcc.dats parser.dats
39 | 
40 | clean:
41 | 	$(RMF) *ats.c *.out *.o
42 | 
43 | cleanall:
44 | 	$(RMF) *ats.c *.o *.a *.out *.out.dSYM
45 | 
46 | test: testall.dats sexp.dats libatsparcc.a 
47 | 	$(PATSCC) -L$(PWD) -latsparcc testall.dats sexp.dats
48 | 		
49 | 	
50 | 
51 | 
52 | 
53 | 


--------------------------------------------------------------------------------
/cps/atsparcc.hats:
--------------------------------------------------------------------------------
1 | staload "parcc.sats"
2 | staload "parser.sats"
3 | 
4 | staload _ = "parcc.dats"
5 | staload _ = "parser.dats"
6 | 


--------------------------------------------------------------------------------
/cps/libatsparcc.a:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/steinwaywhw/ats-parcc/c5c45a444ad5a9f3eba92b7b4469743e297570ac/cps/libatsparcc.a


--------------------------------------------------------------------------------
/cps/parcc.dats:
--------------------------------------------------------------------------------
  1 | #define ATS_DYNLOADFLAG 0
  2 | #include "share/atspre_staload.hats"
  3 | 
  4 | staload "parcc.sats"
  5 | 
  6 | #include "atsutils.hats"
  7 | 
  8 | staload "list.sats"
  9 | staload "maybe.sats"
 10 | 
 11 | 
 12 | #define :: ListCons 
 13 | #define nil ListNil
 14 | 
 15 | (******************************)
 16 | 
 17 | implement (a) order_compare<parser a> (x, y) = 
 18 |     gcompare_val_val<ref(void)> ($UNSAFE.cast{ref(void)} x, $UNSAFE.cast{ref(void)} y)
 19 | 
 20 | (******************************)
 21 | 
 22 | implement {a} parcc_delay (p) = 
 23 |     parser_encode (lam (input, cont) => 
 24 |         parser_apply (p (), input, cont))
 25 | 
 26 | implement {a} parser_apply (p, input, cont) = 
 27 |     (parser_decode p)(input, cont)
 28 | 
 29 | implement {a} parser_fail () = 
 30 |     parser_encode (lam (input, cont) => 
 31 |         $raise ParsingException ("parser_fail"))
 32 | 
 33 | implement {a} parser_succeed (x) = 
 34 |     parser_encode (lam (input, cont) => 
 35 |         cont (x, input))
 36 | 
 37 | implement {a} parcc_maybe (p) = 
 38 |     parser_encode (lam (input, cont) => 
 39 |         try parser_apply (p, input, lam (result, rest) => cont (Just result, rest))
 40 |         with ~ParsingException (str) => (println! str; cont (Nothing (), input)))
 41 | 
 42 | implement {a,b} parcc_bind (p, f) = 
 43 |     parser_encode (lam (input, cont) => 
 44 |         parser_apply (p, input, lam (result, rest) => parser_apply (f result, rest, cont)))
 45 | 
 46 | implement {a,b} parcc_seq (pa, pb) = 
 47 |     pa \parcc_bind (lam a => 
 48 |         pb \parcc_bind (lam b => 
 49 |             parser_succeed ($tup(a, b))))
 50 | 
 51 | implement {a,b,c} parcc_seq3 (pa, pb, pc) =
 52 |     pa \parcc_bind (lam a => 
 53 |         pb \parcc_bind (lam b => 
 54 |             pc \parcc_bind (lam c 
 55 |                 => parser_succeed ($tup(a, b, c)))))
 56 | 
 57 | implement {a} parcc_seqs (pas) =
 58 |     case+ pas of 
 59 |     | nil _     => parser_succeed (nil ())
 60 |     | pa :: pas => 
 61 |         pa \parcc_bind (lam a => 
 62 |             (parcc_seqs pas) \parcc_bind (lam bs => 
 63 |                 parser_succeed (a :: bs)))
 64 | 
 65 | implement {a} parcc_alt (pa, pb) = 
 66 |     (parcc_maybe pa) \parcc_bind (lam a => 
 67 |         case+ a of 
 68 |         | Just a => parser_succeed a 
 69 |         | Nothing _ => pb)
 70 | 
 71 | implement {a} parcc_alt3 (pa, pb, pc) = 
 72 |     (parcc_maybe pa) \parcc_bind (lam a => 
 73 |         case+ a of 
 74 |         | Just a => parser_succeed a
 75 |         | Nothing _ => parcc_alt (pb, pc))
 76 | 
 77 | implement {a} parcc_alts (pas) = 
 78 |     case+ pas of 
 79 |     | nil _     => parser_fail ()
 80 |     | pa :: pas => 
 81 |         (parcc_maybe pa) \parcc_bind (lam a => 
 82 |             case+ a of 
 83 |             | Just a    => parser_succeed a
 84 |             | Nothing _ => parcc_alts pas)
 85 | 
 86 | implement {a} parcc_sat (p, f) = 
 87 |     p \parcc_bind (lam a => 
 88 |         if f a then parser_succeed a else parser_fail ())
 89 | 
 90 | implement {a} parcc_skip (p) = 
 91 |     p \parcc_bind (lam a => let val v = () in parser_succeed v end)
 92 | 
 93 | implement {a,b} parcc_map (p, f) =
 94 |     p \parcc_bind (lam a => parser_succeed (f a))
 95 | 
 96 | implement {a} parcc_rpt0 (p) = 
 97 |     (parcc_maybe p) \parcc_bind (lam a => 
 98 |         case+ a of 
 99 |         | Just a    => (parcc_rpt0 p) \parcc_bind (lam bs => parser_succeed (a :: bs))
100 |         | Nothing _ => parser_succeed (nil ()))
101 | 
102 | implement {a} parcc_rpt1 (p) = 
103 |     (parcc_seq (p, parcc_rpt0 p)) \parcc_bind (lam a => parser_succeed (a.0 :: a.1))
104 | 
105 | implement {a} parcc_rptn (p, n) = 
106 |     if n = 0 
107 |     then parser_succeed (nil ())
108 |     else (parcc_seq (p, parcc_rptn (p, n-1))) \parcc_bind (lam a => parser_succeed (a.0 :: a.1))
109 | 
110 | implement {a,b} parcc_sepby (a, sep) = 
111 |     parcc_seq (a, parcc_rpt0 (parcc_seq (sep, a) \parcc_map (lam x => x.1))) 
112 |         \parcc_map (lam x => ListCons (x.0, x.1))
113 | 
114 | implement {a,b} parcc_leadby (lead, pb) = 
115 |     parcc_seq (lead, pb) \parcc_map (lam x => x.1)
116 | 
117 | implement {a,b} parcc_followedby (pa, follow) = 
118 |     parcc_seq (pa, follow) \parcc_map (lam x => x.0)
119 | 
120 | implement {a,b,c} parcc_between (pa, pb, pc) =
121 |     (pa \parcc_leadby pb) \parcc_followedby pc
122 | 
123 | implement {o} memo0 (f) = let 
124 |     val p = f ()
125 | in 
126 |     lam () => p 
127 | end 
128 | 
129 | implement {i,o} memo1 (f) = let 
130 |     staload "libats/ML/SATS/funmap.sats"
131 |     staload _ = "libats/ML/DATS/funmap.dats"    
132 |     staload _ = "libats/DATS/funmap_avltree.dats"
133 | 
134 |     val table = ref<map(i,o)> (funmap_nil ())
135 | in 
136 |     lam a => 
137 |         case+ funmap_search (!table, a) of 
138 |         | ~Some_vt p => p
139 |         | ~None_vt _ => let 
140 |             val p = f a 
141 |             var t = !table
142 |             val- ~None_vt _ = funmap_insert (t, a, p)
143 |             val _ = !table := t
144 |         in 
145 |             p
146 |         end 
147 | end
148 | 
149 | implement {i1,i2,o} memo2 (f) = let 
150 |     staload "libats/ML/SATS/funmap.sats"
151 |     staload _  = "libats/ML/DATS/funmap.dats"    
152 |     staload _  = "libats/DATS/funmap_avltree.dats"
153 | 
154 |     val table = ref<map(@(i1,i2),o)> (funmap_nil ())
155 | in 
156 |     lam (a, b) => 
157 |         case+ funmap_search (!table, @(a, b)) of 
158 |         | ~Some_vt p => p
159 |         | ~None_vt _ => let 
160 |             val p = f (a, b)
161 |             var t = !table
162 |             val- ~None_vt _ = funmap_insert (t, @(a, b), p)
163 |             val _ = !table := t
164 |         in 
165 |             p
166 |         end 
167 | end
168 | 
169 | 
170 | 
171 | 
172 | 
173 | 
174 | 
175 | 
176 | ////
177 | implement {a} memo_parser (p) = let 
178 |     staload "libats/ML/SATS/funmap.sats"
179 |     staload _  = "libats/ML/DATS/funmap.dats"    
180 |     staload _  = "libats/DATS/funmap_avltree.dats"
181 | 
182 |     #define :: Cons
183 | 
184 |     typedef entry_t = @(a, input_t, list (cont_t a))
185 |     val table = ref<map(input_t, ref entry_t)> (funmap_nil ())
186 | in
187 |     lam (input, cont) =<cloref1> 
188 |         case+ funmap_search (!table, input) of 
189 |         | ~Some_vt entry => 
190 |             let 
191 |                 val _ = !entry.2 := cont :: !entry.2
192 |             in 
193 |                 cont (result, input)
194 |             end 
195 |         | ~None_vt _ => 
196 |             let 
197 |                 val entry = ref<entry_t> ()
198 |                 var t = !table 
199 |                 val- ~None_vt _ = funmap_insert (t, input, entry)
200 |                 val _ = !table := t
201 |             in 
202 |                 p (input, lam (result, input) => let 
203 |                     val :=)
204 | end
205 | 
206 | 
207 | //assume input_t ...
208 | 
209 | implement {} parser_char () = 
210 |     parser_encode (lam (input, cont) => cont (..., ...))
211 | 
212 | 
213 | implement {} parser_digit () = 
214 |     parser_encode (lam (input, cont) => parser_char () \)
215 | implement {} parser_digits () = 
216 |     (parser_digit ())
217 |     \parcc_alt 
218 |     (parser_digits () \parcc_seq parser_digit ())
219 | ////
220 | 
221 | assume input_t = lazy ($sm.stream char)
222 | 
223 | typedef entry_t = [o,a:t@ype] @{ks = list (cont (o, a)), rs = list (result o)}
224 | //assume trampoline = ref (@{stack = list (pair (parser o, input_t)), table = map (input_t, entry)})
225 | 
226 | #define :: Cons
227 | 
228 | (* 
229 |  *  show
230 |  *)
231 | 
232 | implement {o} show_result (r, f) =
233 |     case+ r of 
234 |     | Success (o, _) => f o 
235 |     | Failure i      => () where {
236 |         val _ = show "fail ("
237 |         val _ = $sm.show (i, 10)
238 |         val _ = show ")"
239 |     }
240 | 
241 | implement show_result_int (r)    = show_result (r, lam x => show x)
242 | implement show_result_string (r) = show_result (r, lam x => show x)
243 | implement show_result_char (r)   = show_result (r, lam x => show x)
244 | implement show_result_double (r) = show_result (r, lam x => show x)
245 | implement show_result_bool (r)   = show_result (r, lam x => show x)
246 | implement show_result_unit (r)   = show_result (r, lam x => show "unit")
247 | 
248 | 
249 | 
250 | (*
251 |  *  combinators
252 |  *)
253 | 
254 | implement {o} succeed (ret) = mk (lam (input, k) => k (Success (ret, input)))
255 | implement {o} fail    ()    = mk (lam (input, k) => k (Failure (input)))
256 | 
257 | implement {o,a}   apply (p, input, k)  = (unmk p) (input, k)
258 | implement {o1,o2} bind  (p, f) = mk (lam (input, k) => 
259 |     apply (p, input, lam result => 
260 |         case+ result of 
261 |         | Success (v, rest) => apply ((f v), rest, k)
262 |         | Failure (rest) => k (Failure (rest)))
263 | )
264 | 
265 | implement {o1,o2} seq (a, b) = a \bind (lam x => b \bind (lam y => succeed (Pair (x, y))))
266 | implement {o}     alt (a, b) = mk (lam (input, k) => let 
267 |     val _ = apply (a, input, k)
268 |     val _ = apply (b, input, k)
269 | in 
270 | end
271 | )
272 | 
273 | 
274 | 
275 | implement memo_cps (f) = let 
276 |     val ref = ref<map(input_t, entry)>(map_make ())
277 |     extern fun eq 
278 |     fun table_ref (input) = 
279 |         case+ map_lookup (input, ref) of 
280 |         | Just (entry) => entry 
281 |         | None () => let val _ = insert (input, entry, ref) in entry end
282 | in
283 |     lam (input, k) => 
284 | 
285 | 
286 | ////
287 | implement {i} {o} alt {e1,e2} (a, b) = 
288 |     mk (lam input => 
289 |             case+ apply (a, input) of 
290 |             | Success (ret, rest) => Success (ret, rest)
291 |             | Failure _ => apply (b, input))
292 | 
293 | 
294 | //implement {i} {o} alts (ps) = list_foldr (ps, fail (), lam (a, b) => a \alt b)
295 | //implement {i} {o}     seqs (ps)  = force (list_foldr (ps, succeed (Nil ()), lam (a, b) => a \bind (lam x => b \bind (lam y => succeed (x :: y)))))
296 | 
297 | implement {i} {o1,o2} seq  {e1,e2} (a, b) = a \bind (lam x => b \bind (lam y => succeed (Pair (x, y))))
298 | implement {i} {o,o1}  seqr {e1,e2} (p, r) = red (seq (skip p, r), lam x => snd x)
299 | implement {i} {o,o1}  seql {e1,e2} (l, p) = red (seq (l, skip p), lam x => fst x)
300 | 
301 | implement {i} {o} sat {e} (p, f) = mk p where {
302 |     val p = lam input =<cloref1> 
303 |             (case+ apply (p, input) of 
304 |             | Failure _ => Failure input 
305 |             | Success (ret, rest) =>
306 |                 if f ret
307 |                 then Success (ret, rest) 
308 |                 else Failure (input)): result (i, o)
309 | }
310 | 
311 | 
312 | implement {i} {o} opt {e} (p) = mk p where {
313 |     val p = lam input =<cloref1> 
314 |             (case+ apply (p, input) of 
315 |             | Success (ret, rest) => Success (Just ret, rest)
316 |             | Failure (input) => Success (Nothing (), input)): result (i, maybe o)
317 | }
318 | 
319 | implement {i} {o} rpt1 (p)        = p \bind (lam x => ((rpt1 p) \red (lam y => x :: y)) \alt succeed (x :: Nil ()))
320 | implement {i} {o} rpt0 (p)        = (rpt1 p) \alt (succeed (Nil ()))
321 | implement {i} {o} rptn {n} (p, n) = if n = 0 then succeed (Nil ()) else p \bind (lam x => (rptn (p, n-1)) \bind (lam y => succeed (x :: y)))
322 | 
323 | //implement {i} {o1,o2} rptuntil {e} (p, e) = let 
324 | //    val trye = 
325 | //        lam input =<cloref1> 
326 | //            (case+ apply (e, input) of 
327 | //            | Success (_, _) => Success (Nil (), input)
328 | //            | Failure (_) => Failure (input)): result (i, list o1)
329 | //in 
330 | //    alt (mk trye, (p \seq rptuntil (p, e)) \red (lam x => fst x :: snd x))
331 | //end
332 | 
333 | 
334 | implement {i} {o} skip {e} (p)                             = p \bind (lam x => succeed (Unit ()))
335 | implement {i} {o1,o2} sepby1 (*{e1,e2}*) {e} (p, sep)              = (p \seq (rpt0 (sep \seqr p))) \red (lam x => fst x :: snd x)
336 | implement {i} {o1,o2} sepby0 (*{e1,e2}*) {e} (p, sep)              = (p \sepby1 sep) \alt (succeed (Nil ()))
337 | implement {i} {o,o1,o2} between {e1,e2} (p, open, close) = open \bind (lam _ => p \bind (lam x => close \bind (lam _ => succeed x)))
338 | 
339 | implement {i} {o} not {e} (p) = mk p where {
340 |     val p = lam input =<cloref1>
341 |             (case+ apply (p, input) of 
342 |             | Success (_, _) => Failure input 
343 |             | Failure _ => Success (Unit (), input)): result (i, unit)
344 | }
345 | 
346 | 
347 | //implement {i} {o} mk (p) = p
348 | 
349 | implement {i} {o} force {e} (p)     = mk (lam input => apply (!p, input))
350 | implement {i,o} {r} red {e} (p, f)  = p \bind (lam x => succeed (f x))
351 | 
352 | 
353 | 
354 | 
355 | 
356 | ////
357 | 
358 | 
359 | (*
360 |  *  parsers
361 |  *)
362 | 
363 | 
364 | 
365 | implement anychar () = mk p where {
366 |     val p = lam (input: lazy ($sm.stream char)) =<cloref1>
367 |             (case+ !input of 
368 |             | $sm.Nil () => Failure (input)
369 |             | $sm.Cons (x, rest) => Success (x, rest)): result (lazy ($sm.stream char), char)
370 | }
371 | 
372 | 
373 | 
374 | implement spaces ()     = skip (rpt0 (litchar ' '))
375 | implement space ()      = litchar ' '
376 | implement spacetab ()   = space () \alt (tab ())
377 | implement ws ()         = skip (rpt0 (oneof (" \t\n\v\f\r")))
378 | implement newline ()    = litchar '\n'
379 | implement tab ()        = litchar '\t'
380 | implement uppercase ()  = anychar () \sat (lam x => isupper x)
381 | implement lowercase ()  = anychar () \sat (lam x => islower x)
382 | implement alpha ()      = anychar () \sat (lam x => isalpha x)
383 | implement alphadigit () = anychar () \sat (lam x => isalnum x)
384 | implement digit ()      = anychar () \sat (lam x => isdigit x)
385 | implement hexdigit ()   = anychar () \sat (lam x => isxdigit x)
386 | implement octdigit ()   = anychar () \sat (lam x => x >= '0' && x <= '7')
387 | implement printable ()  = anychar () \sat (lam x => isprint x)
388 | implement symbol ()     = oneof ("!#$%&*+-./<=>?@\\^|~")
389 | implement litchar (c)   = anychar () \sat (lam x => x = c)
390 | implement oneof (s)     = anychar () \sat (lam x => string_find (s, string_from_char x) >= 0)
391 | implement noneof (s)    = anychar () \sat (lam x => string_find (s, string_from_char x) < 0)
392 | implement escape ()     = let
393 |     val case1 = red (
394 |             seq (litchar '\\', oneof "abfnrtv\\\'\"\?`"), 
395 |             lam x => case+ snd x of
396 |                 | 'a' => '\a'
397 |                 | 'b' => '\b'
398 |                 | 'f' => '\f'
399 |                 | 'n' => '\n'
400 |                 | 'r' => '\r'
401 |                 | 't' => '\t'
402 |                 | 'v' => '\v'
403 |                 | ch  =>> ch)
404 |     
405 |     val case2 = red (
406 |             seq (
407 |                 litchar '\\', 
408 |                 red (
409 |                     rptn (red (octdigit (), lam x => x - '0'), 3),
410 |                     lam xs => list_foldl<int><int> (xs, 0, lam (x, y) => y + x * 8))), 
411 |             lam x => int2char0 (snd x))
412 | 
413 |     val case3 = red (
414 |             seq (
415 |                 litstring "\\x", 
416 |                 red (
417 |                     rptn (red (hexdigit (), lam x => if isdigit x then x - '0' else ((tolower x) - 'a') + 10), 2),
418 |                     lam xs => list_foldl<int><int> (xs, 0, lam (x, y) => y + x * 16))),
419 |             lam x => int2char0 (snd x))
420 | 
421 | in 
422 |     (case1 \alt case2) \alt case3
423 | end
424 | 
425 | implement litstring (match) = let
426 |     fun genpar (index: int):<cloref1> parser unit =
427 |         if index = len (match) - 1
428 |         then skip (litchar match[index])
429 |         else skip (seq (skip (litchar match[index]), genpar (index+1)))
430 | in 
431 |     genpar (0) \red (lam _ => match)
432 | end
433 | 
434 | implement alphas ()     = (rpt1 (alpha ()))       \red (lam x => string_unexplode x)
435 | implement digits ()     = (rpt1 (digit ()))       \red (lam x => string_unexplode x)
436 | implement alphadigits() = (rpt1 (alphadigit ()))  \red (lam x => string_unexplode x)
437 | implement hexdigits ()  = (rpt1 (hexdigit ()))    \red (lam x => string_unexplode x)
438 | implement octdigits ()  = (rpt1 (octdigit ()))    \red (lam x => string_unexplode x)
439 | implement uppercases () = (rpt1 (uppercase ()))   \red (lam x => string_unexplode x)
440 | implement lowercases () = (rpt1 (lowercase ()))   \red (lam x => string_unexplode x)
441 | implement symbols ()    = (rpt1 (symbol ()))      \red (lam x => string_unexplode x)
442 | 
443 | implement eof () = mk p where {
444 |     val p = lam (input: lazy ($sm.stream char)) =<cloref1>
445 |         case+ !input of 
446 |         | $sm.Nil _ => Success (Unit (), input)
447 |         | _ => Failure (input)
448 | }
449 | 
450 | 
451 | 
452 | implement id () = let
453 |     val case1 = (alpha() \alt (litchar '_')) \red (lam x => string_from_char x)
454 |     val case2 = (rpt1 (alphadigit() \alt (litchar '_'))) \red (lam x => string_unexplode x)
455 | in 
456 |     ((case1 \seq case2) \red (lam x => string_concat (fst x, snd x))) \alt case1
457 | end
458 | 
459 | 
460 | ////
461 | staload "util/convert.sats"
462 | 
463 | implement parser_test () = () where {
464 |     val sep = "\n==========================\n"
465 |     val _ = show (apply (id (), string_to_stream "x "))
466 |     val _ = show sep 
467 |     val _ = show (apply (spaces (), string_to_stream "   c"))
468 |     val _ = show sep 
469 |     val _ = show (apply (spaces (), string_to_stream "a   c"))
470 |     val _ = show sep 
471 |     val _ = show (apply (space (), string_to_stream "   c"))
472 |     val _ = show sep 
473 |     val _ = show (apply (space (), string_to_stream "c   c"))
474 |     val _ = show sep 
475 |     val _ = show (apply (spacetab (), string_to_stream "\t cdefg"))
476 |     val _ = show sep 
477 |     val _ = show (apply (spacetab (), string_to_stream " \tcdefg"))
478 |     val _ = show sep 
479 |     val _ = show (apply (spacetab (), string_to_stream "cdefg"))
480 |     val _ = show sep 
481 |     val _ = show (apply (ws (), string_to_stream "\t\n\v\f\r end"))
482 |     val _ = show sep 
483 |     val _ = show (apply (newline (), string_to_stream "\ncdefg"))
484 |     val _ = show sep 
485 |     val _ = show (apply (newline (), string_to_stream "a\ncdefg"))
486 |     val _ = show sep 
487 |     val _ = show (apply (tab (), string_to_stream "\tcdefg"))
488 |     val _ = show sep 
489 |     val _ = show (apply (tab (), string_to_stream "a\tcdefg"))
490 |     val _ = show sep 
491 |     val _ = show (apply (uppercase (), string_to_stream "ACcdefg"))
492 |     val _ = show sep 
493 |     val _ = show (apply (uppercase (), string_to_stream "accdefg"))
494 |     val _ = show sep 
495 |     val _ = show (apply (lowercase (), string_to_stream "accdefg"))
496 |     val _ = show sep 
497 |     val _ = show (apply (lowercase (), string_to_stream "aCcdefg"))
498 |     val _ = show sep 
499 |     val _ = show (apply (alpha (), string_to_stream "\tcdefg"))
500 |     val _ = show sep 
501 |     val _ = show (apply (alpha (), string_to_stream "a\tcdefg"))
502 |     val _ = show sep 
503 |     val _ = show (apply (alphadigit (), string_to_stream "a\tcdefg"))
504 |     val _ = show sep 
505 |     val _ = show (apply (alphadigit (), string_to_stream "1a\tcdefg"))
506 |     val _ = show sep 
507 |     val _ = show (apply (alphadigit (), string_to_stream "\tcdefg"))
508 |     val _ = show sep 
509 |     val _ = show (apply (digit (), string_to_stream "1\tcdefg"))
510 |     val _ = show sep 
511 |     val _ = show (apply (digit (), string_to_stream "a\tcdefg"))
512 |     val _ = show sep 
513 |     val _ = show (apply (hexdigit (), string_to_stream "1\tcdefg"))
514 |     val _ = show sep 
515 |     val _ = show (apply (hexdigit (), string_to_stream "a\tcdefg"))
516 |     val _ = show sep 
517 |     val _ = show (apply (hexdigit (), string_to_stream "g\tcdefg"))
518 |     val _ = show sep 
519 |     val _ = show (apply (octdigit (), string_to_stream "0\tcdefg"))
520 |     val _ = show sep 
521 |     val _ = show (apply (octdigit (), string_to_stream "8a\tcdefg"))
522 |     val _ = show sep 
523 |     val _ = show (apply (anychar (), string_to_stream "abcde"))
524 |     val _ = show sep 
525 |     val _ = show (apply (printable (), string_to_stream "cdefg"))
526 |     val _ = show sep 
527 |     val _ = show (apply (printable (), string_to_stream "\bcdefg"))
528 |     val _ = show sep 
529 |     val _ = show (apply (escape (), string_to_stream "\\t"))
530 |     val _ = show sep 
531 |     val _ = show (apply (litchar 'c', string_to_stream "cdefg"))
532 |     val _ = show sep 
533 |     val _ = show (apply (litstring "hello", string_to_stream "hello"))
534 |     val _ = show sep 
535 |     val _ = show (apply (oneof "cde", string_to_stream "eab"))
536 |     val _ = show sep 
537 |     val _ = show (apply (noneof "cde", string_to_stream "eab"))
538 |     val _ = show sep 
539 |     
540 | 
541 | 
542 |     val _ = show (apply (digits (), string_to_stream "123a"))
543 |     val _ = show sep 
544 |     val _ = show (apply (hexdigits (), string_to_stream "a112387x"))
545 |     val _ = show sep 
546 |     val _ = show (apply (alphas (), string_to_stream "avasd1"))
547 |     val _ = show sep 
548 |     val _ = show (apply (alphadigits (), string_to_stream "ansdj123lkasdj\t"))
549 |     val _ = show sep 
550 |     val _ = show (apply (hexdigits (), string_to_stream "abcdef123451l"))
551 |     val _ = show sep 
552 | //  val _ = show (apply (string_double_quote (), string_to_stream "\"\\tbcde\""))
553 | //  val _ = show sep 
554 | //  val _ = show (apply (string_double_quote (), string_to_stream "\"\tbcde\""))
555 | //  val _ = show sep 
556 | //  val _ = show (apply (string_double_quote (), string_to_stream "\"a\"bcde\""))
557 | //  val _ = show sep 
558 | //  val _ = show (apply (string_double_quote (), string_to_stream "\"abc\\\"de\""))
559 | //  val _ = show sep 
560 | //  val _ = show (apply (string_double_quote (), string_to_stream "\"abc\nde\""))
561 | //  val _ = show sep 
562 | //  val _ = show (apply (string_double_quote (), string_to_stream "\"abc'de\""))
563 | //  val _ = show sep 
564 | //  val _ = show (apply (string_backtip (), string_to_stream "`abcde`"))
565 | //  val _ = show sep 
566 | //  val _ = show (apply (string_backtip (), string_to_stream "`\"abcde`"))
567 | //  val _ = show sep 
568 | //  val _ = show (apply (string_backtip (), string_to_stream "`\\abcde`"))
569 | //  val _ = show sep 
570 | //  val _ = show (apply (string_backtip (), string_to_stream "``abcde`"))
571 | //  val _ = show sep 
572 | //  val _ = show (apply (string_backtip (), string_to_stream "`ab`cde`"))
573 | //  val _ = show sep 
574 | //  val _ = show (apply (string_backtip (), string_to_stream "`\\`abcde`"))
575 | //  val _ = show sep 
576 | //  val _ = show (apply (string_multiline (), string_to_stream "```abc\nde`fs``sa````dasd```asd```"))
577 | //  val _ = show sep 
578 | //  val _ = show (apply (signed_int_dec (), string_to_stream "-109"))
579 | //  val _ = show sep 
580 | //  val _ = show (apply (unsigned_int_hex (), string_to_stream "0fF"))
581 | //  val _ = show sep 
582 | //  val _ = show (apply (unsigned_int_bin (), string_to_stream "101"))
583 | //  val _ = show sep 
584 | //  val _ = show (apply (unsigned_int_oct (), string_to_stream "0777"))
585 | //  val _ = show sep 
586 | //  val _ = show (apply (exponent (), string_to_stream "e+10"))
587 | //  val _ = show sep 
588 | //  val _ = show (apply (unsigned_double_dec (), string_to_stream "10.900"))
589 | //  val _ = show sep 
590 | //  val _ = show (apply (signed_double_dec (), string_to_stream "-10.900"))
591 | //  val _ = show sep 
592 | //  val _ = show (apply (boolean (), string_to_stream "true"))
593 | //  val _ = show sep 
594 | }
595 |  
596 | 
597 | implement main0 () = parser_test ()
598 | 
599 | 
600 | 
601 | 
602 | (*
603 | 
604 | 
605 | 
606 | 
607 | 
608 | 
609 | 
610 | *)


--------------------------------------------------------------------------------
/cps/parcc.sats:
--------------------------------------------------------------------------------
  1 | #include "atsutils.hats"
  2 | 
  3 | staload "list.sats"
  4 | staload "maybe.sats"
  5 | 
  6 | exception ParsingException of (string)
  7 | 
  8 | typedef nat = intGte 0
  9 | 
 10 | abstype parser (a:t@ype) = ptr
 11 | 
 12 | abstype input_t  = ptr
 13 | abstype output_t = ptr 
 14 | 
 15 | typedef cont_t (a:t@ype) = (a, input_t) -<cloref1> output_t 
 16 | typedef cont_t = [a:t@ype] cont_t a
 17 | 
 18 | typedef par_t  (a:t@ype) = (input_t, cont_t a) -<cloref1> output_t
 19 | typedef par_t = [a:t@ype] par_t a
 20 |  
 21 | castfn parser_encode {a:t@ype} (par_t a): parser a
 22 | castfn parser_decode {a:t@ype} (parser a): par_t a
 23 | 
 24 | fun {a:t@ype}     parser_apply     (parser a, input_t, cont_t a): output_t
 25 |   
 26 | fun {a:t@ype}     parser_fail      (): parser (a)
 27 | fun {a:t@ype}     parser_succeed   (a): parser (a)
 28 |     
 29 | fun {a:t@ype}     parcc_delay 	   (() -<cloref1> parser a): parser a
 30 | fun {a,b:t@ype}   parcc_bind  	   (parser a, a -<cloref1> parser b): parser b
 31 |   
 32 | fun {a:t@ype}     parcc_maybe 	   (parser a): parser (maybe a)
 33 | 
 34 | fun {a,b:t@ype}   parcc_seq        (parser a, parser b): parser ($tup(a, b))
 35 | fun {a,b,c:t@ype} parcc_seq3       (parser a, parser b, parser c): parser ($tup(a, b, c))
 36 | fun {a:t@ype}     parcc_seqs       (list (parser a)): parser (list a)
 37 | fun {a:t@ype}     parcc_alt        (parser a, parser a): parser a
 38 | fun {a:t@ype}     parcc_alt3       (parser a, parser a, parser a): parser a
 39 | fun {a:t@ype}     parcc_alts       (list (parser a)): parser a
 40 |       
 41 | fun {a:t@ype}     parcc_sat        (parser a, a -<cloref1> bool): parser a
 42 | fun {a:t@ype}     parcc_skip       (parser a): parser void
 43 | fun {a,b:t@ype}   parcc_map        (parser a, a -<cloref1> b): parser b
 44 | fun {a:t@ype}     parcc_rptn       (parser a, nat): parser (list a)
 45 | fun {a:t@ype}     parcc_rpt1       (parser a): parser (list a)
 46 | fun {a:t@ype}     parcc_rpt0       (parser a): parser (list a)
 47 | 
 48 | fun {a,b:t@ype}   parcc_sepby      (parser a, parser b): parser (list a)
 49 | fun {a,b:t@ype}   parcc_leadby     (parser a, parser b): parser b // a ++ b => b
 50 | fun {a,b:t@ype}   parcc_followedby (parser a, parser b): parser a // a ++ b => a
 51 | fun {a,b,c:t@ype} parcc_between    (parser a, parser b, parser c): parser b // a ++ b ++ c => b
 52 | 
 53 | symintr memo 
 54 | fun {o:t@ype}  		memo0 (() -<cloref1> o): () -<cloref1> o
 55 | fun {i,o:t@ype} 	memo1 (i -<cloref1> o): i -<cloref1> o 
 56 | fun {i1,i2,o:t@ype} memo2 ((i1, i2) -<cloref1> o): (i1, i2) -<cloref1> o 
 57 | overload memo with memo0
 58 | overload memo with memo1 
 59 | overload memo with memo2
 60 | 
 61 | 
 62 | 
 63 | 
 64 | 
 65 | 
 66 | ////
 67 | //fun 
 68 | //fun {a:t@ype} memo_parser (par_t a): par_t a
 69 | 
 70 | 
 71 | 
 72 | 
 73 | 
 74 | 
 75 | 
 76 | 
 77 | 
 78 | 
 79 | ////
 80 | 
 81 | (* types *)
 82 | 
 83 | abstype input_t = ptr
 84 | //abstype output_t = ptr
 85 | 
 86 | datatype result (o:t@ype) = 
 87 |     | Success of (o, input_t)
 88 |     | Failure of (input_t)
 89 | 
 90 | typedef cont (o:t@ype, a:t@ype) = result o -<cloref1> a
 91 | 
 92 | abstype parser (o:t@ype) = ptr
 93 | //typedef parser (o:t@ype) = parser (lazy ($sm.stream char), o)
 94 | 
 95 | typedef parserfun (o:t@ype, a:t@ype) = (input_t, cont (o, a)) -<cloref1> a
 96 | 
 97 | castfn mk   {o,a:t@ype} (parserfun (o, a)): parser o
 98 | castfn unmk {o,a:t@ype} (parser o): parserfun (o, a)
 99 | 
100 | //absvtype trampoline 
101 | 
102 | (* show functions *)
103 | 
104 | fun {o:t@ype}     show_result        (result o, o -> void): void
105 | fun               show_result_char   (result char)        : void
106 | fun               show_result_string (result string)      : void
107 | fun               show_result_int    (result int)         : void
108 | fun               show_result_double (result double)      : void
109 | fun               show_result_bool   (result bool)        : void
110 | fun               show_result_unit   (result unit)        : void
111 | 
112 | overload show with show_result
113 | overload show with show_result_int
114 | overload show with show_result_string
115 | overload show with show_result_char
116 | overload show with show_result_bool
117 | overload show with show_result_double
118 | overload show with show_result_unit
119 | 
120 | (* basic combinators *)
121 | 
122 | fun {o:t@ype}     succeed (o): parser o
123 | fun {o:t@ype}     fail    (): parser o
124 | fun {o1,o2:t@ype} bind    (parser o1, o1 -<cloref1> parser o2): parser o2
125 | fun {o,a:t@ype}   apply   (parser o, input_t, cont (o, a)): a
126 | 
127 | fun {o1,o2:t@ype} seq     (parser o1, parser o2): parser (pair (o1, o2))
128 | fun {o:t@ype}     alt     (parser o, parser o): parser o
129 | 
130 | fun {o,a:t@ype}   memo_cps (parser o): parser o
131 | 
132 | 
133 | ////
134 | fun {i:t@ype} {o:t@ype}       force   (lazy (parser (i, o, e))): parser (i, o, e)
135 | 
136 | fun {i:t@ype} {o:t@ype}       alt     (parser (i, o, e1), parser (i, o, e2)):                                         parser (i, o, e1 || e2)
137 | 
138 | 
139 | 
140 | 
141 | 
142 | ////
143 | 
144 | (*
145 |  *  parsers
146 |  *)
147 | 
148 | fun spaces ()              : parser (unit, true) // \s*
149 | fun space ()               : parser char // \s
150 | fun spacetab ()            : parser char // \s\t
151 | fun ws ()                  : parser (unit, true) // \s\t\n\v\f\r *
152 | fun newline ()             : parser char // \n
153 | fun tab ()                 : parser char // \t
154 | fun uppercase ()           : parser char // [A-Z]
155 | fun lowercase ()           : parser char // [a-z]
156 | fun alpha ()               : parser char // [a-zA-Z]
157 | fun alphadigit ()          : parser char // [a-zA-Z0-9]
158 | fun digit ()               : parser char // [0-9]
159 | fun hexdigit ()            : parser char // [0-9A-Fa-f]
160 | fun octdigit ()            : parser char // [0-7]
161 | fun anychar ()             : parser char // .
162 | fun printable ()           : parser char // printable
163 | fun escape ()              : parser char // c escape
164 | fun symbol ()              : parser char // !#$%&*+-/<=>?@\^.|~ (that is, not "'`()[]{},:;_)
165 | fun litchar (char)         : parser char
166 | fun oneof (string)         : parser char
167 | fun noneof (string)        : parser char
168 |     
169 | fun litstring (string)     : parser string
170 | fun alphas ()              : parser string // [a-zA-Z]+
171 | fun digits ()              : parser string // [0-9]+
172 | fun alphadigits()          : parser string // [a-zA-Z0-9]+
173 | fun hexdigits ()           : parser string // [a-fA-F0-9]+
174 | fun octdigits ()           : parser string // [0-7]+
175 | fun uppercases ()          : parser string // [A-Z]+
176 | fun lowercases ()          : parser string // [a-z]+
177 | fun symbols ()             : parser string // symbol+
178 | 
179 | fun eof ()                 : parser (unit, true)
180 | 
181 | (*
182 |  *  misc parsers
183 |  *)
184 | 
185 | fun id (): parser string // [a-zA-Z_][a-zA-Z0-9_]*
186 | 
187 | //fun char_single_quote ()     : parser char   // '_'
188 | //fun string_double_quote ()   : parser string // "one line string"
189 | //fun string_backtip ()        : parser string // `one line string`
190 | //fun string_triple_backtip () : parser string // ```multi line string```
191 | 
192 | (*
193 |  *  combinators
194 |  *)
195 | 
196 | 
197 | 
198 | //fun {i:t@ype} {o:t@ype}       alts     {e:bool} (list (parser (i, o, e))):   [e:bool]                             parser (i, o, e )
199 | //fun {i:t@ype} {o:t@ype}       seqs     (list (parser (i, o))):                                parser (i, list o)
200 | 
201 | fun {i:t@ype} {o,o1:t@ype}    seqr     {e1,e2:bool}   (parser (i, o1, e1), parser (i, o, e2)):                                        parser (i, o, e1 && e2) // keep right, disgard left
202 | fun {i:t@ype} {o,o1:t@ype}    seql     {e1,e2:bool}   (parser (i, o, e1), parser (i, o1, e2)):                                        parser (i, o, e1 && e2) // keep left, disgard right
203 | fun {i:t@ype} {o:t@ype}       sat      {e:bool}       (parser (i, o, e), o -<cloref1> bool):                                          parser (i, o, e)
204 | fun {i:t@ype} {o:t@ype}       opt      {e:bool}       (parser (i, o, e)):                                                             parser (i, maybe o, e)
205 | fun {i:t@ype} {o:t@ype}       rpt0                    (parser (i, o, false)):                                                         parser (i, list o, true)
206 | fun {i:t@ype} {o:t@ype}       rpt1                    (parser (i, o, false)):                                                         parser (i, list o, false)
207 | fun {i:t@ype} {o:t@ype}       rptn     {n:nat}        (parser (i, o, false), int n):                                                  parser (i, list o, n == 0)
208 | fun {i:t@ype} {o1,o2:t@ype}   rptuntil {e:bool}       (p: parser (i, o1, false), e: parser (i, o2, e)):                               parser (i, list o1, e)
209 | fun {i:t@ype} {o:t@ype}       skip     {e:bool}       (parser (i, o, e)):                                                             parser (i, unit, e)
210 | fun {i:t@ype} {o:t@ype}       not      {e:bool}       (parser (i, o, e)):                                                             parser (i, unit, true)
211 | fun {i,o:t@ype} {r:t@ype}     red      {e:bool}       (parser (i, o, e), f: o -<cloref1> r):                                          parser (i, r, e)
212 | fun {i:t@ype} {o,o1,o2:t@ype} between  {e1,e2:bool}   (p: parser (i, o, false), open: parser (i, o1, e1), close: parser (i, o2, e2)): parser (i, o, false)
213 | fun {i:t@ype} {o1,o2:t@ype}   sepby0   (*{e1,e2:bool|(e1&&e2)==false}*) {e:bool} (p: parser (i, o1, false), sep: parser (i, o2, e)):                 parser (i, list o1, true)
214 | fun {i:t@ype} {o1,o2:t@ype}   sepby1   (*{e1,e2:bool|(e1&&e2)==false}*) {e:bool} (p: parser (i, o1, false), sep: parser (i, o2, e)):                 parser (i, list o1, false)
215 | 
216 | 
217 | 
218 | 
219 | (* 
220 |  *  test
221 |  *)
222 | 
223 | fun parser_test (): void 
224 | 
225 | //infixl +>
226 | //infixl <+
227 | //infixl <+>
228 | //infixl <|>
229 | 
230 | //overload +> with seqr 
231 | //overload <+ with seql
232 | //overload <+> with seq 
233 | //overload <|> with alt 
234 | 
235 | 
236 | 
237 | 


--------------------------------------------------------------------------------
/cps/parcc_dats.o:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/steinwaywhw/ats-parcc/c5c45a444ad5a9f3eba92b7b4469743e297570ac/cps/parcc_dats.o


--------------------------------------------------------------------------------
/cps/parcc_sats.o:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/steinwaywhw/ats-parcc/c5c45a444ad5a9f3eba92b7b4469743e297570ac/cps/parcc_sats.o


--------------------------------------------------------------------------------
/cps/parser.dats:
--------------------------------------------------------------------------------
  1 | #define ATS_DYNLOADFLAG 0
  2 | #include "share/atspre_staload.hats"
  3 | 
  4 | #include "atsutils.hats"
  5 | staload "list.sats"
  6 | staload "stream.sats"
  7 | staload "string.sats"
  8 | staload "unit.sats"
  9 | 
 10 | staload "parser.sats"
 11 | 
 12 | staload "parcc.sats"
 13 | staload _ = "parcc.dats"
 14 | 
 15 | 
 16 | #define :: StreamCons 
 17 | #define nil StreamNil
 18 | 
 19 | local 
 20 | 
 21 | assume input_t = stream char
 22 | 
 23 | in 
 24 | 
 25 | implement parser_char () = 
 26 | 	parser_encode (lam (input, cont) => 
 27 | 		case+ !input of 
 28 | 		| x :: xs => cont (x, xs)
 29 | 		| nil _   => $raise ParsingException ("parser_char"))
 30 | 
 31 | implement parser_eof () = 
 32 | 	parser_encode (lam (input, cont) => 
 33 | 		case+ !input of 
 34 | 		| x :: xs => $raise ParsingException ("parser_eof")
 35 | 		| nil _ => cont (Unit (), $delay nil ()))
 36 | 
 37 | end
 38 | 
 39 | implement parser_alpha () = 
 40 | 	parser_char () \parcc_sat (lam c => isalpha c)
 41 | 
 42 | implement parser_digit () = 
 43 | 	parser_char () \parcc_sat (lam c => isdigit c)
 44 | 
 45 | implement parser_xdigit () = 
 46 | 	parser_char () \parcc_sat (lam c => isxdigit c)
 47 | 
 48 | implement parser_printable () = 
 49 | 	parser_char () \parcc_sat (lam c => isprint c)
 50 | 
 51 | implement parser_space () = 
 52 | 	parser_lit_char (' ')
 53 | 
 54 | implement parser_spaces () = 
 55 | 	parcc_rpt1 (parser_space ()) \parcc_map (lam xs => string_unexplode xs)
 56 | 
 57 | implement parser_alphadigit () = 
 58 | 	parser_char () \parcc_sat (lam c => isalnum c)
 59 | 
 60 | implement parser_lowercase () = 
 61 | 	parser_char () \parcc_sat (lam c => islower c)
 62 | 
 63 | implement parser_uppercase () = 
 64 | 	parser_char () \parcc_sat (lam c => isupper c)
 65 | 
 66 | implement parser_lit_char (lit) = 
 67 | 	parser_char () \parcc_sat (lam (c:char) => lit = c)
 68 | 
 69 | implement parser_lit_string (lit) = 
 70 | 	parcc_seqs (foldr<char,list (parser char)> (string_explode lit, ListNil (), lam (x, xs) =<cloref1> ListCons (parser_lit_char x, xs)))
 71 | 		\parcc_map (lam xs => string_unexplode xs)
 72 | 
 73 | implement parser_digits () = 
 74 | 	(parcc_rpt1 (parser_digit ())) \parcc_map (lam ds => string_unexplode ds)
 75 | 
 76 | implement parser_oneof (str) = 
 77 | 	parser_char () \parcc_sat (lam c => string_contains (str, string_from_char c))
 78 | 
 79 | implement parser_noneof (str) = 
 80 | 	parser_char () \parcc_sat (lam c => not (string_contains (str, string_from_char c)))
 81 | 
 82 | implement parser_ws () = 
 83 | 	(parcc_rpt1 (parser_oneof (" \t\n\v\f\r"))) \parcc_map (lam x => string_unexplode x)
 84 | 
 85 | implement parser_symbol () = 
 86 | 	parser_oneof ("!#$%&*+-./<=>?@\\^|~")
 87 | 
 88 | implement parser_symbols () = 
 89 | 	(parcc_rpt1 (parser_symbol ())) \parcc_map (lam xs => string_unexplode xs)
 90 | 
 91 | implement {a} parcc_wsaware (p) = 
 92 | 	p \parcc_followedby parser_ws ()
 93 | 
 94 | implement parser_escape () = let 
 95 | 	val case1 = 
 96 | 		(parser_lit_char ('\\') \parcc_leadby parser_oneof ("abfnrtv\\\'\""))
 97 | 			\parcc_map (lam x => 
 98 | 				case+ x of 
 99 | 				| 'a' => '\a'
100 | 				| 'b' => '\b'
101 | 				| 'f' => '\f'
102 | 				| 'n' => '\n'
103 | 				| 'r' => '\r'
104 | 				| 't' => '\t'
105 | 				| 'v' => '\v'
106 | 				| ch  =>> ch)
107 | 
108 | 	val octnum = 
109 | 		parcc_rptn (parser_digit () \parcc_sat (lam x => x >= '0' andalso x <= '7'), 3)
110 | 			\parcc_map (lam xs => list_foldl<char,int> (xs, 0, lam (d:char, ds:int):int => (d - '0') * 8 + ds))
111 | 
112 | 	val case2 = parser_lit_char ('\\') \parcc_leadby (octnum \parcc_map (lam x => int2char0 x))
113 | 
114 | 	val hexnum = 
115 | 		parcc_rptn (parser_xdigit () \parcc_map (lam x => if isdigit x then x - '0' else ((tolower x) - 'a') + 10), 2)
116 | 			\parcc_map (lam xs => list_foldl<int,int> (xs, 0, lam (d, ds) => d * 16 + ds))
117 | 
118 | 	val case3 = parser_lit_string ("\\x") \parcc_leadby (hexnum \parcc_map (lam x => int2char0 x))
119 | in 
120 | 	parcc_alt3 (case1, case2, case3)
121 | end
122 | 
123 | 
124 | 
125 | 


--------------------------------------------------------------------------------
/cps/parser.sats:
--------------------------------------------------------------------------------
 1 | staload "parcc.sats"
 2 | 
 3 | staload "stream.sats"
 4 | staload "unit.sats"
 5 | 
 6 | fun parser_char (): parser char
 7 | fun parser_eof (): parser unit
 8 | 
 9 | fun parser_oneof (string): parser char
10 | fun parser_noneof (string): parser char
11 | fun parser_printable (): parser char 
12 | fun parser_ws (): parser string
13 | fun parser_space (): parser char 
14 | fun parser_spaces (): parser string 
15 | fun parser_alpha (): parser char 
16 | fun parser_digit (): parser char 
17 | fun parser_xdigit (): parser char 
18 | fun parser_digits (): parser string 
19 | fun parser_alphadigit (): parser char 
20 | fun parser_lowercase (): parser char 
21 | fun parser_uppercase (): parser char 
22 | fun parser_lit_char (char): parser char
23 | fun parser_lit_string (string): parser string 
24 | fun parser_escape (): parser char 
25 | fun parser_symbol (): parser char 
26 | fun parser_symbols (): parser string 
27 | 
28 | fun {a:t@ype} parcc_wsaware (parser a): parser a
29 | 
30 | (****************************************************************)
31 | 
32 | 
33 | 
34 | 
35 | 


--------------------------------------------------------------------------------
/cps/parser_dats.o:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/steinwaywhw/ats-parcc/c5c45a444ad5a9f3eba92b7b4469743e297570ac/cps/parser_dats.o


--------------------------------------------------------------------------------
/cps/sexp.dats:
--------------------------------------------------------------------------------
 1 | #define ATS_DYNLOADFLAG 0
 2 | #include "share/atspre_staload.hats"
 3 | 
 4 | staload "sexp.sats"
 5 | staload "parcc.sats"
 6 | staload "parser.sats"
 7 | 
 8 | #include "atsutils.hats"
 9 | staload "list.sats"
10 | staload "unit.sats"
11 | staload "string.sats"
12 | 
13 | staload _ = "parcc.dats"
14 | staload _ = "parser.dats"
15 | 
16 | 
17 | overload ^* with parcc_rpt0
18 | postfix ^*
19 | 
20 | overload ^+ with parcc_rpt1 
21 | postfix ^+
22 | 
23 | overload ++ with parcc_seq 
24 | infixl ++
25 | 
26 | symintr ||
27 | overload || with parcc_alt 
28 | infixl || 
29 | 
30 | 
31 | (******************************)
32 | 
33 | implement show_any<sexp> (sexp) = 
34 | 	case+ sexp of 
35 | 	| SString s => ignoret (show<string> "Str("; show<string> s; show<string> ")")
36 | 	| SBool s   => ignoret (show<string> "Bool("; show<bool> s; show<string> ")")
37 | 	| SInt s    => ignoret (show<string> "Int("; show<int> s; show<string> ")")
38 | 	| SSymbol s => ignoret (show<string> "Sym("; show<string> s; show<string> ")")
39 | 	| SList ss  => ignoret (show<string> "List("; let val _ = list_foldl<sexp,unit> (ss, Unit (), lam (s, ss) => (show s; Unit ())) in () end; show<string> ")")
40 | 
41 | (******************************)
42 | 
43 | implement parser_sexp_symbol () = 
44 | 	(((parser_alpha () || parser_lit_char '_') ++ (parser_alphadigit () ^*))
45 | 			\parcc_map (lam xs => SSymbol (string_unexplode (ListCons (xs.0, xs.1)))))
46 | 	|| ((parser_symbols ()) \parcc_map (lam x => SSymbol x))
47 | 
48 | implement parser_sexp_bool () =  
49 | 	(parser_lit_string ("true") || parser_lit_string ("false"))
50 | 		\parcc_map (lam x => if x = "true" then SBool true else SBool false)
51 | 
52 | implement parser_sexp_string () = 
53 | 	parcc_between (parser_lit_char '"', parcc_rpt0 (parser_escape () \parcc_alt parser_char ()), parser_lit_char '"')
54 | 		\parcc_map (lam xs => SString (string_unexplode xs))
55 | 
56 | implement parser_sexp_int () = 
57 | 	parser_digits () \parcc_map (lam xs => SInt (string_to_int xs))
58 | 
59 | implement parser_sexp_atom () = let 
60 | 	#define :: ListCons 
61 | 	#define nil ListNil 
62 | in 
63 | 	parcc_alts (parser_sexp_int () :: parser_sexp_bool () :: parser_sexp_symbol () :: parser_sexp_string () :: nil ())
64 | end
65 | 
66 | implement parser_sexp_sexp () = 
67 | 	parser_sexp_atom () 
68 | 		\parcc_alt (parcc_between (
69 | 			parser_lit_string "(", 
70 | 			(parcc_delay (lam () => parser_sexp_sexplist ())) || parser_succeed (SList (ListNil ())), 
71 | 			parser_lit_string ")"))
72 | 
73 | implement parser_sexp_sexplist () = 
74 | 	parcc_sepby (parser_sexp_sexp (), parser_ws ())
75 | 		\parcc_map (lam xs => SList xs)
76 | 
77 | implement parser_sexp_file () = 
78 | 	parser_sexp_sexplist () \parcc_followedby parser_eof ()
79 | 
80 | 


--------------------------------------------------------------------------------
/cps/sexp.sats:
--------------------------------------------------------------------------------
 1 | staload "parcc.sats"
 2 | staload "list.sats"
 3 | staload "unit.sats"
 4 | 
 5 | datatype sexp = 
 6 | | SList of list sexp 
 7 | | SSymbol of string 
 8 | | SInt of int 
 9 | | SBool of bool 
10 | | SString of string 
11 | 
12 | fun parser_sexp_symbol (): parser sexp 
13 | fun parser_sexp_bool (): parser sexp 
14 | fun parser_sexp_string (): parser sexp 
15 | fun parser_sexp_int (): parser sexp 
16 | 
17 | fun parser_sexp_atom (): parser sexp 
18 | fun parser_sexp_sexp (): parser sexp 
19 | fun parser_sexp_sexplist (): parser sexp
20 | fun parser_sexp_file (): parser sexp 
21 | 
22 | 


--------------------------------------------------------------------------------
/cps/simple.dats:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/steinwaywhw/ats-parcc/c5c45a444ad5a9f3eba92b7b4469743e297570ac/cps/simple.dats


--------------------------------------------------------------------------------
/cps/test1.sexp:
--------------------------------------------------------------------------------
1 | (lam x (lam y (lam z ((x z) (y z)))))


--------------------------------------------------------------------------------
/cps/testall.dats:
--------------------------------------------------------------------------------
 1 | #define ATS_DYNLOADFLAG 0
 2 | #include "share/atspre_staload.hats"
 3 | #include "atsparcc.hats"
 4 | #include "atsutils.hats"
 5 | 
 6 | staload "stream.sats"
 7 | staload "unit.sats"
 8 | 
 9 | staload "sexp.sats"
10 | staload _ = "sexp.dats"
11 | 
12 | extern fun file_get_stream (string): stream char 
13 | implement file_get_stream (path) = sm where {
14 | 	staload "libc/SATS/stdio.sats"
15 | 
16 | 	fun tostream (file: FILEref): stream char = let
17 | 		val c = int2char0 (fgetc file)
18 | 	in 
19 | 		if feof file = 0
20 | 		then $delay StreamCons (c, tostream file)
21 | 		else $delay StreamNil () where {
22 | 			val _ = fclose_exn file
23 | 		} 
24 | 	end
25 | 
26 | 	val file = fopen_ref_exn (path, file_mode_r)
27 | 	val sm = tostream file
28 | }
29 | 
30 | implement main0 () = {
31 |   	assume output_t = unit 
32 | 
33 | 	val input = file_get_stream ("./test1.sexp")
34 | 	val input = $UNSAFE.cast{input_t} input
35 | 
36 | 	val _ = parser_apply (parser_sexp_file (), input, lam (x, input) => (show x; Unit ()))
37 | }
38 | 
39 | 


--------------------------------------------------------------------------------
/file/file.dats:
--------------------------------------------------------------------------------
 1 | #include "share/atspre_staload.hats"
 2 | #define ATS_DYNLOADFLAG 0
 3 | 
 4 | staload "libc/SATS/stdio.sats"
 5 | 
 6 | staload "util/util.sats"
 7 | staload sm = "util/stream.sats"
 8 | 
 9 | staload "file/file.sats"
10 | staload "file/location.sats"
11 | 
12 | staload "util/pair.sats"
13 | 
14 | staload _ = "util/stream.dats"
15 | staload _ = "file/location.dats"
16 | 
17 | 
18 | implement file_get_stream (path) = sm where {
19 | 	fun tostream (file: FILEref): lazy ($sm.stream char) = let
20 | 		val c = int2char0 (fgetc file)
21 | 	in 
22 | 		if feof file = 0
23 | 		then $delay $sm.Cons (c, tostream file)
24 | 		else $delay $sm.Nil () where {
25 | 			val _ = fclose_exn file
26 | 		} 
27 | 	end
28 | 
29 | 	val file = fopen_ref_exn (path, file_mode_r)
30 | 	val sm = tostream file
31 | }
32 | 
33 | implement file_append_position (xs, p) = 
34 | 	case+ !xs of 
35 | 	| $sm.Nil _        => $delay $sm.Nil()
36 | 	| $sm.Cons (x, xs) => $delay $sm.Cons (Pair (x, p), file_append_position (xs, position_next (p, x)))
37 | 
38 | implement file_append_location (xs, file) = 
39 | 	$sm.map (xs, lam (x) => v where {
40 | 			val Pair (ch, pos) = x 
41 | 			val v = Pair (ch, Loc (file, Range (pos, pos)))
42 | 		})
43 | 
44 | 


--------------------------------------------------------------------------------
/file/file.sats:
--------------------------------------------------------------------------------
 1 | staload "util/util.sats"
 2 | staload "util/stream.sats"
 3 | staload "util/pair.sats"
 4 | staload "file/location.sats"
 5 | 
 6 | typedef fs_char_t = lazy (stream char) 
 7 | typedef fs_pos_t = lazy (stream (pair (char, position)))
 8 | typedef fs_loc_t = lazy (stream (pair (char, location)))
 9 | 
10 | // public interface
11 | fun file_get_stream (path: string): fs_char_t
12 | fun file_append_position (fs_char_t, origin: position): fs_pos_t
13 | fun file_append_location (fs_pos_t, file: string): fs_loc_t
14 | 
15 | 
16 | 
17 | 


--------------------------------------------------------------------------------
/file/location.dats:
--------------------------------------------------------------------------------
  1 | #include "share/atspre_staload.hats"
  2 | #define ATS_DYNLOADFLAG 0
  3 | 
  4 | staload "file/location.sats"
  5 | staload "util/util.sats"
  6 | 
  7 | assume position = '{line=int, col=int}
  8 | assume range    = '{a=position, b=position}
  9 | assume location = '{file=string, r=range}
 10 | 
 11 | implement Pos (line, col)   = '{line = line, col = col}
 12 | 
 13 | implement position_line (p) = p.line
 14 | implement position_col (p)  = p.col
 15 | implement position_next (current, ch) = 
 16 | 	if ch = '\n'
 17 | 	then '{line = current.line + 1, col = 1}
 18 | 	else '{line = current.line, col = current.col + 1}
 19 | 
 20 | implement position_origin = '{line = 1, col = 1}
 21 | implement position_eof    = '{line = ~1, col = ~1}
 22 | 
 23 | implement Range (a, b)        = '{a=a, b=b} 
 24 | implement range_begin (range) = range.a
 25 | implement range_end (range)   = range.b
 26 | 
 27 | local 
 28 | 	fun min (x:position, y:position): position = if x < y then x else y
 29 | 	fun max (x:position, y:position): position = if x > y then x else y
 30 | in
 31 | 	implement range_merge (x, y) = '{a=min(x.a, y.a), b=max(x.b, y.b)}
 32 | end
 33 | 
 34 | implement Loc (file, r)        = '{file=file, r=r} 
 35 | implement location_file (loc)  = loc.file
 36 | implement location_range (loc) = loc.r
 37 | 
 38 | (***************
 39 | 	Utilities
 40 |  ***************)
 41 | 
 42 | //implement fprint_location (loc, out) = () where {
 43 | //	val _ = fprint (out, loc.file)
 44 | //	val _ = fprint (out, " [")
 45 | //	val _ = fprint (out, loc.r)
 46 | //	val _ = fprint (out, "]")
 47 | //}
 48 | 
 49 | //implement fprint_position (pos, out) = $extfcall (void, "fprintf", out, "%d:%d", pos.line, pos.col)
 50 | 
 51 | //implement fprint_range (r, out) = () where {
 52 | //	val _ = fprint (out, r.a)
 53 | //	val _ = fprint (out, " - ")
 54 | //	val _ = fprint (out, r.b)
 55 | //}
 56 | 
 57 | implement print_location (loc) = () where {
 58 | 	val _ = show (loc.file)
 59 | 	val _ = show " ["
 60 | 	val _ = print_range loc.r
 61 | 	val _ = show "]"
 62 | }
 63 | 
 64 | implement print_position (p) = () where {
 65 | 	val _ = show p.line 
 66 | 	val _ = show ":"
 67 | 	val _ = show p.col
 68 | }
 69 | 
 70 | implement print_range (r) = () where {
 71 | 	val _ = print_position r.a
 72 | 	val _ = show " - "
 73 | 	val _ = print_position r.b
 74 | }
 75 | 
 76 | 
 77 | implement eq_pos_pos (a, b)			 = compare_pos_pos (a, b) = 0	
 78 | implement eq_range_range (a, b)		 = a.a = b.a && a.b = b.b	
 79 | implement eq_loc_loc (a, b)			 = a.file = b.file && a.r = b.r
 80 | 
 81 | implement neq_pos_pos (a, b)		 = ~(a = b)
 82 | implement neq_range_range (a, b)	 = ~(a = b)
 83 | implement neq_loc_loc (a, b)		 = ~(a = b)
 84 | 
 85 | implement gt_pos_pos (a, b)			 = compare_pos_pos (a, b) > 0	
 86 | implement lt_pos_pos (a, b)			 = compare_pos_pos (a, b) < 0	
 87 | implement gte_pos_pos (a, b)		 = compare_pos_pos (a, b) >= 0	
 88 | implement lte_pos_pos (a, b)		 = compare_pos_pos (a, b) <= 0	
 89 | 
 90 | implement compare_pos_pos (a, b)	 = if a.line = b.line then a.col - b.col else a.line - b.line	
 91 | 
 92 | ////
 93 | 
 94 | implement fprint_position (out, pos) = 
 95 | 	case+ pos of Pos (line, col) => $extfcall (void, "fprintf", out, "%d:%d", line, col)
 96 | 
 97 | implement fprint_location (out, loc) = 
 98 | 	case+ loc of
 99 | 	| None ()  				 => fprint (out, "none")
100 | 	| Stdin () 			 	 => fprint (out, "stdin")
101 | 	| FilePos (path, a) 	 => () where {
102 | 		val _ = $extfcall (void, "fprintf", out, "%s [", path)
103 | 		val _ = fprint (out, a)
104 | 		val _ = fprint (out, "]")
105 | 	}
106 | 	| FileRange (path, a, b) => () where {
107 | 		val _ = $extfcall (void, "fprintf", out, "%s [", path)
108 | 		val _ = fprint (out, a)
109 | 		val _ = fprint (out, " - ")
110 | 		val _ = fprint (out, b)
111 | 		val _ = fprint (out, "]")
112 | 	}
113 | 
114 | implement compare_pos_pos (p1, p2) = let 
115 | 	val Pos (l1, c1) = p1
116 | 	val Pos (l2, c2) = p2
117 | in 
118 | 	if l1 != l2
119 | 	then l1 - l2
120 | 	else p1 - p2
121 | end
122 | 
123 | implement isnone (x:location): bool = 
124 | 	case+ x of 
125 | 	| None _ => true
126 | 	| _ => false
127 | implement isstdin (x:location): bool = 
128 | 	case+ x of 
129 | 	| Stdin _ => true
130 | 	| _ => false
131 | implement ispos (x:location): bool = 
132 | 	case+ x of 
133 | 	| FilePos _ => true
134 | 	| _ => false
135 | implement isrange (x:location): bool = 
136 | 	case+ x of 
137 | 	| FileRange _ => true
138 | 	| _ => false
139 | 
140 | implement eq_loc_loc (x, y) = 
141 | 	case+ x of
142 | 	| None _ => isnone y
143 | 	| Stdin _ => isstdin y 
144 | 	| FilePos _ => ispos y
145 | 	| FileRange _ => isrange y
146 | 
147 | end (* LOCAL IN END*)
148 | 
149 | implement merge (x, y) = 
150 | 	


--------------------------------------------------------------------------------
/file/location.sats:
--------------------------------------------------------------------------------
 1 | staload "util/util.sats"
 2 | 
 3 | abstype position = ptr
 4 | abstype range    = ptr
 5 | abstype location = ptr
 6 | 
 7 | fun Pos (row: int, col: int): position 
 8 | fun position_next (current: position, ch: char): position 
 9 | fun position_line (position): int 
10 | fun position_col (position): int 
11 | 
12 | val position_origin : position 
13 | val position_eof : position 
14 | 
15 | fun Range (a: position, b: position): range 
16 | fun range_begin (range): position 
17 | fun range_end (range): position 
18 | fun range_merge (range, range): range
19 | 
20 | fun Loc (file: string, r: range): location 
21 | fun location_file (location): string
22 | fun location_range (location): range
23 | 
24 | 
25 | (***************
26 | 	Utilities
27 |  ***************)
28 | 
29 | //fun fprint_location (loc: location, out: FILEref): void
30 | //fun fprint_position (pos: position, out: FILEref): void
31 | //fun fprint_range (r: range, out: FILEref): void
32 | fun print_location (location): void 
33 | fun print_position (position): void 
34 | fun print_range (range): void 
35 | 
36 | //overload show with fprint_range
37 | //overload show with fprint_location
38 | //overload show with fprint_position
39 | overload show with print_range
40 | overload show with print_location
41 | overload show with print_position
42 | 
43 | fun eq_pos_pos (position, position): bool
44 | fun eq_range_range (range, range): bool
45 | fun eq_loc_loc (location, location): bool
46 | 
47 | fun neq_pos_pos (position, position): bool
48 | fun neq_range_range (range, range): bool
49 | fun neq_loc_loc (location, location): bool
50 | 
51 | fun gt_pos_pos (position, position): bool
52 | fun lt_pos_pos (position, position): bool
53 | fun gte_pos_pos (position, position): bool
54 | fun lte_pos_pos (position, position): bool
55 | 
56 | fun compare_pos_pos (position, position): int
57 | 
58 | overload = with eq_pos_pos
59 | overload = with eq_range_range
60 | overload = with eq_loc_loc
61 | 
62 | overload != with neq_pos_pos
63 | overload != with neq_range_range
64 | overload != with neq_loc_loc
65 | 
66 | overload > with gt_pos_pos
67 | overload < with lt_pos_pos
68 | overload >= with gte_pos_pos
69 | overload <= with lte_pos_pos
70 | 
71 | overload compare with compare_pos_pos
72 | 


--------------------------------------------------------------------------------
/old/continuation.sats:
--------------------------------------------------------------------------------
1 | 
2 | abstype cont


--------------------------------------------------------------------------------
/old/input.sats:
--------------------------------------------------------------------------------
1 | #include "share/atspre_staload.hats"
2 | 
3 | staload "util.sats"
4 | 


--------------------------------------------------------------------------------
/old/interface.sats:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/steinwaywhw/ats-parcc/c5c45a444ad5a9f3eba92b7b4469743e297570ac/old/interface.sats


--------------------------------------------------------------------------------
/old/lexcc.dats:
--------------------------------------------------------------------------------
  1 | #include "share/atspre_staload.hats"
  2 | #define ATS_DYNLOADFLAG 0
  3 | 
  4 | staload "util/util.sats"
  5 | staload "util/string.sats"
  6 | staload "util/list.sats"
  7 | staload sm = "util/stream.sats"
  8 | staload "util/pair.sats"
  9 | staload "util/unit.sats"
 10 | 
 11 | staload "parcc.sats"
 12 | staload "lexcc.sats"
 13 | 
 14 | staload _ = "parcc.dats"
 15 | staload _ = "util/list.dats"
 16 | staload _ = "util/pair.dats"
 17 | 
 18 | //staload "file/location.sats"
 19 | 
 20 | #define :: Cons 
 21 | 
 22 | implement anychar () =
 23 | 	lam input => 
 24 | 		case+ !input of
 25 | 		| $sm.Nil () => Failure (input)
 26 | 		| $sm.Cons (x, rest) => Success (x, rest)
 27 | 
 28 | implement lit_char (match) = sat (anychar (), lam x => x = match)
 29 | 
 30 | implement lit_string (match) = let 
 31 | 	fun genpar (index: int):<cloref1> lexer unit =
 32 | 		if index = len (match) - 1
 33 | 		then skip (lit_char match[index])
 34 | 		else skip (seq (skip (lit_char match[index]), genpar (index+1)))
 35 | in 
 36 | 	red (genpar (0), lam _ => match)
 37 | end
 38 | 
 39 | 
 40 | implement charin (charset) = sat (anychar (), lam x => string_find (charset, string_from_char x) >= 0)
 41 | implement charnotin (charset) = sat (anychar (), lam x => string_find (charset, string_from_char x) < 0)
 42 | 
 43 | implement digit () = sat (anychar (), lam x => isdigit x)
 44 | implement xdigit () = sat (anychar (), lam x => isxdigit x)
 45 | implement alpha () = sat (anychar (), lam x => isalpha x)
 46 | implement spacetab () = sat (anychar (), lam x => isblank x)
 47 | implement printable () = sat (anychar (), lam x => isprint x)
 48 | implement newline () = lit_char '\n'
 49 | implement whitespace () = sat (anychar (), lam x => isspace x)
 50 | 
 51 | implement escape () = let 
 52 | 	val case1 = 
 53 | 		red (
 54 | 			seq (literal '\\', charin ("abfnrtv\\\'\"\?`")), 
 55 | 			lam x => 
 56 | 				case+ snd x of
 57 | 				| 'a' => '\a'
 58 | 				| 'b' => '\b'
 59 | 				| 'f' => '\f'
 60 | 				| 'n' => '\n'
 61 | 				| 'r' => '\r'
 62 | 				| 't' => '\t'
 63 | 				| 'v' => '\v'
 64 | 				| ch  => ch
 65 | 			)
 66 | 	
 67 | 	val ds = red (rptn (digit(), 3), lam xs => map(xs, lam x => x-'0')): lexer (list int)
 68 | 	val case2 =  
 69 | 		red (
 70 | 			seq (literal '\\', ds), 
 71 | 			lam x => 
 72 | 				case- snd x of 
 73 | 				| x :: y :: z :: Nil () => int2char0 (x*64 + y*8 + z)
 74 | 			)
 75 | 
 76 | 	val xds = red (rptn (xdigit(), 2), lam xs => map (xs, lam x => if isdigit x then x-'0' else tolower(x)-'a'+10)): lexer (list int)
 77 | 	val case3 = 
 78 | 		red (
 79 | 			seq (literal "\\x", xds),
 80 | 			lam x => 
 81 | 				case- snd x of 
 82 | 				| x :: y :: Nil () => int2char0 (x * 16 + y)
 83 | 			)
 84 | 
 85 | in 
 86 | 	alt (case1, alt (case2, case3)) 
 87 | end
 88 | 
 89 | 
 90 | implement {o} skipws (l) = 
 91 | 	red (seq (l, skip (rpt0 (spacetab ()))), lam x => fst x)
 92 | 
 93 | implement alphadigit () = 
 94 | 	alt (alpha (), digit ())
 95 | 
 96 | implement alphas () =
 97 | 	red (rpt1 (alpha ()), lam x => string_unexplode x)
 98 | 
 99 | implement digits () =
100 | 	red (rpt1 (digit ()), lam x => string_unexplode x)
101 | 
102 | implement xdigits () =
103 | 	red (rpt1 (xdigit ()), lam x => string_unexplode x)
104 | 
105 | implement alphadigits () = 		
106 | 	red (rpt1 (alphadigit ()), lam x => string_unexplode x)
107 | 
108 | 
109 | implement char_single_quote () = 
110 | 	red (
111 | 		seq (literal '\'', 
112 | 			seq (alt (escape (), printable ()), 
113 | 				literal '\'')),
114 | 		lam x => fst (snd x)
115 | 		)
116 | 
117 | implement string_double_quote () = let
118 | 	val content = red (rpt0 (alt (charnotin "\n\\\"", escape())), lam x => string_unexplode x)
119 | 	val str = seq (literal '"', seq (content, literal '"'))
120 | in 
121 | 	red (str, lam x => fst (snd x))
122 | end 
123 | 
124 | implement string_backtip () = let
125 | 	val content = red (rpt0 (alt (charnotin "\n\\`", escape())), lam x => string_unexplode x)
126 | 	val str = seq (literal '`', seq (content, literal '`'))
127 | in 
128 | 	red (str, lam x => fst (snd x))
129 | end 
130 | 
131 | implement string_multiline () = let
132 | 	val backtips = red (sat (rpt1 (literal '`'), lam xs => len (xs) != 3), lam x => string_unexplode x)
133 | 	val nonbacktips = red (rpt1 (alt (charnotin "\\`", escape())), lam x => string_unexplode x)
134 | 	val content = red (rpt0 (alt (backtips, nonbacktips)), lam xs => string_join (xs, ""))
135 | 	val str = seq (literal "```", seq (content, literal "```"))
136 | in 
137 | 	red (str, lam x => fst (snd x))
138 | end 
139 | 
140 | implement unsigned_int_dec () =
141 | 	alt (
142 | 		red (
143 | 			literal '0', 
144 | 			lam x => 0), 
145 | 		red (
146 | 			seq (charin "123456789", digits ()), 
147 | 			lam x => string_to_int_unsigned (prepend (snd x, fst x))))       
148 | 
149 | implement signed_int_dec () = 
150 | 	red (
151 | 		seq (
152 | 			red (alt (literal '+', literal '-'), lam x => if x = '+' then 1 else ~1),
153 | 			unsigned_int_dec ()),
154 | 		lam x => let 
155 | 			val a = fst x : int 
156 | 			val b = snd x : int 
157 | 		in a * b end)
158 | 
159 | implement unsigned_int_hex () = let 
160 | 	fun loop (s: string, ret: int): int = 
161 | 		if empty s 
162 | 		then ret 
163 | 		else 
164 | 			if isdigit (head s)
165 | 			then loop (tail s, (head s) - '0' + 16 * ret)
166 | 			else loop (tail s, tolower (head s) - 'a' + 10 + 16 * ret)
167 | in 
168 | 	red (xdigits (), lam x => loop (x, 0))
169 | end
170 | 
171 | implement unsigned_int_bin () = let 
172 | 	val str = red (rpt1 (charin "01"), lam x => string_unexplode x) : lexer string 
173 | 	fun loop (s: string, ret: int): int = 
174 | 		if empty s 
175 | 		then ret 
176 | 		else loop (tail s, (head s) - '0' + 2 * ret)
177 | in 
178 | 	red (str, lam x => loop (x, 0))
179 | end
180 | 
181 | implement unsigned_int_oct () = let
182 | 	val str = red (rpt1 (charin "01234567"), lam x => string_unexplode x) : lexer string 
183 | 	fun loop (s: string, ret: int): int = 
184 | 		if empty s 
185 | 		then ret 
186 | 		else loop (tail s, (head s) - '0' + 8 * ret)
187 | in 
188 | 	red (str, lam x => loop (x, 0))
189 | end
190 | 
191 | implement exponent () = 
192 | 	red (
193 | 		seq (
194 | 			alt (literal 'e', literal 'E'), 
195 | 			alt (signed_int_dec (), unsigned_int_dec ())), 
196 | 		lam x => snd x)
197 | 
198 | implement unsigned_double_dec () = let 
199 | 	val p = digits () :: literal "." :: digits () :: Nil () : list (lexer string)
200 | in
201 | 	red (
202 | 		seq (digits (), 
203 | 			seq (literal ".", digits ())),
204 | 		lam xs => string_to_double_unsigned (string_join (fst xs :: "." :: snd (snd xs) :: Nil (), "")))
205 | end
206 | 
207 | implement signed_double_dec () =
208 | 	red (
209 | 		seq (
210 | 			red (
211 | 				alt (literal '+', literal '-'), 
212 | 				lam x => if x = '+' then 1.0 else ~1.0), 
213 | 			unsigned_double_dec ()), 
214 | 		lam x => let 
215 | 			val a = fst x : double 
216 | 			val b = snd x : double 
217 | 		in a * b end)
218 | 
219 | implement boolean () = 
220 | 	red (
221 | 		alt (literal "true", literal "false"), 
222 | 		lam x => if x = "true" then true else false)
223 | 
224 | implement symbol () = charin "!#$%&*+-./<=>?@\\^|~"
225 | implement symbols () = red (rpt1 (symbol ()), lam x => string_unexplode x)
226 | 
227 | 
228 | staload _ = "util/stream.dats"
229 | staload "util/convert.sats"
230 | 
231 | implement main0 () = () where {
232 | 	val sep = "\n==========================\n"
233 | 	val _ = show (apply (literal 'c', string_to_stream "cdefg"))
234 | 	val _ = show sep 
235 | 	val _ = show (apply (literal "hello", string_to_stream "hello"))
236 | 	val _ = show sep 
237 | 	val _ = show (apply (anychar (), string_to_stream "abcde"))
238 | 	val _ = show sep 
239 | 	val _ = show (apply (charin "cde", string_to_stream "eab"))
240 | 	val _ = show sep 
241 | 	val _ = show (apply (charnotin "cde", string_to_stream "eab"))
242 | 	val _ = show sep 
243 | 	val _ = show (apply (digit (), string_to_stream "123"))
244 | 	val _ = show sep 
245 | 	val _ = show (apply (xdigit (), string_to_stream "a1"))
246 | 	val _ = show sep 
247 | 	val _ = show (apply (alpha (), string_to_stream "a1"))
248 | 	val _ = show sep 
249 | 	val _ = show (apply (spacetab (), string_to_stream "\t"))
250 | 	val _ = show sep 
251 | 	val _ = show (apply (escape (), string_to_stream "\\t"))
252 | 	val _ = show sep 
253 | 	val _ = show (apply (string_double_quote (), string_to_stream "\"abcde\""))
254 | 	val _ = show sep 
255 | 	val _ = show (apply (string_double_quote (), string_to_stream "\"\\tbcde\""))
256 | 	val _ = show sep 
257 | 	val _ = show (apply (string_double_quote (), string_to_stream "\"\tbcde\""))
258 | 	val _ = show sep 
259 | 	val _ = show (apply (string_double_quote (), string_to_stream "\"a\"bcde\""))
260 | 	val _ = show sep 
261 | 	val _ = show (apply (string_double_quote (), string_to_stream "\"abc\\\"de\""))
262 | 	val _ = show sep 
263 | 	val _ = show (apply (string_double_quote (), string_to_stream "\"abc\nde\""))
264 | 	val _ = show sep 
265 | 	val _ = show (apply (string_double_quote (), string_to_stream "\"abc'de\""))
266 | 	val _ = show sep 
267 | 	val _ = show (apply (string_backtip (), string_to_stream "`abcde`"))
268 | 	val _ = show sep 
269 | 	val _ = show (apply (string_backtip (), string_to_stream "`\"abcde`"))
270 | 	val _ = show sep 
271 | 	val _ = show (apply (string_backtip (), string_to_stream "`\\abcde`"))
272 | 	val _ = show sep 
273 | 	val _ = show (apply (string_backtip (), string_to_stream "``abcde`"))
274 | 	val _ = show sep 
275 | 	val _ = show (apply (string_backtip (), string_to_stream "`ab`cde`"))
276 | 	val _ = show sep 
277 | 	val _ = show (apply (string_backtip (), string_to_stream "`\\`abcde`"))
278 | 	val _ = show sep 
279 | 	val _ = show (apply (string_multiline (), string_to_stream "```abc\nde`fs``sa````dasd```asd```"))
280 | 	val _ = show sep 
281 | 	val _ = show (apply (signed_int_dec (), string_to_stream "-109"))
282 | 	val _ = show sep 
283 | 	val _ = show (apply (unsigned_int_hex (), string_to_stream "0fF"))
284 | 	val _ = show sep 
285 | 	val _ = show (apply (unsigned_int_bin (), string_to_stream "101"))
286 | 	val _ = show sep 
287 | 	val _ = show (apply (unsigned_int_oct (), string_to_stream "0777"))
288 | 	val _ = show sep 
289 | 	val _ = show (apply (exponent (), string_to_stream "e+10"))
290 | 	val _ = show sep 
291 | 	val _ = show (apply (unsigned_double_dec (), string_to_stream "10.900"))
292 | 	val _ = show sep 
293 | 	val _ = show (apply (signed_double_dec (), string_to_stream "-10.900"))
294 | 	val _ = show sep 
295 | 	val _ = show (apply (boolean (), string_to_stream "true"))
296 | 	val _ = show sep 
297 | }
298 | 
299 | 
300 | ////
301 | implement lit_char (match) = sat (anychar (), lam x => x = match)
302 | 		
303 | implement lit_string (match) = let 
304 | 	fun genpar (index: int):<cloref1> parser (charloc_stream, location) =
305 | 		if index = len (match) - 1
306 | 		then red (lit_char match[index], lam x => snd x)
307 | 		else red (
308 | 				seq (lit_char match[index], genpar (index+1)), 
309 | 				lam (x) => loc where {
310 | 					val Pair (chloc, loc) = x 
311 | 					val range = range_merge (location_range (snd chloc), location_range loc)
312 | 					val loc = Loc (location_file loc, range)
313 | 				}
314 | 			)
315 | in 
316 | 	red (genpar (0), lam (x) => Pair (match, x))
317 | end
318 | 
319 | implement charin (charset) = 
320 | 	sat (anychar (), lam x => string_find (charset, fst x) >= 0)
321 | 
322 | 
323 | 
324 | implement digit () = 
325 | 	red (
326 | 		sat (anychar (), lam x => isdigit (fst x)),
327 | 		lam x => Pair (fst x - '0', snd x))
328 | 
329 | implement xdigit () = 
330 | 	red (
331 | 		sat (anychar (), lam x => isxdigit (fst x)),
332 | 		lam x => 
333 | 			if isdigit (fst x)
334 | 			then Pair (fst x - '0', snd x)
335 | 			else Pair (tolower (fst x) - 'a' + 10, snd x)
336 | 		)
337 | 
338 | 
339 | implement alpha () = sat (anychar (), lam x => isalpha (fst x))
340 | implement spacetab () = sat (anychar (), lam x => isblank (fst x))
341 | implement printable () = sat (anychar (), lam x => isprint (fst x))
342 | implement newline () = literal '\n'
343 | implement whitespace () = sat (anychar (), lam x => isspace (fst x))
344 | implement charnotin (charset) = sat (anychar (), lam x => string_find (charset, fst x) < 0)
345 | 
346 | implement escape () = let 
347 | 	fun merge (a:location, b:location): location =
348 | 		Loc (location_file a, range_merge (location_range a, location_range b))
349 | 
350 | 	fun mergepair (x: pair (charloc, charloc)): location = merge (snd (fst x), snd (snd x))
351 | 
352 | 	fun projdigit (xs: list (pair (int, location))): list (int) = map (xs, lam x => fst x)
353 | 	fun projloc (xs: list (pair (int, location))): list (location) = map (xs, lam x => snd x)
354 | 
355 | 	val case1 = 
356 | 		red (seq (literal '\\', charin ("abfnrtv\\\'\"?")), 
357 | 			lam x => 
358 | 				case+ fst (snd x) of
359 | 				| 'a' => Pair ('\a', mergepair x)
360 | 				| 'b' => Pair ('\b', mergepair x)
361 | 				| 'f' => Pair ('\f', mergepair x)
362 | 				| 'n' => Pair ('\n', mergepair x)
363 | 				| 'r' => Pair ('\r', mergepair x)
364 | 				| 't' => Pair ('\t', mergepair x)
365 | 				| 'v' => Pair ('\v', mergepair x)
366 | 				| ch  => Pair (ch, mergepair x)
367 | 		)
368 | 	
369 | 	val case2 = let 
370 | 		val p = seq (literal '\\', rptn (digit (), 3))
371 | 		val p = red (p, lam x => let 
372 | 				val ch = int2char0 (list_toint (projdigit (snd x), 8))
373 | 				val begpos = range_begin (location_range (snd (fst x)))
374 | 				val begpos = Pos (position_line begpos, position_col begpos + 1)
375 | 				val endpos = range_end (location_range (snd (fst x)))
376 | 				val endpos = Pos (position_line endpos, position_col endpos + 3)
377 | 			in Pair (ch, Loc (location_file (snd (fst x)), Range (begpos, endpos))) end)
378 | 
379 | 		in p end
380 | 
381 | 	val case3 = let 
382 | 		val p = seq (literal "\\x", rptn (xdigit (), 2))
383 | 		val p = red (p, lam x => let 
384 | 				val ch = int2char0 (list_toint (projdigit (snd x), 16))
385 | 				val begpos = range_begin (location_range (snd (fst x)))
386 | 				val begpos = Pos (position_line begpos, position_col begpos + 2)
387 | 				val endpos = range_end (location_range (snd (fst x)))
388 | 				val endpos = Pos (position_line endpos, position_col endpos + 2)
389 | 			in Pair (ch, Loc (location_file (snd (fst x)), Range (begpos, endpos))) end)
390 | 		in p end
391 | 
392 | in alt (case1, alt (case2, case3)) end
393 | 
394 | 


--------------------------------------------------------------------------------
/old/lexcc.sats:
--------------------------------------------------------------------------------
 1 | staload "parcc.sats"
 2 | staload sm = "util/stream.sats"
 3 | //staload "lexing/token.sats"
 4 | //staload "file/location.sats"
 5 | //staload "util/pair.sats"
 6 | 
 7 | typedef lexer (o:t@ype) = parser (lazy ($sm.stream char), o)
 8 | 
 9 | fun lit_char (char)        : lexer char
10 | fun lit_string (string)    : lexer string
11 | 
12 | fun anychar ()             : lexer char // any input
13 | fun charin (string)        : lexer char // char is in the set
14 | fun charnotin (string)     : lexer char // char is not in the set
15 | fun digit ()               : lexer char // [0-9]
16 | fun xdigit ()              : lexer char // [0-9] + ABCDEF + abcdef
17 | fun alpha ()               : lexer char // [a-zA-Z]
18 | fun alphadigit ()          : lexer char // [a-zA-Z0-9]
19 | fun spacetab ()            : lexer char // space or tab
20 | fun newline ()             : lexer char // \n
21 | fun whitespace ()          : lexer char // space, \t\n\v\f\r
22 | fun printable ()           : lexer char // printable
23 | fun escape ()              : lexer char // c escape
24 | fun symbol () 			   : lexer char // !#$%&*+-/<=>?@\^.|~ (that is, not "'`()[]{},:;_)
25 | 
26 | fun alphas ()              : lexer string
27 | fun digits ()              : lexer string
28 | fun xdigits ()             : lexer string
29 | fun alphadigits ()         : lexer string
30 | fun symbols () 			   : lexer string 
31 | 
32 | fun char_single_quote ()   : lexer char
33 | fun string_double_quote () : lexer string // "asdasdasd"
34 | fun string_backtip ()      : lexer string // `asdasasd`
35 | fun string_multiline ()    : lexer string // ``` asdf;lkasdf;lkj ```
36 | 
37 | // all of these don't include prefix or suffix
38 | // these are purely numbers
39 | fun signed_int_dec ()      : lexer int 
40 | fun unsigned_int_dec ()    : lexer int 
41 | fun unsigned_int_hex ()    : lexer int 
42 | fun unsigned_int_bin ()    : lexer int 
43 | fun unsigned_int_oct ()    : lexer int 
44 | fun exponent ()            : lexer int     // [eE] signed int 
45 | fun unsigned_double_dec () : lexer double  // not including exponent
46 | fun signed_double_dec ()   : lexer double  // not including exponent
47 | 
48 | fun boolean ()             : lexer bool 
49 |  
50 | symintr literal 
51 | overload literal with lit_char 
52 | overload literal with lit_string 
53 | 
54 | fun {o:t@ype} skipws (lexer o): lexer o 
55 | 
56 | (*// These types are for internal use only
57 | // No public use is allowed
58 | typedef charloc = pair (char, location)
59 | typedef charloc_stream = lazy (stream charloc)
60 | typedef strloc = pair (string, location)
61 | typedef intloc = pair (int, location)
62 | 
63 | typedef lex_t = parser (charloc_stream, charloc)
64 | 
65 | //
66 | // lexer
67 | //
68 | symintr literal
69 | 
70 | fun lit_char (input: char): lex_t
71 | fun lit_string (input: string): parser (charloc_stream, strloc)
72 | overload literal with lit_char 
73 | overload literal with lit_string
74 | 
75 | fun anychar (): lex_t // any input
76 | fun charin (string): lex_t // char is in the set
77 | fun charnotin (string): lex_t // char is not in the set
78 | fun digit (): parser (charloc_stream, intloc) // [0-9]
79 | fun xdigit (): parser (charloc_stream, intloc) // [0-9] + ABCDEF + abcdef
80 | fun alpha (): lex_t // [a-zA-Z]
81 | fun spacetab (): lex_t // space or tab
82 | fun newline (): lex_t // \n
83 | fun whitespace (): lex_t // space, \t\n\v\f\r
84 | fun printable (): lex_t // printable
85 | fun escape (): lex_t // c escape*)


--------------------------------------------------------------------------------
/old/trampoline.dats:
--------------------------------------------------------------------------------
 1 | staload "parcc.sats"
 2 | staload "trampoline.sats"
 3 | 
 4 | 
 5 | 
 6 | (* ***** LOCAL in end ***** *) 
 7 | local
 8 | (* ***** LOCAL in end ***** *) 
 9 | 
10 | var g_stackref : ref (stack (call_node (k, v)))
11 | var g_tableref : ref (map (k, map (v, o)))
12 | 
13 | //val g_stack = stack_nil ()
14 | //val g_table = map_nil ()
15 | 
16 | (* ***** local IN end ***** *) 
17 | in 
18 | (* ***** local IN end ***** *) 
19 | 
20 | implement set_call_stack {k,v} (t, s) = t where () = g_stackref := s
21 | implement get_call_stack {k,v} (t) = g_stackref
22 | implement set_memo_table {k,v} (t, m) = t where () = g_tableref := m
23 | implement get_memo_table {k,v} (t) = g_tableref
24 | 
25 | implement has_next (t) = not (empty (!get_call_stack (t)))
26 | 
27 | implement push {k,v} (t, key, value) = 
28 | 	insert (s, key, value) 
29 | 	where s = get_call_stack (t)
30 | 	// tbd
31 | 
32 | 
33 | implement step {o} (t) = 
34 | 	if has_next (t) then 
35 | 		just (apply (node.f, node.args)) where {
36 | 			val s = get_call_stack (t)
37 | 			val node = head (!s)
38 | 			val () = !s := tail (!s)
39 | 		}
40 | 	else
41 | 		nothing ()
42 | 
43 | implement run {o} (t) = let
44 | 	fun loop (t:tramp (o), rs: list (o)): list (o) = 
45 | 		if has_next (t) then
46 | 			loop (t, append (rs, step (t)))
47 | 
48 | 
49 | (* ***** local in END ***** *) 
50 | end
51 | (* ***** local in END ***** *)


--------------------------------------------------------------------------------
/old/trampoline.sats:
--------------------------------------------------------------------------------
  1 | 
  2 | 
  3 | abstype list (a:t@ype) = ptr
  4 | 
  5 | 
  6 | 
  7 | 
  8 | 
  9 | 
 10 | //typedef c0_t (o:t@ype) = () -<cloref1> o 
 11 | //typedef c1_t (i1:t@ype, o:t@ype) = i -<cloref1> o
 12 | //typedef c2_t (i1:t@ype, i2:t2ype, o:t@ype) = (i1, i2) -<cloref1> o 
 13 | 
 14 | typedef callentry_t = @{p = parser a, args = input_t}
 15 | typedef callstack_t = list callentry_t
 16 | typedef memoresult_t = @{ks = list (input_t -<cloref1> output_t), os = list output_t}
 17 | typedef memoentry_t = @{i = input_t, r = ref memoresult_t}
 18 | typedef memotable_t = list ($rec{name = string, fn = () -<cloref1> output_t, memo = list memoentry_t})
 19 | 
 20 | typedef trampoline = $rec{s = ref callstack_t, m = ref memotable_t}
 21 | 
 22 | 
 23 | 
 24 | 
 25 | 
 26 | 
 27 | 
 28 | 
 29 | 
 30 | 
 31 | 
 32 | 
 33 | 
 34 | ////
 35 | 
 36 | fun new_trampoline (): trampoline
 37 | fun free_trampoline (trampoline): void
 38 | 
 39 | 
 40 | fun has_next (trampoline): bool
 41 | 
 42 | 
 43 | 
 44 | 
 45 | fun push_stack (stack, f, args) = {f, args} :: stack 
 46 | fun step (stack) = let 
 47 | 	{f, args} :: s = stack 
 48 | 	 stack := s 
 49 | 	 f(args)
 50 | 
 51 | fun push (f, str, cont) = let 
 52 | 
 53 | 
 54 | abstype entry (k:t@ype, o:t@ype) = ptr 
 55 | fun {k,o:t@ype} entry_make (): entry (k, o)
 56 | fun {k,o:t@ype} entry_put_cont (entry (k, o), k): entry (k, o)
 57 | fun {k,o:t@ype} entry_put_result (entry (k, o), o): entry (k, o)
 58 | datatype _entry (k:t@ype, o:t@ype) = Entry (k, o) of (list k (*continuation*), list o (*output*))
 59 | assume entry (k:t@ype, o:t@ype) = _entry (k, o)
 60 | 
 61 | abstype memo (i:t@ype, k:t@ype, o:t@ype) = ptr 
 62 | fun {i,k,o:t@ype} memo_add_entry (memo (i, k, o), i, entry (k, o)): memo (i, k, o)
 63 | datatype _memo (i:t@ype, k:t@ype, o:t@ype) = Memo (i, k, o) of (i (*input*), _entry (k, o))
 64 | assume memo (i, k, o) = _memo (i, k, o)
 65 | 
 66 | abstype table (f:t@ype, i:t@ype, k:t@ype, o:t@ype) = ptr 
 67 | assume table (f:t@ype, i:t@ype, k:t@ype, o:t@ype) = list ()
 68 | 
 69 | 
 70 | (define/public (push fn str cont)
 71 |       (define head mcar)
 72 |       (define tail mcdr)
 73 |       (define (push-continuation! entry cont)
 74 |       	let x :: xs = entry 
 75 |       	entry := {cont :: x} :: xs 
 76 |       (define (push-result! entry result)
 77 |       	let x :: xs = entry 
 78 |       	entry := x :: {result :: xs}
 79 |       (define (result-subsumed? entry result)
 80 |         (mmember result (tail entry)))
 81 |       (define (make-entry)
 82 |         (mcons (mlist) (mlist)))
 83 | 
 84 |       // table = (fn, memo) :: (fn, memo) :: ...
 85 |       // memo = (str, entry) :: (str, entry) ::
 86 |       (define (table-ref fn str)
 87 |         (let ((pair (massoc fn table)))
 88 |           (match pair
 89 |             [(mcons fn memo)
 90 |              (match (massoc str memo)
 91 |                ;; parser has been called with str before
 92 |                [(mcons str entry) entry]
 93 |                ;; first time parser has been called with str
 94 |                [_ (let ((entry (make-entry)))
 95 |                     (set-mcdr! pair (mcons (mcons str entry) memo))
 96 |                     entry)])]
 97 |             ;; first time parser has been called
 98 |             [_ (let* ((entry (make-entry))
 99 |                       (memo (mlist (mcons str entry))))
100 |                  (set! table (mcons (mcons fn memo) table))
101 |                  entry)])))
102 | 
103 |       	case+ lookup (table, f) of 
104 |       	| (fn, memo) => 
105 |       		case+ lookup(memo, input) of 
106 |       		| (input, entry) => entry 
107 |       		| (_) => (fn, (str, new entry) :: memo)
108 | 
109 |       	| _ => let 
110 |       		entry = pair (nil, nil) = (cont :: cont :: ..., output :: output :: ...)
111 |       		memo  = list of pair (str, entry) = (input, (nil, nil)) :: (input, (nil, nil))
112 |       		table := (f, memo) :: table = (f, (input, (nil, nil)) :: (input, (nil, nil)) ....)
113 | 
114 | 
115 | 
116 | 
117 | ////
118 | staload "parcc.sats"
119 | //
120 | // k: key type, should be the parser
121 | // v: value type, shoud be the stream (the input of the parser)
122 | // o: output type, should be the result (the output of the parser)
123 | //
124 | abstype tramp (k:t@ype, v:t@ype, o:t@ype)
125 | 
126 | typedef tramp (o:t@ype) = [k,v:t@ype] tramp (k, v, o)
127 | typedef tramp (k:t@ype, v:t@ype) = [o:t@ype] tramp (k, v, o)
128 | typedef tramp = [k,v,o:t@ype] tramp (k, v, o)
129 | 
130 | fun has_next 		 (tramp): bool
131 | fun push {k,v:t@ype} (tramp (k, v), k, v): void // stateful
132 | fun step {o:t@ype}   (tramp (o)): maybe (o)	 	// stateful
133 | fun run  {o:t@ype}   (tramp (o)): list (o)		// stateful
134 | 
135 | typedef call_node (k:t@ype, v:t@ype): @{f = k, args = v}
136 | 
137 | //
138 | // These are stateful
139 | //
140 | fun set_call_stack {k,v:t@ype} (tramp (k, v), ref (stack (call_node (k, v)))): tramp (k, v)
141 | fun get_call_stack {k,v:t@ype} (tramp (k, v)): ref (stack (call_node (k, v)))
142 | fun set_memo_table {k,v:t@ype} {o:t@ype} (tramp (k, v, o), ref (map (k, map (v, o)))): tramp (k, v, o)
143 | fun get_memo_table {k,v:t@ype} {o:t@ype} (tramp (k, v, o)): ref (map (k, map (v, o)))


--------------------------------------------------------------------------------
/sexp/LamLite.g4:
--------------------------------------------------------------------------------
  1 | /*
  2 |  * To change this license header, choose License Headers in Project Properties.
  3 |  * To change this template file, choose Tools | Templates
  4 |  * and open the template in the editor.
  5 |  */
  6 | 
  7 | grammar LamLite;
  8 | 
  9 | 
 10 | 
 11 | program	->	{lexeme | whitespace }
 12 | lexeme	->	qvarid | qconid | qvarsym | qconsym
 13 | |	literal | special | reservedop | reservedid
 14 | literal	->	integer | float | char | string
 15 | special	->	( | ) | , | ; | [ | ] | `| { | }
 16 | whitespace	->	whitestuff {whitestuff}
 17 | whitestuff	->	whitechar | comment | ncomment
 18 | whitechar	->	newline | vertab | space | tab | uniWhite
 19 | newline	->	return linefeed | return | linefeed | formfeed
 20 | return	->	a carriage return
 21 | linefeed	->	a line feed
 22 | vertab	->	a vertical tab
 23 | formfeed	->	a form feed
 24 | space	->	a space
 25 | tab	->	a horizontal tab
 26 | uniWhite	->	any Unicode character defined as whitespace
 27 | comment	->	dashes [ any<symbol> {any}] newline
 28 | dashes	->	-- {-}
 29 | opencom	->	{-
 30 | closecom	->	-}
 31 | ncomment	->	opencom ANYseq {ncomment ANYseq}closecom
 32 | ANYseq	->	{ANY}<{ANY}( opencom | closecom ) {ANY}>
 33 | ANY	->	graphic | whitechar
 34 | any	->	graphic | space | tab
 35 | graphic	->	small | large | symbol | digit | special | : | " | '
 36 | small	->	ascSmall | uniSmall | _
 37 | ascSmall	->	a | b | ... | z
 38 | uniSmall	->	any Unicode lowercase letter
 39 | large	->	ascLarge | uniLarge
 40 | ascLarge	->	A | B | ... | Z
 41 | uniLarge	->	any uppercase or titlecase Unicode letter
 42 | symbol	->	ascSymbol | uniSymbol<special | _ | : | " | '>
 43 | ascSymbol	->	! | # | $ | % | & | * | + | . | / | < | = | > | ? | @
 44 | |	\ | ^ | | | - | ~
 45 | uniSymbol	->	any Unicode symbol or punctuation
 46 | digit	->	ascDigit | uniDigit
 47 | ascDigit	->	0 | 1 | ... | 9
 48 | uniDigit	->	any Unicode decimal digit
 49 | octit	->	0 | 1 | ... | 7
 50 | hexit	->	digit | A | ... | F | a | ... | f
 51 | varid	->	(small {small | large | digit | ' })<reservedid>
 52 | conid	->	large {small | large | digit | ' }
 53 | reservedid	->	case | class | data | default | deriving | do | else
 54 | |	if | import | in | infix | infixl | infixr | instance
 55 | |	let | module | newtype | of | then | type | where | _
 56 | varsym	->	( symbol {symbol | :})<reservedop | dashes>
 57 | consym	->	(: {symbol | :})<reservedop>
 58 | reservedop	->	.. | : | :: | = | \ | | | <- | -> | @ | ~ | =>
 59 | varid			(variables)
 60 | conid			(constructors)
 61 | tyvar	->	varid	(type variables)
 62 | tycon	->	conid	(type constructors)
 63 | tycls	->	conid	(type classes)
 64 | modid	->	conid	(modules)
 65 | qvarid	->	[ modid . ] varid
 66 | qconid	->	[ modid . ] conid
 67 | qtycon	->	[ modid . ] tycon
 68 | qtycls	->	[ modid . ] tycls
 69 | qvarsym	->	[ modid . ] varsym
 70 | qconsym	->	[ modid . ] consym
 71 | decimal	->	digit{digit}
 72 | octal	->	octit{octit}
 73 | hexadecimal	->	hexit{hexit}
 74 | integer	->	decimal
 75 | |	0o octal | 0O octal
 76 | |	0x hexadecimal | 0X hexadecimal
 77 | float	->	decimal . decimal [exponent]
 78 | |	decimal exponent
 79 | exponent	->	(e | E) [+ | -] decimal
 80 | char	->	' (graphic<' | \> | space | escape<\&>) '
 81 | string	->	" {graphic<" | \> | space | escape | gap}"
 82 | escape	->	\ ( charesc | ascii | decimal | o octal | x hexadecimal )
 83 | charesc	->	a | b | f | n | r | t | v | \ | " | ' | &
 84 | ascii	->	^cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK
 85 | |	BEL | BS | HT | LF | VT | FF | CR | SO | SI | DLE
 86 | |	DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN
 87 | |	EM | SUB | ESC | FS | GS | RS | US | SP | DEL
 88 | cntrl	->	ascLarge | @ | [ | \ | ] | ^ | _
 89 | gap	->	\ whitechar {whitechar}\
 90 | 
 91 | 
 92 | 
 93 | VARID 
 94 |     : SMALL (SMALL | LARGE | DIGIT | '_')*
 95 |     ;
 96 | 
 97 | CONID
 98 |     : LARGE (SMALL | LARGE | DIGIT | '_')*
 99 |     ;
100 | 
101 | VARSYM 
102 |     : SYMBOL (SYMBOL | ':')*
103 |     ;
104 | 
105 | CONSYM 
106 |     : ':' (SYMBOL | ':')*
107 |     ;
108 | 
109 | SMALL
110 |     : ASCII_SMALL
111 |     ;
112 | 
113 | LARGE 
114 |     : ASCII_LARGE 
115 |     ;
116 | 
117 | SYMBOL 
118 |     : ASCII_SYMBOL
119 |     ;
120 | 
121 | DIGIT
122 |     : ASCII_DIGIT
123 |     ;
124 | 
125 | fragment ASCII_SMALL 
126 |     : [a-z]
127 |     ;
128 | 
129 | fragment ASCII_LARGE 
130 |     : [A-Z]
131 |     ;
132 | 
133 | fragment ASCII_SYMBOL 
134 |     : [!#$%&*+./<=>?@\^|~] | '-'
135 |     ;
136 | 
137 | fragment ASCII_DIGIT 
138 |     : [0-9]
139 |     ;
140 | 
141 | fragment SPECIAL_SYM 
142 |     : [(),;\[\]`{}]
143 |     ;
144 | 
145 | GAP
146 |     : [ \t\r\n\u000C]+ -> skip
147 |     ;
148 | 
149 | LINE_COMMENT
150 |     : '--' ~[\r\n]* -> skip
151 |     ;
152 | 
153 | BLOCK_COMMENT 
154 |     : '{-' .*? '-}' -> skip 
155 |     ;
156 | 
157 | REST_COMMENT 
158 |     : '----' .*? -> skip
159 |     ;


--------------------------------------------------------------------------------
/sexp/lexer.dats:
--------------------------------------------------------------------------------
 1 | #define ATS_DYNLOADFLAG 0
 2 | 
 3 | staload "util/util.sats"
 4 | staload "util/string.sats"
 5 | staload "util/pair.sats"
 6 | staload "sexp/lexer.sats"
 7 | staload "lexcc.sats"
 8 | staload "sexp/token.sats"
 9 | staload "parcc.sats"
10 | 
11 | 
12 | staload _ = "parcc.dats"
13 | staload _ = "lexcc.dats"
14 | staload _ = "util/list.dats"
15 | staload _ = "util/pair.dats"
16 | 
17 | implement lex_comment () =
18 | 	red (
19 | 		seq (
20 | 			literal "---", 
21 | 			rpt1 (
22 | 				sat (anychar (), lam x => x != '\n'))), 
23 | 		lam x => TComment (string_unexplode (snd x)))
24 | 
25 | implement lex_space () =   
26 | 	red (rpt1 (whitespace ()), lam x => TSpace ())
27 | 
28 | implement lex_id () = let 
29 | 	val case1 = red (seq (literal '_', alphadigits()), lam x => prepend (snd x, '_'))
30 | 	val case2 = red (seq (alphadigit (), red (rpt0 (alt (alphadigit (), literal '_')), lam x => string_unexplode x)), lam x => prepend (snd x, fst x))
31 | in 
32 | 	red (alt (case1, case2), lam x => TId (x))
33 | end
34 | 
35 | implement lex_lparen ()     = red (literal "(", lam _ => TLParen ())
36 | implement lex_rparen ()     = red (literal ')', lam _ => TRParen ())
37 | implement lex_lcurly ()     = red (literal "(", lam _ => TLCurly ())
38 | implement lex_rcurly ()     = red (literal '}', lam _ => TRCurly ())
39 | implement lex_lbrac ()      = red (literal "[", lam _ => TLBrac ())
40 | implement lex_rbrac ()      = red (literal ']', lam _ => TRBrac ())
41 | implement lex_underscore () = red (literal '_', lam _ => TUnderscore ())
42 | implement lex_colon ()      = red (literal ':', lam _ => TColon ())
43 | implement lex_semicolon ()  = red (literal ';', lam _ => TSemiColon ())
44 | implement lex_comma ()      = red (literal ',', lam _ => TComma ())
45 | 
46 | implement lex_lambda () = red (literal "lambda", lam _ => TLambda ())
47 | implement lex_case ()   = red (literal "case", lam _ => TCase ())
48 | implement lex_if ()     = red (literal "if", lam _ => TIf ())
49 | implement lex_let ()    = red (literal "let", lam _ => TLet ())
50 | implement lex_val ()    = red (literal "val", lam _ => TVal ())
51 | 
52 | implement lex_string () = red (string_backtip(), lam x => TString (x))
53 | implement lex_char () = red (char_single_quote (), lam x => TChar (x))
54 | implement lex_int () = red (alt (signed_int_dec (), unsigned_int_dec ()), lam x => TInt (x))
55 | implement lex_double () = red (alt (unsigned_double_dec (), signed_double_dec ()), lam x => TDouble (x))
56 | implement lex_bool () = red (boolean (), lam x => TBool (x))    
57 | implement lex_symbol () = red (symbols (), lam x => TSym (x))
58 | 
59 | 
60 | 


--------------------------------------------------------------------------------
/sexp/lexer.sats:
--------------------------------------------------------------------------------
 1 | 
 2 | staload "util/util.sats"
 3 | staload "lexcc.sats"
 4 | staload "sexp/token.sats"
 5 | 
 6 | fun lex_comment ()       : lexer token
 7 | fun lex_space ()         : lexer token
 8 | fun lex_id ()            : lexer token
 9 | fun lex_lparen ()        : lexer token
10 | fun lex_rparen ()        : lexer token
11 | fun lex_lcurly ()        : lexer token
12 | fun lex_rcurly ()        : lexer token
13 | fun lex_lbrac ()         : lexer token
14 | fun lex_rbrac ()         : lexer token
15 | fun lex_underscore ()    : lexer token
16 | fun lex_colon ()         : lexer token
17 | fun lex_semicolon ()     : lexer token
18 | fun lex_comma ()         : lexer token
19 | 
20 | fun lex_lambda ()        : lexer token
21 | fun lex_case ()          : lexer token
22 | fun lex_if ()            : lexer token
23 | fun lex_let ()           : lexer token
24 | fun lex_val ()           : lexer token
25 | 
26 | fun lex_string ()        : lexer token
27 | fun lex_char ()          : lexer token
28 | 
29 | fun lex_int ()           : lexer token
30 | fun lex_double ()        : lexer token
31 | fun lex_bool ()          : lexer token
32 | 
33 | fun lex_symbol ()        : lexer token


--------------------------------------------------------------------------------
/sexp/syntax.sats:
--------------------------------------------------------------------------------
 1 | 
 2 | 
 3 | 
 4 | 
 5 | datatype syntree = 
 6 | 	| SynTerminal
 7 | 	| SynExp
 8 | 
 9 | datatype synexpr = 
10 | 	| SEId
11 | 	| SEValue
12 | 	| SE
13 | 
14 | datatype synvalue = 
15 | 	| SVString 
16 | 	| SVInt
17 | 	| SVDouble
18 | 	| SVList
19 | 	| SVMap 
20 | 	| SVVoid
21 | 
22 | datatype synpattern = 
23 | 	| SPId of ()
24 | 	| SPAny of ()
25 | 	| SPVoid of ()
26 | 	| SPList of (list synpattern)


--------------------------------------------------------------------------------
/sexp/token.dats:
--------------------------------------------------------------------------------
 1 | #include "share/atspre_staload.hats"
 2 | #define ATS_DYNLOADFLAG 0
 3 | staload "libc/SATS/stdio.sats"
 4 | 
 5 | staload "util/util.sats"
 6 | staload "sexp/token.sats"
 7 | staload "file/location.sats"
 8 | staload "util/maybe.sats"
 9 | staload "util/list.sats"
10 | 
11 | 
12 | staload _ = "util/list.dats"
13 | staload _ = "file/location.dats"
14 | staload _ = "util/maybe.dats"
15 | 
16 | implement fprint_token (t, out) =
17 |     case+ t of 
18 |     | TComment    s   => $extfcall (void, "fprintf", out, "TComment (%s)", s)
19 |     | TSpace      _  => $extfcall (void, "fprintf", out, "TSpace")
20 |     | TId         id  => $extfcall (void, "fprintf", out, "TId (%s)", id)
21 | 
22 |     | TLParen     _   => $extfcall (void, "fprintf", out, "TLParen")
23 |     | TRParen     _   => $extfcall (void, "fprintf", out, "TRParen")
24 |     | TLCurly     _   => $extfcall (void, "fprintf", out, "TLCurly")
25 |     | TRCurly     _   => $extfcall (void, "fprintf", out, "TRCurly")
26 |     | TLBrac      _   => $extfcall (void, "fprintf", out, "TLBrac")
27 |     | TRBrac      _   => $extfcall (void, "fprintf", out, "TRBrac")
28 |     | TUnderscore _   => $extfcall (void, "fprintf", out, "TUnderscore")
29 |     | TColon      _   => $extfcall (void, "fprintf", out, "TColon")
30 |     | TSemiColon  _   => $extfcall (void, "fprintf", out, "TSemiColon")
31 |     | TComma      _   => $extfcall (void, "fprintf", out, "TComma")
32 |     
33 | 
34 |     | TLambda     _   => $extfcall (void, "fprintf", out, "TLambda")
35 |     | TCase       _   => $extfcall (void, "fprintf", out, "TCase")
36 |     | TIf         _   => $extfcall (void, "fprintf", out, "TIf")
37 |     | TLet        _   => $extfcall (void, "fprintf", out, "TLet")
38 |     | TVal        _   => $extfcall (void, "fprintf", out, "TVal")
39 | 
40 |     | TChar       c   => $extfcall (void, "fprintf", out, "TChar (%c)", c)
41 |     | TString     s   => $extfcall (void, "fprintf", out, "TString (%s)", s)
42 |     | TInt        i   => $extfcall (void, "fprintf", out, "TInt (%d)", i)
43 |     | TDouble     d   => $extfcall (void, "fprintf", out, "TDouble (%f)", d)
44 |     | TBool       b   => $extfcall (void, "fprintf", out, "TBool (%d)", b)
45 | 
46 |     | TSym        opr => $extfcall (void, "fprintf", out, "TSym (%s)", opr)
47 | 
48 | implement print_token (t) = fprint_token (t, stdout_ref)
49 | 
50 | //assume token = '{node = tokennode, loc = location}
51 | 
52 | //implement fprint_token (out, t) = () where {
53 | //  val _ = fprint (out, t.node)
54 | //  val _ = fprint (out, " at ")
55 | //  val _ = fprint (out, t.loc)
56 | //}
57 | 
58 | 
59 | 
60 | //implement token_get_file (t) = location_file t.loc
61 | //implement token_get_range (t) = location_range t.loc
62 | //implement token_get_location (t) = t.loc
63 | //implement token_get_node (t) = t.node
64 | //implement token_make (t, loc) = '{node = t, loc = loc}
65 | 
66 | //implement fprint_token_list (out, ts, len) = 
67 | //  if empty (ts) || len = 0
68 | //  then fprint (out, "nil")
69 | //  else fprint_token_list (out, tail ts, len - 1) where {
70 | //      val _ = fprint_token (out, maybe_unjust (head ts))
71 | //      val _ = fprint (out, '\n')
72 | //  }


--------------------------------------------------------------------------------
/sexp/token.sats:
--------------------------------------------------------------------------------
  1 | staload "util/util.sats"
  2 | staload "file/location.sats"
  3 | staload "util/list.sats"
  4 | 
  5 | //abstype token = ptr
  6 | 
  7 | datatype token = 
  8 | //main
  9 |     | TSpace      of ()
 10 |     | TComment    of string
 11 |     | TId         of string
 12 |   
 13 | //misc  
 14 |     | TLParen     of () // (
 15 |     | TRParen     of () // )
 16 |     | TLCurly     of () // {
 17 |     | TRCurly     of () // }
 18 |     | TLBrac      of () // [
 19 |     | TRBrac      of () // ]
 20 |     | TUnderscore of () // _
 21 |     | TColon      of () // :
 22 |     | TSemiColon  of () // ;
 23 |     | TComma      of () // ,
 24 |  
 25 | //keyword 
 26 |     | TLambda     of ()
 27 |     | TCase       of ()
 28 |     | TIf         of ()
 29 |     | TLet        of () 
 30 |     | TVal        of ()
 31 |   
 32 | //literal  
 33 |     | TString     of string 
 34 |     | TChar       of char 
 35 |     | TInt        of int 
 36 |     | TDouble     of double
 37 |     | TBool       of bool 
 38 |   
 39 | //operator  
 40 |     | TSym        of string
 41 | 
 42 | fun print_token (token): void 
 43 | fun fprint_token (token, FILEref): void
 44 | 
 45 | overload show with print_token 
 46 | overload show with fprint_token 
 47 | 
 48 | 
 49 | 
 50 | (*
 51 |   top-level-form         = general-top-level-form
 52 |                          | (#%expression expr)
 53 |                          | (module id module-path (#%plain-module-begin module-level-form ...))
 54 |                          | (begin top-level-form ...)
 55 |                          | (begin-for-syntax top-level-form ...)
 56 |                  
 57 |   module-level-form      = general-top-level-form
 58 |                          | (#%provide raw-provide-spec ...)
 59 |                          | (begin-for-syntax module-level-form ...)
 60 |                          | submodule-form
 61 |                          | (#%declare declaration-keyword ...)
 62 |                  
 63 |   submodule-form         = (module id module-path (#%plain-module-begin module-level-form ...))
 64 |                          | (module* id module-path (#%plain-module-begin module-level-form ...))
 65 |                          | (module* id #f (#%plain-module-begin module-level-form ...))
 66 |                  
 67 |   general-top-level-form = expr
 68 |                          | (val (id+) expr)
 69 | 
 70 |                          | (define-syntaxes (id ...) expr)
 71 |                          | (#%require raw-require-spec ...)
 72 |                  
 73 |   expr                   = id
 74 |                          | value
 75 |                          | (expr)
 76 |                          | (expr expr+)
 77 |                          | (lambda pattern expr)
 78 |                          | (case expr (pattern expr)+)
 79 |                          | (if expr expr expr?)
 80 |                          | (let (pattern expr)+ expr)
 81 | 
 82 |   value                  = string
 83 |                          | int
 84 |                          | bool
 85 |                          | double
 86 |                          | ()
 87 |                          | (list value+)        // list
 88 |                          | (map (value value)+) // map
 89 |                          | (value value+)       // tuple
 90 |                          | (value)
 91 | 
 92 | 
 93 |                          | (begin expr ...+)
 94 |                          | (begin0 expr expr ...)
 95 |                          | (let-values ([(id ...) expr] ...) expr ...+)
 96 |                          | (letrec-values ([(id ...) expr] ...) expr ...+)
 97 |                          | (set! id expr)
 98 |                          | (quote datum)
 99 |                          | (quote-syntax datum)
100 |                          | (with-continuation-mark expr expr expr)
101 |                          | (#%plain-app expr ...+)
102 |                          | (#%top . id)
103 |                          | (#%variable-reference id)
104 |                          | (#%variable-reference (#%top . id))
105 |                          | (#%variable-reference)
106 | 
107 |   pattern                = id
108 |                          | value
109 |                          | (list pattern+)
110 |                          | (map (pattern pattern)+)
111 |                          | (tuple pattern pattern+)
112 |                          | ()
113 |                          | (pattern)
114 |                          | void
115 |                          | _
116 | 
117 |   formals                = (id ...)
118 |                          | (id ...+ . id)
119 |                          | id
120 | 
121 | *)
122 | 
123 | 
124 | 
125 | 
126 | 
127 | 
128 | ////
129 | fun token_get_file (token): string
130 | fun token_get_range (token): range
131 | fun token_get_location (token): location
132 | fun token_get_node (token): tokennode
133 | fun token_make (tokennode, location): token
134 | 
135 | fun fprint_token (out: FILEref, t: token): void
136 | fun fprint_tokennode (out: FILEref, t: tokennode): void
137 | fun fprint_token_list (out: FILEref, ts: list (token), int): void
138 | overload fprint with fprint_token
139 | overload fprint with fprint_tokennode
140 | overload fprint with fprint_token_list 
141 | 
142 | 
143 | 


--------------------------------------------------------------------------------
/simple/parcc.sats:
--------------------------------------------------------------------------------
  1 | staload "symintr.sats"
  2 | staload "list.sats"
  3 | staload "maybe.sats"
  4 | 
  5 | 
  6 | typedef nat = intGte 0
  7 | 
  8 | abstype parser (a:t@ype) = ptr 
  9 | 
 10 | abstype input_t  = ptr
 11 | abstype output_t = ptr 
 12 | 
 13 | typedef cont_t (a:t@ype) = (a, input_t) -<cloref1> output_t 
 14 | typedef cont_t = [a:t@ype] cont_t a
 15 | 
 16 | typedef par_t  (a:t@ype) = (input_t, cont_t a) -<cloref1> output_t
 17 | typedef par_t = [a:t@ype] par_t a
 18 |  
 19 | castfn parser_encode {a:t@ype} (par_t a): parser a
 20 | castfn parser_decode {a:t@ype} (parser a): par_t a
 21 | 
 22 | fun {a:t@ype}     parser_apply   (parser a, input_t, cont_t a): output_t
 23 | 
 24 | fun {a:t@ype}     parser_fail    (): parser (a)
 25 | fun {a:t@ype}     parser_succeed (a): parser (a)
 26 |   
 27 | fun {a:t@ype}     parcc_maybe (parser a): parser (maybe a)
 28 | fun {a,b:t@ype}   parcc_bind  (parser a, a -<cloref1> parser b): parser b
 29 | 
 30 | fun {a,b:t@ype}   parcc_seq   (parser a, parser b): parser ($tup(a, b))
 31 | fun {a,b,c:t@ype} parcc_seq3  (parser a, parser b, parser c): parser ($tup(a, b, c))
 32 | fun {a:t@ype}     parcc_seqs  (list (parser a)): parser (list a)
 33 | fun {a:t@ype}     parcc_alt   (parser a, parser a): parser a
 34 | fun {a:t@ype}     parcc_alt3  (parser a, parser a, parser a): parser a
 35 | fun {a:t@ype}     parcc_alts  (list (parser a)): parser a
 36 |  
 37 | fun {a:t@ype}     parcc_sat   (parser a, a -<cloref1> bool): parser a
 38 | fun {a:t@ype}     parcc_skip  (parser a): parser void
 39 | fun {a,b:t@ype}   parcc_map   (parser a, a -<cloref1> b): parser b
 40 | fun {a:t@ype}     parcc_rptn  (parser a, nat): parser (list a)
 41 | fun {a:t@ype}     parcc_rpt1  (parser a): parser (list a)
 42 | fun {a:t@ype}     parcc_rpt0  (parser a): parser (list a)
 43 | fun {a,b:t@ype}   parcc_sepby (parser a, parser b): parser (list a)
 44 | 
 45 | symintr memo 
 46 | fun {o:t@ype}  		memo0 (() -<cloref1> o): () -<cloref1> o
 47 | fun {i,o:t@ype} 	memo1 (i -<cloref1> o): i -<cloref1> o 
 48 | fun {i1,i2,o:t@ype} memo2 ((i1, i2) -<cloref1> o): (i1, i2) -<cloref1> o 
 49 | overload memo with memo0
 50 | overload memo with memo1 
 51 | overload memo with memo2
 52 | 
 53 | exception ParsingException of (string)
 54 | //fun 
 55 | //fun {a:t@ype} memo_parser (par_t a): par_t a
 56 | 
 57 | 
 58 | 
 59 | 
 60 | 
 61 | 
 62 | 
 63 | 
 64 | 
 65 | 
 66 | ////
 67 | 
 68 | (* types *)
 69 | 
 70 | abstype input_t = ptr
 71 | //abstype output_t = ptr
 72 | 
 73 | datatype result (o:t@ype) = 
 74 |     | Success of (o, input_t)
 75 |     | Failure of (input_t)
 76 | 
 77 | typedef cont (o:t@ype, a:t@ype) = result o -<cloref1> a
 78 | 
 79 | abstype parser (o:t@ype) = ptr
 80 | //typedef parser (o:t@ype) = parser (lazy ($sm.stream char), o)
 81 | 
 82 | typedef parserfun (o:t@ype, a:t@ype) = (input_t, cont (o, a)) -<cloref1> a
 83 | 
 84 | castfn mk   {o,a:t@ype} (parserfun (o, a)): parser o
 85 | castfn unmk {o,a:t@ype} (parser o): parserfun (o, a)
 86 | 
 87 | //absvtype trampoline 
 88 | 
 89 | (* show functions *)
 90 | 
 91 | fun {o:t@ype}     show_result        (result o, o -> void): void
 92 | fun               show_result_char   (result char)        : void
 93 | fun               show_result_string (result string)      : void
 94 | fun               show_result_int    (result int)         : void
 95 | fun               show_result_double (result double)      : void
 96 | fun               show_result_bool   (result bool)        : void
 97 | fun               show_result_unit   (result unit)        : void
 98 | 
 99 | overload show with show_result
100 | overload show with show_result_int
101 | overload show with show_result_string
102 | overload show with show_result_char
103 | overload show with show_result_bool
104 | overload show with show_result_double
105 | overload show with show_result_unit
106 | 
107 | (* basic combinators *)
108 | 
109 | fun {o:t@ype}     succeed (o): parser o
110 | fun {o:t@ype}     fail    (): parser o
111 | fun {o1,o2:t@ype} bind    (parser o1, o1 -<cloref1> parser o2): parser o2
112 | fun {o,a:t@ype}   apply   (parser o, input_t, cont (o, a)): a
113 | 
114 | fun {o1,o2:t@ype} seq     (parser o1, parser o2): parser (pair (o1, o2))
115 | fun {o:t@ype}     alt     (parser o, parser o): parser o
116 | 
117 | fun {o,a:t@ype}   memo_cps (parser o): parser o
118 | 
119 | 
120 | ////
121 | fun {i:t@ype} {o:t@ype}       force   (lazy (parser (i, o, e))): parser (i, o, e)
122 | 
123 | fun {i:t@ype} {o:t@ype}       alt     (parser (i, o, e1), parser (i, o, e2)):                                         parser (i, o, e1 || e2)
124 | 
125 | 
126 | 
127 | 
128 | 
129 | ////
130 | 
131 | (*
132 |  *  parsers
133 |  *)
134 | 
135 | fun spaces ()              : parser (unit, true) // \s*
136 | fun space ()               : parser char // \s
137 | fun spacetab ()            : parser char // \s\t
138 | fun ws ()                  : parser (unit, true) // \s\t\n\v\f\r *
139 | fun newline ()             : parser char // \n
140 | fun tab ()                 : parser char // \t
141 | fun uppercase ()           : parser char // [A-Z]
142 | fun lowercase ()           : parser char // [a-z]
143 | fun alpha ()               : parser char // [a-zA-Z]
144 | fun alphadigit ()          : parser char // [a-zA-Z0-9]
145 | fun digit ()               : parser char // [0-9]
146 | fun hexdigit ()            : parser char // [0-9A-Fa-f]
147 | fun octdigit ()            : parser char // [0-7]
148 | fun anychar ()             : parser char // .
149 | fun printable ()           : parser char // printable
150 | fun escape ()              : parser char // c escape
151 | fun symbol ()              : parser char // !#$%&*+-/<=>?@\^.|~ (that is, not "'`()[]{},:;_)
152 | fun litchar (char)         : parser char
153 | fun oneof (string)         : parser char
154 | fun noneof (string)        : parser char
155 |     
156 | fun litstring (string)     : parser string
157 | fun alphas ()              : parser string // [a-zA-Z]+
158 | fun digits ()              : parser string // [0-9]+
159 | fun alphadigits()          : parser string // [a-zA-Z0-9]+
160 | fun hexdigits ()           : parser string // [a-fA-F0-9]+
161 | fun octdigits ()           : parser string // [0-7]+
162 | fun uppercases ()          : parser string // [A-Z]+
163 | fun lowercases ()          : parser string // [a-z]+
164 | fun symbols ()             : parser string // symbol+
165 | 
166 | fun eof ()                 : parser (unit, true)
167 | 
168 | (*
169 |  *  misc parsers
170 |  *)
171 | 
172 | fun id (): parser string // [a-zA-Z_][a-zA-Z0-9_]*
173 | 
174 | //fun char_single_quote ()     : parser char   // '_'
175 | //fun string_double_quote ()   : parser string // "one line string"
176 | //fun string_backtip ()        : parser string // `one line string`
177 | //fun string_triple_backtip () : parser string // ```multi line string```
178 | 
179 | (*
180 |  *  combinators
181 |  *)
182 | 
183 | 
184 | 
185 | //fun {i:t@ype} {o:t@ype}       alts     {e:bool} (list (parser (i, o, e))):   [e:bool]                             parser (i, o, e )
186 | //fun {i:t@ype} {o:t@ype}       seqs     (list (parser (i, o))):                                parser (i, list o)
187 | 
188 | fun {i:t@ype} {o,o1:t@ype}    seqr     {e1,e2:bool}   (parser (i, o1, e1), parser (i, o, e2)):                                        parser (i, o, e1 && e2) // keep right, disgard left
189 | fun {i:t@ype} {o,o1:t@ype}    seql     {e1,e2:bool}   (parser (i, o, e1), parser (i, o1, e2)):                                        parser (i, o, e1 && e2) // keep left, disgard right
190 | fun {i:t@ype} {o:t@ype}       sat      {e:bool}       (parser (i, o, e), o -<cloref1> bool):                                          parser (i, o, e)
191 | fun {i:t@ype} {o:t@ype}       opt      {e:bool}       (parser (i, o, e)):                                                             parser (i, maybe o, e)
192 | fun {i:t@ype} {o:t@ype}       rpt0                    (parser (i, o, false)):                                                         parser (i, list o, true)
193 | fun {i:t@ype} {o:t@ype}       rpt1                    (parser (i, o, false)):                                                         parser (i, list o, false)
194 | fun {i:t@ype} {o:t@ype}       rptn     {n:nat}        (parser (i, o, false), int n):                                                  parser (i, list o, n == 0)
195 | fun {i:t@ype} {o1,o2:t@ype}   rptuntil {e:bool}       (p: parser (i, o1, false), e: parser (i, o2, e)):                               parser (i, list o1, e)
196 | fun {i:t@ype} {o:t@ype}       skip     {e:bool}       (parser (i, o, e)):                                                             parser (i, unit, e)
197 | fun {i:t@ype} {o:t@ype}       not      {e:bool}       (parser (i, o, e)):                                                             parser (i, unit, true)
198 | fun {i,o:t@ype} {r:t@ype}     red      {e:bool}       (parser (i, o, e), f: o -<cloref1> r):                                          parser (i, r, e)
199 | fun {i:t@ype} {o,o1,o2:t@ype} between  {e1,e2:bool}   (p: parser (i, o, false), open: parser (i, o1, e1), close: parser (i, o2, e2)): parser (i, o, false)
200 | fun {i:t@ype} {o1,o2:t@ype}   sepby0   (*{e1,e2:bool|(e1&&e2)==false}*) {e:bool} (p: parser (i, o1, false), sep: parser (i, o2, e)):                 parser (i, list o1, true)
201 | fun {i:t@ype} {o1,o2:t@ype}   sepby1   (*{e1,e2:bool|(e1&&e2)==false}*) {e:bool} (p: parser (i, o1, false), sep: parser (i, o2, e)):                 parser (i, list o1, false)
202 | 
203 | 
204 | 
205 | 
206 | (* 
207 |  *  test
208 |  *)
209 | 
210 | fun parser_test (): void 
211 | 
212 | //infixl +>
213 | //infixl <+
214 | //infixl <+>
215 | //infixl <|>
216 | 
217 | //overload +> with seqr 
218 | //overload <+ with seql
219 | //overload <+> with seq 
220 | //overload <|> with alt 
221 | 
222 | 
223 | 
224 | 


--------------------------------------------------------------------------------
/test/1.test:
--------------------------------------------------------------------------------
1 | + 1 2


--------------------------------------------------------------------------------
/test/test.dats:
--------------------------------------------------------------------------------
 1 | #include "share/atspre_staload.hats"
 2 | staload "libc/SATS/stdio.sats"
 3 | 
 4 | staload "parcc.sats"
 5 | staload "lexing/token.sats"
 6 | staload "lexing/lexcc.sats"
 7 | staload "file/file.sats"
 8 | staload "file/location.sats"
 9 | staload "util/pair.sats"
10 | staload "util/stream.sats"
11 | staload "util/util.sats"
12 | 
13 | staload _ = "parcc.dats"
14 | staload _ = "lexing/token.dats"
15 | staload _ = "file/file.dats"
16 | staload _ = "file/location.dats"
17 | staload _ = "util/stream.dats"
18 | staload _ = "util/pair.dats"
19 | staload _ = "util/maybe.dats"
20 | staload _ = "util/list.dats"
21 | staload _ = "lexing/token.dats"
22 | staload _ = "lexing/lexcc.dats"
23 | 
24 | 
25 | 
26 | 
27 | val ops = charin "+-*/"
28 | val number = red (digit()^+, lam x => foldr (x, 0, lam x, y => x + 10 * y))
29 | 
30 | 
31 | 
32 | 
33 | extern fun test (path: string): void
34 | 
35 | implement test (path) = () where {
36 | 
37 | 	val sm = file_get_stream path
38 | 
39 | 
40 | 	val _ = show (apply (skipws ops() <|> skipws number() <|> skipws number())
41 | 	
42 | }
43 | 
44 | 
45 | implement main0 () = () where {
46 | 	val _ = test("./test/1.test")
47 | }


--------------------------------------------------------------------------------
/test/test2.dats:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/steinwaywhw/ats-parcc/c5c45a444ad5a9f3eba92b7b4469743e297570ac/test/test2.dats


--------------------------------------------------------------------------------
/untyped/1.test:
--------------------------------------------------------------------------------
1 | (lam (x) => x) (y)
2 | lam (y) => x y


--------------------------------------------------------------------------------
/untyped/parser.dats:
--------------------------------------------------------------------------------
  1 | #include "share/atspre_staload.hats"
  2 | #define ATS_DYNLOADFLAG 0
  3 | 
  4 | staload "parcc.sats"
  5 | staload _ = "parcc.dats"
  6 | 
  7 | staload "util/util.sats"
  8 | staload "util/list.sats"
  9 | staload "util/string.sats"
 10 | staload "util/pair.sats"
 11 | staload sm = "util/stream.sats"
 12 | 
 13 | staload _ = "util/list.dats"
 14 | staload _ = "util/stream.dats"
 15 | staload _ = "util/string.dats"
 16 | staload _ = "util/pair.dats"
 17 | 
 18 | staload "untyped/parser.sats"
 19 | 
 20 | #define :: Cons
 21 | 
 22 | infixl +>
 23 | infixl <+
 24 | infixl <+>
 25 | infixl <|>
 26 | infixl </>
 27 | 
 28 | postfix ^?
 29 | postfix ^+
 30 | postfix ^*
 31 | 
 32 | overload +> with seqr 
 33 | overload <+ with seql
 34 | overload <+> with seq 
 35 | overload <|> with alt 
 36 | overload </> with red
 37 | 
 38 | overload ^? with opt 
 39 | overload ^+ with rpt1
 40 | overload ^* with rpt0
 41 | 
 42 | implement show_syntax (s) = 
 43 | 	case+ s of 
 44 | 	| TmVar x => $extfcall (void, "printf", "var(%s)", x)
 45 | 	| TmApp (x, y) => () where {
 46 | 		val _ = show "("
 47 | 		val _ = show_syntax x 
 48 | 		val _ = show ")"
 49 | 		val _ = show "("
 50 | 	 	val _ = show_syntax y 
 51 | 	 	val _ = show ")"
 52 | 	}
 53 | 	| TmLam (x, y) => () where {
 54 | 		val _ = $extfcall (void, "printf", "lam(%s)=>", x)
 55 | 		val _ = show_syntax y
 56 | 	}
 57 | 
 58 | //implement parser_lam () = $delay (let 
 59 | //	val _ = show "lam\n"
 60 | 
 61 | //	val l = skip (litstring "lam" <+> ws ())
 62 | //	val b = between (ws () +> id () <+ ws (), litstring "(", litstring ")")
 63 | //	val o = between (skip (litstring "=>"), ws(), ws())
 64 | //in 
 65 | 	
 66 | //		red (l +> b <+ o <+> force (parser ()), lam x => TmLam (fst x, snd x))
 67 | //end
 68 | //)
 69 | 
 70 | //implement parser_var () = 
 71 | //	(id () \red (lam x => TmVar x))
 72 | //	where {
 73 | //		val _ = show "var\n"
 74 | //	}
 75 | 
 76 | 
 77 | //implement parser_app () = 
 78 | //	$delay (
 79 | //		red (
 80 | //			force (parser ()) <+ ws () <+> between (force (parser ()), litstring "(", litstring ")"),
 81 | //			lam x => TmApp (fst x, snd x))
 82 | //	)
 83 | //	where {
 84 | //		val _ = show "app\n"
 85 | //	}
 86 | 
 87 | 
 88 | 
 89 | implement parser () = $delay let 
 90 | 
 91 | //	val _ = $showtype parser()
 92 | 	val b = lam p => between (p, litstring "(" <+> ws(), ws () <+> litstring ")")
 93 | 
 94 | 	val pvar = (id () \sat (lam x => x != "lam")) </> (lam x => TmVar x) where {val _ = show "var\n"}
 95 | 
 96 | //	val papp = $delay (
 97 | //			 force (parser ()) <+ ws () <+> between (force (parser ()), litstring "(" <+> ws(), ws () <+> litstring ")") </> (lam x => TmApp (fst x, snd x))
 98 | //		) where {val _ = show "app\n"}
 99 | 	
100 | 	val plam = $delay (
101 | 			litstring "lam" +> ws () +> b (id()) <+ ws () <+ litstring "=>" <+ ws () <+> force (parser ()) (*succeed (TmVar ("s"))*) </> (lam x => TmLam (fst x, snd x))
102 | 		) where {val _ = show "lam\n"}
103 | 
104 | 	val papp1 = $delay (
105 | 			pvar <+ ws() <+> force (parser ()) </> (lam x => TmApp (fst x, snd x))
106 | 		)
107 | 
108 | 	val papp2 = $delay (
109 | 			between (force plam, litstring "(" <+> ws(), ws () <+> litstring ")") <+> force (parser ()) </> (lam x => TmApp (fst x, snd x))
110 | 		)
111 | 
112 | 
113 | 
114 | //	val _ = $showtype pvar 
115 | //	val _ = $showtype plam 
116 | //	val _ = $showtype papp
117 | in 
118 | 	pvar <|> force plam <|> force papp1 <|> force papp2 <|> between (force (parser ()), litstring "(" <+> ws(), ws () <+> litstring ")")
119 | end
120 | 
121 | 
122 | 
123 | 
124 | //implement parser () = 
125 | //	$delay (
126 | //		parser_var () <|> force (parser_lam ()) <|> force (parser_app ()) <|> between (force (parser ()), litstring "(", litstring ")")
127 | //	)
128 | //	where {
129 | //		val _ = show "term\n"
130 | //	}
131 | 
132 | 
133 | staload "libc/SATS/stdio.sats"
134 | 
135 | implement main0 () = () where {
136 | 	fun file_get_stream (path: string): lazy ($sm.stream char) = sm where {
137 | 		fun tostream (file: FILEref): lazy ($sm.stream char) = let
138 | 			val c = int2char0 (fgetc file)
139 | 		in 
140 | 			if feof file = 0
141 | 			then $delay $sm.Cons (c, tostream file)
142 | 			else $delay $sm.Nil () where {
143 | 				val _ = fclose_exn file
144 | 			} 
145 | 		end
146 | 
147 | 		val file = fopen_ref_exn (path, file_mode_r)
148 | 		val sm = tostream file
149 | 	}
150 | 
151 | //	val p = sepby1 (parser (), ws ()): parser (list syntax)
152 | 	val s = file_get_stream ("untyped/1.test")
153 | //	val p = parser ()
154 | //	val test = litstring "lam" <+ ws () <+ litstring "(" <+ ws () <+> id () <+ ws () <+ litstring ")" 
155 | //	val _ = show_result_string (apply (red (test, lam x => string_concat (fst x, snd x)), s))
156 | 	val _ = show_result (apply (force (parser()) <+ eof (), s), lam x => show_syntax x)
157 | //	val _ = show_result (apply (sepby1 (force (parser ()), ws ()), s), lam x => list_foreach (x, lam x => show_syntax x))
158 | }
159 | 
160 | 
161 | 
162 | (*
163 | 
164 | term = var
165 |      | lam (name) => term 
166 |      | term term
167 |      | (term)
168 | 
169 | *)


--------------------------------------------------------------------------------
/untyped/parser.sats:
--------------------------------------------------------------------------------
 1 | staload "parcc.sats"
 2 | 
 3 | datatype syntax = 
 4 | 	| TmLam of (string, syntax)
 5 | 	| TmVar of (string)
 6 | 	| TmApp of (syntax, syntax)
 7 | 
 8 | 
 9 | 
10 | //fun parser_lam (): lazy (parser syntax)
11 | //and parser_var (): parser syntax
12 | //and parser_app (): lazy (parser syntax)
13 | fun parser (): lazy (parser (syntax, false))
14 | 
15 | 
16 | fun show_syntax (syntax): void
17 | 
18 | 
19 | 


--------------------------------------------------------------------------------