From 618450133a8d7e39e27c2ec23ba48b92701a8032 Mon Sep 17 00:00:00 2001 From: Art Eschenlauer Date: Wed, 28 Dec 2022 16:57:43 -0600 Subject: [PATCH] changes to support bidirectional interface with sqlite3 CLI. I forgot -a ;( --- LiComboP.icn | 8 +- README.md | 903 +++++++++++++++++++-- RecTable.icn | 4 +- fieldedDataFile.icn | 7 +- fileDirIo.icn | 293 ++++++- iimage.icn | 4 +- rpn.icn | 3 + runt.icn | 206 ++++- selectRecordFromListByField.icn | 4 +- tests/test_LiComboP.icn | 6 +- tests/test_fieldedDataFile.icn | 10 +- tests/test_fileDirIo.icn | 84 +- tests/test_fileDirIo.std | 10 +- tests/test_rpn.icn | 5 +- tests/test_runningStats.icn | 12 +- tests/test_runningStats.std | 6 +- tests/test_selectRecordFromListByField.icn | 4 +- tests/test_vnom.icn | 29 +- tests/test_vnom.std | 38 +- tests/test_wora.icn | 4 +- vnom.icn | 182 +++-- wora.icn | 40 +- 22 files changed, 1597 insertions(+), 265 deletions(-) diff --git a/LiComboP.icn b/LiComboP.icn index 1116df3..5472722 100644 --- a/LiComboP.icn +++ b/LiComboP.icn @@ -1,3 +1,5 @@ +$ifndef _LiComboP_ +$define _LiComboP_ ############################################################################ # # File: LiComboP.icn @@ -33,12 +35,10 @@ # Recurrently suspend lists combining finite seqs. # ############################################################################ -$ifndef _LiComboP_ -$define _LiComboP_ $ifndef _wora_ -$error wora.icn must be included for definition of procedure wora(id) -$endif +$include "wora.icn" +$endif # _wora_ procedure LiP(A) #: produce lists combining infinite sequences # Generate combinations of argument results for list-invocation, diff --git a/README.md b/README.md index 432db31..50ad8b4 100644 --- a/README.md +++ b/README.md @@ -11,11 +11,49 @@ development repo: [https://chiselapp.com/user/eschen42/repository/aceincl](https mirror and release repo: [https://github.com/eschen42/aceincl](https://github.com/eschen42/aceincl) +Except where otherwise noted, this code is created (with others' inspiration) by Art Eschenlauer ([OrcID 0000-0002-2882-0508](https://orcid.org/0000-0002-2882-0508)). + +The usual [Icon value type abbreviations](http://www2.cs.arizona.edu/icon/refernce/misc.htm#datatypes) apply on this page: + +- cset(`c`) +- file(`f`) +- integer(`i`) +- list(`L`) +- null(`n`) +- procedure(`p`) +- real(`r`) +- string(`s`) +- co-expression(`C`) +- record types(`R`) +- set(`S`) +- table(`T`) + +with one addition: + +- VNom(`V`) + - see `vnom.icn` below. + +--- + + + ## Contents - [Testing program `runt.icn` and working examples](#testing-program-runticn-and-working-examples) + - The `runt.icn` runs a selection of, or all, test programs in specified directories to validate their outputs: - In the `tests` directory are "working examples" of how to use the files in this directory. - - The `runt.icn` runs the test programs to validate their output. + - In the `sl3tests` directory are sqlite3-dependent "working examples". + +- [`baton.icn`](#batonicn) + - Procedure to coordinate passing data from one process to another via a file-based buffer. + +- `baton_main.icn` - Procedures to use facilitate creation of processes that exchange data + with current process via batons. + - [`baton_main`](#procedure-baton_mainargs--exit0--1) Procedure for creating executable to interface between a batons and a stream. + - [`baton_flatware`](#procedure-baton_flatwareargs--fail--exit0--1) Procedure to access batons without translating an additional executable. + - [`baton_crowbar`](#procedure-baton_crowbar--n--stop) Procedure to handle programming error by terminating program exection when `baton_flatware` is not linked. + +- [`batonsys.icn`](#batonsysicn) - Invoke process using batons to exchange input and output - [`fieldedDataFile.icn`](#fieldeddatafileicn) - Procedures to produce logical lines or fields from formatted data files. @@ -26,9 +64,15 @@ mirror and release repo: [https://github.com/eschen42/aceincl](https://github.co - [`iimage.icn`](#iimageicn) - Procedures to transform data structures into includable Icon declarations and statements. +- [`jsonparse.icn`](#jsonparseicn) + - Procedures to parse and generate JSON, by Carl Sturtivant and Gregg Townsend. + - [`LiComboP.icn`](#licombopicn) - Procedures to suspend lists combining sequences. +- [`lindel.icn`](#lindelicn) + - In-place delete or insert of a pseudo-section of L. + - [`RecTable.icn`](#rectableicn) - Procedures to produce/manipulate record-like tables. @@ -41,6 +85,9 @@ mirror and release repo: [https://github.com/eschen42/aceincl](https://github.co - [`selectRecordFromListByField.icn`](#selectrecordfromlistbyfieldicn) - Procedure to produce records from a list of records (or a list of tables), matching specified criteria. +- [`sl3.icn`](#sl3icn) + - Interface to exchange commands and results with `sqlite3`. + - [`vnom.icn`](#vnomicn) - "Nominal vector", i.e., a list whose elements may be accessed by rank (index) or name (key). - This construct is supported by a Lua-inspired metatable. @@ -50,6 +97,10 @@ mirror and release repo: [https://github.com/eschen42/aceincl](https://github.co - [Legacy Source Code Control](#legacy-source-code-control) +--- + + + ## Testing program `runt.icn` and working examples Working examples, named `test_*.icn`, are in the `tests` directory: @@ -57,15 +108,384 @@ Working examples, named `test_*.icn`, are in the `tests` directory: - `test_*.std` captures the corresponding test's expected output. - `icon runt.icn tests` will run the tests and compare the results to their expected output. -- usage: `icon runt.icn [--continue] [--verbose] []` +- usage: `icon runt.icn [--continue] [--verbose] []` + - Tests are not run unless an `.icn` file and a `.std` file share exactly + the same name; names must begin with `test_`. + - Optional arguments may be: + - paths to directories in which to locate tests, or + - names of tests to run, without `test_` prefix; + - if *any* nonexistent paths are present then *only* the named tests will be run. - By default, tests are located and run in the current working directory. - Otherwise, tests are located and run in the specified directory or directories. - - Tests are not run unless an `.icn` file and a `.std` file share exactly - the same name. + - As usual, LPATH is required for `$include` dirctives to succeed. - Use the `--continue` option to run all tests regardless of whether any fail. - Use the `--verbose` option to show both the expected output from the `.std` file and the actual output produced by the test program. +--- + + + +## baton.icn + +`baton.icn` provides a serverless way to pass data between +processes using five files, one for the message transmitted and the others +for coordinating transfer. + +### procedure `baton(action:s, filename:s, file:f, warn:C, wait_secs:N) : s|n|fail` + +Procedure `baton` provides four distinct modes of action: + +``` + action buffer file Cwarn wait_secs + baton("write", buffer:s, file:f|C, warn:C, wait_secs:N) : s|fail + baton("read", buffer:s, file:f|C, warn:C, wait_secs:N) : s|fail + baton("select", buffer:s, file:n|x, warn:C, wait_secs:N) : n|fail + baton("clean", buffer:s, file:n|x, warn:C ) : fail +``` + +Usages: + +#### `action == "write"` + +`baton("write", buffer:s, file:f|C, warn:n|C, wait_secs:N) : s | fail` + +Copy input from `file` to file named by `buffer` + +- `file` is optional; default is `&input` + - `file:f` is a file open for reading + - `file:C` is a co-expression producing string values, + - e.g.: `file := create !&input` + - `file:C` is permitted to produce values containing multiple newlines +- `buffer` argument is required +- `warn` argument may be `&null` or a co-expression that can handle + transmitted warning strings, e.g.: + - `create repeat @&source | @main # silence; is the default behavior` + - `create repeat write(&errout, \@&source | "") | @main` +- `wait_secs` argument may be `&null`, integer, or real, specifying + approximate number of seconds to wait for initial handshake +- produces an error string only if unsuccessful (fails otherwise) + +#### `action == "read"` + +`baton("read", buffer:s, file:f|C, warn:n|C, wait_secs:N) : s | fail` + +Copy output from file named by `buffer` to `file` + +- `file` is optional; default is `&output` + - `file:f` is a file open for writing + - `file:C` is a co-expression receiving string values, + - e.g.: `@(file := create while write(&output, @&source))` +- `buffer`, `warn`, and `wait_secs` arguments as for "write". +- produces an error string only if unsuccessful (fails otherwise) + +#### `action == "select"` + +`baton("select", buffer:s, file:n|x, warn:n|C, wait_secs:N) : n | fail` + +- produces `&null` only when data are available for reading from buffer +- `buffer` and `warn` arguments as for "write". +- wait (approximately) `wait_secs` seconds for success. +- `file` is ignored even if not `&null` +- This action is experimental and may be of no practical value. + +#### `action == "clean"` + +`baton("clean", buffer:s, file:n|x, warn:n|C) : fail` + +- cleans up coordination files that may be left behind when "write" or + "read" is interrupted before they can delete these files +- `buffer` and `warn` arguments as above +- `file` is ignored even if not `&null` + +See "case two" in the example under `baton_flatware` below for +a demonstration of use of "read" and "write" from within a program. + +--- + +## baton_main.icn + +See below for notes regarding usage of these procedures. + + + +### procedure `baton_main(args) : exit(0 | 1)` + +This procedure provides an implementation for `main` for a standalone +executable to interface a baton to or from a stream, as described below. + +- Exit code 0 indicates ordinary termination +- Otherwise, exit code is 1. + +Note that Icon does not catch `SIGPIPE`. +Consequently, if `baton("read",...)` is feeding a pipe, +and if the downstream process dies, +then the Icon process running `baton("read",...)` will die as well! +This is the motivation for running an output pipe from a separate process +and coordiating data-passing using a baton. + +*Usage of baton program* + +``` +baton read bufferfile [handshake_timeout_secs] +baton write bufferfile [handshake_timeout_secs] +baton select bufferfile [success_timeout_secs] +baton clean bufferfile + + write reads from standard input into bufferfile in coordination with + read, which copies from bufferfile to standard output. + When supplied, handshake_timeout_secs specifies number of seconds + to wait for initial handshake. + + select returns a zero exit code only when data are + available to read. + When supplied, handshake_timeout_secs specifies number of seconds + to wait for success. + + clean removes coordination files that may remain when + read or write experiences abnormal termination. +``` + +*Building baton program* + +Create a file `baton_main_build.icn` containing: +``` +$define baton_main main +$include "baton_main.icn" +``` + +Then translate: + +``` +icont -u -o baton baton_main_build.icn # on Unix-like OSs +icont -u -o baton.exe baton_main_build.icn # on MS Windows +``` + +The resulting program can be used as in the following (trivial) example: + +``` + $include "fileDirIo.icn" + procedure main() + # Pass one line of data from output pipe to input pipe. + fsend := open("baton write buffer", "wp") + frecv := open("baton read buffer", "rp") + write(fsend, "hello world from " || &progname) + write(read(frecv)) + close(fsend) + close(frecv) + end +``` + +However, the ordinary way to use this program is to have "baton write" +stream one baton to the standard input of a process and to have "baton read" +stream the standard output of a process to another baton, +as demonstrated in the example for `baton_flatware` below. + + + +### procedure `baton_flatware(args) : fail | exit(0 | 1)` + +This procedure facilitates creation of a "multi-entry binary"; +specifically, it eliminates the necessity to create a distinct executable +to use batons outside of the parent program's process. + +See `tests/test_baton_main.icn` for examples. + +This procedure diverts the control to `baton_main(args)` when: + +- `*args = 3` +- `args[1]` is `"baton_main"` +- `args[2]` is `"read" | "write" | "select" | "clean"` +- `args[3]` is a string (to name a buffer) + +Otherwise, the procedure fails. + +This allows an executable program to have two behaviors: + +- Its "ordinary" behavior when not diverted to `baton_main` +- The `baton_main` behavior, invoked by the "parent" instance of the executable. + +The following exemple demonstrates invocation of `baton_flatware(args)` from within `main(args)`: + +``` + # example usage of baton_flatware; requires that sqlite3 is on PATH + $define BATON_TRACE if &fail then write + $define BATON_CWARN create repeat write(&errout, \@&source | "") | @&main + $define BATON_TIMEOUT_MS 200 + $include "baton_main.icn" # implies include baton.icn and fileDirIo.icn + $define PLUGH "A hollow voice says \"plugh\"." + $define PLOVER "end of SQLite result list" + procedure main(args) + local baton_self # string to invoke child "flatware" via baton_flatware + local chunk # temporary holder for a string of data + local status # exit status of child process, captured from Cexit + local Cexit # co-expression producing exit code if child "flatware" + # has terminated; producing &null otherwise + local Crecv # co-expression to receive input from child "flatware" + local Csend # co-expression to send output to child "flatware" + # handle calls to baton_main; does not return; kind of like a fork... + baton_flatware(args) + # path to self is platform-specific; this has been minimally tested! + baton_self := &progname + if not (&features == "MS Windows" | path_separator() == baton_self[1]) + then baton_self := "." || path_separator() || &progname + baton_self ||:= " baton_main " + # Exchange data with external process via batons. + # Launch process in background; if process dies, no SIGPIPE + # can reach us (see: https://unix.stackexchange.com/a/84828) + # which is good because Icon does not catch signals. + Cexit := + system_nowait( + baton_self || " read buf_in | " || + "sqlite3 -batch -json | " || + baton_self || " write buf_out" + ) + # Set up baton for standard output of process + Crecv := create baton("read", "buf_out", &main) + # Set up baton for standard input of process + # and activate baton so that it can receive a value + @( Csend := create baton("write", "buf_in", &main) ) + # Send a command to SQLite, producing output + ".show" @Csend + # Send a query to SQLite, not producing any output + "select 'plover' where 1 = 0;" @Csend + # Send a query to SQLite to mark end-of-output + "select 'plugh' as xyzzy;" @Csend + # Retrieve lines until end-of-output mark (or closed pipe) + while chunk := @Crecv + do + if chunk == "[{\"xyzzy\":\"plugh\"}]" + then break write(PLUGH) + else write(chunk) + # Send "[]" to SQLite to mark end-of-output + ".print '[]'" @Csend + # Retrieve lines until end-of-output mark (or closed pipe) + while chunk := @Crecv + do + if chunk == "[]" + then break write(PLOVER) + else write(chunk) + # Close the output baton + char(4) @Csend + # Close the input baton to clean up baton files. + @Crecv + # Wait (briefly) for process exit and retrieve exit code. + every 1 to 5 + do { + write("SQLite exit code: ", image(status := @Cexit)) + if /status + then delay(BATON_TIMEOUT_MS) + else break + } + end +``` + +You will find another example under [`sl3.icn`](#sl3icn). + + + +### procedure `baton_crowbar() : n | stop()` + +Kill the program when `baton_flatware` is not linked (which is a +programming error) to avert "infinite forking" that consumes all slots +in the process table. + +This approach is imperfect since one may circumvent it with +``` + invocable all +``` +or with +``` + invocable baton_flatware +``` + +--- + + + +## batonsys.icn + +# procedure `baton_system() : V` + +`baton_system(basename, cmd, inC, outC) : BatonSys` (a VNom extension) + +- This procedure is a VNom initializer producing a VNom that implements + BatonSys message handling; i.e., BatonSys extends VNom (from `vnom.icn`) + such that BatonSys-specific messages are invoked via the vmsg procedure. +- This procedure is supported by `VNomBatonSysCtor` and `VNomBatonSysMesg`, + neither of which need to be invoked directly. The BatonSys-specific + VNom messages (handled by `VNomBatonSysMesg`, as described below) are: + - `create` + - `send` + - `receive` + - `dispose` + - `select` + +# procedure `VNomBatonSysCtor() : V` + +`VNomBatonSysCtor(Original:T, Type:s, ID:s, Metatable:T, Disposable:n|x, Kind:s):BatonSys` (a VNom extension) + +- This procedure provides the implementation for `baton_system` initialiaztion. + VNom initializer producing a VNom that implements BatonSys + message handling; i.e., BatonSys extends VNom (from `vnom.icn`) + such that BatonSys-specific messages are invoked via the vmsg procedure. +- `Original:T` + - If not null, a plain table, or another VNom (or extension + of VNom), from which values are copied. +- `Type:s` + - "Type" property, if `&null` then Type of `\Original`; + default is `Kind || typecount`. +- `ID:s` + - "ID" property; this is required (in contrast to VNom, + which synthesizes a default). +- `Metatable:T` + - Table that maps message strings to message-handler procedures; + when `&null`, the metatable from Original is assigned, if available; otherwise, + a default metatable is created; in any event, the BatonSys messages. + are added to the metatable. +- `Disposable:n?` + - Disposability flag; when not `&null`, a "Disposable" property is added and + set to "yes", to be switched to "done" when the VNom has been disposed. +- `Kind:s` "Kind" property, defaults to "BatonSys". + + +# procedure `VNomBatonSysMesg() : x` + +`VNomBatonSysMesg(args[]):x` + +- This procedure is a VNom message-handler extension for BatonSys messages. +- Extensions to VNom messages: +``` + vmsg(V, "create", s, C, C ) : C # CreateProcess, producing result + # from system_nowait + # arg1: command string + # arg2: C providing stdin + # arg3: C receiving stdout + vmsg(V, "send", s ) : n # Send s to stdin of child pro- + # cess from system_nowait + vmsg(V, "receive" ) : s # Receive s from stdout of child + # process; not assignable + vmsg(V, "select" ) : n # Produce n if input is ever + # pending from stdout of child + # TODO determine when it's TRUE + vmsg(V, "dispose" ) : i # Terminate child process; produ- + # cing exit code +``` +- Extensions to VNom state: +``` + buf_in - base filename for baton handling data to child stdin + buf_out - base filename for baton handling data from child stdout + cmd - system_nowait command string, minus baton pipes + status - "running" | "closed" | &null (disposed) + whichme - path to current executable + Cexit - co-expression producing child's exit code; otherwise, &null + Csend - co-expression providing stdin to child + Crecv - co-expression receiving stdin from child +``` + +--- + + ## fieldedDataFile.icn @@ -78,23 +498,23 @@ Produce record holding two co-expression factories: - `lines` === tabularLines | iniLines - `fields` === tabularFields | iniFields -#### procedure `FieldedDataFactory(format, filePath)` : FieldedData +### procedure `FieldedDataFactory(format, filePath) : FieldedData` Produce a `FieldedData` record for `filePath` corresponding to format. - `format == ("tabular" | "ini")` -#### procedure `tabularLines(f)` : C +### procedure `tabularLines(f) : C` Factory for a co-expression producing logical lines of a tabular file `f`. -#### procedure `tabularFields(line, sep)` : C +### procedure `tabularFields(line, sep) : C` Factory for a co-expression producing fields from a logical line of a tabular file: - `line` is a logical line produced by `tabularLines`. - `sep` is the field separator; if omitted or &null, TAB is used. -#### procedure `getTabular(typeName, tsvPath, colL, sep, dflt)` : L +### procedure `getTabular(typeName, tsvPath, colL, sep, dflt) : L` Produce L of RecTable from a tabular file @@ -104,76 +524,157 @@ Produce L of RecTable from a tabular file - `sep` : (optional) separators, c - `dflt` : (optional) default value for RecTable fields, x -#### procedure `iniLines(f)` : C +### procedure `iniLines(f)` : C Factory for a co-expression producing logical lines of an INI file `f`. -#### procedure `iniFields(line)` : C +### procedure `iniFields(line) : C` Factory for a co-expression producing fields from a logical line of an INI file - `line` is a logical line produced by `iniLines`. -#### procedure `getIni(ini)` : T (two dimensional) +### procedure `getIni(ini) : T` (two dimensional) Parse an INI file at path `ini` into a table of tables +--- + + ## fileDirIo.icn Procedures to manipulate files, directores, and their paths. -#### procedure `alterExtension(fn, old_ex, new_ex)` : s1, ... +### procedure `alterExtension(fn, old_ex, new_ex) : s1, ...` -Produce modified `fn`, substituting `new_ex` for `old_ex` +Generate modified `fn`, substituting `new_ex` for `old_ex` - If `new_ex` is "", the trailing period will be removed. -#### procedure `directory_seq(name)` : s1, ... +### procedure `cmd_separator() : s` + +Produce platform-specific command separator + +### procedure `directory_seq(name) : s1, ...` + +Generate name(s) that name a directory + +### procedure `home() : s` + +Produce platform-specific path to the HOME directory, if available + +### procedure `path_atoms(path) : s1, ...` -Produce name(s) that name a directory +Generate root, subdirectories, filename for a directory path -#### procedure `prog_path_parts()` : s1, s2 +### procedure `path_constructP{exprs} : s1, ...` -Suspend location then name of program file. +Generate paths from sequences of results of exprs -#### procedure `path_atoms(path)` : s1, ... +- `exprs` are comma-separated and used to create a list of co-expressions. -Suspend root, subdirectories, filename for a directory path +### procedure `path_parts(qualname) : s1, s2` -#### procedure `path_constructP{expr}` : s1, ... +Generate location then name from path `qualname` -Construct paths from sequences +### procedure `path_separator() : s` -#### procedure `cmd_separator()` : s +Produce platform-specific path separator -Return platform-specific command separator +### procedure `prog_path_parts() : s1, s2` -#### procedure `path_separator()` : s +Generate location then name of program file. -Return platform-specific path separator +### procedure `pwd() : s` -#### procedure `pwd()` : s +Produce platform-specific path to the current directory -Return platform-specific path to the current directory +### procedure `system_nowait(command:s, title:s) : C` +Run command, but do not wait for exit, producing result C + +- `command`, command to be passed to shell +- `title`, title for background window, optional, for MS Windows +- `@result` produces `&null` before command exits; exit code, after termination. + - Please invoke `@result` till it does not produce `&null` to + delete the file that holds the exit code. + +### procedure `tmpdir() : s` + +Produce platform-specific path to a tmp directory + +### procedure `tmppath() : s` + +Generate platform-specific temporary file path(s) + +### procedure `which(filename:s, all:n|x) : s1, ...` + +Generate full path(s) for filename on PATH + +- on Unix, results are first (or all when `\all`) for `which -a`. +- on Windows, results are first (or all when `\all`) for `where`. + +--- + + ## iimage.icn Procedures to transform data structures into includable Icon declarations and statements. -#### procedure `iimage(x)` : s +### procedure `iimage(x)` : s + - Produce Icon code to reproduce value `x`, if possible -#### procedure `idump(f, x[])` : (writes to `\f | &errout`) + +### procedure `idump(f, x[])` : (writes to `\f | &errout`) + - Write Icon code to reproduce values in list `x` to `f` if it is a file; otherwise to `&errout` and `f` is discarded. +--- + + + +## jsonparse.icn + +Procedures to parse and generate JSON, by +[Carl Sturtivant](https://www-users.cse.umn.edu/~carl/) ([OrcID 0000-0003-1528-4504](https://orcid.org/0000-0003-1528-4504)) +and [Gregg Townsend](https://www2.cs.arizona.edu/~gmt/). + +### procedure `json(L|T|i|n|r|s) : s` + + - Takes data (list|table|integer|string|real|&null) and produces a JSON + string defining that data. It is an error to use another type, even + in substructures. See http://json.org/. To serialize other types, + see codeobj.icn from the Icon Programming Library. + +### procedure `jsonparse(s) : x` + + - Takes a JSON string and produces the corresponding Icon value or + structure. Tables in such a structure will have default values of null. + JSON text containing true and false (booleans) will have those converted + to the strings "true" and "false" respectively. + +### procedure `jsonIconstringencoding(s) : n` + + - Fixes the encoding of Icon strings (NOT quoted strings embedded in + JSON text) for all subsequent calls of json and jsonparse until + jsonIconstringencoding is called again. The initial behavior of + json and jsonparse is as if `jsonIconstringencoding("UTF-8")` has + been called. Fails unless `map(s)` is either "utf-8" or "utf8" or + "latin1" or "latin-1". + +--- + + ## LiComboP.icn Procedures to suspend lists combining sequences. -#### procedure `LiP(A)` : L1, ... +### procedure `LiP(A) : L1, ...` + - Suspend lists combining infinite sequences. LiP: - evaluates in a "breadth first" manner to ensure that all values of finite sequences will eventually be produced even when some sequences are infinite. @@ -181,18 +682,50 @@ Procedures to suspend lists combining sequences. - uses wora(LiP) to determine whether to use LiFiniteP (the default) or nAltP to combine memoized results. - requires that `wora.icn` be previously included, for wora(id) -#### procedure `LiFiniteP(LofC)` : L1, ... + +### procedure `LiFiniteP(LofC) : L1, ...` + - Recursively suspend lists combining finite seqs; - does not enforce "breadth first" evaluation. -#### procedure `nAltP(LofC)` : L1, ... + +### procedure `nAltP(LofC) : L1, ...` + - Recurrently suspend lists combining finite seqs; - does not enforce "breadth first" evaluation. +--- + + + +## lindel.icn + +In-place delete or insert of a pseudo-section of L. + +### procedure `Ldelete(L, i, j) : L` + +Delete indexes `i` to `j` from `L` (in-place), producing `L` + +### procedure `Linsert(L, i, Lins) : L` + +Insert list `Lins` into `L` (in-place) before index `i`, producing `L` + +- use i = 0 when L is empty + +### procedure `Lfind(L, x) : i1, i2, ...` + +Generate indices where `x` appears in `L` + +--- + + + ## RecTable.icn Procedures to produce/manipulate record-like tables. -### procedure `RecTable(rec_name_s, rec_fields_L, rec_data_L, rec_default_x)` : T +See also: `vnom.icn` below for another, potentially more flexible approach. + +### procedure `RecTable(rec_name_s, rec_fields_L, rec_data_L, rec_default_x) : T` Produce a table with record-like aspects: @@ -203,7 +736,7 @@ Produce a table with record-like aspects: defaults to all - `rec_default_x`: default value for table members -### procedure `RecTableType(x)` : s1, S2, s3, ... +### procedure `RecTableType(x) : s1, S2, s3, ...` For RecTable, produce: @@ -213,31 +746,31 @@ For RecTable, produce: For non-RecTable, return type(x). -### procedure `RecTableFields(x)` : s1, ... +### procedure `RecTableFields(x) : s1, ...` Produce RecTable's field names. - This will fail for a non-RecTable. -### procedure `RecTableFieldsL(x)` : L +### procedure `RecTableFieldsL(x) : `L Return a list of the values produced by RecTableFields(x). - This returns an empty list when x is not a RecTable instance. -### procedure `RecTableFieldVals(x)` : s1, ... +### procedure `RecTableFieldVals(x) : s1, ...` Produce RecTable's field values. - This will fail for a non-RecTable. -### procedure `RecTableFieldValsL(x)` : L +### procedure `RecTableFieldValsL(x) : L` Return a list of the values produced by RecTableFieldVals(x). - This returns an empty list when x is not a RecTable instance. -### procedure `RecTableColTypeCheck(x, type_name, col_name, preamble)` : x +### procedure `RecTableColTypeCheck(x, type_name, col_name, preamble) : x` Return x, except abort when x is not instance of `type_name`: @@ -247,7 +780,7 @@ Return x, except abort when x is not instance of `type_name`: - `preamble` : initial string for error message; defaults value of name RecTablePreamble. -### procedure `RecTableConstructorC(rec_name_s, rec_fields_L, rec_default_x)` : C +### procedure `RecTableConstructorC(rec_name_s, rec_fields_L, rec_default_x) : C` Produce a C that, when receiving a transmitted list of values (of the same length as `rec_fields_L`), produces a RecTable instance: @@ -258,10 +791,13 @@ same length as `rec_fields_L`), produces a RecTable instance: defaults to all - `rec_default_x` default value for table members +--- + + ## rpn.icn -Procedures to embed RPN-based (Forth-like) interpreter into Icon programs; can also be run in REPL. +Procedures to embed RPN-based (Forth-like) interpreter into Icon programs; can also be run in a [REPL](https://en.wikipedia.org/wiki/Read%E2%80%93eval%E2%80%93print_loop). This file may be used to embed RPN-scripted access to Icon procedures and operators, in a manner reminiscent of Forth. @@ -329,6 +865,10 @@ LPATH=~/src/aceincl rlwrap icon -P ' ``` then you can get proper interpretation of the arrow keys in the REPL loop. +--- + + + ## runningStats.icn These procedures support computing summary statistics for normally @@ -337,30 +877,34 @@ from Wikipedia. ref: [https://en.wikipedia.org/wiki/Algorithms\_for\_calculating\_variance#Welford's\_online\_algorithm](https://en.wikipedia.org/wiki/Algorithms_for_calculating_variance#Welford%27s_online_algorithm) -record `welford_running(count, mean, M2)` +### record `welford_running(count, mean, M2)` - record accumulating online results without persisting raw data -record `welford_cumulative(n, mean, variance, sampleVariance, SD, SE)` +### record `welford_cumulative(n, mean, variance, sampleVariance, SD, SE)` - record of statistical results extracted from `welford_running` -procedure `welford_new()` +### procedure `welford_new()` - produce an initialized `welford_running` record -procedure `welford_add(W, x)` +### procedure `welford_add(W, x)` - produce an updated `welford_running` record - `W` a `welford_running` record - `x` the next value to add to the record -procedure `welford_get(welford_running)` +### procedure `welford_get(welford_running)` - produce `welford_cumulative` record summarizing normal statistics for the series of x provided to `welford_add` - `welford_running` a `welford_running` record updated by `welford_add` +--- + + + ## selectRecordFromListByField.icn Procedure to produce records from a list of records (or a list of tables), matching specified criteria. @@ -370,19 +914,226 @@ Procedure to produce records from a list of records (or a list of tables), match - For a better way to do this, see [fix_selectRecordFromListByField.icn](https://sourceforge.net/p/unicon/mailman/attachment/CACb17F7MTimKsVuYS0LCmB6CpuE1pLvTZBtdCiNZRJEzFsFeKA%40mail.gmail.com/1/), which I will eventually apply here instead. - Even so, there is yet the need to incorporate a "fuzzy binary search" to speed things up immensely for larger lists or tables. -#### procedure `selectRecordFromListByField(Lfrom, sField, Ctest)` : R1, ... +### procedure `selectRecordFromListByField(Lfrom, sField, Ctest) : R1, ...` - Produce matching records (or tables) `X` - from list `Lfrom` (`type(Lfrom[i]) == "record" | "table"`) - where `X[sField] @ Ctest` succeeds -#### procedure `selectRecordFromListByFieldL(Lfrom, sFieldL, Ctest)` : R1, ... +### procedure `selectRecordFromListByFieldL(Lfrom, sFieldL, Ctest) : R1, ...` - Produce matching records (or tables) `X` - from list `Lfrom` (`type(Lfrom[i]) == "record" | "table"`) - where this succeeds:
`L := []; every put(L, X[!sFieldL]); L @ Ctest` +--- + + + +## sl3.icn + +Interface to exchange commands and results with `sqlite3`, which must be on PATH. + +`sl3.icn` defines an interface to the sqlite3 command line interface, +which is described in detail at https://sqlite.org/cli.html + +No generalized process interface exists in the basic Icon implementation +and library that would allow access to both the standard input and the +standard output of a child process, this interface uses the `baton` +inteface via `baton.icn`, `baton_main.icn`, and `batonsys.icn` to hand +data back and forth between Icon and sqlite3 without resorting to such +platform-specific devices such as FIFOs or named-pipes. + +For convenience, if the symbol `sl3` is not defined by the preprocessor +before `sl3.icn` is included, then it is defined as `sl3Msg`: + +``` +$ifndef sl3 + $define sl3msg sl3 +$endif +``` + +`sl3new(path, options, errC) : VNom` (a SQLite3 connection) + - This is a synonym for `sl3(&null, "open", path, options, errC)` + - See below for details of the "open" message. + +`sl3Msg(conn:SQLite3, message, arg1, arg2, arg3) : x` + - takes as its first argument, a "database connection" that is a + "SQLite3" VNom (or `&null` when the message is "open"). + - takes as its second argument an operation message string, which is: + - either one of `"open" | "prepare" | "fetch" | "close"` + - or "the default key", a prepared statement or SQL string. + - The value produced depends on the signature invoked. + +The signatures of sl3 messages are as follows: + +``` + sl3(&null, "open", path, options, errC ) : VNom (a SQLite3 conn) + sl3(conn, "prepare", stmt ) : VNom (a prep_stmt) + sl3(conn, stmt:s, parmL:L, errC ) : n|fail + sl3(conn, prep_stmt:V, &null|x, errC ) : n|fail + sl3(conn, "fetch" ) : VNom (a result row) + sl3(conn, "close", errC ) : &null +``` + +You can find some examples with (modest) error handling in `sl3tests/test_sl3_02.icn`. + +In lieu of a detailed description of each signature (which may be found the header of `sl3.icn`), here is a working example, which emphasizes several ways of passing parameters to prepared statements. + +``` +$include "fileDirIo.icn" +$include "vnom.icn" +$include "jsonparse.icn" +$include "sl3.icn" +$define ERR_OFFSET [0, -1][2] +$define DISPOSE_ON_ERROR if write(trace_reset(err_off)) then dispose(cnxn, errC) +global g_exit_code +procedure main(args) + local cnxn, path_s, options_s, errC, chunk, err_off, prep_stmt + # don't forget this or infinite forks will fill the process space... + baton_flatware(args) + # set exit code for premature termination + g_exit_code := -1 + # create co-expression to handle error strings + @(errC := create while write(@ &source)) + # open sqlite and establish baton + path_s := ":memory:" + options_s := &null + # open database connection + # signature: sl3new(path, options, errC) : VNomSQLite3 + # === sl3(connection, "open", path, options, errC) : VNomSQLite3 + if not (cnxn := sl3new(path_s, options_s, errC)) + then stop("failed to open connection") + err_off := ERR_OFFSET + + # execute SQL immediately, without parameters + # signature: sl3(conn, stmt:s, &null, errC) : n|fail + sl3(cnxn, + "CREATE TABLE invent(desc text, number integer, amount float);", , errC) + DISPOSE_ON_ERROR + # execute dot command immediately + sl3(cnxn, ".dump", , errC) + DISPOSE_ON_ERROR + # show result lines, which are not rows from a SQL query + every chunk := sl3(cnxn, "fetch") do write_ordered_values(chunk) + + # initialize first prepared statement, which has named parameters + # signature: sl3(conn, "prepare", stmt) : VNom (a prep_stmt) + prep_stmt := sl3(cnxn, "prepare", + "INSERT INTO invent VALUES(@desc, @number, @amount);") + DISPOSE_ON_ERROR + # set parameters for first prepared statement + vmsg(prep_stmt, "put", "@desc", "a description") + vmsg(prep_stmt, "put", "@number", 42) + vmsg(prep_stmt, "put", "@amount", 3.14159) + # execute first prepared statment + # signature: sl3(conn, prep_stmt:V, &null, errC ) : n|fail + if not sl3(cnxn, prep_stmt, , errC) then { + write("test one: execute prepared statement with named parameters failed") + dispose(cnxn, errC)} + + # initialize second prepared statement, which has named and unnamed parameters + # signature: sl3(conn, "prepare", stmt) : VNom (a prep_stmt) + prep_stmt := sl3(cnxn, "prepare", "INSERT INTO invent VALUES(?, ?3, ?2);") + DISPOSE_ON_ERROR + # set parameters for second prepared statement + vmsg(prep_stmt, "put", "?1", "another description") + vmsg(prep_stmt, "put", "?2", 1066) + vmsg(prep_stmt, "put", "?3", 1.414214) + # execute second prepared statment + # signature: sl3(conn, prep_stmt:V, &null, errC) : n|fail + if not sl3(cnxn, prep_stmt, , errC) + then { + write("test two: execute prepared statement with unnamed parameters failed") + dispose(cnxn, errC)} + DISPOSE_ON_ERROR + + # execute SQL with implicit prepared statement and with L of unnamed params + # signature: sl3(conn, stmt:s, parmL:L, errC) : n|fail + if not sl3(cnxn, "INSERT INTO invent VALUES(?, ?, ?);", + ["foobar", 2401, 21.0/7], errC) + then { write("test three: execute implicit prepared statement failed") + dispose(cnxn, errC)} + DISPOSE_ON_ERROR + + # execute SQL without params + # signature: sl3(conn, stmt:s, &null, errC) : n|fail + sl3(cnxn, "select * from invent;", , errC) + DISPOSE_ON_ERROR + # show results from previous SQL + write("---") + every chunk := sl3(cnxn, "fetch") do { + write_vnom_fields(chunk) + write("---")} + + # set exit code for normal termination + g_exit_code := 0 + &error := 0 + # stop sqlite3 and shut down the batons + dispose(cnxn, errC) +end +procedure dispose(cnxn, errC) + # stop sqlite3 and shut down the batons + sl3(cnxn, "close", errC) | write("sl3 \"close\" failed") + write(" batonsys disposition: ", image(cnxn["disposition"])) + exit(g_exit_code) +end +procedure trace_reset(error_offset) + local result + result := "" + if &error = 0 then fail + if (&error < error_offset) then { + result ||:= "There were " || error_offset - &error || " errors; " + result ||:= "last error " || &errornumber || " - " || &errortext + &error := error_offset + return result + } + &error := error_offset +end +procedure write_vnom_fields(chunk, f) + local i + /f := &output + # row fields are ordered by VNom key + every i := vmsg(chunk, "key") do write(f, " ", i, ": ", chunk[i]) + return +end +procedure write_ordered_values(chunk, f) + local i + /f := &output + # results of commands are ordered by a discardable integer key + every i := key(chunk) do if i ~=== chunk then write(f, " ", chunk[i]) + return +end +``` + +which produces as output: + +``` + PRAGMA foreign_keys=OFF; + BEGIN TRANSACTION; + CREATE TABLE invent(desc text, number integer, amount float); + COMMIT; +--- + desc: a description + number: 42 + amount: 3.14159 +--- + desc: another description + number: 1.414214 + amount: 1066.0 +--- + desc: foobar + number: 2401 + amount: 3.0 +--- + batonsys disposition: 0 +``` + +--- + + + ## vnom.icn "Nominal vector", i.e., a list whose elements may be accessed by rank (index) or name (key). @@ -399,7 +1150,7 @@ a reference to the metatable rather than making a copy of the metatable. Thus, behavior of the set of instances may (even dynamically) be modified by changing a single structure. -#### procedure `vnew(Original:T, Type:s, ID:s, Metatable:T, Disposable:s, Kind:s) : V` +### procedure `vnew(Original:T, Type:s, ID:s, Metatable:T, Disposable:s, Kind:s) : V` Construct a new VNom instance. @@ -418,31 +1169,41 @@ Construct a new VNom instance. - `Kind:s` - Kind property -#### procedure `vmsg(VNom:V, Message:s, args[]) : x` +### procedure `vmsg(VNom:V, Message:s, args[]) : x` Send messages to update or interrogate the VNom instance. - - `vmsg(V, "!" ) : x1, ... # generate values in order keys in L` - - `vmsg(V, "*" ) : i # produce number of values ` - - `vmsg(V, "get" | "pop" ) : x # pop value, discarding key ` - - `vmsg(V, "pull" ) : x # pull value, discarding key ` - - `vmsg(V, "push", x1, x2) : V # push value with key ` - - `vmsg(V, "put", x1, x2) : V # put value with key ` - - `vmsg(V, "key" ) : x1, ... # generate keys in order keys in L ` - - `vmsg(V, "keylist" ) : L # copy of L of ranked keys ` - - `vmsg(V, "bykey", x ) : s # value, assignable by key ` - - `vmsg(V, "byrank", i ) : s # value, assignable by rank (index) ` - - `vmsg(V, "kind" ) : s # Kind property, assignable ` - - `vmsg(V, "id" ) : s # ID property, assignable ` - - `vmsg(V, "type" ) : s # Type property, assignable ` - - `vmsg(V, "image" ) : s # image property ` - - `vmsg(V, "metatable" ) : s # Metatable, assignable ` - ` + - `vmsg(V, "!" ) : x1, ... # generate values in order keys in L ` + - `vmsg(V, "*" ) : i # produce number of values ` + - `vmsg(V, "get" | "pop" ) : x # pop value, discarding key ` + - `vmsg(V, "copy" ) : V # produce copy of V with same metatable` + - `vmsg(V, "pull" ) : x # pull value, discarding key ` + - `vmsg(V, "push", xk, xv) : V # push (or replace) value x2 for key x1` + - `vmsg(V, "put", xk, xv) : V # put (or replace) value x2 for key x1 ` + - `vmsg(V, "key" ) : x1, ... # generate keys in order keys in L ` + - `vmsg(V, "keylist" ) : L # copy of L of ranked keys ` + - `vmsg(V, "bykey", x ) : s # value, assignable by key ` + - `vmsg(V, "byrank", i ) : s # value, assignable by rank (index) ` + - `vmsg(V, "delbykey", x ) : n # delete value by key ` + - `vmsg(V, "delbyrank", i ) : n # delete value by rank ` + - `vmsg(V, "strings" ) : s # generate string showing each KVP ` + - `vmsg(V, "disposable" ) : s # disposable property ` + - `vmsg(V, "id" ) : s # ID property, assignable ` + - `vmsg(V, "image" ) : s # image property ` + - `vmsg(V, "kind" ) : s # Kind property, assignable ` + - `vmsg(V, "metatable" ) : s # Metatable, assignable ` + - `vmsg(V, "strings" ) : s # generate a string to show each KVP ` + - `vmsg(V, "type" ) : s # Type property, assignable ` + +--- + + + ## wora.icn Procedure to produce a value that can be read globally but can be reset only by the co-expression that set it it initially. -#### procedure `wora(id,del)` : x (lvalue or rvalue) +### procedure `wora(id,del)` : x (lvalue or rvalue) - Set or read a globally visible read-only value, - which is resettable by the C that creates it. - `id` identifies the value; it is a key to a static table. @@ -450,13 +1211,15 @@ Procedure to produce a value that can be read globally but can be reset only by - Otherwise, this argument is ignored. -
+--- + + -## Legacy Source Code Control +## Legacy Source Code Control Problems If you are still using Git rather than [the best thing since CVS](https://fossil-scm.org), then you may need the following to recover from the mess that Git Submodule can create if you are not *very* careful. -## Git Submodule - some practical reminders +### Git Submodule - some practical reminders Reference: [http://openmetric.org/til/programming/git-pull-with-submodule/](http://openmetric.org/til/programming/git-pull-with-submodule/) diff --git a/RecTable.icn b/RecTable.icn index 95fd4e9..632b9eb 100644 --- a/RecTable.icn +++ b/RecTable.icn @@ -1,3 +1,5 @@ +$ifndef _RecTable_ +$define _RecTable_ ############################################################################ # # File: RecTable.icn @@ -65,8 +67,6 @@ # RecTablePreamble. # ############################################################################ -$ifndef _RecTable_ -$define _RecTable_ $ifndef RecTablePreamble $define RecTablePreamble "\n File " || &file || "; Line " || &line || ":\n Bad Argument ==> " diff --git a/fieldedDataFile.icn b/fieldedDataFile.icn index 99b888b..a936e39 100644 --- a/fieldedDataFile.icn +++ b/fieldedDataFile.icn @@ -1,3 +1,5 @@ +$ifndef _fieldedDataFile_ +$define _fieldedDataFile_ ############################################################################ # # File: fieldedDataFile.icn @@ -54,14 +56,11 @@ # Produce a table of table from an INI file # ############################################################################ -$ifndef _fieldedDataFile_ -$define _fieldedDataFile_ $ifndef _RecTable_ -$error Must include RecTable.icn for procedure RecTableConstructorC +$include "RecTable.icn" $endif - # FieldedData organizes functions that create co-expressions producing # logical lines and fields within a logical line from tabular data record FieldedData(lines, fields) #: record holding two co-expression factories diff --git a/fileDirIo.icn b/fileDirIo.icn index ece2da8..9112725 100644 --- a/fileDirIo.icn +++ b/fileDirIo.icn @@ -1,4 +1,5 @@ - +$ifndef _fileDirIo_ +$define _fileDirIo_ ############################################################################ # # File: fileDirIo.icn @@ -19,38 +20,79 @@ ############################################################################ # # procedure alterExtension(fn, old_ex, new_ex) : s1, ... -# Produce modified fn, substituting new_ex for old_ex +# Generate modified fn, substituting new_ex for old_ex +# - If `new_ex` is "", the trailing period will be removed. +# +# procedure cmd_separator() : s +# Produce platform-specific command separator # # procedure directory_seq(name) : s1, ... -# Produce name(s) that name a directory +# Generate name(s) that name a directory # -# procedure prog_path_parts() : s1, s2 -# suspend location then name of program file. +# procedure home() : s +# Produce platform-specific path to the HOME directory, if available. # # procedure path_atoms(path) : s1, ... -# suspend root, subdirectories, filename for a directory path +# Generate root, subdirectories, filename for a directory path # -# procedure path_constructP{expr} : s1, ... -# construct paths from sequences +# procedure path_constructP{exprs} : s1, ... +# Generate paths from sequences of results of exprs. +# - `exprs` are comma-separated and used to create a list of +# co-expressions. # -# procedure cmd_separator() : s -# return platform-specific command separator +# procedure path_parts(qualname) : s1, s2 +# Generate location then name from path. # # procedure path_separator() : s -# return platform-specific path separator +# Produce platform-specific path separator +# +# procedure prog_path_parts() : s1, s2 +# Generate location then name of program file. # # procedure pwd() : s -# return platform-specific path to the current directory +# Produce platform-specific path to the current directory +# +# procedure system_nowait(command:s, title:s) : C +# Run command, but do not wait for exit, producing result C +# - `command`, command to be passed to shell +# - `title`, title for background window, optional, for MS Windows +# - `@result` produces `&null` before command exits; exit code after +# - Please invoke `@result` till it does not produce `&null` to +# delete the file that holds the exit code. +# +# procedure tmpdir() : s +# Produce platform-specific path to a tmp directory +# +# procedure tmppath(suffix:s, len:s) : s1, ... +# Generate temporary file paths +# +# procedure which(filename:s, all:n|x) : s1, ... +# Generate full path(s) for filename on PATH +# - on Unix, results are first (or all when `\all`) for `which -a`. +# - on Windows, results are first (or all when `\all`) for `where`. # ############################################################################ # -# links: regexp +# requires: +# - pipes +# - Windows or Linux/MacOS/Unix +# +############################################################################ +# +# links: regexp, strings # ############################################################################ -$ifndef _fileDirIo_ -$define _fileDirIo_ link regexp # for regular expressions to support alterExtension +link strings # for replace(s1, s2, s3) + # replaces all occurrences of s2 in s1 by s3; fails + # if s2 is null. + +$define FILEDIRIO_MSWINDOWS (&features == ("MS Windows NT" | "MS Windows")) + +$ifndef FILEDIRIO_TRACE +$define FILEDIRIO_TRACE if &fail then write +$endif # FILEDIRIO_TRACE procedure alterExtension(fn, old_ex, new_ex) #: change extension of file name ReCaseIndependent() @@ -65,19 +107,39 @@ end # adapted from IPL proc io.icn procedure directory_seq(name) #: suspend name(s) when a directory - suspend (close(open(name || "/.")), name) + suspend (close(open(name || path_separator() || ".")), name) +end + +procedure home() #: return platform-specific path to the home directory, if available + local C, x, cmd + static is_mswin + initial is_mswin := FILEDIRIO_MSWINDOWS + if \is_mswin + then + return map(getenv("HOMEDRIVE"), string(&lcase), string(&ucase)) || + getenv("HOMEPATH") + else + return getenv("HOME") end # inspired by IPL proc io.icn procedure prog_path_parts() #: suspend location then name of program file. + local i, prog_name + prog_name := which(&progname) | &progname + suspend path_parts(prog_name) +end + +# inspired by IPL proc io.icn +procedure path_parts(qualname) #: suspend location then name from path. local i - &progname ? every i := find(path_separator()) + qualname ? every i := find(path_separator()) if /i - then suspend pwd() - else suspend &progname[1:i] - if /i - then suspend &progname - else suspend &progname[i+1:0] + then { + suspend pwd() | qualname + fail + } + suspend &progname[1:i] + suspend &progname[i+1:0] end # inspired by IPL proc io.icn @@ -121,31 +183,182 @@ procedure path_constructP(atoms) #: construct paths from sequences end procedure cmd_separator() #: return platform-specific command separator - $ifdef _MS_WINDOWS - return "&" - $else - return ";" - $endif + static is_mswin + initial is_mswin := FILEDIRIO_MSWINDOWS + return if \is_mswin then "&" else ";" end procedure path_separator() #: return platform-specific path separator - $ifdef _MS_WINDOWS - return "\\" - $else - return "/" - $endif + static is_mswin + initial is_mswin := FILEDIRIO_MSWINDOWS + #ACE if \is_mswin then every write(&errout, &features) + return if \is_mswin then "\\" else "/" end procedure pwd() #: return platform-specific path to the current directory - $ifdef _MS_WINDOWS - local C, x, cmd - cmd := "cd" - C := create x := open(cmd, "pr") & !x@&source | close(x) & &fail - while x := @C - return x - $else + local C, x, cmd + static is_mswin + initial is_mswin := FILEDIRIO_MSWINDOWS + if \is_mswin + then { + return 2( + x := open("cmd /c echo %CD%", "pr"), + read(x), + close(x) + ) + } + else return getenv("PWD") - $endif + stop("fileDirIo.icn: FATAL pwd() did not produce current directory") +end + +procedure system_nowait(command, title) #: run command, do not wait for exit + # result:C - C produces &null before command terminates; exit code after + # command:s - command to be passed to shell + # title:s - title for background window, optional, only for MS Windows + static win_unicon # not &null when running Unicon on Microsoft Windows + static portableIcon # not &null when running protableIcon on MS Windows + local f # system command with escaped double quotes + local rslt # C producing exit code, or null if not yet available + local exit_code # integer exit code or null if not yet available + + initial { + win_unicon := (&features == "MS Windows NT", &features == "POSIX") + portableIcon := ( + &features == "MS Windows", + &features == "Cygwin" + , not (&features == "MS Windows NT") + , not (&features == "POSIX") + , not (&features == "UNIX") + , 1 + ) + } + + rslt := tmppath() + if \win_unicon | \portableIcon + then { # unicon or portableIcon on Microsoft Windows NT + f := 0 + command ? every upto('"') do f +:= 1 + 0 = f % 2 | + stop( + "fileDirIo.icn: argument for system_async cannot ", + "contain odd number of double quotes.\n ", + command, "\n There are ", f, " double quotes." + ) + /title := tmppath(, , "") + + f := "start \"" || title || "\" /b cmd /c \"(" || + command || ") ^& (echo %ERRORLEVEL% > \"" || rslt || "\") \"" + FILEDIRIO_TRACE(&errout, "background task: ", f) + if 0 ~= system(f) + then fail + } + else { # regular Icon + f := replace(command, "\"", "\\\"") || "; echo $?> " || rslt + FILEDIRIO_TRACE(&errout, "(" || f || ") &") + if 0 ~= system("(" || f || ") &") + then fail + FILEDIRIO_TRACE(&errout, "returned from: ", "(" || f || ") &") + } + # return C producing exit code after exit, &null before exit + return create repeat { + FILEDIRIO_TRACE(&errout, "... Crslt scans file: ", rslt) + # when exit_code is null and result file can be opened + if (/exit_code, f := open(rslt, "r")) + then { + # get the exit code if it's available + # Does this block until process completes? + if exit_code := integer(read(f)) + then { + # if file can be opened and read (containing an integer), then + # close and delete file + close(f) + remove(rslt) + } + else { + # otherwise, close but don't delete the file + close(f) + } + } + # produce either null or exit code + FILEDIRIO_TRACE(&errout, "... Crslt transmits: ", image(exit_code)) + exit_code @&source + } +end + +procedure tmpdir() #: return platform-specific path to a tmp directory + # note: both procs/io.icn and procs/popen.icn in IPL define tempfile + # nothing in IPL defines tmpfile, tmpdir, or tempdir + static is_mswin + initial is_mswin := FILEDIRIO_MSWINDOWS + return if \is_mswin + then + # there are only two possibilities of success on Windows + return getenv("TMP" | "TEMP") || path_separator() + else + # inspired by answers to https://unix.stackexchange.com/q/352107 + # because some unixes do not define TMPDIR, TMP, or TEMP + return (getenv("TMPDIR" | "TMP" | "TEMP") | "/tmp") || path_separator() +end + +procedure tmppath(suffix, len, dir) #: generate temporary file paths + initial { + # core of randomize() in procs/random.icn in IPL + &random := + map("sSmMhH", "Hh:Mm:Ss", &clock) + + map("YyXxMmDd", "YyXx/Mm/Dd", &date) + + &time + } + # core of tempname(...) in procs/io.icn + /suffix := "tmp" + /len := 8 + /dir := tmpdir() + suspend 2( + ?1, # change &random + name := dir || "tmp" || left(&random, len, "0") || "." || suffix, + not close(open(name, "r")) + ) +end + + +# procedure which(filename:s, all:n|x) : s1 | s2 | ... +procedure which(filename, all) #: Generate full path(s) for filename on PATH + local f, path, pathsL + static whichcmd, stderrnull + initial { + $ifndef _UNIX + $ifdef _MS_WINDOWS # _MS_WINDOWS + $ifdef _MS_WINDOWS_NT # _MS_WINDOWS and _MS_WINDOWS_NT + whichcmd := "where " + stderrnull := " 2>NUL" + $else # _MS_WINDOWS but not _MS_WINDOWS_NT + whichcmd := "where " + stderrnull := " 2>NUL" + $endif + $else # neither _MS_WINDOWS nor _UNIX + $error 'Refusing to translate because platform has not been tested' + $endif + $else # _UNIX + whichcmd := "which -a " + stderrnull := " 2>/dev/null" + $endif + } + # initialize list of paths + pathsL := [ ] + # produce path matching filename (or paths if \all) + f := whichcmd || filename || stderrnull + f := open(f, "pr") | fail + # read(f) should produce something like "/usr/bin/mkfifo" + # produce path only if file exists at such a path + while path := read(f) + do put(pathsL, path) + close(f) + # only produce first path if all flag has not been set + if /all + then pathsL := [get(pathsL)] + # suspend paths until exhausted + suspend !pathsL + # fail once exhausted end $endif # _fileDirIo_ diff --git a/iimage.icn b/iimage.icn index 585d209..03fff5f 100644 --- a/iimage.icn +++ b/iimage.icn @@ -1,3 +1,5 @@ +$ifndef _iimage_ +$define _iimage_ ############################################################################ # # File: iimage.icn @@ -163,7 +165,6 @@ # such problems. # ############################################################################ -$ifndef _iimage_ $ifndef SPCS $define SPCS " " @@ -404,5 +405,4 @@ procedure idump(f, x[]) #: write images of values in list x return x[-1] | &null end -$define _iimage_ $endif # _iimage_ diff --git a/rpn.icn b/rpn.icn index 5f80ffd..139e498 100644 --- a/rpn.icn +++ b/rpn.icn @@ -1,3 +1,5 @@ +$ifndef RPN_INTERPRETER +$define RPN_INTERPRETER ############################################################################ # # File: rpn.icn @@ -1058,4 +1060,5 @@ procedure token( Cin ) } end +$endif # RPN_INTERPRETER # vim: ai ts=2 sw=2 et : diff --git a/runt.icn b/runt.icn index 9fd4634..e3b1b77 100644 --- a/runt.icn +++ b/runt.icn @@ -37,26 +37,58 @@ # ############################################################################ # -# links: popen, showtbl +# links: showtbl # requried includes: fileDirIo.icn # ############################################################################ $include "fileDirIo.icn" -$define USAGE "usage: icon runt.icn [--continue] [--verbose] dir_names" +$include "lindel.icn" + +$define USAGE "usage: icon runt.icn [--continue] [--verbose] dir_names [test_names]" $define USAGE1 " --continue: run other tests after a test fails" $define USAGE2 " --verbose: trace test results" $define USAGE3 " --help - print this message" +$define USAGE4 "Any test_names supplied constitute an exclusive list of tests" +$define USAGE5 "to run; e.g., to run only test_baton and test_baton_main, type:" +$define USAGE6 " runt tests baton baton_main" + +#$define HIDE_CMDLINE &fail +$define HIDE_CMDLINE &null +#$define SHOW_TIMINGS &fail +$define SHOW_TIMINGS &null + +$ifndef _UNIX + $ifdef _MS_WINDOWS # _MS_WINDOWS + $ifdef _MS_WINDOWS_NT # _MS_WINDOWS and _MS_WINDOWS_NT + # e.g., for Unicon on MS Windows + $define SET_LPATH "set LPATH=" || workingdir || "&& " + $else # _MS_WINDOWS but not _MS_WINDOWS_NT + # e.g., for portableIcon on MS Windows + # kludge: if PATH starts with a lowercase drive letter, path search + # fails; however, beginning with a semicolon hacks the issue away. + # This could not be addressed via smudge.cmd. Is it a Cygnal issue? + $define SET_LPATH "set PATH=;%PATH%&& set LPATH="||workingdir||"&& " + $endif + $else # neither _MS_WINDOWS nor _UNIX + # e.g. for unknown POSIX shell ... + $define SET_LPATH "LPATH=" || workingdir || " " + $endif +$else # _UNIX + # e.g., for Linux, FreeBSD, or MacOS + $define SET_LPATH "LPATH=" || workingdir || " " +$endif -link popen # for procedure popen link showtbl # for procedure showtbl # flag that exit should produce error status even with --continue argument -global failure +global failure, portableIcon, win_unicon # run all the test_*.icn for which there is a matching test_*.std procedure main(args) local abort # if !args == "--continue" then write else stop + local bespoke # names of individual tests to run rather than all + local cmd # scratch variable for tracing commands local dir # one member of dirs local dirEntry # entry in current working directory local dirListing # names of files and subdirectores in CWD @@ -77,53 +109,134 @@ procedure main(args) write(USAGE1) write(USAGE2) write(USAGE3) + write(USAGE4) + write(USAGE5) + write(USAGE6) exit(if *args < 1 then 1 else 0) } - traceout := if !args == "--verbose" then write else 2 - abort := if !args == "--continue" then write_abort else stop + + traceout := + if !args == "--verbose" then write else 2 + abort := + if !args == "--continue" then write_abort else stop if traceout === 2 - then write( &errout, "To trace output, invoke as: icon " - , &progname, " --verbose") + then + write( &errout, "To trace output, invoke as: icon " + , &progname, " --verbose") + else + every dir := Lfind(args, "--verbose") + do args := Ldelete(args, dir, ) if abort === stop - then write( &errout, "To run all tests, invoke as: icon " - , &progname, " --continue") + then + write( &errout, "To run all tests, invoke as: icon " + , &progname, " --continue") + else + every dir := Lfind(args, "--continue") + do args := Ldelete(args, dir, ) + win_unicon := (&features == "MS Windows NT", &features == "POSIX") + portableIcon := ( + &features == "MS Windows", + &features == "Cygwin" + , not (&features == "MS Windows NT") + , not (&features == "POSIX") + , not (&features == "UNIX") + , 1 + ) + if SHOW_TIMINGS & \win_unicon + then + write(&errout, + "Windows Unicon detected; pipes & co-expressions may fail") + else + if \win_unicon + then + write(&errout, + "Windows Unicon detected; pipe & co-expressions may fail") # timing support totalTime := -&time timings := table(-1) # dirs either lists the directory arguments or the current directory dirs := [] - every put( dirs, directory_seq(!args) || "/" ) - if *dirs == 0 then dirs := put( dirs, "./" ) - workingdir := getenv("PWD") + every put(dirs, directory_seq(!args) || path_separator()) + if *dirs == 0 + then dirs := put( dirs, "." || path_separator()) + # prepare for specification of individual tests, if any + bespoke := [] + every testName := !args + do + if not directory_seq(testName) + then put(bespoke, "test_" || testName || ".icn") + workingdir := pwd() # getenv("PWD") every dir := !dirs do { chdir(workingdir) | ( - write("Could not change to directory: ", workingdir) & next) + write("Could not change to working directory: ", workingdir) & next) chdir(dir) | (write("Could not change to directory: ", dir) & next) # For each file in the directory every dirEntry := !(dirListing := open(".")) do { # All paths should be relative to the directory-under-test - # Assume it's a file if it begins with test; check tha it ends with .icn + # If "bespoke" is of length > 0, skip tests not in list + if (*bespoke > 0, not(dirEntry == !bespoke)) + then next + # Assume it's a test file if its name begins with "test"; + # check that it ends with ".icn" if dirEntry ? dirEntry == ( testName := ="test_" || tab(find(".icn")) ) || =".icn" then ( # Write nothing unless we find a .std file filExpected := open( testName || ".std") # Report that we will run the test - , write("\n", testName) + , write("::: Running ", testName) , timings[testName] := -&time # Prepare to generate the observed result lines - , filObserved := popen( "icon " || testName || ".icn", "r") + , &trace := -1 + #, write(&errout, "... ante") + , if \win_unicon # only for Unicon on Microsoft Windows NT + then ( + remove(testName || ".bat") | 1, + remove(testName || ".exe") | 1, + system(SET_LPATH || "unicon -s -u " || testName || ".icn"), + delay(100), + system(testName || " > " || testName || ".out") + ) + else if \portableIcon + then ( # portableIcon + system( + SET_LPATH || "icont -s -u " || testName || + ".icn && call " || testName || ".bat" || + " > " || testName || ".out" + ) + ) + else ( # Icon + if ( + cmd <- SET_LPATH || "icont -s -u " || testName || ".icn", + HIDE_CMDLINE | write(&errout, " building: " || \cmd), + 0 = system(\cmd) | break failure := -1 + #, write(&errout, "... building returned zero") + ) + then ( + cmd <- SET_LPATH || "./" || testName || " > " || testName || ".out", + HIDE_CMDLINE | write(&errout, " running: " || \ cmd), + 0 = system(\cmd) | break failure := -1 + #, write(&errout, "... running returned zero"), + ) + else break failure := -1 + ) + , &trace := 0 + #, write(&errout, "... post") + , filObserved := open(testName || ".out", "r") # Create a sequence of expected result lines - , linObsC := create traceout("observed: ",!filObserved) + , linObsC := create traceout(" observed: ", !filObserved) , linCount := 0 # For each observed result line, abort if expected line does not match - , ( every linExpected := traceout("expected: ", !filExpected) do { + , ( every linExpected := traceout(" expected: ", !filExpected) do { linCount +:= 1 # termination is premature if expected line is not observed linObserved := @linObsC | ( abort( " ... line ", linCount - , ": premature termination, expected: '", linExpected, "'" + , ": premature termination, expected: '" + , linExpected, "'" + , if /win_unicon then "" else + " (Windows Unicon pipe or co-expression may have failed.)" ) , break ) @@ -133,36 +246,49 @@ procedure main(args) , linExpected ~== linObserved , "' was produced but '" , linExpected - , "' was expected" + , "' was expected\n" ) & break ) | next } ) | if linObserved := @linObsC # report unexpected output - then abort( " ... line ", linCount - , ": unexpected output: '", linObserved, "'" - ) - else timings[testName] +:= &time + then + abort( " ... line ", linCount + , ": unexpected output: '", linObserved, "'\n" + ) + else { + timings[testName] +:= &time + write(" Passed") + } ) + remove(testName || ".out") } close(\dirListing) } - # from IPL procs showtbl.icn - showtbl( - "approx. runtimes, mS", # 1 title heading title "" - timings, # 2 tbl table to be shown NO DEFAULT - , # 3 sort_type type of sorting "ref"/"val" - , # 4 limit lines of output infinite - , # 5 sort_order increasing? "incr"/"decr" - , # 6 posit first column "val"/"ref" - 40, # 7 w1 width of 1st col 10 - , # 8 w2 width of 2nd col 10 - , # 9 gutter width between cols 3 - right, # 10 f1 f justify 1st col left - left, # 11 f2 f justify 2nd col right - ) - write("\nTotal testing time (milliseconds, within whatever resolution): ", totalTime +:= &time) + if SHOW_TIMINGS & /win_unicon + then{ + # from IPL procs showtbl.icn + showtbl( + "approx. runtimes, mS", # 1 title heading title "" + timings, # 2 tbl table to be shown NO DEFAULT + , # 3 sort_type type of sorting "ref"/"val" + , # 4 limit lines of output infinite + , # 5 sort_order increasing? "incr"/"decr" + , # 6 posit first column "val"/"ref" + 40, # 7 w1 width of 1st col 10 + , # 8 w2 width of 2nd col 10 + , # 9 gutter width between cols 3 + right, # 10 f1 f justify 1st col left + left, # 11 f2 f justify 2nd col right + ) + write("\nTotal testing time (milliseconds, within whatever resolution): ", totalTime +:= &time) + } + if /failure + then { + write() + write("All tests passed. Yippee!!") + } # exit code zero unless falure was encountered when abort === write_abort exit( \failure | 0) end diff --git a/selectRecordFromListByField.icn b/selectRecordFromListByField.icn index e102aa5..ee5757b 100644 --- a/selectRecordFromListByField.icn +++ b/selectRecordFromListByField.icn @@ -1,3 +1,5 @@ +$ifndef _selectRecordFromListByField_ +$define _selectRecordFromListByField_ ############################################################################ # # File: selectRecordFromListByField.icn @@ -76,8 +78,6 @@ # } # ############################################################################ -$ifndef _selectRecordFromListByField_ -$define _selectRecordFromListByField_ procedure selectRecordFromListByField(Lfrom, sField, Ctest) #: produce matching records (or tables) # Lfrom - a list of either: diff --git a/tests/test_LiComboP.icn b/tests/test_LiComboP.icn index 403858a..d9f9e4e 100644 --- a/tests/test_LiComboP.icn +++ b/tests/test_LiComboP.icn @@ -1,5 +1,7 @@ -$include "../wora.icn" -$include "../LiComboP.icn" +# assume that LPATH includes .. + +$include "wora.icn" +$include "LiComboP.icn" procedure printtuple(ls[]) local C diff --git a/tests/test_fieldedDataFile.icn b/tests/test_fieldedDataFile.icn index 3cd3d0a..7272b77 100644 --- a/tests/test_fieldedDataFile.icn +++ b/tests/test_fieldedDataFile.icn @@ -1,7 +1,9 @@ -$include "../RecTable.icn" -$include "../fieldedDataFile.icn" -$include "../wora.icn" -$include "../fileDirIo.icn" +# assume that LPATH includes .. + +$include "RecTable.icn" +$include "fieldedDataFile.icn" +$include "wora.icn" +$include "fileDirIo.icn" $define prog_dir_path prog_path_parts() || path_separator() link ximage diff --git a/tests/test_fileDirIo.icn b/tests/test_fileDirIo.icn index e140fd9..6fa5fb4 100644 --- a/tests/test_fileDirIo.icn +++ b/tests/test_fileDirIo.icn @@ -1,12 +1,20 @@ -$include "../fileDirIo.icn" +# assume that LPATH includes .. #$define DEBUG + $ifdef DEBUG link ximage + $define DBGTRC if not &fail then write + $define FILEDIRIO_TRACE if not &fail then write +$else + $define DBGTRC if &fail then write + $define FILEDIRIO_TRACE if &fail then write $endif # DEBUG +$include "fileDirIo.icn" + procedure main() - local prgL, r, expected + local prgL, r, expected, f, Crslt $ifdef DEBUG local atmL atmL := [] @@ -19,25 +27,47 @@ procedure main() write("*prgL = ", *prgL) $ifdef DEBUG every put(atmL, path_atoms(&progname)) - write("prog_path_parts") - write(ximage(prgL)) - write("path_atoms") - write(ximage(atmL)) - write(&progname) - write(path_constructP{path_atoms(&progname)}) + DBGTRC(&errout, "prog_path_parts") + DBGTRC(&errout, ximage(prgL)) + DBGTRC(&errout, "path_atoms") + DBGTRC(&errout, ximage(atmL)) + DBGTRC(&errout, &progname) + DBGTRC(&errout, path_constructP{path_atoms(&progname)}) $endif # DEBUG - write("exercising directory_seq()") directory_seq(prgL[1]) | stop("directory_seq failed for " || prgL[1]) write("found directory path where program is located") + + write("exercising home()") + if not (r := home()) + then write("home() failed") + else { + FILEDIRIO_TRACE(&errout, "home dir is " || r) + write("home() succeeded") + } + r := &null + write("exercising pwd()") directory_seq(pwd()) | stop("directory_seq failed for " || pwd()) write("pwd() produced a valid directory path") - write("exercising alterExtension()") write("exercising path_atoms()") + if not path_atoms(&progname) + then stop("FAILURE") + write("exercising path_constructP()") + if not path_constructP{path_atoms(&progname)} + then stop("FAILURE") + + DBGTRC(&errout, "path_constructP{path_atoms(&progname)} is:\n ", + path_constructP{path_atoms(&progname)} + ) + + DBGTRC(&errout, "prgL[1] is ", image(prgL[1])) + DBGTRC(&errout, "prgL[2] is ", image(prgL[2])) + + write("exercising alterExtension()") expected := prgL[2] if path_constructP{path_atoms(&progname)} ? r := ( =prgL[1], move(1), tab(0) ) @@ -48,9 +78,37 @@ procedure main() , "\nobserved program name (without path or extension): ", r ) } - write( - if r == expected then "success" else "FAILURE" - ) + if \r == expected + then write("success") + else stop("FAILURE") + + write("exercising tmpdir() and tmppath()") + if (tmppath("foo"), tmppath("bar")) + then write("success") + else stop("FAILURE") + + write("exercising system_nowait") + r := tmppath("foo") + DBGTRC(&errout, "result path: ", r) + Crslt := system_nowait( + "echo \"hello world\" \"with love from Mars and Venus\"> " || r + ) + every 1 to 10 + do + if write("exit code: ", \(@Crslt)) + then break + else delay(100) + + if f := open(r) + then { + DBGTRC(&errout, "begin every write(!f)") + every write(!f) + DBGTRC(&errout, "end every write(!f)") + close(f) + remove(r) + write("success") + } + else stop("FAILURE") exit(0) end diff --git a/tests/test_fileDirIo.std b/tests/test_fileDirIo.std index 0c2b251..72b4a5a 100644 --- a/tests/test_fileDirIo.std +++ b/tests/test_fileDirIo.std @@ -3,11 +3,19 @@ exercising prog_path_parts() *prgL = 2 exercising directory_seq() found directory path where program is located +exercising home() +home() succeeded exercising pwd() pwd() produced a valid directory path -exercising alterExtension() exercising path_atoms() exercising path_constructP() +exercising alterExtension() expected program name (without path or extension): test_fileDirIo observed program name (without path or extension): test_fileDirIo success +exercising tmpdir() and tmppath() +success +exercising system_nowait +exit code: 0 +"hello world" "with love from Mars and Venus" +success diff --git a/tests/test_rpn.icn b/tests/test_rpn.icn index eb70f82..668328b 100644 --- a/tests/test_rpn.icn +++ b/tests/test_rpn.icn @@ -1,6 +1,9 @@ # test rpn.icn routines and rpn_core.rpn words $define DEBUG 1 -$include "../rpn.icn" + +# assume that LPATH includes .. + +$include "rpn.icn" procedure main( ) local f diff --git a/tests/test_runningStats.icn b/tests/test_runningStats.icn index ebd5990..f4d76b4 100644 --- a/tests/test_runningStats.icn +++ b/tests/test_runningStats.icn @@ -1,6 +1,9 @@ -$include "../runningStats.icn" +# assume that LPATH includes .. + +$include "runningStats.icn" link ximage +link numbers # test case inspired by: # https://rosettacode.org/wiki/Cumulative_standard_deviation#Icon_and_Unicon @@ -8,5 +11,10 @@ procedure main() local s, W, x W := welford_running(0, 0, 0) every s := welford_add(W, x := ![2,4,4,4,5,5,7,9]) - write(ximage(welford_get(W))) + x := welford_get(W) + # brittle hack to make Unicon (quad precision) match Icon (double precision) + x.sampleVariance := frn(x.sampleVariance, 11, 9) + x.SD := frn(x.SD, 11, 9) + x.SE := frn(x.SE, 11, 9) + write(ximage(x)) end diff --git a/tests/test_runningStats.std b/tests/test_runningStats.std index 4a01f1a..642b7e1 100644 --- a/tests/test_runningStats.std +++ b/tests/test_runningStats.std @@ -2,6 +2,6 @@ R_welford_cumulative_1 := welford_cumulative() R_welford_cumulative_1.n := 8.0 R_welford_cumulative_1.mean := 5.0 R_welford_cumulative_1.variance := 4.0 - R_welford_cumulative_1.sampleVariance := 4.571428571 - R_welford_cumulative_1.SD := 2.138089935 - R_welford_cumulative_1.SE := 0.755928946 + R_welford_cumulative_1.sampleVariance := "4.571428571" + R_welford_cumulative_1.SD := "2.138089935" + R_welford_cumulative_1.SE := "0.755928946" diff --git a/tests/test_selectRecordFromListByField.icn b/tests/test_selectRecordFromListByField.icn index c45a28f..3ac5931 100644 --- a/tests/test_selectRecordFromListByField.icn +++ b/tests/test_selectRecordFromListByField.icn @@ -1,4 +1,6 @@ -$include "../selectRecordFromListByField.icn" +# assume that LPATH includes .. + +$include "selectRecordFromListByField.icn" record ion(name, polarity) diff --git a/tests/test_vnom.icn b/tests/test_vnom.icn index c940be6..2ce333b 100644 --- a/tests/test_vnom.icn +++ b/tests/test_vnom.icn @@ -5,7 +5,11 @@ # $define VNOM_MAIN_XCODE # $define VNOM_MAIN_XIMAGE -$include "../vnom.icn" +# assume that LPATH includes .. + +$include "lindel.icn" +$include "vnom.icn" +$include "jsonparse.icn" $ifdef VNOM_MAIN_XIMAGE link ximage @@ -18,7 +22,7 @@ $ifdef VNOM_MAIN_XCODE $endif procedure main() - local V, k, v, Vcopy + local V, k, v, Vcopy, L # VNomCtor(Original, Type, ID, Metatable, Disposable, Kind) V := vnew(, "vtype", , , , "vkind") @@ -26,13 +30,26 @@ procedure main() $ifdef VNOM_MAIN_XIMAGE write("ximage(k):\n", ximage(k)) $endif - every v := key(k) do write("metatable[\"", v, "\"] := ", image(k[v])) + L := [] + every v := key(k) do put(L, v) + L := sort(L) + every v := !L do write("metatable[\"", v, "\"] := ", image(k[v])) vmsg(V, "push", 1, "bye bye") vmsg(V, "put", "hola", "mundo") + vmsg(V, "put", "delete3", "york") + vmsg(V, "put", "delete4", "kent") vmsg(V, "push", "hello", "world") + vmsg(V, "put", "coda", "tail") + every write(vmsg(V, "strings")) $ifdef VNOM_MAIN_XIMAGE write("ximage(V):\n", ximage(V)) $endif + write("bykey \"delete3\": " , vmsg(V, "bykey" , "delete3")) + vmsg(V, "delbykey", "delete3") + write("byrank 4: ", vmsg(V, "byrank", 4)) + vmsg(V, "delbyrank", 4) + write("bykey \"coda\": " , vmsg(V, "bykey" , "coda")) + vmsg(V, "delbykey", "coda") Vcopy := vmsg(V, "copy") $ifdef VNOM_MAIN_XIMAGE write("ximage(Vcopy):\n", ximage(Vcopy)) @@ -85,4 +102,10 @@ procedure main() v := create write(" --> ", vmsg(V, "!")) k := create writes(vmsg(V, "key")) while @k do @v + + V := vnew() + vmsg(V, "put", "xyzzy", "you are in a maze of little twisty passages") + vmsg(V, "put", "x", table()) + V["x", "foo"] := "bar" + every write(vmsg(V, "strings")) end diff --git a/tests/test_vnom.std b/tests/test_vnom.std index 668f052..73ce53e 100644 --- a/tests/test_vnom.std +++ b/tests/test_vnom.std @@ -1,20 +1,32 @@ -metatable["keylist"] := procedure VNomMesg -metatable["metatable"] := procedure VNomMesg -metatable["bykey"] := procedure VNomMesg +metatable["!"] := procedure VNomMesg metatable["*"] := procedure VNomMesg -metatable["put"] := procedure VNomMesg +metatable["bykey"] := procedure VNomMesg +metatable["byrank"] := procedure VNomMesg +metatable["copy"] := procedure VNomMesg +metatable["delbykey"] := procedure VNomMesg +metatable["delbyrank"] := procedure VNomMesg +metatable["disposable"] := procedure VNomMesg +metatable["get"] := procedure VNomMesg +metatable["id"] := procedure VNomMesg metatable["image"] := procedure VNomMesg -metatable["!"] := procedure VNomMesg +metatable["key"] := procedure VNomMesg +metatable["keylist"] := procedure VNomMesg metatable["kind"] := procedure VNomMesg -metatable["type"] := procedure VNomMesg -metatable["id"] := procedure VNomMesg -metatable["copy"] := procedure VNomMesg -metatable["push"] := procedure VNomMesg -metatable["byrank"] := procedure VNomMesg +metatable["metatable"] := procedure VNomMesg metatable["pop"] := procedure VNomMesg -metatable["key"] := procedure VNomMesg metatable["pull"] := procedure VNomMesg -metatable["get"] := procedure VNomMesg +metatable["push"] := procedure VNomMesg +metatable["put"] := procedure VNomMesg +metatable["type"] := procedure VNomMesg +hello: world +1: bye bye +hola: mundo +delete3: york +delete4: kent +coda: tail +bykey "delete3": york +byrank 4: kent +bykey "coda": tail hello --> world 1 --> bye bye hola --> mundo @@ -48,3 +60,5 @@ There are 3 values in Vcopy foo --> bar magic --> 1 2 --> marker +xyzzy: you are in a maze of little twisty passages +{"foo" : "bar"} diff --git a/tests/test_wora.icn b/tests/test_wora.icn index 0d9c154..e20b46c 100644 --- a/tests/test_wora.icn +++ b/tests/test_wora.icn @@ -1,4 +1,6 @@ -$include "../wora.icn" +# assume that LPATH includes .. + +$include "wora.icn" procedure main() local foo, bar, baz diff --git a/vnom.icn b/vnom.icn index b8ae015..e5cc2ed 100644 --- a/vnom.icn +++ b/vnom.icn @@ -1,3 +1,5 @@ +$ifndef VNOM +$define VNOM ############################################################################ # # File: vnom.icn @@ -76,21 +78,27 @@ # # in order keys in L # vmsg(V, "*" ) : i # produce number of values # +# vmsg(V, "copy" ) : V # produce a copy of V +# # having same metatable instance # vmsg(V, "get" | "pop" ) : x # pop value, discarding key # vmsg(V, "pull" ) : x # pull value, discarding key -# vmsg(V, "push", x1, x2) : V # push value with key -# vmsg(V, "put", x1, x2) : V # put value with key +# vmsg(V, "push", xk, xv) : V # push|replace value xv for key xk +# vmsg(V, "put", xk, xv) : V # put|replace value xv for key xk # vmsg(V, "key" ) : x1, ... # generate keys # # in order keys in L # vmsg(V, "keylist" ) : L # copy of L of ranked keys # vmsg(V, "bykey", x ) : s # value, assignable by key # vmsg(V, "byrank", i ) : s # value, assignable by rank +# vmsg(V, "delbykey", x ) : n # delete value by key +# vmsg(V, "delbyrank", i ) : n # delete value by rank # -# vmsg(V, "kind" ) : s # Kind property, assignable +# vmsg(V, "disposable" ) : s # disposable property # vmsg(V, "id" ) : s # ID property, assignable -# vmsg(V, "type" ) : s # Type property, assignable # vmsg(V, "image" ) : s # image property +# vmsg(V, "kind" ) : s # Kind property, assignable # vmsg(V, "metatable" ) : s # Metatable, assignable +# vmsg(V, "strings" ) : s # generate a string to show each KVP +# vmsg(V, "type" ) : s # Type property, assignable # # Constructor # vnew(Original:T, Type:s, ID:s, Metatable:T, Disposable:s, Kind:s):V @@ -118,6 +126,7 @@ # # icon -P ' # link ximage +# $include "lindel.icn" # $include "vnom.icn" # # vnew and vmsg are $defined in vnom.icn as: # # $define vnew VNomCtor @@ -148,6 +157,9 @@ # T3["bykey"] := procedure VNomMesg # T3["byrank"] := procedure VNomMesg # T3["copy"] := procedure VNomMesg +# T3["delbykey"] := procedure VNomMesg +# T3["delbyrank"] := procedure VNomMesg +# T3["disposable"] := procedure VNomMesg # T3["get"] := procedure VNomMesg # T3["id"] := procedure VNomMesg # T3["image"] := procedure VNomMesg @@ -168,7 +180,9 @@ # ############################################################################ # -# Requires: preprocessor +# Requires: +# - preprocessor +# - $include "lindel.icn" # ############################################################################ # @@ -178,6 +192,11 @@ # vnom.icn - a named vector with Lua-style metatable access +# require LINDEL for Ldelete from lindel.icn +$ifndef LINDEL +$include "lindel.icn" +$endif + $ifndef vnew $define vnew VNomCtor $endif @@ -199,8 +218,7 @@ procedure VNomCtor(Original, Type, ID, Metatable, Disposable, Kind) # allocate internal table for properties V[V] := table() - # set properties - + #----- META-PROPERTIES ----- # Dspsbl is &null | "yes" | "done" V[V, "Dspsbl"] := /Disposable | "yes" @@ -231,32 +249,38 @@ procedure VNomCtor(Original, Type, ID, Metatable, Disposable, Kind) V[V, "ID"] := \ID | V[V, "Type"] || (image(V) ? (="table",tab(upto('(')))) - # declare handler for each message - + #----- MESSAGE HANDLERS ----- # messages having 0 args - MT["!"] := VNomMesg - MT["*"] := VNomMesg - MT["copy"] := VNomMesg - MT["get"] := VNomMesg - MT["key"] := VNomMesg - MT["keylist"] := VNomMesg - MT["pop"] := VNomMesg - MT["pull"] := VNomMesg - - MT["id"] := VNomMesg - MT["image"] := VNomMesg - MT["kind"] := VNomMesg - MT["type"] := VNomMesg + # - property accessors + MT["disposable"] := VNomMesg + MT["id"] := VNomMesg + MT["image"] := VNomMesg + MT["kind"] := VNomMesg + MT["metatable"] := VNomMesg + MT["type"] := VNomMesg + # - L/T messages + MT["!"] := VNomMesg + MT["*"] := VNomMesg + MT["copy"] := VNomMesg + MT["get"] := VNomMesg + MT["key"] := VNomMesg + MT["keylist"] := VNomMesg + MT["pop"] := VNomMesg + MT["pull"] := VNomMesg # messages having 1 arg - MT["bykey"] := VNomMesg - MT["byrank"] := VNomMesg - MT["metatable"]:= VNomMesg + # - element selectors/deleters + MT["bykey"] := VNomMesg + MT["byrank"] := VNomMesg + MT["delbykey"] := VNomMesg + MT["delbyrank"] := VNomMesg # messages having 2 args - MT["push"] := VNomMesg - MT["put"] := VNomMesg + # - L/T messages + MT["push"] := VNomMesg + MT["put"] := VNomMesg + # produce newly-constructed "object" return V end @@ -272,6 +296,8 @@ procedure VNomMesg(args[]) nargs := *args - 2 # count of args beyond V and msg V := args[1] # extract VNom from args message := args[2] # extract message from args + if /V[V] # coerce ordinary table to get + then V := VNomCtor(V) # the same interface as VNom metamethod := V[V, "Mttbl", message] # extract metamethod from VNom suspend if (\metamethod ~=== VNomMesg) # Is this proc the impl. of msg.? then metamethod ! args # if not, invoke implementation @@ -281,17 +307,17 @@ procedure VNomMesg(args[]) case nargs of { 2 : case message of { # message handlers taking 2 args "push" : { # "push" message handler - if (idx := args[3]) === !state # make sure key is not in state - then fail # when so, disallow message - push(state, idx) # add idx to left end of state L - V[idx] := args[4] # add idx and value to V + idx := args[3] # get intended key + if not (idx === !state) # make sure key is in state; + then push(state, idx) # or add left end of state L + V[idx] := args[4] # assign key and value in V V # produce V } "put" : { # "put" message handler - if (idx := args[3]) === !state # make sure key is not in state - then fail # when so, disallow message - put(state, idx) # add idx to right end of state L - V[idx] := args[4] # add idx and value to V + idx := args[3] # get intended key + if not (idx === !state) # make sure key is in state; + then put(state, idx) # or add right end of state L + V[idx] := args[4] # assign key and value in V V # produce V } default : fail @@ -303,6 +329,24 @@ procedure VNomMesg(args[]) "byrank" : { # "byrank" message handler V[state[args[3]]] # produce L-value for rank in L } + "delbykey" : ( # "delbykey" message handler + idx := # if key exists in state, + args[3] === # get index of key in state + state[ # otherwise fail + val := 1 to *state + ], + Ldelete(state, val), # delete element at index + delete(V, idx), # delete key from V + &null + ) + "delbyrank" : ( # "delbyrank" message handler + 0 < ( val := # fail when rank is valid + (*state >= args[3])), + idx := state[val], # get key from state + Ldelete(state, val), # delete element at index + delete(V, idx), # delete key from V + &null + ) default : fail } 0 : case message of { # message handlers taking 0 args @@ -313,12 +357,16 @@ procedure VNomMesg(args[]) *state # produce length of state L } "copy" : { # "copy" message handler - val := VNomCtor(V) - # val := copy(V) # create shallow copy of V, - # delete(val, V) # remove old self-ID - # val[val] := copy(V[V]) # add new self-ID - # val[val, "State"] := copy(state) # make shallow copy of state L - # val # produce the copy of V + val := VNomCtor(V) # produce copy of V + } # with same metatable instance + "disposable" : { # "disposable" message handler + V[V, "Dspsbl"] # produce disposable property + } # as an L-value + "id" : { # "id" message handler + V[V, "ID"] # produces ID property + } # as an L-value + "image" : { # "image" message handler + V[V, "ID"] || "(" || *state || ")" # produces s } "key" : { # "key" message handler !state # generate keys (names), @@ -326,6 +374,12 @@ procedure VNomMesg(args[]) "keylist" : { # "keylist" message handler copy(state) # produce L of keys (names), } # ordered by state L + "kind" : { # "kind" message handler + V[V, "Kind"] # produces Kind property + } # as an L-value + "metatable" : { # "metatable" message handler + V[V, "Mttbl"] # produce metatable + } # as an L-value "pop" | "get" : { # "pop" and "get" message handlers val := V[idx := pull(state)] # get idx and val delete(V, idx) # remove idx from keys of V @@ -336,21 +390,12 @@ procedure VNomMesg(args[]) delete(V, idx) # remove idx from keys of V val # produce val } + "strings" : { # "strings" message handler + VNomStrings(V) # generates one representative + } # string per key-value pair "type" : { # "type" message handler V[V, "Type"] # produces Type property } # as an L-value - "kind" : { # "kind" message handler - V[V, "Kind"] # produces Kind property - } # as an L-value - "id" : { # "id" message handler - V[V, "ID"] # produces ID property - } # as an L-value - "image" : { # "image" message handler - V[V, "ID"] || "(" || *state || ")" # produces s - } - "metatable" : { # "metatable" message handler - V[V, "Mttbl"] # produce metatable - } # as an L-value default : fail } default : fail @@ -358,4 +403,35 @@ procedure VNomMesg(args[]) } end +invocable "json" + +# generate elements of VNom as strings +procedure VNomStrings(V, j) + local k, p, s, x, e + e := &error; &error := -1 # save &error state; convert errors to failure + /j := proc("json") | proc("encode") | image + &error := e # restore error state + every k := vmsg(V, "key") + do + case type(x := V[k]) of { + default : suspend j(x) + "null" : suspend k || ": " || "NA" + "string" | + "integer" | + "real" : suspend k || ": " || V[k] + "list" : { + s := "[" + every p := 1 to *x + do + s ||:= + if p ~= *x + then x[p] || ", " + else x[p] + suspend s || "]" + } + } +end + + # see tests/test_vnom.* for demonstrations +$endif # VNOM diff --git a/wora.icn b/wora.icn index cccffe1..1404d8f 100644 --- a/wora.icn +++ b/wora.icn @@ -1,3 +1,5 @@ +$ifndef _wora_ +$define _wora_ ############################################################################ # # File: wora.icn @@ -10,10 +12,40 @@ # ############################################################################ # -# This file is in the public domain. +# This file is in the public domain. Art Eschenlauer has waived all +# copyright and related or neighboring rights to: +# wora.icn - Restricted-access globally accessible storage +# For details, see: +# https://creativecommons.org/publicdomain/zero/1.0/ +# +# If you require a specific license and public domain status is not +# sufficient for your needs, please substitute the MIT license (see +# below), bearing in mind that the copyright "claim" is solely to meet +# your requirements and does not imply any restriction on use or copying +# by the author: # -# SPDX-License-Identifier: CC-PDDC -# https://spdx.org/licenses/CC-PDDC.html +# Copyright (c) 2022, Arthur Eschenlauer +# +# Permission is hereby granted, free of charge, to any person obtain- +# ing a copy of this software and associated documentation files (the +# "Software"), to deal in the Software without restriction, including +# without limitation the rights to use, copy, modify, merge, publish, +# distribute, sublicense, and/or sell copies of the Software, and to +# permit persons to whom the Software is furnished to do so, subject +# to the following conditions: +# +# The above copyright notice and this permission notice shall be +# included in all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +# NON-INFRINGEMENT. +# +# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR +# ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF +# CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +# WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. # ############################################################################ # @@ -23,8 +55,6 @@ # `del` - not null when owner requests deletion; ignored otherwise. # ############################################################################ -$ifndef _wora_ -$define _wora_ procedure wora(id,del) #: a globally visible value, settable by only one C # WORA - Writeable-by-One, Readable-by-All