Programs

_images/unicon.png

Index Unicon

Sample programs

For lack of a better chapter name, this part of the docset is miscellaneous sample programs.

S-Lang

An example of embedding an S-Lang interpreter. S-Lang programs, as Unicon strings, are evaluated, and the last S-Lang result is passed back to Unicon.

Allowed return types:

S-Lang, by John Davis. http://www.jedsoft.org/slang/

Note

The mkRlist function in ipl/cfuncs/icall.h had the wrong prototype prior to Revision 4501 of the Unicon sources. Was int x[], needs to be double x[].

-word mkRlist(int x[], int n);
+word mkRlist(double x[], int n);

Already fixed, thanks to Jafar Al-Gharaibeh.

Note

Also be aware that some of the memory management in slang.c may be erroneous. Not for production use if you see this note.

Here is the slang loadfunc C function:

/*
 Embed an S-Lang interpreter in a Unicon loadfunc extension
 tectonics: gcc -o slang.so -shared -fpic slang.c -lslang
*/

#include <stdio.h>
#include <slang.h>
#include "icall.h"

/*
 slangEval, run S-Lang code or load filename
 Init S-Lang if necessary
 Then load from or evaluate a string argv[1]
 The last result stacked by S-Lang is returned to Unicon
 Integer, Double, String and Array as List values allowed
*/
int
slangEval(int argc, descriptor *argv, int fromfile)
{
    static int slang_loaded = 0;

    int tos;
    int i, iv;
    double r;
    char *s, *slast = NULL;
    /* Limit to single dimension arrays for this version */
    listblock *list;
    SLang_Array_Type *at;
    SLindex_Type ind;

    /* load slang, and all intrinsics */
    if (!slang_loaded) {
        if (-1 == SLang_init_all()) {
            /* Program malfunction */
#ifdef DEBUG
            fprintf(stderr, "Can't initialize S-Lang\n");
#endif
            Error(500);  
        } else {
            slang_loaded = 1;
        }
    }

    /* ensure argv[1] is a string */
    ArgString(1)

    if (fromfile) {
        /* evaluate filename in argv[1] */
        if (-1 == SLang_load_file(StringVal(argv[1]))) {
            SLang_restart(1);
            SLang_set_error(0);

            /* report invalid procedure type error to Unicon */
            Error(178);
        }
     } else {
        /* evaluate argv[1] */
        if (-1 == SLang_load_string(StringVal(argv[1]))) {
            /* Reset S-Lang to allow later code attempts */
            SLang_restart(1);
            SLang_set_error(0);
    
            /* report invalid procedure type error to Unicon */
            Error(178);
        }
    }

    /* Unicon result will be last S-Lang expression */
    tos = SLang_peek_at_stack();
    switch (tos) {
        case SLANG_INT_TYPE:
            /* return an integer to Unicon */
            SLang_pop_integer(&i);
            RetInteger(i);
            break;
        case SLANG_DOUBLE_TYPE:
            /* return a real to Unicon */
            SLang_pop_double(&r);
            RetReal(r);
            break;
        case SLANG_STRING_TYPE:
            /* return an allocated string to Unicon */
            /* memory allocation strategy; previous string is freed */
            if (slast)  SLfree(slast);
            SLpop_string(&s);
            slast = s;
            RetString(s);
            break;
        case SLANG_ARRAY_TYPE:
	    /* return an array as a Unicon list */
            if (-1 == SLang_pop_array_of_type(&at, SLANG_DOUBLE_TYPE)) {
                /* report malfuntion */
                Error(500);
            }
#ifdef DEBUG
            if (at->num_dims != 1) {
                /* warn about flattening array */
                fprintf(stderr, "S-Lang array flattened to one dimension\n");
            }
#endif
            double *doubles = malloc(sizeof(double) * at->num_elements);
            for (i = 0; i < at->num_elements; i++) {
                (void) SLang_get_array_element(at, &i, &r);
                doubles[i] = r;
            } 
            /* 
             mkRlist was defined as (int [], n) now (double [], n)
            */
            list = mkRlist(doubles, at->num_elements);
            
            /* clean up the temporary array*/
            free(doubles);

            RetList(list);
            break;
        default:
#ifdef DEBUG
            fprintf(stderr, "Unsupported S-Lang datatype %d\n", tos);
#endif
            /* report invalid value error to Unicon */
            Error(205);
    }
    return 0;
}

/*
 input string is a filename
 Usage from Unicon
     slangfile = loadfunc("./slang.so", "slangFile")
     x := slangfile("slang.sl")
*/
int
slangFile(int argc, descriptor *argv)
{
    int result;
    result = slangEval(argc, argv, 1);
    return result;
}

/*
 input string is S-Lang code
 Usage from Unicon
     slang = loadfunc("./slang.so", "slang")
     x := slang("S-Lang statements;")
*/
int
slang(int argc, descriptor *argv)
{
    int result;
    result = slangEval(argc, argv, 0);
    return result;
}

programs/slang.c

A Unicon test head:

#
# slang.icn, load a S-Lang interpreter, and evaluate some statements
#
# tectonics: gcc -o slang.so -shared -fpic slang.c -lslang
link ximage
procedure main()
    # embed the interpreter
    slang := loadfunc("./slang.so", "slang")

    # return a computed variable, sum of list
    code := "variable slsum = sum([0,1,2,3,4,5,6,7,8,9]);_
             slsum;"
    result := slang(code)
    write("Unicon sum: ", result)

    # return value is from S-Lang printf (bytes written)
    code := "printf(\"S-Lang: %f\\n\", slsum);"
    write("Unicon printf length: ", slang(code))

    # S-Lang IO mix in
    code := "printf(\"S-Lang: %s = %f and %s = %f\\n\",_
           \"hypot([3,4])\", hypot([3,4]),_
           \"sumsq([3,4])\", sumsq([3,4]));"
    write("Unicon printf length: ", slang(code))

    # 3D vector length
    code := "variable A = [3,4,5]; hypot(A);"
    write("Unicon hypot([3,4,5]): ", slang(code))

    # try some strings, last one created will stay allocated
    code := "\"abc\";"
    write("Unicon abc: ", slang(code))
    code := "\"def\";"
    write("Unicon def: ", slang(code))

    # Pass an array, returned as a list of Real
    code := "[1, 2.2, 3, [4, 5, [6, 7], 8], 9.9];"
    write("Unicon from ", code)
    L := slang(code)
    writes("Unicon (array flattened) ")
    every i := !L do writes(i, " ")
    write()

    # Cummulative summation
    code := "cumsum([1.1, 2.2, 3.3, 4.4]);"
    L := slang(code)
    writes("Unicon from ", code, ": ")
    every i := !L do writes(i, " ")
    write()

    # try a small S-Lang program    
    code := "variable t, i; t = 0; for (i = 0; i < 10; i++) t += i; t;"
    write("Unicon from ", code, ": ", slang(code))

    
    # Exercise S-Lang load file
    write()
    write("Unicon run code from file slang.sl")
    slangfile := loadfunc("./slang.so", "slangFile")
    file := "slang.sl"

    # show the file
    cf := open(file, "r") | write("No ", file, " for test")
    write("####")
    while write(read(cf))
    close(cf)
    write("####")

    # run the file
    L := slangfile(file)
    writes("Unicon from ", file, ": ")
    every i := !L do writes(i, " ")
    write()

 
    # convert an error to failure
    write()
    write("Unicon convert S-Lang error to failure")
    &error := 1
    code := "[1, 2, \"abc\"];"
    write("Unicon trying: ", code)
    slang(code)
    write("Unicon S-Lang &errornumber: ", &errornumber)

    # and an abend
    write()
    write("Unicon abend on S-Lang divide by zero")
    code := "1/0"
    slang(code)
end

programs/slang.icn

And a flying carpet run to see how things go:

prompt$ gcc -o slang.so -shared -fpic slang.c -lslang

Sample run ends in a purposeful error demonstration:

prompt$ unicon -s slang.icn -x
Unicon sum: 45.0
S-Lang: 45.000000
Unicon printf length: 18
S-Lang: hypot([3,4]) = 5.000000 and sumsq([3,4]) = 25.000000
Unicon printf length: 61
Unicon hypot([3,4,5]): 7.071067811865476
Unicon abc: abc
Unicon def: def
Unicon from [1, 2.2, 3, [4, 5, [6, 7], 8], 9.9];
Unicon (array flattened) 1.0 2.2 3.0 4.0 5.0 6.0 7.0 8.0 9.9 
Unicon from cumsum([1.1, 2.2, 3.3, 4.4]);: 1.1 3.3 6.6 11.0 
Unicon from variable t, i; t = 0; for (i = 0; i < 10; i++) t += i; t;: 45

Unicon run code from file slang.sl
####
%
% slang.sl, S-Lang file loaded from Unicon
%
% Unicon test program expects a list result
%
% Date: August 2016
% Modified: 2016-08-30/10:15-0400
%
define factorial();   % declare, for recursion

define factorial(n)
{
    if (n < 2) return 1;
    return n * factorial(n - 1);
}

variable list=[factorial(7),factorial(8),factorial(9)];
list;
####
Unicon from slang.sl: 5040.0 40320.0 362880.0 

Unicon convert S-Lang error to failure
Unicon trying: [1, 2, "abc"];
Unable to typecast Integer_Type to String_Type
***string***:1:<top-level>:Type Mismatch
Unicon S-Lang &errornumber: 178

Unicon abend on S-Lang divide by zero
Divide by Zero
***string***:1:<top-level>:Divide by Zero

Run-time error 178
File slang.icn; Line 95

Traceback:
   main()
   slang("1/0") from line 95 in slang.icn

And Unicon can use S-Lang scripts whenever necessary.


COBOL

An example of embedding a COBOL module. First pass is simply seeing if integers make into the COBOL runtime.

GnuCOBOL is a free software COBOL compiler; part of the GNU project, copyright Free Software Foundation. https://sourceforge.net/projects/open-cobol/

GnuCOBOL

Note

This is first step trial code

The loaded COBOL function, unicob:

      *> Unicon interfacing with COBOL
       identification division.
       program-id. unicob.
      
      *> tectonics: cobc -m -fimplicit-init unicob.cob
      *> In Unicon: unicob := loadfunc("./unicob.so", "unicob")

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 actual usage binary-long.
       01 arguments based.
          05 args occurs 1 to 10 times depending on actual.
             10 dword usage binary-double unsigned.
             10 vword usage binary-double.
       linkage section.
       01 argc usage binary-long.
       01 argv usage pointer.
       
       procedure division using by value argc, argv.
       sample-main.
       display argc, ", ", argv

      *> if there is a null argv, report program malfunction
       if argv equal null then
           move 500 to return-code
           goback
       end-if

      *> argc needs one extra allocation to account for zeroth
       add 1 to argc giving actual
       set address of arguments to argv

      *> Let's see some integers
       perform varying tally from 1 by 1 until tally > actual
           display dword(tally), ", ", vword(tally)
       end-perform

      *> initial trickery to get a result to Unicon
       move dword(2) to dword(1)
       compute vword(1) = vword(2) * 6

      *> the "C" function returns 0 on success
       move 0 to return-code
       goback.
       end program unicob.

programs/unicob-v1.cob

A test head:

#
# unicob.icn, load a COBOL module and show some integers
#
# tectonics: cobc -m -fimplicit-init unicob.cob
procedure main()
    # embed some COBOL
    unicob := loadfunc("./unicob.so", "unicob")
    result := unicob(7, 8, 9)
    write("unicob completed with ", result)
end

programs/unicob-v1.icn

And a flying carpet run to see how things go:

prompt$ cobc -m -w -fimplicit-init unicob-v1.cob
prompt$ unicon -s unicob-v1.icn -x
+0000000004 arguments
 
&null      :
integer    : +00000000000000000007
integer    : +00000000000000000008
integer    : +00000000000000000009
unicob completed with 42

Seems to work ok. Nerd dancing ensues, with a couple of “Oh, yeah, uh huh”s thrown in.

Step 2

This is still fairly experimental code. A little bit of icall.h ported in, with support of more datatypes than simple integers.

      *> Unicon interfacing with COBOL
       identification division.
       program-id. unicob.

      *> tectonics: cobc -m -fimplicit-init unicob.cob
      *> In Unicon: unicob := loadfunc("./unicob.so", "unicob")
      *>   result := unicob(integer, real, or strin, ...)

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 actual usage binary-long.

       01 arguments based.
          05 args occurs 1 to 96 times depending on actual.
             10 dword usage binary-double unsigned.
             10 vword usage binary-double.

       01 unicon-int usage binary-c-long based.
       01 unicon-real usage float-long based.
       01 unicon-string usage pointer based.
       01 cobol-buffer pic x(8192) based.
       01 cobol-string pic x(8192).

      *> If DESCRIPTOR-DOUBLE not found in environment, default to set
       >>DEFINE DESCRIPTOR-DOUBLE PARAMETER
       >>IF DESCRIPTOR-DOUBLE IS NOT DEFINED
       >>DEFINE DESCRIPTOR-DOUBLE 1
       >>END-IF

       >>IF P64 IS SET
       01 FLAG-NOT-STRING constant as H"8000000000000000".
       01 FLAG-VARIABLE   constant as H"4000000000000000".
       01 FLAG-POINTER    constant as H"2000000000000000".
       01 FLAG-TYPECODE   constant as H"1000000000000000".
       01 DESCRIPTOR-TYPE constant as H"A000000000000000".
       01 DESCRIPTOR-NULL constant as H"A000000000000000".
       01 DESCRIPTOR-INT  constant as H"A000000000000001".
       >>IF DESCRIPTOR-DOUBLE IS DEFINED
       01 DESCRIPTOR-REAL constant as H"A000000000000003".
       >>ELSE
       01 DESCRIPTOR-REAL constant as H"B000000000000003".
       >>END-IF
       >>ELSE  *> not 64 bit
       01 FLAG-NOT-STRING constant as H"80000000".
       01 FLAG-VARIABLE   constant as H"40000000".
       01 FLAG-POINTER    constant as H"20000000".
       01 FLAG-TYPECODE   constant as H"10000000".
       01 DESCRIPTOR-TYPE constant as H"A0000000".
       01 DESCRIPTOR-NULL constant as H"A0000000".
       01 DESCRIPTOR-INT  constant as H"A0000001".
       >>IF DESCRIPTOR-DOUBLE IS DEFINED
       01 DESCRIPTOR-REAL constant as H"A0000003".
       >>ELSE
       01 DESCRIPTOR-REAL constant as H"B0000003".
       >>END-IF
       >>END-IF

      *> take argc int, argv array pointer
       linkage section.
       01 argc usage binary-long.
       01 argv usage pointer.

       procedure division using by value argc, argv.
       unicob-main.

      *> if there is a null argv, report program malfunction
       if argv equal null or argc less than 1 then
           move 500 to return-code
           goback
       end-if

      *> argc needs one extra allocation to account for zeroth
       add 1 to argc giving actual
       set address of arguments to argv
       display actual " arguments"
       display space

      *> Let's see the arguments (including current &null result slot)
       perform varying tally from 1 by 1 until tally > actual
           *> display "Arg: " tally " = " dword(tally), ", ", vword(tally)
           evaluate dword(tally)
              when equal DESCRIPTOR-NULL
                  display "&null      :"
              when equal DESCRIPTOR-INT
                  perform show-integer
              when equal DESCRIPTOR-REAL
                  perform show-real
              when less than FLAG-NOT-STRING
                  perform show-string
              when other
                  display "unsupported: type code is " dword(tally)
           end-evaluate
       end-perform

      *> send back the universal answer
       move DESCRIPTOR-INT to dword(1)
       move 42 to vword(1)
    
      *> the loadfunc function returns 0 on success
       move 0 to return-code
       goback.

      *> ****************
       show-integer.
       call "cnv_c_int" using args(tally) args(tally)
       display "integer    : " vword(tally)
       .

       show-real.
       call "cnv_c_dbl" using args(tally) args(tally)
       set address of unicon-real to address of vword(tally)
       display "float-long : " unicon-real
       .

       show-string.
       call "cnv_c_str" using args(tally) args(tally)
       set address of unicon-string to address of vword(tally)
       set address of cobol-buffer to unicon-string
       string cobol-buffer delimited by low-value into cobol-string
       *> The length is in dword(tally)
       display 'string     : "' trim(cobol-string) '"'
       .

       end program unicob.

programs/unicob.cob

Adding to the test head:

#
# unicob.icn, load a COBOL module and show some integers
#
# tectonics: cobc -m -fimplicit-init unicob.cob
procedure main()
    # embed some COBOL
    unicob := loadfunc("./unicob.so", "unicob")
    result := unicob(7, 8, 9, &phi, [], "Unicon and COBOL, together at last")
    write()
    write("Unicon     : unicob completed with ", result)
end

programs/unicob.icn

And a fly by to check out the new datatype support:

prompt$ cobc -m -w -fimplicit-init unicob.cob
prompt$ unicon -s unicob.icn -x
+0000000007 arguments
 
&null      :
integer    : +00000000000000000007
integer    : +00000000000000000008
integer    : +00000000000000000009
float-long : 1.618033988749895
unsupported: type code is 12682136550675316744
string     : "Unicon and COBOL, together at last"

Unicon     : unicob completed with 42

So, yeah, Unicon and COBOL; might come in handy.

There are a lot more details about GnuCOBOL at http://open-cobol.sourceforge.net/faq/index.html


Duktape

A Javascript engine. Another exploratory trial.

Duktape is hosted at http://duktape.org You will need the .c and .h files from the src/ directory from the distribution. This test uses version 1.5.1. http://duktape.org/duktape-1.5.1.tar.xz

With Duktape, you simply include the .c files in a build. In this case, uniduk.so is built with uniduk.c and dukctape.c.

The C sample for loadfunc. uniduk-v1.c.

/*
 uniduk-v1.c, first trial, integrate a Javascript engine in Unicon
 tectonics: gcc -std=c99 -o uniduk.so -shared -fpic uniduk-v1.c duktape.c -lm
*/

#include <stdio.h>
#include "duktape.h"
#include "icall.h"

int
uniduk(int argc, descriptor *argv)
{

    duk_context *ctx = duk_create_heap_default();
    duk_eval_string(ctx, argv[1].vword.sptr);
    duk_destroy_heap(ctx);
    argv[0].dword = D_Integer;
    argv[0].vword.integr = 42;
    return 0;
}

programs/uniduk-v1.c

The sample Unicon file to load and test the engine, uniduk-v1.icn.

#
# uniduk.icn, load the Duktape ECMAScript engine 
#
# tectonics: gcc -std=c99 -o uniduk.so -shared -fpic uniduk.c duktape.c
procedure main()
    # embed some Duktape
    uniduk := loadfunc("./uniduk.so", "uniduk")
    result := uniduk("print('Hello, world');")
    write("Unicon: uniduk completed with ", result)
end

programs/uniduk-v1.icn

And a test run

prompt$ gcc -std=c99 -o uniduk.so -shared -fpic uniduk-v1.c duktape.c
prompt$ unicon -s uniduk-v1.icn -x
Hello, world
Unicon: uniduk completed with 42

And Duktape Javascript step 1 has been taken.

Second step

Todo

extend this further to handle more datatypes

The extended C sample for loadfunc. uniduk.c.

/*
 uniduk.c, integrate a Javascript engine in Unicon
 tectonics: gcc -std=c99 -o uniduk.so -shared -fpic uniduk.c duktape.c -lm
*/

#include <stdio.h>
#include "duktape.h"
#include "icall.h"

/*
 dukeval, evaluate a Javascript string or from file
*/
static duk_context *unictx;
static int duk_loaded = 0;

int
dukeval(int argc, descriptor *argv, int fromfile)
{
    /* Need a string argument */
    if (argc < 1) Error(103); 

    if (!duk_loaded) {
        unictx = duk_create_heap_default();
        /* if bad init, report program malfunction */
        if (!unictx)  Error(500);
        duk_loaded = 1;
    }

    /* argument is either a filename or code string */
    ArgString(1);

    if (fromfile) {
        duk_eval_file(unictx, StringVal(argv[1]));
    } else {
        duk_eval_string(unictx, StringVal(argv[1]));
    }
    duk_int_t typ = duk_get_type(unictx, -1);
    switch (typ) {
        case DUK_TYPE_NONE:
        case DUK_TYPE_UNDEFINED:
            RetNull();
            break;
        case DUK_TYPE_NULL:
            duk_pop(unictx);
            RetNull();
            break;
        case DUK_TYPE_NUMBER:
        case DUK_TYPE_BOOLEAN:
            RetReal(duk_get_number(unictx, -1));
            break;
        case DUK_TYPE_STRING:
            RetConstString((char *)duk_get_string(unictx, -1));
            break;
        default:
            fprintf(stderr, "Unsupported Duk type: %d\n", typ);
            Error(178);
            break;
    }
    return 0;
}

/*
 uniduk, a Unicon loadfunc function
 Usage from Unicon
    uniduk := loadfunc("./uniduk.so", "uniduk")
    result := uniduk("print('Hello'); var r = 7 * 6;")
*/
int
uniduk(int argc, descriptor *argv)
{
    int result;
    result = dukeval(argc, argv, 0);
    return result;
}

/*
 unidukFile, load Duktape code from file
 Usage from Unicon
    unidukfile := loadfunc("./uniduk.so", "unidukFile")
    result := unidukfile("uniduk.js")
*/
int
unidukFile(int argc, descriptor *argv)
{
    int result;
    result = dukeval(argc, argv, 1);
    return result;
}

/*
 unidukDone, a Unicon loadfunc function for Duktape rundown
 Usage from Unicon
    unidukdone := loadfunc("./uniduk.so", "unidukDone")
    result := unidukDone()
 Unicon result is &null, by nature of not being set
*/
int
unidukDone(int argc, descriptor *argv)
{
    duk_destroy_heap(unictx);
    duk_loaded = 0;
    return 0;
}

programs/uniduk.c

The sample Unicon file to load and test the engine, uniduk.icn.

#
# uniduk.icn, load the Duktape ECMAScript engine 
#
# tectonics: gcc -std=c99 -o uniduk.so -shared -fpic uniduk.c duktape.c
#
procedure main()
    # embed some Duktape ECMAScript
    uniduk := loadfunc("./uniduk.so", "uniduk")
    unidukfile := loadfunc("./uniduk.so", "unidukFile")
    unidukdone := loadfunc("./uniduk.so", "unidukDone")

    # numbers
    code := "1 + 2;"
    write("Attempt: ", code)
    result := uniduk(code)
    write("Unicon: uniduk completed with ", result)

    # no result, but side effect
    code := "print('Duktape print'); var r = 7 * 6;"
    write("Attempt: ", code)
    result := uniduk(code)
    write("Unicon: uniduk completed with ", result)

    # var r, number, set from previous script
    code := "r;"
    write("Attempt: ", code)
    result := uniduk(code)
    write("Unicon: uniduk completed with ", result)

    # string
    code := "'abc';"
    write("Attempt: ", code)
    result := uniduk(code)
    write("Unicon: uniduk completed with ", result)

    # JSON (Duktape custom JX format, readable JSON)
    code := "var obj = {foo: 0/0, bar: [1, undefined, 3]};_
             Duktape.enc('jx', obj);"
    write("Attempt: ", code)
    result := uniduk(code)
    write("Unicon: uniduk completed with ", result)
    
    # evaluate a test script from file
    filename := "uniduk.js"
    write("Attempt: ", filename)
    result := unidukfile(filename)

    # close up
    write("Unicon: Unload Duktape")
    unidukdone()
end

programs/uniduk.icn

// fib.js
function fib(n) {
    if (n == 0) { return 0; }
    if (n == 1) { return 1; }
    return fib(n-1) + fib(n-2);
}

function test() {
    var res = [];
    for (i = 0; i < 20; i++) {
        res.push(fib(i));
    }
    print(res.join(' '));
}

test();

programs/uniduk.js

And a test run

prompt$ gcc -std=c99 -o uniduk.so -shared -fpic uniduk.c duktape.c
prompt$ unicon -s uniduk.icn -x
Attempt: 1 + 2;
Unicon: uniduk completed with 3.0
Attempt: print('Duktape print'); var r = 7 * 6;
Duktape print
Unicon: uniduk completed with 
Attempt: r;
Unicon: uniduk completed with 42.0
Attempt: 'abc';
Unicon: uniduk completed with abc
Attempt: var obj = {foo: 0/0, bar: [1, undefined, 3]};Duktape.enc('jx', obj);
Unicon: uniduk completed with {foo:NaN,bar:[1,undefined,3]}
Attempt: uniduk.js
0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181
Unicon: Unload Duktape

And Duktape Javascript step 2 has been taken. Can you feel the nerd dancing? Running man with a wicked loud[1] “Ice, Ice Baby” playing in the background?

To be a little more confident, here is an initial stress test, calling out the Viking, valgrind.

prompt$ valgrind ./uniduk
==14698== Memcheck, a memory error detector
==14698== Copyright (C) 2002-2015, and GNU GPL'd, by Julian Seward et al.
==14698== Using Valgrind-3.11.0 and LibVEX; rerun with -h for copyright info
==14698== Command: ./uniduk
==14698== 
==14699== Warning: invalid file descriptor -1 in syscall close()
==14700== 
==14700== HEAP SUMMARY:
==14700==     in use at exit: 10,018 bytes in 54 blocks
==14700==   total heap usage: 61 allocs, 7 frees, 10,730 bytes allocated
==14700== 
==14700== LEAK SUMMARY:
==14700==    definitely lost: 0 bytes in 0 blocks
==14700==    indirectly lost: 0 bytes in 0 blocks
==14700==      possibly lost: 0 bytes in 0 blocks
==14700==    still reachable: 10,018 bytes in 54 blocks
==14700==         suppressed: 0 bytes in 0 blocks
==14700== Rerun with --leak-check=full to see details of leaked memory
==14700== 
==14700== For counts of detected and suppressed errors, rerun with: -v
==14700== ERROR SUMMARY: 0 errors from 0 contexts (suppressed: 0 from 0)
==14699== 
==14699== HEAP SUMMARY:
==14699==     in use at exit: 1,853 bytes in 54 blocks
==14699==   total heap usage: 59 allocs, 5 frees, 2,037 bytes allocated
==14699== 
==14699== LEAK SUMMARY:
==14699==    definitely lost: 0 bytes in 0 blocks
==14699==    indirectly lost: 0 bytes in 0 blocks
==14699==      possibly lost: 0 bytes in 0 blocks
==14699==    still reachable: 1,853 bytes in 54 blocks
==14699==         suppressed: 0 bytes in 0 blocks
==14699== Rerun with --leak-check=full to see details of leaked memory
==14699== 
==14699== For counts of detected and suppressed errors, rerun with: -v
==14699== ERROR SUMMARY: 0 errors from 0 contexts (suppressed: 0 from 0)
Attempt: 1 + 2;
Unicon: uniduk completed with 3.0
Attempt: print('Duktape print'); var r = 7 * 6;
Duktape print
Unicon: uniduk completed with 
Attempt: r;
Unicon: uniduk completed with 42.0
Attempt: 'abc';
Unicon: uniduk completed with abc
Attempt: var obj = {foo: 0/0, bar: [1, undefined, 3]};Duktape.enc('jx', obj);
Unicon: uniduk completed with {foo:NaN,bar:[1,undefined,3]}
Attempt: uniduk.js
0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181
Unicon: Unload Duktape

There used to be a warning about invalid fd passed to the close syscall. Turns out, by tracking with strace, it was actually Unicon start up doing that.[2]. Didn’t effect program outcome, but after mentioning it to the principals it was fixed.[3].

The rest is all good, 0 leaked RAM. The still reachable being non-zero is a common thing in most processes; exit was called while the Unicon engine was still in play, so there is valid runtime memory used for statics (like message strings) and a little bit of allocation for buffers. The important numbers for this test pass are

...
==nnnnn== LEAK SUMMARY:
==nnnnn==    definitely lost: 0 bytes in 0 blocks
==nnnnn==    indirectly lost: 0 bytes in 0 blocks
==nnnnn==      possibly lost: 0 bytes in 0 blocks
...
==nnnnn== ERROR SUMMARY: 0 errors from 0 contexts (suppressed: 0 from 0)
...

Those are what you want to see from a Viking[4] report.

Process numbers will vary by machine and run

[1]Turned up wayyy past 4 on the dial, maybe even a 6.
[2]Tried this with a bare bones Unicon program, single write of a string. valgrind still reported the invalid -1 to the close syscall.
[3]Mentioned the -1 being passed to close during ucode invocation. This was caused by a lower level sh edge case interaction in handling the way ucode is attached to an invocation script. Harmless, and not to be entirely blamed on Unicon, but it was fixed anyway. Every bug reported to the Unicon team has been fixed while writing this book.
[4]valgrind is a Norse name, pronounced to rhyme with grinned, not grind. Go vikings.

Duktape license obligation

Copyright (c) 2013-2016 by Duktape authors (see AUTHORS.rst)

Permission is hereby granted, free of charge, to any person obtaining 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 NONINFRINGEMENT. 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.

mruby

Integrate the mruby (Mini Ruby) library with Unicon.

First pass, see if things gel:

/*
 uniruby-v1.c loadfunc an mruby interpreter in Unicon

 tectonics: gcc -o unirbuy.so -shared -fpic uniruby-v1.c \
                /usr/lib/libmruby.a -lm
*/
#include <stdio.h>
#include <stdlib.h>

#include <mruby.h>
#include <mruby/compile.h>

#include "icall.h"

int
uniruby(int argc, descriptor *argv)
{
    /* start up an mruby engine */
    mrb_state *mrb = mrb_open();
    if (!mrb) Error(500);

    /* Need a string of code parameter */
    if (argc < 1) Error(103);
    ArgString(1);
    
    /* run the Ruby code, and return a universal answer */
    mrb_load_string(mrb, StringVal(argv[1]));
    RetInteger(42); 
}

programs/uniruby-v1.c

The sample Unicon file to load and test the engine, uniruby-v1.icn.

#
# uniruby-v1.icn, integrate mruby in Unicon
#
# tectonics: gcc -o uniruby.so -shared -fpic uniruby-v1.c \
#                /usr/lib/libmruby.a -lm
procedure main()
    uniruby := loadfunc("./uniruby.so", "uniruby")

    code := "p 'Hello, world'"
    write("Attempt: ", code)
    result := uniruby(code)
    write("Unicon result: ", result)
end

programs/uniruby-v1.icn

And a test run

prompt$ gcc -o uniruby.so -shared -fpic uniruby-v1.c /usr/lib/libmruby.a -lm
prompt$ unicon -s uniruby-v1.icn -x
Attempt: p 'Hello, world'
"Hello, world"
Unicon result: 42

mruby license obligation

Copyright (c) 2016 mruby developers

Permission is hereby granted, free of charge, to any person obtaining 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 NONINFRINGEMENT. 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.

ficl

The Forth Inspired Command Language.

http://ficl.sourceforge.net/

This sample embeds a Forth interpreter using ficl-4.1.0 as a shared library.

The initial trial, unificl-v1

/*
 unificl-v1.c a Forth interpreter in Unicon with loadfunc

 tectonics:
     gcc -o unificl.so -shared -fpic unificl-v1.c -lficl
                
*/
#include <stdio.h>
#include <stdlib.h>

#include "ficl.h"
#include "icall.h"

/* Global variables to track VM across calls */
int unificlLoaded = 0;
ficlVm *unificlVm = NULL;
ficlSystem *unificlSystem = NULL;

/* Unicon calling ficl */
int
unificl(int argc, descriptor *argv)
{
    int returnValue = 0;
    char buffer[256];

    /* Need a string of code parameter */
    if (argc < 1) Error(103);
    ArgString(1);

    /* start up the ficl VM */
    if (!unificlLoaded) {
        unificlSystem = ficlSystemCreate(NULL);
        ficlSystemCompileExtras(unificlSystem);
        unificlVm = ficlSystemCreateVm(unificlSystem);
        returnValue = ficlVmEvaluate(unificlVm,
                                     ".ver .( " __DATE__ " ) cr quit");
        unificlLoaded = 1;
    }

    /* Run the Forth code and get an integer status */
    returnValue = ficlVmEvaluate(unificlVm, StringVal(argv[1]));

    /* return to Unicon */
    RetInteger(returnValue);
}

/* run down the ficl VM, return a 0 to Unicon */
int
unificlRundown(int argc, descriptor *argv)
{
    ficlSystemDestroy(unificlSystem);
    unificlVm = NULL;
    unificlSystem = NULL;
    unificlLoaded = 0;
    RetInteger(0);
}

programs/unificl-v1.c

A sample Unicon file to load and test the engine, unificl-v1.icn.

#
# unificl.icn, Forth scripting with ficl
#
# tectonics:
#    gcc -o unificl.so -shared -fpic unificl.c -lficl
#
procedure main()
    unificl := loadfunc("./unificl.so", "unificl")
    unificlRundown := loadfunc("./unificl.so", "unificlRundown")

    # say hello, and leave a number on the stack
    code := "cr .( Hello, world) cr 123454321"
    write("\nEvaluate: ", image(code), "\n")
    result := unificl(code)
    write("Unicon result: ", result) 

    # display the left over number from previous invocation
    code := ". cr"
    write("\nEvaluate: ", image(code), "\n")
    result := unificl(code)
    write("Unicon result: ", result)

    # rundown the ficl system
    unificlRundown()

    # start a fresh copy
    code := ": unificl-test  6 7 * . cr ;  unificl-test"
    write("\nEvaluate: ", image(code), "\n")
    result := unificl(code)
    write("Unicon result: ", result)

    # display the default ficl word list
    code := "words"
    write("\nEvaluate: ", image(code), "\n")
    result := unificl(code)
    write("Unicon result: ", result)

    # and a test with an error
    code := "nonsense forth code"
    write("\nEvaluate: ", image(code))
    write("Expect ficl error", "\n")
    result := unificl(code)
    write("Unicon result: ", result)
end

programs/unificl-v1.icn

And a test run (using an uninstalled copy of ficl, so the Makefile includes C compiler -L, -I options and LD_LIBRARY_PATH runtime settings).

Forth scripting inside Unicon. If you look closely, that ficl word-list display includes the test definition of unificl-test, along with the ficl core, and default extension words.

Note that ficl result code -257 is the normal exit status. Defined as

/* hungry - normal exit */
#define FICL_VM_STATUS_OUT_OF_TEXT  (-257)

That means the text was successfully interpreted and the engine is ready for more.

-260 is defined as

/* interpreter found an error */
#define FICL_VM_STATUS_ERROR_EXIT   (-260)

Second step

And now for some real integration.

/*
 unificl-v1.c a Forth interpreter in Unicon with loadfunc

 tectonics:
     gcc -o unificl.so -shared -fpic unificl-v1.c -lficl
                
*/
#include <stdio.h>
#include <stdlib.h>

#include "ficl.h"
#include "icall.h"

/* Global variables to track VM across calls */
int unificlLoaded = 0;
ficlVm *unificlVm = NULL;
ficlSystem *unificlSystem = NULL;

/* Unicon calling ficl */
int
unificl(int argc, descriptor *argv)
{
    int returnValue = 0;
    char buffer[256];

    /* Need a string of code parameter */
    if (argc < 1) Error(103);
    ArgString(1);

    /* start up the ficl VM */
    if (!unificlLoaded) {
        unificlSystem = ficlSystemCreate(NULL);
        ficlSystemCompileExtras(unificlSystem);
        unificlVm = ficlSystemCreateVm(unificlSystem);
        //returnValue = ficlVmEvaluate(unificlVm,
        //                             ".ver .( " __DATE__ " ) cr quit");
        unificlLoaded = 1;
    }

    /* Run the Forth code and get an integer status */
    returnValue = ficlVmEvaluate(unificlVm, StringVal(argv[1]));

    /* return to Unicon */
    RetInteger(returnValue);
}

/* run down the ficl VM, return a 0 to Unicon */
int
unificlRundown(int argc, descriptor *argv)
{
    ficlSystemDestroy(unificlSystem);
    unificlVm = NULL;
    unificlSystem = NULL;
    unificlLoaded = 0;
    RetInteger(0);
}

/* Return the stack */
int
unificlStack(int argc, descriptor *argv)
{
    int depth;
    int i;
    listblock *list;

    if (!unificlLoaded) {
        Error(117); /* report engine not loaded, missing main procedure */
    }

    depth = ficlStackDepth(unificlVm->dataStack);
    int *integers = malloc(sizeof(int) * depth);
    for (i = 0; i < depth; i++) {
        integers[i] = ficlStackFetch(unificlVm->dataStack, i).i;
    }
    list = mkIlist(integers, depth);

    /* return to Unicon */
    free(integers);
    RetList(list);
}

/* Return the floating point stack */
int
unificlFloatStack(int argc, descriptor *argv)
{
    int depth;
    int i;
    listblock *list;

    if (!unificlLoaded) {
        Error(117); /* report engine not loaded, missing main procedure */
    }

    depth = ficlStackDepth(unificlVm->floatStack);
    double *doubles = malloc(sizeof(double) * depth);
    for (i = 0; i < depth; i++) {
        doubles[i] = ficlStackFetch(unificlVm->floatStack, i).f;
    }
    list = mkRlist(doubles, depth);

    /* return to Unicon */
    free(doubles);
    RetList(list);
}

programs/unificl.c

A sample Unicon file to load and test the updated engine, unificl.icn.

#
# unificl.icn, Forth scripting with ficl
#
# tectonics:
#    gcc -o unificl.so -shared -fpic unificl.c -lficl
#
link fullimag
procedure main()
    unificl := loadfunc("./unificl.so", "unificl")
    unificlStack := loadfunc("./unificl.so", "unificlStack")
    unificlFloatStack := loadfunc("./unificl.so", "unificlFloatStack")
    unificlRundown := loadfunc("./unificl.so", "unificlRundown")

    # say hello, and leave a number on the stack
    code := ".( Hello, world) cr 123454321"
    write("\nUnicon evaluate: ", image(code))
    result := unificl(code)
    write("Unicon ficl (", result, "): ", fullimage(unificlStack()))

    # display the left over number from previous invocation
    code := ". cr"
    write("\nUnicon evaluate: ", image(code))
    result := unificl(code)
    write("Unicon ficl (", result, "): ", fullimage(unificlStack()))

    # rundown the ficl system
    unificlRundown()

    # start a fresh copy, and leave some numbers on the data stack
    code := ": unificl-test  6 7 * dup 1+ dup 1+ ; unificl-test"
    write("\nUnicon evaluate: ", image(code))
    result := unificl(code)
    write("Unicon ficl (", result, "): ", fullimage(unificlStack()))

    # try the floating point stack
    code := ": unificl-float  1e 4.2e ; unificl-float"
    write("\nUnicon evaluate: ", image(code))
    result := unificl(code)
    write("Unicon ficl (", result, "): ", fullimage(unificlFloatStack()))

    # try addresses, add the Xt of the sample definition to the stack
    code := "' unificl-test"
    write("\nUnicon evaluate: ", image(code))
    result := unificl(code)
    write("Unicon ficl (", result, "): ", fullimage(unificlStack()))

    # execute that Xt
    code := "execute"
    write("\nUnicon evaluate: ", image(code))
    result := unificl(code)
    write("Unicon ficl (", result, "): ", fullimage(unificlStack()))


    # and a test with an error
    code := "nonsense forth code"
    write("\nUnicon evaluate: ", image(code))
    write("Unicon expect ficl error")
    result := unificl(code)
    write("Unicon ficl (", result, "): ", fullimage(unificlStack()))

    # and a test with a crash
    code := "0 ?"
    write("\nUnicon evaluate: ", image(code))
    write("Unicon expect ficl segfault")
    result := unificl(code)
    write("Unicon ficl (", result, "): ", fullimage(unificlStack()))
end

programs/unificl.icn

Sample run ends in a purposeful error, Unicon trapping a Ficl segfault:

prompt$ make -B unificl
make[1]: Entering directory '/home/btiffin/wip/writing/unicon/programs'
gcc -o unificl.so -shared -fpic unificl.c -lficl -lm
unicon -s unificl.icn -x

Unicon evaluate: ".( Hello, world) cr 123454321"
Hello, world
Unicon ficl (-257): [123454321]

Unicon evaluate: ". cr"
123454321 
Unicon ficl (-257): []

Unicon evaluate: ": unificl-test  6 7 * dup 1+ dup 1+ ; unificl-test"
Unicon ficl (-257): [44,43,42]

Unicon evaluate: ": unificl-float  1e 4.2e ; unificl-float"
Unicon ficl (-257): [4.199999809265137,1.0]

Unicon evaluate: "' unificl-test"
Unicon ficl (-257): [37308328,44,43,42]

Unicon evaluate: "execute"
Unicon ficl (-257): [44,43,42,44,43,42]

Unicon evaluate: "nonsense forth code"
Unicon expect ficl error
nonsense not found
Unicon ficl (-260): []

Unicon evaluate: "0 ?"
Unicon expect ficl segfault

Run-time error 302
File unificl.icn; Line 72
memory violation
Traceback:
   main()
   &null("0 ?") from line 72 in unificl.icn
Makefile:47: recipe for target 'unificl' failed
make[1]: *** [unificl] Error 1
make[1]: Leaving directory '/home/btiffin/wip/writing/unicon/programs'

The unificl engine can evaluate Forth source, and Unicon can snag the stack and the floating point stack as needed, as a list. That returned list is ready for Unicon style stack functions, pop will pop what would be the top of the ficl data stack. Separate structures, the ficl stack is the ficl stack, and Unicon gets a copy as a list.

As a side bonus, no effort was required to have Unicon catch (and report) the purposeful segfault in the last ficl test of 0 ? (an attempt to read address 0).

FICL License obligation

FICL LICENSE

Copyright © 1997-2001 John Sadler (john_sadler@alum.mit.edu)
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
   notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
   notice, this list of conditions and the following disclaimer in the
   documentation and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
SUCH DAMAGE.

Lua

Lua scripts embedded in Unicon.

First pass, see if things gel:

/*
 unilua-v1.c loadfunc a Lua interpreter in Unicon

 tectonics: gcc -o unilua-v1.so -shared -fpic unilua-v1.c \
                -I/usr/include/lua5.3 -llua5.3
*/
#include <stdio.h>
#include <string.h>
#include <lua.h>
#include <lauxlib.h>
#include <lualib.h>

#include "icall.h"

int unilua (int argc, descriptor argv[]) {
  char buff[256];
  int error;

  char *unibuf;

#ifdef LUA50
  lua_State *L = lua_open();   /* opens Lua */
  if (!L) {
      Error(500);
  } 
  luaopen_base(L);             /* opens the basic library */
  luaopen_table(L);            /* opens the table library */
  luaopen_io(L);               /* opens the I/O library */
  luaopen_string(L);           /* opens the string lib. */
  luaopen_math(L);             /* opens the math lib. */
#else
  lua_State *L = luaL_newstate();
  if (!L) {
      Error(500);
  } 
  luaL_openlibs(L);
#endif

  /* ensure argv[1] is a string */
  ArgString(1);
  
  /* evaluate some Lua */
  unibuf = StringVal(argv[1]);
  error = luaL_loadbuffer(L, unibuf, strlen(unibuf), "line") ||
          lua_pcall(L, 0, 0, 0);
  if (error) {
      fprintf(stderr, "%s", lua_tostring(L, -1));
      lua_pop(L, 1);  /* pop error message from the stack */
      Error(107);
  }

  lua_close(L);
  RetInteger(42);
  return 0;
}

programs/unilua-v1.c

The sample Unicon file to load and test the engine, unilua-v1.icn.

#
# unilua-v1.icn, Initial trial of Lua integration
#
# tectonics:
#    gcc -o unilua-v1.so -shared -fpic unilua-v1.c \
#        -I/usr/include/lua5.3 -llua5.3
#
procedure main()
    unilua := loadfunc("./unilua-v1.so", "unilua")

    code := "print(\"Hello, world\")"
    result := unilua(code)
    write("Unicon: ", result)
end

programs/unilua-v1.icn

The make recipes:

# Lua in Unicon
# alpha test
unilua-v1.so: unilua-v1.c
> gcc -o unilua-v1.so -shared -fpic unilua-v1.c \
      -I/usr/include/lua5.3 -llua5.3

unilua-v1: unilua-v1.so
> unicon -s unilua-v1.icn -x

# unilua
unilua.so: unilua.c
> gcc -o unilua.so -shared -fpic unilua.c \
      -I/usr/include/lua5.3 -llua5.3

unilua: unilua.so
> unicon -s unilua.icn -x

And the alpha test run:

prompt$ make -B --no-print-directory unilua-v1.so
gcc -o unilua-v1.so -shared -fpic unilua-v1.c -I/usr/include/lua5.3 -llua5.3
prompt$ unicon -s unilua-v1.icn -x
Hello, world
Unicon: 42

Second step

Lua state is held in a persistent variable, remembered across calls. A new luaclose function is supported.

/*
 unilua.c loadfunc a Lua interpreter in Unicon

 tectonics: gcc -o unilua.so -shared -fpic unilua.c \
                -I/usr/include/lua5.3 -llua5.3
*/
#include <stdio.h>
#include <string.h>
#include <lua.h>
#include <lauxlib.h>
#include <lualib.h>

#include "icall.h"

lua_State *uniLuaState;

/*
 unilua: execute Lua code from Unicon string
*/
int
unilua (int argc, descriptor argv[])
{
    int error;

    char *unibuf;
    int luaType;

    if (!uniLuaState) {
#ifdef LUA50
        uniLuaState = lua_open();     /* opens Lua */
        if (!uniLuaState) {
            Error(500);
        } 
        luaopen_base(uniLuaState);    /* opens the basic library */
        luaopen_table(uniLuaState);   /* opens the table library */
        luaopen_io(uniLuaState);      /* opens the I/O library */
        luaopen_string(uniLuaState);  /* opens the string lib. */
        luaopen_math(uniLuaState);    /* opens the math lib. */
#else
        uniLuaState = luaL_newstate();
        if (!uniLuaState) {
            Error(500);
        } 
        luaL_openlibs(uniLuaState);
#endif
    }

    /* ensure argv[1] is a string */
    ArgString(1);
    
    /* evaluate some Lua */
    unibuf = StringVal(argv[1]);
    error = luaL_loadbuffer(uniLuaState, unibuf, strlen(unibuf), "line") ||
            luaL_dostring(uniLuaState, unibuf);
    if (error) {
        fprintf(stderr, "%s", lua_tostring(uniLuaState, -1));
        lua_pop(uniLuaState, 1);  /* pop error message from the stack */
        Error(107);
    }

    luaType = lua_type(uniLuaState, -1);
    switch (luaType) {
        case LUA_TSTRING:
            RetString((char *)lua_tostring(uniLuaState, -1));
            break;
        case LUA_TNUMBER:
            if (lua_isinteger(uniLuaState, -1)) {
                RetInteger(lua_tointeger(uniLuaState, -1));
            } else {
                RetReal(lua_tonumber(uniLuaState, -1));
            }    
            break;
        default:
            RetString((char *)lua_typename(uniLuaState, luaType));
            break;
    }  
    return 0;
}

/*
 Close Lua state
*/
int
uniluaClose(int argc, descriptor argv[])
{
    lua_close(uniLuaState);
    RetNull();
    return 0;
}  

programs/unilua.c

Another sample Unicon file to load and test the engine, unilua.icn.

#
# unilua.icn, Lua integration demonstration
#
# tectonics:
#     gcc -o unilua.so -share -fpic unilua.c \
#         -I/usr/include/lua5.3 -llua5.3
#
procedure main()
    unilua := loadfunc("./unilua.so", "unilua")
    luaclose := loadfunc("./unilua.so", "uniluaClose")

    code := "return \"Running \" .. _VERSION"
    result := unilua(code)
    write("Unicon: ", result)

    luaclose()
end

programs/unilua.icn

And the second test run:

prompt$ make -B unilua.so
make[1]: Entering directory '/home/btiffin/wip/writing/unicon/programs'
gcc -o unilua.so -shared -fpic unilua.c -I/usr/include/lua5.3 -llua5.3
make[1]: Leaving directory '/home/btiffin/wip/writing/unicon/programs'
prompt$ unicon -s unilua.icn -x
Unicon: Running Lua 5.3

A final step will be returning all Lua stack items to Unicon during each call, and perhaps exposing a few more Lua internal API features.

Lua license obligation

Copyright © 1994–2016 Lua.org, PUC-Rio.

Permission is hereby granted, free of charge, to any person obtaining 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 NONINFRINGEMENT. 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.

Fortran

Calling FORTRAN programs from Unicon.

The first step passes no arguments, but uses various Fortran source forms; FORTRAN-66, FORTRAN-77. A Fortran-90 (free format) program takes an integer and returns a result to Unicon.

C
C FORTRAN 66 FORM
C
      WRITE (6,7)
    7 FORMAT(13H HELLO, WORLD)
      END

programs/fortran-66.f

*
* Fortran 77 form
*
      PROGRAM HELLO
      PRINT *,'Hello, world'
      END

programs/fortran-77.f

This next Fortran-90 source accepts an integer argument and returns the square of the Unicon value (using Fortran subroutine call frame expectations which has no return value, all parameters passed by reference) plus the cube of the Unicon number (using Fortran function call frame expectations). The data marshalling to and from Fortran uses a small layer of C, but that could be pure Fortran if the data structures from icall.h were ported to Fortran friendly data definitions.

!
! Fortran 90 form
!
! Compute the square of n, result in m
subroutine squareto(n,m)
    m = n*n
    return
end

! Compute the cube of n, return value
integer function cube(n)
    cube = n*n*n
    return
end

programs/fortran.f

A little bit of C as an intermedia data marshalling layer:

/*
 unifortran.c loadfunc some Fortran functions in Unicon

 tectonics:
     gfortran -o fortran.o -fpic fortran.f
     gcc -o fortran.so -shared -fpic unifortran.c fortran.o
*/
#include <stdio.h>
#include <string.h>

#include "icall.h"

/* Fortran is pass by reference */
int squareto_(int *, int *);
int cube_(int *);

/*
 unifortran: execute Fortran functions
*/
int
unifortran (int argc, descriptor argv[])
{
    int n, m;
    if (argc != 1) Error(104);

    /* ensure argv[1] is an integer */
    ArgInteger(1);
    n = IntegerVal(argv[1]);

    /* first call the subroutine, data comes back in second argument */
    squareto_(&n, &m);
    
    /* invoke Fortran function, argument by address, add to previous */
    m += cube_(&n);
    RetInteger(m);
}

programs/unifortran.c

The make recipes:

# gfortran modules
fortran-66.so: fortran-66.f
> gfortran -o fortran-66.so -shared -fpic fortran-66.f

fortran-77.so: fortran-77.f
> gfortran -o fortran-77.so -shared -fpic fortran-77.f

fortran.so: fortran.f unifortran.c
> gfortran -ffree-form -c -fpic fortran.f
> gcc -o fortran.so -shared -fpic unifortran.c fortran.o

fortran: fortran.icn fortran-66.so fortran-77.so fortran.so
> unicon -s $< -x

A Unicon test file:

#
# fortran.icn, invoke some gfortran programs and functions
#
# tectonics:
#    gfortran -o fortran-66.so -shared -fpic fortran-66.f
#    gfortran -o fortran-77.so -shared -fpic fortran-77.f
#    gfortran -ffree-form -c -fpic fortran.f
#    gcc -o fortran.so -shared -fpic unifortran.c fortran.o
#
procedure main()
    # load and invoke an old form Fortran main module
    # this could just as well be an open pipe or system call
    # but this is an alpha level proof of mechanism
    fortran66 := loadfunc("./fortran-66.so", "main")
    fortran66()

    # load and invoke another Fortran main module
    # a simple demonstration of variant forms of Fortran source
    fortran77 := loadfunc("./fortran-77.so", "main")
    fortran77()

    # load a Fortran module, and pass arguments
    # any realistic use of Fortran would build on this type of interface
    # or, would require fortran-ization of the C macros in icall.h
    fortran := loadfunc("./fortran.so", "unifortran")
    result := fortran(5)
    write("Subroutine square(5, result) + cube(5) from Fortran: ", result)
end

programs/fortran.icn

The alpha trial serves multiple purposes in this case. There is a simple goal of trying various forms of Fortran source; FORTRAN 66, FORTRAN 77, and more modern Fortran syntax.

There is also a proof of technology test to see if main modules can be loaded with loadfunc.

A third purpose is ensuring that C interstitial code plays well between Fortran and Unicon, when passing parameters and retrieving results.

prompt$ make --no-print-directory -B fortran
gfortran -o fortran-66.so -shared -fpic fortran-66.f
gfortran -o fortran-77.so -shared -fpic fortran-77.f
gfortran -ffree-form -c -fpic fortran.f
gcc -o fortran.so -shared -fpic unifortran.c fortran.o
unicon -s fortran.icn -x
 HELLO, WORLD
 Hello, world
Subroutine square(5, result) + cube(5) from Fortran: 150

Assembler

Calling assembly programs from Unicon.

Assembler is no different than C when it comes to the binary objects produced for the operating system. Assembler is a step on the way to native binary for many C compilers, GCC in particular.

A very similar Unicon loadfunc setup, identical actually:

#
# uniasm.icn, load an assembler object file
#
# tectonics:
#    gcc -S -fpic uniasm.c
#    gcc -o uniasm.so -shared -fpic uniasm.s
#
procedure main()
    # load the uniasm module
    uniasm := loadfunc("./uniasm.so", "uniasm")

    # pass a 42, and get back the length of an output message
    result := uniasm(42)
    write("Unicon: ", result)
end

programs/uniasm.icn

A fairly sophisticated looking piece of x86_64 assembler source:

	.file	"uniasm.c"
	.section	.rodata
.LC0:
	.string	"uniasm: %ld\n"
	.text
	.globl	uniasm
	.type	uniasm, @function
uniasm:
.LFB2:
	.cfi_startproc
	pushq	%rbp
	.cfi_def_cfa_offset 16
	.cfi_offset 6, -16
	movq	%rsp, %rbp
	.cfi_def_cfa_register 6
	subq	$16, %rsp
	movl	%edi, -4(%rbp)
	movq	%rsi, -16(%rbp)
	cmpl	$0, -4(%rbp)
	jg	.L2
	movl	$101, %eax
	jmp	.L3
.L2:
	movq	-16(%rbp), %rax
	leaq	16(%rax), %rdx
	movq	-16(%rbp), %rax
	addq	$16, %rax
	movq	%rdx, %rsi
	movq	%rax, %rdi
	call	cnv_int@PLT
	testl	%eax, %eax
	jne	.L4
	movq	-16(%rbp), %rcx
	movq	-16(%rbp), %rax
	movq	24(%rax), %rdx
	movq	16(%rax), %rax
	movq	%rax, (%rcx)
	movq	%rdx, 8(%rcx)
	movl	$101, %eax
	jmp	.L3
.L4:
	movq	-16(%rbp), %rax
	movabsq	$-6917529027641081855, %rcx
	movq	%rcx, (%rax)
	movq	-16(%rbp), %rax
	addq	$16, %rax
	movq	8(%rax), %rax
	movq	%rax, %rsi
	leaq	.LC0(%rip), %rdi
	movl	$0, %eax
	call	printf@PLT
	movslq	%eax, %rdx
	movq	-16(%rbp), %rax
	movq	%rdx, 8(%rax)
	movl	$0, %eax
.L3:
	leave
	.cfi_def_cfa 7, 8
	ret
	.cfi_endproc
.LFE2:
	.size	uniasm, .-uniasm
	.ident	"GCC: (Ubuntu 5.4.0-6ubuntu1~16.04.4) 5.4.0 20160609"
	.section	.note.GNU-stack,"",@progbits

programs/uniasm.s

Which is computer generated output from a much simpler looking C source file:

/* uniasm.c, used to produce uniasm.s */
#include <stdio.h>
#include "icall.h"

int
uniasm(int argc, descriptor argv[])
{
    /* Expect an integer argument from Unicon */
    ArgInteger(1);
   
    /* print a message with arg, and return the number of bytes written */
    RetInteger(printf("uniasm: %ld\n", IntegerVal(argv[1])));
}

programs/uniasm.c

prompt$ gcc -S -fpic uniasm.c

That assembly can be used just like a C file when it comes to creating the shared objects required by loadfunc.

The -fpic option is required along with gcc -S to generate assembly code that can be relocated, for use in a dynamic shared object file.

prompt$ gcc -o uniasm.so -shared -fpic uniasm.s

Note the .s on that command line, not a .c file.

And running that from Unicon:

prompt$ unicon -s uniasm.icn -x
uniasm: 42
Unicon: 11

Although this example was generated assembly, the .s source code could be used as a basis for hand edited files, all the Unicon loadfunc requirements, and associated macros, properly expanded into working assembler.


vedis

vedis, an embedded Redis clone by Symisc Systems. Using a Redis style data store from Unicon.

http://vedis.symisc.net/

The Unicon setup uses pathload from IPL file io.icn.

#
# univedis-v1.icn, Embed a Redis clone, vedis by Symisc
#
# tectonics:
#    gcc -o univedis-v1.so -shared -fpic univedis-v1.c vedis.c
#
link io
procedure main()
    lib := "univedis-v1.so"
    VedisOpen := pathload(lib, "VedisOpen")
    Vedis := pathload(lib, "Vedis")
    VedisClose := pathload(lib, "VedisClose")

    handle := VedisOpen(":mem:")
    
    Vedis(handle, "SET message 'Hello, world'")
    result := Vedis(handle, "GET message")
    write(result)

    VedisClose(handle)
end

programs/univedis-v1.icn

The vedis source is an SQLite style amalgamation bundle. Just include vedis.c in a build.

# vedis (Embedded Redis clone)
univedis-v1.so: univedis-v1.c
> gcc -o univedis-v1.so -shared -fpic univedis-v1.c vedis.c \
  -Wno-unused

univedis-v1: univedis-v1.so univedis-v1.icn
> unicon -s univedis-v1.icn -x

The initial trial is a simple vedis example:

/*
 univedis-v1.c, trial for vedis embedding in Unicon

 tectonics:
     gcc -o univedis-v1.so -shared -fpic univedis-v1.c vedis.c
*/

#include <stdio.h>
#include "vedis.h"
#include "icall.h"

/*
 open a vedis data store (":mem:" for in-memory)
*/
int
VedisOpen(int argc, descriptor argv[])
{
    int rc;
    vedis *vp;

    ArgString(1)

    rc = vedis_open(&vp, StringVal(argv[1]));
    if (rc != VEDIS_OK) Error(500);

    RetInteger((long)vp);    
}

/*
 close a vedis connection
*/
int
VedisClose(int argc, descriptor argv[])
{
    int rc;
    vedis *vp;

    /* argv[1] is vedis handle */
    ArgInteger(1);
    rc = vedis_close((vedis *)IntegerVal(argv[1]));
    RetInteger(rc);
}

/*
 execute a vedis command
*/
int
Vedis(int argc, descriptor argv[])
{
    int rc;
    vedis *vp;
    vedis_value *rp;
    const char *result;
    
    /* argv[1] is vedis handle */
    ArgInteger(1);
    /* argv[2] is vedis command as string - single result */
    ArgString(2);

    vp = (vedis *)IntegerVal(argv[1]);
    rc = vedis_exec(vp, StringVal(argv[2]), -1);
    vedis_exec_result(vp, &rp);
    result = vedis_value_to_string(rp, 0);
    RetString((char *)result);
}

programs/univedis-v1.c

And a sample run:

prompt$ make -B --no-print-directory univedis-v1
gcc -o univedis-v1.so -shared -fpic univedis-v1.c vedis.c \
  -Wno-unused
unicon -s univedis-v1.icn -x
Hello, world

There are some 70 Redis type commands in the vedis engine.

vedis license obligation

/*
 * Copyright (C) 2013 Symisc Systems, S.U.A.R.L [M.I.A.G Mrad Chems Eddine <chm@symisc.net>].
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 * 3. Redistributions in any form must be accompanied by information on
 *    how to obtain complete source code for the Vedis engine and any
 *    accompanying software that uses the Vedis engine software.
 *    The source code must either be included in the distribution
 *    or be available for no more than the cost of distribution plus
 *    a nominal fee, and must be freely redistributable under reasonable
 *    conditions. For an executable file, complete source code means
 *    the source code for all modules it contains.It does not include
 *    source code for modules or files that typically accompany the major
 *    components of the operating system on which the executable file runs.
 *
 * THIS SOFTWARE IS PROVIDED BY SYMISC SYSTEMS ``AS IS'' AND ANY EXPRESS
 * OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 * WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
 * NON-INFRINGEMENT, ARE DISCLAIMED.  IN NO EVENT SHALL SYMISC SYSTEMS
 * BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
 * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 */

libcox

libcox a cross platform system command evaluation library by Symisc Systems.

http://libcox.symisc.net/

Another Unicon loadfunc sample.

#
# unicox.icn, Embed libcox system utilities by Symisc Systems
#
# tectonics:
#    gcc -o unicox.so -shared -fpic unicox.c libcox.c
#
link io
procedure main()
    lib := "unicox.so"
    unicox := pathload(lib, "unicox")
    unicoxClose := pathload(lib, "unicoxClose")

    # Fetch the libcox supported commands
    result := unicox("CMD_LIST")
    write("\nCMD_LIST\n",result)

    # list the .rst file names from the given directory
    result := unicox("glob *.txt '%s'", "..")
    write("\nglob *.txt from ..\n",result)

    # shut down the command engine
    unicoxClose() | stop("Error shutting down libcox")
end

programs/unicox.icn

The libcox source is an SQLite style amalgamation bundle. Just include libcox.c in a build.

# libcox (cross platform POSIX type commands)
unicox.so: unicox.c
> gcc -o unicox.so -shared -fpic unicox.c libcox.c
> @echo

unicox: unicox.so unicox.icn
> unicon -s unicox.icn -x

The loadable:

/*
 unicox.c, trial for libcox embedding in Unicon

 tectonics:
     gcc -o unicox.so -shared -fpic unicox.c libcox.c
*/
#include <stdio.h>
#include "libcox.h"
#include "icall.h"

static libcox *libcoxHandle;
static libcox_value *libcoxResult;

int
unicox(int argc, descriptor argv[])
{
    const char *libcoxValue;
    int rc;

    /* handle is remembered across calls */
    if (!libcoxHandle) {
        rc = libcox_init(&libcoxHandle);
        if (rc != LIBCOX_OK) {
            Error(500);
        }
    }

    /* Unicon passes a command string (and possibly one argument) */
    ArgString(1);

    if (argc > 1) {
        ArgString(2);
    }

    /* last result left alone, freed before converting a new value */
    if (libcoxResult) {
        libcox_exec_result_destroy(libcoxHandle, libcoxResult);
    }

    /* Evaluate the command, with no, or one argument */
    if (argc > 1) {
        rc = libcox_exec_fmt(libcoxHandle, &libcoxResult,
                             StringVal(argv[1]), StringVal(argv[2]));
    } else {
        rc = libcox_exec(libcoxHandle, &libcoxResult,
                         StringVal(argv[1]), -1);
    }

    if (rc != LIBCOX_OK) {
        Error(107);
    }

    libcoxValue = libcox_value_to_string(libcoxResult, 0);
    RetString((char *)libcoxValue);
}

int
unicoxClose(int argc, descriptor argv[])
{
    if (libcoxHandle) {
        libcox_release(libcoxHandle);
        RetNull();
    } else {
        Fail;
    }
}

programs/unicox.c

The initial trial includes the libcox CMD_LIST and a sample file expansion glob from a different working directory.

prompt$ make -B --no-print-directory unicox | par
gcc -o unicox.so -shared -fpic unicox.c libcox.c

unicon -s unicox.icn -x

CMD_LIST
["glob","list","ls","mmap","cat","CMD_LIST","time","microtime","getdate"
,"gettimeofday","date","strftime","gmdate","localtime","idate","mktime",
"base64_decode","base64_encode","urldecode","urlencode","size_format","s
trrev","strrchr","strripos","strrpos","stripos","strpos","stristr","strs
tr","bin2hex","strtoupper","strtolower","rtrim","ltrim","trim","explode"
,"implode","strncasecmp","strcasecmp","strncmp","strcmp","strlen","html_
decode","html_escape","chunk_split","substr_count","substr_compare","sub
str","base_convert","baseconvert","octdec","bindec","hexdec","decbin","d
ecoct","dechex","round","os","osname","uname","umask","slink","symlink",
"lnk","link","fnmatch","strglob","pathinfo","basename","dirname","touch"
,"file_type","filetype","dt","disk_total_space","df","disk_free_space","
chgrp","chown","chmod","delete","remove","rm","unlink","usleep","sleep",
"chroot","lstat","stat","tmpdir","temp_dir","tmp_dir","fileexists","file
_exists","filemtime","file_mtime","filectime","file_ctime","fileatime","
file_atime","filesize","file_size","isexec","is_exec","is_executable","i
swr","is_wr","is_writable","isrd","is_rd","is_readable","isfile","is_fil
e","islnk","is_lnk","islink","is_link","isdir","is_dir","getgid","getuid
","gid","uid","getusername","username","getpid","pid","random","rand","g
etenv","fullpath","full_path","real_path","realpath","rename","set_env",
"setenv","putenv","env","echo","mkdir","rmdir","getcwd","cwd","pwd","chd
ir","cd"]

glob *.txt from .. ["gpl-3.0.txt","preamble.txt","lgpl-3.0.txt"]

With libcox.c version 1.7, there are over 145 commands available. Set to work across multiple platforms; GNU/Linux and Windows at a minimum.

libcox license obligation

/*
 * Symisc libcox: Cross Platform Utilities & System Calls.
 * Copyright (C) 2014, 2015 Symisc Systems http://libcox.net/
 * Version 1.7
 * For additional information on licensing, redistribution of this file,
 * and for a DISCLAIMER OF ALL WARRANTIES please contact Symisc Systems via:
 *       licensing@symisc.net
 *       contact@symisc.net
 * or visit:
 *      http://libcox.net/
 */
/*
 * Copyright (C) 2014, 2015 Symisc Systems, S.U.A.R.L [M.I.A.G Mrad Chems Eddine <chm@symisc.net>].
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 *
 * THIS SOFTWARE IS PROVIDED BY SYMISC SYSTEMS ``AS IS'' AND ANY EXPRESS
 * OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 * WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
 * NON-INFRINGEMENT, ARE DISCLAIMED.  IN NO EVENT SHALL SYMISC SYSTEMS
 * BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
 * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 */

PH7

PH7 is an embeddable PHP engine from Symisc Systems.

Calling PHP programs from Unicon with PH7.

http://ph7.symisc.net/

A very similar Unicon setup:

#
# uniph7-v1.icn, trial run for PH7 integration
#
# tectonics:
#    gcc -o uniph7-v1.so -shared -fpic uniph7-v1.c ph7.c
#
procedure main()
    ph7 := loadfunc("./uniph7-v1.so", "uniph7")
    phpProg := "<?php _
        echo PHP_EOL.'Welcome, '.get_current_user().PHP_EOL;_
        echo 'System time is: '.date('Y-m-d H:i:s').PHP_EOL;_
        echo 'Running: '.substr(php_uname(),0,54).'...'.PHP_EOL;_
    ?>"
    ph7(phpProg)
end

programs/uniph7-v1.icn

The PH7 source is an SQLite style amalgamation bundle. Just include ph7.c in a build.

# PH7 (Embedded PHP)
uniph7-v1.so: uniph7-v1.c
> gcc -o uniph7-v1.so -shared -fpic uniph7-v1.c ph7.c \
  -Wno-unused -Wno-sign-compare

uniph7-v1: uniph7-v1.so uniph7-v1.icn
> unicon -s uniph7-v1.icn -x

The initial trial is a simple change to the PH7 example, ph7_intro.c.

--- programs/ph7_intro.c
+++ programs/uniph7-v1.c
@@ -29,11 +29,9 @@
  *	and you are running Microsoft Windows 7 localhost 6.1 build 7600 x86
  *
  */
-#define PHP_PROG "<?php "\
-                 "echo 'Welcome guest'.PHP_EOL;"\
-                 "echo 'Current system time is: '.date('Y-m-d H:i:s').PHP_EOL;"\
-                 "echo 'and you are running '.php_uname().PHP_EOL;"\
-                 "?>"
+
+/* PHP_PROG passed from Unicon */
+
 /* Make sure you have the latest release of the PH7 engine
  * from:
  *  http://ph7.symisc.net/downloads.html
@@ -42,6 +40,10 @@
 #include <stdlib.h>
 /* Make sure this header file is available.*/
 #include "ph7.h"
+
+/* Unicon loadfunc */
+#include "icall.h"
+
 /* 
  * Display an error message and exit.
  */
@@ -78,7 +80,7 @@
 /* 
  * Main program: Compile and execute the PHP program defined above.
  */
-int main(void)
+int uniph7(int argc, descriptor argv[])
 {
 	ph7 *pEngine; /* PH7 engine */
 	ph7_vm *pVm;  /* Compiled PHP program */
@@ -92,13 +94,17 @@
 		 */
 		Fatal("Error while allocating a new PH7 engine instance");
 	}
+
+        /* Get PHP program from Unicon */
+        ArgString(1)
+       
 	/* Compile the PHP test program defined above */
 	rc = ph7_compile_v2(
-		pEngine,  /* PH7 engine */
-		PHP_PROG, /* PHP test program */
-		-1        /* Compute input length automatically*/, 
-		&pVm,     /* OUT: Compiled PHP program */
-		0         /* IN: Compile flags */
+		pEngine,            /* PH7 engine */
+		StringVal(argv[1]), /* PHP test program */
+		-1                  /* Compute input length automatically*/, 
+		&pVm,               /* OUT: Compiled PHP program */
+		0                   /* IN: Compile flags */
 		);
 	if( rc != PH7_OK ){
 		if( rc == PH7_COMPILE_ERR ){

A complete listing for clarity:

/*
 * Compile this file together with the ph7 engine source code to generate
 * the executable. For example: 
 *  gcc -W -Wall -O6 -o ph7_test ph7_intro.c ph7.c
*/
/*
 * This simple program is a quick introduction on how to embed and start
 * experimenting with the PH7 engine without having to do a lot of tedious
 * reading and configuration.
 *
 * For an introduction to the PH7 C/C++ interface, please refer to this page
 *        http://ph7.symisc.net/api_intro.html
 * For the full C/C++ API reference guide, please refer to this page
 *        http://ph7.symisc.net/c_api.html
 */
/*
 * The following is the PHP program to execute.
 *   <?php
 *    echo 'Welcome guest'.PHP_EOL;
 *    echo 'Current system time is: '.date('Y-m-d H:i:s').PHP_EOL;
 *    echo 'and you are running '.php_uname();
 *   ?>
 * That is, this simple program when running should display a greeting
 * message, the current system time and the host operating system.
 * A typical output of this program would look like this:
 *
 *	Welcome guest
 *	Current system time is: 2012-09-14 02:08:44
 *	and you are running Microsoft Windows 7 localhost 6.1 build 7600 x86
 *
 */

/* PHP_PROG passed from Unicon */

/* Make sure you have the latest release of the PH7 engine
 * from:
 *  http://ph7.symisc.net/downloads.html
 */
#include <stdio.h>
#include <stdlib.h>
/* Make sure this header file is available.*/
#include "ph7.h"

/* Unicon loadfunc */
#include "icall.h"

/* 
 * Display an error message and exit.
 */
static void Fatal(const char *zMsg)
{
	puts(zMsg);
	/* Shutdown the library */
	ph7_lib_shutdown();
	/* Exit immediately */
	exit(0);
}
/*
 * VM output consumer callback.
 * Each time the virtual machine generates some outputs, the following
 * function gets called by the underlying virtual machine  to consume
 * the generated output.
 * All this function does is redirecting the VM output to STDOUT.
 * This function is registered later via a call to ph7_vm_config()
 * with a configuration verb set to: PH7_VM_CONFIG_OUTPUT.
 */
static int Output_Consumer(const void *pOutput, unsigned int nOutputLen, void *pUserData /* Unused */)
{
	/* 
	 * Note that it's preferable to use the write() system call to display the output
	 * rather than using the libc printf() which everybody now is extremely slow.
	 */
	printf("%.*s", 
		nOutputLen, 
		(const char *)pOutput /* Not null terminated */
		);
	/* All done, VM output was redirected to STDOUT */
	return PH7_OK;
}
/* 
 * Main program: Compile and execute the PHP program defined above.
 */
int uniph7(int argc, descriptor argv[])
{
	ph7 *pEngine; /* PH7 engine */
	ph7_vm *pVm;  /* Compiled PHP program */
	int rc;
	/* Allocate a new PH7 engine instance */
	rc = ph7_init(&pEngine);
	if( rc != PH7_OK ){
		/*
		 * If the supplied memory subsystem is so sick that we are unable
		 * to allocate a tiny chunk of memory, there is no much we can do here.
		 */
		Fatal("Error while allocating a new PH7 engine instance");
	}

        /* Get PHP program from Unicon */
        ArgString(1)
       
	/* Compile the PHP test program defined above */
	rc = ph7_compile_v2(
		pEngine,            /* PH7 engine */
		StringVal(argv[1]), /* PHP test program */
		-1                  /* Compute input length automatically*/, 
		&pVm,               /* OUT: Compiled PHP program */
		0                   /* IN: Compile flags */
		);
	if( rc != PH7_OK ){
		if( rc == PH7_COMPILE_ERR ){
			const char *zErrLog;
			int nLen;
			/* Extract error log */
			ph7_config(pEngine, 
				PH7_CONFIG_ERR_LOG, 
				&zErrLog, 
				&nLen
				);
			if( nLen > 0 ){
				/* zErrLog is null terminated */
				puts(zErrLog);
			}
		}
		/* Exit */
		Fatal("Compile error");
	}
	/*
	 * Now we have our script compiled, it's time to configure our VM.
	 * We will install the VM output consumer callback defined above
	 * so that we can consume the VM output and redirect it to STDOUT.
	 */
	rc = ph7_vm_config(pVm, 
		PH7_VM_CONFIG_OUTPUT, 
		Output_Consumer,    /* Output Consumer callback */
		0                   /* Callback private data */
		);
	if( rc != PH7_OK ){
		Fatal("Error while installing the VM output consumer callback");
	}
	/*
	 * And finally, execute our program. Note that your output (STDOUT in our case)
	 * should display the result.
	 */
	ph7_vm_exec(pVm, 0);
	/* All done, cleanup the mess left behind.
	*/
	ph7_vm_release(pVm);
	ph7_release(pEngine);
	return 0;
}

programs/uniph7-v1.c

And a sample run:

prompt$ make -B --no-print-directory uniph7-v1
gcc -o uniph7-v1.so -shared -fpic uniph7-v1.c ph7.c \
  -Wno-unused -Wno-sign-compare
unicon -s uniph7-v1.icn -x

Welcome, btiffin
System time is: 2017-06-13 06:50:14
Running: Linux 4.4.0-77-generic #98-Ubuntu SMP Wed Apr 26 08:34...

There are some differences between the reference implementation of PHP and PH7, so large frameworks may not work, but small bits of PHP will, and the PH7 includes a foreign function interface to add features if required.

PH7 license obligation

/*
 * Copyright (C) 2011,2012 Symisc Systems. All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 * 3. Redistributions in any form must be accompanied by information on
 *    how to obtain complete source code for the PH7 engine and any
 *    accompanying software that uses the PH7 engine software.
 *    The source code must either be included in the distribution
 *    or be available for no more than the cost of distribution plus
 *    a nominal fee, and must be freely redistributable under reasonable
 *    conditions. For an executable file, complete source code means
 *    the source code for all modules it contains.It does not include
 *    source code for modules or files that typically accompany the major
 *    components of the operating system on which the executable file runs.
 *
 * THIS SOFTWARE IS PROVIDED BY SYMISC SYSTEMS ``AS IS'' AND ANY EXPRESS
 * OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 * WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
 * NON-INFRINGEMENT, ARE DISCLAIMED.  IN NO EVENT SHALL SYMISC SYSTEMS
 * BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
 * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 */

UnQLite

Another amalgam release from Symisc. This is a NoSQL database engine, with Jx9 scripting included (Jx9 is another Symisc software but included in the UnQLite distribution).

Similar build environment, include unqlite.c along with other sources to build a shared object file for use with Unicon loadfunc.

Aside: Being a COBOL programmer, and growing up on Vax/VMS, the term “NoSQL” is a sad state of word smithery. Key-value database would be better. Computers had ISAM and RMS and other indexed record management systems long before SQL became dominant, and the term NoSQL just shows a lack of educational history in the field of computer science. Unstructured Query Language is the new post-modern database paradigm, UnQL (pronounced Uncle) but records and keys is not “NoSQL”. Rant over.

So here is a NoSQL data engine with UnQLite. A fairly unique blend of key-value store and document store.

First step is to see if it’ll work.

#
# uniunql-v1.icn, Embed UnQLite in Unicon
#
# tectonics:
#    gcc -o uniunql-v1.so -shared -fpic uniunql-vi.c unqlite.c
#
procedure main()
    uniunql := loadfunc("./uniunql-v1.so", "uniunql")

    program := "/* Create the collection 'users'  */\n_
        if( !db_exists('users') ){\n_
           /* Try to create it */\n_
          $rc = db_create('users');\n_
          if ( !$rc ){\n_
            /*Handle error*/\n_
            print db_errlog();\n_
        	  return;\n_
          }else{\n_
             print \"Collection 'users' successfuly created\n\";\n_
           }\n_
         }\n_
        /*The following is the records to be stored shortly in our collection*/ \n_
        $zRec = [\n_
        {\n_
          name : 'james',\n_
          age  : 27,\n_
          mail : 'dude@example.com'\n_
        },\n_
        {\n_
          name : 'robert',\n_
          age  : 35,\n_
          mail : 'rob@example.com'\n_
        },\n_
        {\n_
          name : 'monji',\n_
          age  : 47,\n_
          mail : 'monji@example.com'\n_
        },\n_
        {\n_
         name : 'barzini',\n_
         age  : 52,\n_
         mail : 'barz@mobster.com'\n_
        }\n_
        ];\n_
        /*Store our records*/\n_
        $rc = db_store('users',$zRec);\n_
        if( !$rc ){\n_
         /*Handle error*/\n_
         print db_errlog();\n_
         return;\n_
        }\n_
        /*Create our filter callback*/\n_
        $zCallback = function($rec){\n_
           /*Allow only users >= 30 years old.*/\n_
           if( $rec.age < 30 ){\n_
               /* Discard this record*/\n_
               return FALSE;\n_
           }\n_
           /* Record correspond to our criteria*/\n_
           return TRUE;\n_
        }; /* Dont forget the semi-colon here*/\n_
        /* Retrieve collection records and apply our filter callback*/\n_
        $data = db_fetch_all('users',$zCallback);\n_
        print \"Filtered records\n\";\n_
        /*Iterate over the extracted elements*/\n_
        foreach($data as $value){ /*JSON array holding the filtered records*/\n_
         print $value..JX9_EOL;\n_
        }"

    result := uniunql(":mem:", program)
    write("Unicon result: ", result)
end

programs/uniunql-v1.icn

The make rules

# UnQLite (embed a key value and document store engine in Unicon)
uniunql-v1.so: uniunql-v1.c
> gcc -o uniunql-v1.so -shared -fpic uniunql-v1.c unqlite.c \
  -Wno-unused

uniunql-v1: uniunql-v1.so uniunql-v1.icn
> unicon -s uniunql-v1.icn -x

A slightly modified unqlite_doc_intro.c for use with a loadfunc trial.

--- programs/unqlite_doc_intro.c
+++ programs/uniunql-v1.c
@@ -45,6 +45,7 @@
 #include <stdlib.h> /* exit() */
 /* Make sure this header file is available.*/
 #include "unqlite.h"
+#include "icall.h"
 /*
  * Banner.
  */
@@ -81,148 +82,30 @@
 }
 /* Forward declaration: VM output consumer callback */
 static int VmOutputConsumer(const void *pOutput,unsigned int nOutLen,void *pUserData /* Unused */);
-/*
- * The following is the Jx9 Program to be executed later by the UnQLite VM:
- * This program store some JSON objects (a collections of dummy users) into
- * the collection 'users' stored in our database.
- * // Create the collection 'users'
- * if( !db_exists('users') ){
- *   // Try to create it 
- *  $rc = db_create('users');
- *  if ( !$rc ){
- *    //Handle error
- *     print db_errlog();
- *	  return;
- *  }
- * }
- * //The following is the records to be stored shortly in our collection
- * $zRec = [
- * {
- *  name : 'james',
- *  age  : 27,
- *  mail : 'dude@example.com'
- * },
- * {
- *  name : 'robert',
- *  age  : 35,
- *  mail : 'rob@example.com'
- * },
- *
- * {
- *  name : 'monji',
- *  age  : 47,
- *  mail : 'monji@example.com'
- * },
- * {
- * name : 'barzini',
- * age  : 52,
- * mail : 'barz@mobster.com'
- * }
- * ];
- *
- * //Store our records
- * $rc = db_store('users',$zRec);
- * if( !$rc ){
- *  //Handle error
- *  print db_errlog();
- *  return;
- * }
- * //Create our filter callback
- * $zCallback = function($rec){
- *   //Allow only users >= 30 years old.
- *   if( $rec.age < 30 ){
- *       // Discard this record
- *       return FALSE;
- *   }
- *   //Record correspond to our criteria
- *   return TRUE;
- * }; //Don't forget the semi-colon here
- *
- * //Retrieve collection records and apply our filter callback
- * $data = db_fetch_all('users',$zCallback);
- * 
- * //Iterate over the extracted elements
- * foreach($data as $value){ //JSON array holding the filtered records
- * print $value..JX9_EOL; 
- * }
- */
-#define JX9_PROG \
-"/* Create the collection 'users'  */"\
- "if( !db_exists('users') ){"\
- "   /* Try to create it */"\
- "  $rc = db_create('users');"\
- "  if ( !$rc ){"\
- "    /*Handle error*/"\
- "    print db_errlog();"\
- "	  return;"\
- "  }else{"\
- "     print \"Collection 'users' successfuly created\\n\";"\
- "   }"\
- " }"\
- "/*The following is the records to be stored shortly in our collection*/ "\
- "$zRec = ["\
- "{"\
- "  name : 'james',"\
- "  age  : 27,"\
- "  mail : 'dude@example.com'"\
- "},"\
- "{"\
- "  name : 'robert',"\
- "  age  : 35,"\
- "  mail : 'rob@example.com'"\
- "},"\
- "{"\
- "  name : 'monji',"\
- "  age  : 47,"\
- "  mail : 'monji@example.com'"\
- "},"\
- "{"\
- " name : 'barzini',"\
- " age  : 52,"\
- " mail : 'barz@mobster.com'"\
- "}"\
- "];"\
- "/*Store our records*/"\
- "$rc = db_store('users',$zRec);"\
- "if( !$rc ){"\
- " /*Handle error*/"\
- " print db_errlog();"\
- " return;"\
- "}"\
- "/*Create our filter callback*/"\
- "$zCallback = function($rec){"\
- "   /*Allow only users >= 30 years old.*/"\
- "   if( $rec.age < 30 ){"\
- "       /* Discard this record*/"\
- "       return FALSE;"\
- "   }"\
- "   /* Record correspond to our criteria*/"\
- "   return TRUE;"\
- "}; /* Don't forget the semi-colon here*/"\
- "/* Retrieve collection records and apply our filter callback*/"\
- "$data = db_fetch_all('users',$zCallback);"\
- "print \"Filtered records\\n\";"\
- "/*Iterate over the extracted elements*/"\
- "foreach($data as $value){ /*JSON array holding the filtered records*/"\
- " print $value..JX9_EOL;"\
- "}"
 
-int main(int argc,char *argv[])
+int uniunql(int argc, descriptor argv[])
 {
 	unqlite *pDb;       /* Database handle */
 	unqlite_vm *pVm;    /* UnQLite VM resulting from successful compilation of the target Jx9 script */
 	int rc;
 
+        /* pass in the name of the data store, :mem: for in-memory */
+        ArgString(1)
+
+        /* Jx9 script as string */
+        ArgString(2)
+
 	puts(zBanner);
+	fflush(stdout);
 
 	/* Open our database */
-	rc = unqlite_open(&pDb,argc > 1 ? argv[1] /* On-disk DB */ : ":mem:" /* In-mem DB */,UNQLITE_OPEN_CREATE);
+	rc = unqlite_open(&pDb,argc > 1 ? StringVal(argv[1]) /* On-disk DB */ : ":mem:" /* In-mem DB */,UNQLITE_OPEN_CREATE);
 	if( rc != UNQLITE_OK ){
 		Fatal(0,"Out of memory");
 	}
 	
 	/* Compile our Jx9 script defined above */
-	rc = unqlite_compile(pDb,JX9_PROG,sizeof(JX9_PROG)-1,&pVm);
+	rc = unqlite_compile(pDb, StringVal(argv[2]), strlen(StringVal(argv[2])),&pVm);
 	if( rc != UNQLITE_OK ){
 		/* Compile error, extract the compiler error log */
 		const char *zBuf;
@@ -232,19 +115,19 @@
 		if( iLen > 0 ){
 			puts(zBuf);
 		}
-		Fatal(0,"Jx9 compile error");
+		Fatal(0, "Jx9 compile error");
 	}
 
 	/* Install a VM output consumer callback */
 	rc = unqlite_vm_config(pVm,UNQLITE_VM_CONFIG_OUTPUT,VmOutputConsumer,0);
 	if( rc != UNQLITE_OK ){
-		Fatal(pDb,0);
+		Fatal(pDb, 0);
 	}
 	
 	/* Execute our script */
 	rc = unqlite_vm_exec(pVm);
 	if( rc != UNQLITE_OK ){
-		Fatal(pDb,0);
+		Fatal(pDb, 0);
 	}
 
 	/* Release our VM */
@@ -252,7 +135,7 @@
 	
 	/* Auto-commit the transaction and close our database */
 	unqlite_close(pDb);
-	return 0;
+	RetInteger(rc);
 }
 
 #ifdef __WINNT__
@@ -298,4 +181,4 @@
 	
 	/* All done, data was redirected to STDOUT */
 	return UNQLITE_OK;
-}+}

A complete listing, for clarity

/*
 * Compile this file together with the UnQLite database engine source code
 * to generate the executable. For example: 
 *  gcc -W -Wall -O6 unqlite_doc_intro.c unqlite.c -o unqlite_doc
*/
/*
 * This simple program is a quick introduction on how to embed and start
 * experimenting with UnQLite without having to do a lot of tedious
 * reading and configuration.
 *
 * Introduction to the UnQLite Document-Store Interfaces:
 *
 * The Document store to UnQLite which is used to store JSON docs (i.e. Objects, Arrays, Strings, etc.)
 * in the database is powered by the Jx9 programming language.
 *
 * Jx9 is an embeddable scripting language also called extension language designed
 * to support general procedural programming with data description facilities.
 * Jx9 is a Turing-Complete, dynamically typed programming language based on JSON
 * and implemented as a library in the UnQLite core.
 *
 * Jx9 is built with a tons of features and has a clean and familiar syntax similar
 * to C and Javascript.
 * Being an extension language, Jx9 has no notion of a main program, it only works
 * embedded in a host application.
 * The host program (UnQLite in our case) can write and read Jx9 variables and can
 * register C/C++ functions to be called by Jx9 code. 
 *
 * For an introduction to the UnQLite C/C++ interface, please refer to:
 *        http://unqlite.org/api_intro.html
 * For an introduction to Jx9, please refer to:
 *        http://unqlite.org/jx9.html
 * For the full C/C++ API reference guide, please refer to:
 *        http://unqlite.org/c_api.html
 * UnQLite in 5 Minutes or Less:
 *        http://unqlite.org/intro.html
 * The Architecture of the UnQLite Database Engine:
 *        http://unqlite.org/arch.html
 */
/* $SymiscID: unqlite_doc_intro.c v1.0 FreeBSD 2013-05-17 15:56 stable <chm@symisc.net> $ */
/*
 * Make sure you have the latest release of UnQLite from:
 *  http://unqlite.org/downloads.html
 */
#include <stdio.h>  /* puts() */
#include <stdlib.h> /* exit() */
/* Make sure this header file is available.*/
#include "unqlite.h"
#include "icall.h"
/*
 * Banner.
 */
static const char zBanner[] = {
	"============================================================\n"
	"UnQLite Document-Store (Via Jx9) Intro                      \n"
	"                                         http://unqlite.org/\n"
	"============================================================\n"
};
/*
 * Extract the database error log and exit.
 */
static void Fatal(unqlite *pDb,const char *zMsg)
{
	if( pDb ){
		const char *zErr;
		int iLen = 0; /* Stupid cc warning */

		/* Extract the database error log */
		unqlite_config(pDb,UNQLITE_CONFIG_ERR_LOG,&zErr,&iLen);
		if( iLen > 0 ){
			/* Output the DB error log */
			puts(zErr); /* Always null termniated */
		}
	}else{
		if( zMsg ){
			puts(zMsg);
		}
	}
	/* Manually shutdown the library */
	unqlite_lib_shutdown();
	/* Exit immediately */
	exit(0);
}
/* Forward declaration: VM output consumer callback */
static int VmOutputConsumer(const void *pOutput,unsigned int nOutLen,void *pUserData /* Unused */);

int uniunql(int argc, descriptor argv[])
{
	unqlite *pDb;       /* Database handle */
	unqlite_vm *pVm;    /* UnQLite VM resulting from successful compilation of the target Jx9 script */
	int rc;

        /* pass in the name of the data store, :mem: for in-memory */
        ArgString(1)

        /* Jx9 script as string */
        ArgString(2)

	puts(zBanner);
	fflush(stdout);

	/* Open our database */
	rc = unqlite_open(&pDb,argc > 1 ? StringVal(argv[1]) /* On-disk DB */ : ":mem:" /* In-mem DB */,UNQLITE_OPEN_CREATE);
	if( rc != UNQLITE_OK ){
		Fatal(0,"Out of memory");
	}
	
	/* Compile our Jx9 script defined above */
	rc = unqlite_compile(pDb, StringVal(argv[2]), strlen(StringVal(argv[2])),&pVm);
	if( rc != UNQLITE_OK ){
		/* Compile error, extract the compiler error log */
		const char *zBuf;
		int iLen;
		/* Extract error log */
		unqlite_config(pDb,UNQLITE_CONFIG_JX9_ERR_LOG,&zBuf,&iLen);
		if( iLen > 0 ){
			puts(zBuf);
		}
		Fatal(0, "Jx9 compile error");
	}

	/* Install a VM output consumer callback */
	rc = unqlite_vm_config(pVm,UNQLITE_VM_CONFIG_OUTPUT,VmOutputConsumer,0);
	if( rc != UNQLITE_OK ){
		Fatal(pDb, 0);
	}
	
	/* Execute our script */
	rc = unqlite_vm_exec(pVm);
	if( rc != UNQLITE_OK ){
		Fatal(pDb, 0);
	}

	/* Release our VM */
	unqlite_vm_release(pVm);
	
	/* Auto-commit the transaction and close our database */
	unqlite_close(pDb);
	RetInteger(rc);
}

#ifdef __WINNT__
#include <Windows.h>
#else
/* Assume UNIX */
#include <unistd.h>
#endif
/*
 * The following define is used by the UNIX build process and have
 * no particular meaning on windows.
 */
#ifndef STDOUT_FILENO
#define STDOUT_FILENO	1
#endif
/*
 * VM output consumer callback.
 * Each time the UnQLite VM generates some outputs, the following
 * function gets called by the underlying virtual machine to consume
 * the generated output.
 *
 * All this function does is redirecting the VM output to STDOUT.
 * This function is registered via a call to [unqlite_vm_config()]
 * with a configuration verb set to: UNQLITE_VM_CONFIG_OUTPUT.
 */
static int VmOutputConsumer(const void *pOutput,unsigned int nOutLen,void *pUserData /* Unused */)
{
#ifdef __WINNT__
	BOOL rc;
	rc = WriteFile(GetStdHandle(STD_OUTPUT_HANDLE),pOutput,(DWORD)nOutLen,0,0);
	if( !rc ){
		/* Abort processing */
		return UNQLITE_ABORT;
	}
#else
	ssize_t nWr;
	nWr = write(STDOUT_FILENO,pOutput,nOutLen);
	if( nWr < 0 ){
		/* Abort processing */
		return UNQLITE_ABORT;
	}
#endif /* __WINT__ */
	
	/* All done, data was redirected to STDOUT */
	return UNQLITE_OK;
}

And a sample run:

prompt$ make -B --no-print-directory uniunql-v1
gcc -o uniunql-v1.so -shared -fpic uniunql-v1.c unqlite.c \
  -Wno-unused
unicon -s uniunql-v1.icn -x
============================================================
UnQLite Document-Store (Via Jx9) Intro                      
                                         http://unqlite.org/
============================================================

Collection 'users' successfuly created
Filtered records
{"name":"robert","age":35,"mail":"rob@example.com","__id":1}
{"name":"monji","age":47,"mail":"monji@example.com","__id":2}
{"name":"barzini","age":52,"mail":"barz@mobster.com","__id":3}
Unicon result: 0

A JSON document stored and then retrieved, filtered by age > 30, from :mem: in-memory storage.

A different (valid) filename passed from Unicon in uniunql() would create a disk persistent document store.

Next step will be a more capable Unicon binding.

Performance of UnQLite is impressive.

https://unqlite.org/

UnQLite license obligation

/*
 * Copyright (C) 2012, 2013 Symisc Systems, S.U.A.R.L [M.I.A.G Mrad Chems Eddine <chm@symisc.net>].
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 *
 * THIS SOFTWARE IS PROVIDED BY SYMISC SYSTEMS ``AS IS'' AND ANY EXPRESS
 * OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 * WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
 * NON-INFRINGEMENT, ARE DISCLAIMED.  IN NO EVENT SHALL SYMISC SYSTEMS
 * BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
 * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 */

There is a visible conflict with this license and the Jx9 engine. Separated, Jx9 ships with more capabilities and a 3 clause license, comparable to the vedis and PH7 licenses. Symisc has openly stated that the license intent with UnQLite is 2 clause, there is no obligation to produce source for all associated usage or work out a dual licensing contract when using the version of Jx9 that ships with UnQLite in closed source systems.

Not that Unicon is against strong copyleft freedoms, but the conflict is visible when inspecting the unqlite.c file when looking at the included jx9.h source file. Although it may be wise to treat UnQLite as a three clause system if you need to satisfy company attorneys, this forum post clarifies the author’s intent

https://unqlite.org/forum/thread.php?file=can-i-use-the-jx9-with-unqlite-for-closed-source-project

...

So, even UnQLite uses a portion of the Jx9 core to implement it's document
storage engine, everything is covered by the UnQLite BSD license as far
you do not embed the entire Jx9 library (I mean here the independent
engine available here http://jx9.smisc.net) in your commercial software.

Or, just ship all the sources when using UnQLite and avoid any and all potential issues.


REXX

Restructured Extended Executor as Open Object Rexx, embedded in Unicon via loadfunc. Rexx was originally designed and implemented from 1979 to 1982 by Mike Cowlishaw. Rexx is a close relative to Icon, age wise. A version of Object Rexx was released by IBM as free software in 2004. That spawned Open Object Rexx, which is used here for the demonstration.

Regina Rexx would also work for classic Rexx, and may make more sense for loadfunc, being a solid C build environment, but ooRexx has some pretty nifty features and is keeping the C heritage available while the team builds out the new C++ API.

#
# unirexx.icn, Invoke ooRexx from Unicon, with C and C++ interfaces
#
# tectonics:
#     gcc -o unirexx.so -shared -fPIC unirexx.c -lrexx -lrexxapi
#     g++ -o oorexx.so -shared -fPIC oorexx.c -lrexx -lrexxapi
#
procedure main()
    unirexx := loadfunc("./unirexx.so", "unirexx")
    result := unirexx("hello.rexx")
    write("Unicon RexxStart from file = " || result)

    write()
    result := unirexx("[PARSE SOURCE data]",
                      "say \"Hello, from Rexx in Unicon\";" ||
                      " PARSE SOURCE a; return a")
    write("Unicon RexxStart from string = " || result)

    write("\n--------\nC++ API")
    oorexx := loadfunc("./oorexx.so", "oorexx")
    result := oorexx("hello.rexx")
    write("Unicon ooRexx C++ API rc = " || result)
end

programs/unirexx.icn

The main ooRexx API is now a C++ implementation, but there is a classic interface based on C. Both are tested here.

The classic API.

/* Unicon integration with Open Object Rexx, classic C API */
/* tectonics: gcc -o unirexx.so -shared -fPIC unirexx.c */
#include <stdio.h>
#include <rexx.h>
#include "icall.h"
int
unirexx(int argc, descriptor argv[])
{
    int rc;

    /* RexxStart fields */
    size_t ArgCount = 0;
    PCONSTRXSTRING ArgList = NULL;
    const char *ProgramName;
    PRXSTRING PassStore;
    RXSTRING Instore[2];
    const char *EnvName = NULL;
    int CallType = RXCOMMAND;
    PRXSYSEXIT Exits = NULL;
    short ReturnCode;

    RXSTRING Result;
    char returnBuffer[256];

    /* Need a Rexx ProgramName and/or Instore evaluation string */
    fprintf(stderr, "argc: %d\n", argc);
    fflush(stderr);

    if (argc < 1) Error(105);  /* Need a filename or PARSE SOURCE */

    ArgString(1);

    /* Second string is optional, will be text to interpret */
    if (argc > 1) ArgString(2);

    /* Instore is two Rexx string descriptors */
    /*   one for the text and second for precompiled image */
    /*   no precompiled image is used here */
    RXNULLSTRING(Instore[0]);
    RXNULLSTRING(Instore[1]);
    if (argc > 1) {
        MAKERXSTRING(Instore[0], StringVal(argv[2]), StringLen(argv[2]));
        PassStore = &Instore[0];
    } else {
        /* If only the file name is passed, Instore is NULL */
        PassStore = NULL;
    }

    /* set up initial Result string space, Rexx may allocate its own */
    MAKERXSTRING(Result, returnBuffer, sizeof(returnBuffer));

    rc = RexxStart(ArgCount, ArgList, StringVal(argv[1]), PassStore,
                   EnvName, CallType, Exits, &ReturnCode, &Result);

    fprintf(stderr, "RexxStart rc: %d\nRexx ReturnCode: %d, Result: %s\n",
            rc, ReturnCode, RXSTRPTR(Result));
    fflush(stderr);

    /* A RetStringN, but Rexx may need to free the space */
    argv[0].dword = Result.strlength;
    argv[0].vword.sptr = alcstr(RXSTRPTR(Result), RXSTRLEN(Result));

    /* Rexx may have decided to allocate a return result space */
    if (RXSTRPTR(Result) != returnBuffer) {
        RexxFreeMemory(RXSTRPTR(Result));
    }

    Return;
}

programs/unirexx.c

The C++ API, with a slightly simpler Unicon interface. This is also testing whether Unicon loadfunc can manage C++ (which it does seem to, at least for the initial trials).

/* Unicon integration with Open Object Rexx, C++ API sample */
/* tectonics: g++ -o oorexx.so -shared -fPIC oorexx.cpp -lrexx -lrexxapi */

#include <stdio.h>
#include <oorexxapi.h>

bool checkForCondition(RexxThreadContext *c, bool clear);

extern "C" {
#include "icall.h"

int
oorexx(int argc, descriptor argv[])
{
    RexxInstance *interpreter;
    RexxThreadContext *threadContext;
    RexxOption *options = NULL;
    int rc;

    /* Create a Rexx Interpreter */
    rc = RexxCreateInterpreter(&interpreter, &threadContext, options);
    fprintf(stderr, "rc = %d\n", rc);
    fflush(stderr);

    if (rc == 0) {
        fprintf(stderr, "Failed to create Rexx interpreter\n");
        exit(1);
    }

    /* Expect program name from Unicon */
    ArgString(1);

    /* Call a program */
    RexxArrayObject args = NULL;
    RexxObjectPtr result = threadContext->CallProgram(StringVal(argv[1]),
                                                      args);

    /* See if any conditions were raised */
    if (threadContext->CheckCondition()) {
        checkForCondition(threadContext, true);
    } else {
        if (result != NULLOBJECT) {
            fprintf(stderr, "\nProgram result = %s\n\n",
                   threadContext->ObjectToStringValue(result));
            fflush(stderr);
        }
    }

    /* this test just returns an integer code */
    interpreter->Terminate();
    RetInteger(rc);
}
} /* end extern C */

/* Support routines */
inline wholenumber_t conditionSubCode(RexxCondition *condition)
{
    return (condition->code - (condition->rc * 1000));
}

void standardConditionMsg(RexxThreadContext *c,
                          RexxDirectoryObject condObj,
                          RexxCondition *condition)
{
    RexxObjectPtr list = c->SendMessage0(condObj, "TRACEBACK");
    if ( list != NULLOBJECT )
    {
        RexxArrayObject a = (RexxArrayObject)c->SendMessage0(list,
                                                             "ALLITEMS");
        if ( a != NULLOBJECT )
        {
            size_t count = c->ArrayItems(a);
            for ( size_t i = 1; i <= count; i++ )
            {
                RexxObjectPtr o = c->ArrayAt(a, i);
                if ( o != NULLOBJECT )
                {
                    fprintf(stderr, "%s\n", c->ObjectToStringValue(o));
                    fflush(stderr);
                }
            }
        }
    }
    fprintf(stderr, "Error %d running %s line %ld: %s\n", (int)condition->rc,
           c->CString(condition->program), condition->position,
           c->CString(condition->errortext));

    fprintf(stderr, "Error %d.%03d:  %s\n", (int)condition->rc,
           (int)conditionSubCode(condition),
           c->CString(condition->message));
    fflush(stderr);
}

bool checkForCondition(RexxThreadContext *c, bool clear)
{
    if ( c->CheckCondition() )
    {
        RexxCondition condition;
        RexxDirectoryObject condObj = c->GetConditionInfo();

        if ( condObj != NULLOBJECT )
        {
            c->DecodeConditionInfo(condObj, &condition);
            standardConditionMsg(c, condObj, &condition);

            if ( clear )
            {
                c->ClearCondition();
            }
            return true;
        }
    }
    return false;
}

programs/oorexx.cpp

The build rules are not complicated.

# ooRexx integration (classic RexxStart interface)
unirexx.so: unirexx.c
> gcc -o unirexx.so -shared -fPIC unirexx.c -lrexx -lrexxapi

oorexx.so: oorexx.cpp
> g++ -o oorexx.so -shared -fPIC oorexx.cpp -lrexx -lrexxapi

unirexx: unirexx.icn unirexx.so oorexx.so
> unicon -s unirexx.icn -x

And the sample run. A single Unicon program tests both API implementation style.

prompt$ make -B unirexx
make[1]: Entering directory '/home/btiffin/wip/writing/unicon/programs'
gcc -o unirexx.so -shared -fPIC unirexx.c -lrexx -lrexxapi
g++ -o oorexx.so -shared -fPIC oorexx.cpp -lrexx -lrexxapi
unicon -s unirexx.icn -x
argc: 1
Hello, world
RexxStart rc: 0
Rexx ReturnCode: 0, Result: hello.rexx return value (string)
Unicon RexxStart from file = hello.rexx return value (string)

argc: 2
Hello, from Rexx in Unicon
RexxStart rc: 0
Rexx ReturnCode: 0, Result: LINUX COMMAND [PARSE SOURCE data]
Unicon RexxStart from string = LINUX COMMAND [PARSE SOURCE data]

--------
C++ API
rc = 1002
Hello, world

Program result = hello.rexx return value (string)

Unicon ooRexx C++ API rc = 1002
make[1]: Leaving directory '/home/btiffin/wip/writing/unicon/programs'

Open Object Rexx is available on SourceForge at

https://sourceforge.net/projects/oorexx/

This is 4.2, ooRexx has started in on 5.0 beta releases.


Internationalization and Localization

i18n/L10n

The GNU project provides very extensive localization tools. gettext being one of the main C functions provided to allow for runtime human language translations based on Locale.

/*
 unicon-i18n.c, call gettext for translations
 tectonics:
     gcc -o unicon-i18n.so -shared -fpic unicon-i18n.c
*/

#include <libintl.h>
#include <locale.h>
#include "icall.h"

/*
 translate the first string argument from Unicon
*/
int
translate(int argc, descriptor *argv)
{
    char *trans;

    /* Need a string argument */
    if (argc < 1) Error(500);
    ArgString(1);

    /* attempt translation */
    trans = gettext(StringVal(argv[1]));

    /* return translation, or original */
    if (trans) RetString(trans);
    RetString(StringVal(argv[1]));
}

/*
 set up for translations
*/
int
initlocale(int argc, descriptor *argv)
{
    /* Need a domain and a locale root directory */
    if (argc < 2) Error(500);
    ArgString(1);
    ArgString(2);

    /* set up according to environment variables */
    setlocale(LC_ALL, "");
    bindtextdomain(StringVal(argv[1]), StringVal(argv[2]));
    textdomain(StringVal(argv[1]));

    /* return nothing */
    RetNull();
}

programs/unicon-i18n.c

#
# unicon-i18n.icn, demonstrate GNU gettext locale translation
#
# tectonics: gcc -o unicon-i18n.so -shared -fpic unicon-i18n.c
#
link printf
procedure main()
    write("Test error message about invalid width in environment")
    initlocale("coreutils", "/usr/share")
    write(printf(_("ignoring invalid width in environment _
                    variable COLUMNS: %s"), -4))

    write("\nTest message about write error")
    write(_("write error"))

    write("\nTest message about specifying fields")
    write(_("you must specify a list of bytes, characters, or fields"))

    write("\nTest messages about invalid pattern and regex")
    write(printf(_("%s: invalid pattern"), &progname || ":" || &line))
    write(printf(_("%s: invalid regular expression: %s"),
        &progname || ":" || &line, "["))
end

#
# i18n/L10n setup
#
procedure initlocale(domain, localedir)
    &error +:= 1
    initlocale := loadfunc("./unicon-i18n.so", "initlocale") | nolocale
    &error -:= 1
    return initlocale(domain, localedir)
end
procedure nolocale(domain, localedir)
    return &null
end

#
# i18n/L10n
#
procedure _(text:string)
    &error +:= 1
    _ := loadfunc("./unicon-i18n.so", "translate") | _none
    &error -:= 1
    return _(text)
end
procedure _none(text:string)
    return text
end

programs/unicon-i18n.icn

With a sample run (using messages from GNU coretils and Spanish translations)

prompt$ gcc -o unicon-i18n.so -shared -fpic unicon-i18n.c

Using local default locale, English

prompt$ unicon -s unicon-i18n.icn -x
Test error message about invalid width in environment
ignoring invalid width in environment variable COLUMNS: -4

Test message about write error
write error

Test message about specifying fields
you must specify a list of bytes, characters, or fields

Test messages about invalid pattern and regex
unicon-i18n:26: invalid pattern
unicon-i18n:28: invalid regular expression: [

Using a Spanish language locale setting

prompt$ LC_ALL="es_ES.UTF-8" LANG="spanish" LANGUAGE="spanish" ./unicon-i18n
Test error message about invalid width in environment
se descarta el ancho inválido de la variable de entorno COLUMNS: -4

Test message about write error
error de escritura

Test message about specifying fields
se debe indicar una lista de bytes, caracteres o campos

Test messages about invalid pattern and regex
./unicon-i18n:26: plantilla inválida
./unicon-i18n:28: la expresión regular no es válida: [

libsoldout markdown

A loadable function to process Markdown into HTML. libsoldout also ships with example renderers for LaTeX and man page outputs. Simple Markdown, and extended Discount and soldout features included.

/*
 libsoldout markdown processor from Unicon
*/
#include <stdio.h>
#include <soldout/markdown.h>
#include <soldout/renderers.h>

#include "icall.h"

int
soldout(int argc, descriptor argv[])
{
    struct buf *ib, *ob;
    descriptor d;

    /* Need a string of markdown */
    if (argc < 1) Error(103);
    ArgString(1);

    /* set up input and output buffers */    
    ib = bufnew(strlen(StringVal(argv[1])));
    ob = bufnew(1024);
    bufputs(ib, StringVal(argv[1]));

    markdown(ob, ib, &nat_html);
    Protect(StringAddr(d) = alcstr(ob->data, ob->size), Error(306));
    argv->dword = (int)ob->size;
    argv->vword.sptr = StringAddr(d);
    //RetStringN(ob->data, (int)ob->size);

    bufrelease(ib);
    bufrelease(ob);
    return 0;
}

programs/soldout.icn

#
# soldout.icn, a loadable Markdown to HTML demonstration
#
# tectonics:
#     gcc -o soldout.so -shared -fpic soldout.c -lsoldout
#
link base64

# any arguments will trigger firefox with the HTML output
procedure main(argv)
    markdown := "_
        Unicon and libsoldout\n_
        =====================\n_
        \n_
        ## Header 2\n_
        ### Header 3\n_
        - list item\n\n_
        a link: <http://example.com>\n\n_
        `some code`\n\n_
        and soldout extensions: ++insert++ --delete--"
    write(markdown)

    # load up the soldout library function
    soldout := loadfunc("./soldout.so", "soldout")

    # convert the Markdown and show the HTML
    markup := soldout(markdown)
    write("\n---HTML markup follows---\n")
    write(markup)

    # base64 encode the result and pass through a data url for browsing
    if \argv[1] then system("firefox \"data:text/html;base64, " || 
                            base64encode(markup) || "\" &")
end

programs/soldout.icn

And a sample run:

prompt$ unicon -s soldout.icn -x
Unicon and libsoldout
=====================

## Header 2
### Header 3
- list item

a link: <http://example.com>

`some code`

and soldout extensions: ++insert++ --delete--

---HTML markup follows---

<h1>Unicon and libsoldout</h1>

<h2>Header 2</h2>

<h3>Header 3</h3>

<ul>
<li>list item</li>
</ul>

<p>a link: <a href="http://example.com">http://example.com</a></p>

<p><code>some code</code></p>

<p>and soldout extensions: <ins>insert</ins> <del>delete</del></p>
_images/soldout-firefox.png

ie modified for readline

ie, the Icon Evaluator, part of the IPL and built along with Unicon, is a handy utility for trying out Unicon expressions in an interactive shell. Nicer when the commands can be recalled. This example integrates GNU readline into ie.

Note

You could also use rlwrap ie to get the same effect.

/*
 unireadline.c, add readline powers to Unicon
 tectonics: gcc -o unireadline.so -shared -fpic unireadline.c

 Unicon usage: readline := loadfunc("./unireadline", "unirl")

 Dedicated to the public domain

 Date: September 2016
 Modified: 2016-09-07/04:53-0400
*/

#include <stdio.h>
#include <stdlib.h>
#include <readline/readline.h>
#include <readline/history.h>
#include "icall.h"

int
unirl(int argc, descriptor *argv)
{
    static char *line;

    /* need the string prompt */
    if (argc < 1) Error(500);
    ArgString(1);

    /* if line already allocated, free it */
    if (line) {
        free(line);
        line = (char *)NULL;
    }

    /* call readline with prompt */
    line = readline(StringVal(argv[1]));

    /* fail when no line read (EOF for instance) or save and return */
    if (!line) Fail;
    if (*line) add_history(line);
    RetString(line);
}

programs/unireadline.c

The changes to ie are minor. In the sources from uni/prog/ie.icn, change

writes(if *line = 0 then "][ " else "... ")
inline := (read()|stop())

to

inline := (readline(if *line = 0 then "uni> " else "... ")|stop())

and add

procedure reader(prompt)
    writes(prompt)
    return read()
end

procedure readline(prompt)
    &error +:= 1
    readline := loadfunc("./unireadline.so", "unirl") | reader
    &error -:= 1
    return readline(prompt)
end

Then recompile ie.

prompt$ gcc -o unireadline.so -shared -fpic unireadline -lreadline
prompt$ unicon ie.icn
prompt$ cp ie unireadline.so [INSTALL-DIR]/bin/

After that, when you run ie, you will have readline command recall available. Assuming readline is installed. If readline is not installed, you will get the old interface of read. To properly compile unireadline.c, you will need the GNU readline development headers installed on your system.


SNOBOL4

A short program to run SNOBOL4 programs with a pipe, and display any OUTPUT.

Some of the test programs that ship with SNOBOL4 are included, to highlight how complete the distribution is:

https://sourceforge.net/projects/snobol4/

Run SNOBOL files passed as arguments. This is a very lightweight program, results are simply written to &output. Much more could be done with the snobol4 OUTPUT = data.

# 
# snobol.icn, run snobol4 programs
#
# Requires snobol4
#
$define VERSION 0.1

link options

procedure main(argv)
    opts := options(argv, "-h! -v! -source!", optError)
    if \opts["h"] then return showHelp()
    if \opts["v"] then return showVersion()
    if \opts["source"] then return showSource()

    # run the rest of the arguments as snobol4 files
    every arg := !argv do snobol(arg)
end

#
# Run a snobol4 program, trim formfeeds
#
procedure snobol(filename)
    local sf
    sf := open("snobol4 " || filename, "p") | stop("no snobol4")
    while write(trim(read(sf), '\f', 0))
end

#
# show help, version and source info
#
procedure showVersion()
    write(&errout, &progname, " ", VERSION, " ", __DATE__)
end

procedure showHelp()
    showVersion()
    write(&errout, "Usage: snobol [opts] files...")
    write(&errout, "\t-h\tshow this help")
    write(&errout, "\t-v\tshow version")
    write(&errout, "\t-source\tlist source code")
    write(&errout)
    write(&errout, "all other arguments are run as SNOBOL4 sources")
end

procedure showSource()
    local f
    f := open(&file, "r") | stop("Source file ", &file, " unavailable")
    every write(!f)
    close(f)
end

#
# options error
#
procedure optError(s)
    write(&errout, s)
    stop("Try ", &progname, " -h for more information")
end

programs/snobol.icn

And a sample run, with spitbol based diagnostics and a hello:

prompt$ unicon -s snobol.icn -x hello.sno diag[12].sno
hello world
************************************************
**** s n o b o l      d i a g n o s t i c s ****
****          p h a s e    o n e            ****
************************************************
****  any trace output indicates an error   ****
************************************************
************************************************
**** n o     e r r o r s    d e t e c t e d ****
**** e n d    o f     d i a g n o s t i c s ****
************************************************
Dump of variables at termination

Natural variables

A = ARRAY('3')
AA = 'a'
AAA = ARRAY('10')
ABORT = PATTERN
AMA = ARRAY('2,2,2,2')
ARB = PATTERN
ATA = TABLE(2,10)
B = NODE
BAL = PATTERN
BB = 'b'
C = CLUNK
CC = 'c'
D = ARRAY('-1:1,2')
DIAGNOSTICS = 0
E = 'e'
EXPR = EXPRESSION
F = 'f'
FAIL = PATTERN
FENCE = PATTERN
FEXP = EXPRESSION
OUTPUT = '************************************************'
Q = 'qqq'
QQ = 'x'
REM = PATTERN
SEXP = EXPRESSION
STARS = '  error detected          ***'
SUCCEED = PATTERN
T = TABLE(10,10)
TA = ARRAY('2,2')

Unprotected keywords

&ABEND = 0
&ANCHOR = 0
&CASE = 1
&CODE = 0
&DUMP = 2
&ERRLIMIT = 999
&FILL = ' '
&FTRACE = 0
&FULLSCAN = 0
&GTRACE = 0
&INPUT = 1
&MAXLNGTH = 4294967295
&OUTPUT = 1
&STLIMIT = -1
&TRACE = 1000000
&TRIM = 0
**********************************************
**** snobol  diagnostics -- phase two     ****
**********************************************
****           &fullscan = 0              ****
****** error detected at 67 ********
***** resuming execution *******
**********************************************
****           &fullscan = 1              ****
****           no errors detected         ****
**********************************************
****           end of diagnostics         ****
**********************************************
Dump of variables at termination

Natural variables

ABORT = PATTERN
ARB = PATTERN
BAL = PATTERN
ERRCOUNT = 0
FAIL = PATTERN
FENCE = PATTERN
OUTPUT = '**********************************************'
REM = PATTERN
SUCCEED = PATTERN
TEST = 'abcdefghijklmnopqrstuvwxyz'
VAR = 'abc'
VARA = 'i'
VARD = 'abc'
VARL = 'abc'
VART = 'abc'

Unprotected keywords

&ABEND = 0
&ANCHOR = 0
&CASE = 1
&CODE = 0
&DUMP = 2
&ERRLIMIT = 99
&FILL = ' '
&FTRACE = 0
&FULLSCAN = 1
&GTRACE = 0
&INPUT = 1
&MAXLNGTH = 4294967295
&OUTPUT = 1
&STLIMIT = -1
&TRACE = 1000
&TRIM = 0

The SNOBOL sources are from the SNOBOL4 distribution test/ directory downloaded from SourceForge. Tabs replaced with spaces at tab stop 8.

        OUTPUT = 'hello world'
END

programs/hello.sno

*-title snobol test program #1 -- diagnostics phase one
*
*        this is a standard test program for spitbol which tests
*        out functions, operators and datatype manipulations
*
         &dump = 2
         trace(.test)
         &trace = 1000000
         stars =                     '  error detected          ***'
         &errlimit = 1000
         setexit(.errors)
         output = '************************************************'
         output = '**** s n o b o l      d i a g n o s t i c s ****'
         output = '****          p h a s e    o n e            ****'
         output = '************************************************'
         output = '****  any trace output indicates an error   ****'
         output = '************************************************'
-eject
*
*        test replace function
*
         test = differ(replace('axxbyyy','xy','01'),'a00b111') stars
         a = replace(&alphabet,'xy','ab')
         test = differ(replace('axy',&alphabet,a),'aab') stars
*
*        test convert function
*
         test = differ(convert('12','integer') , 12) stars
         test = differ(convert(2.5,'integer'),2)       stars
         test = differ(convert(2,'real'),2.0) stars
         test = differ(convert('.2','real'),0.2) stars
*
*        test datatype function
*
         test = differ(datatype('jkl'),'STRING') stars
         test = differ(datatype(12),'INTEGER') stars
         test = differ(datatype(1.33),'REAL') stars
         test = differ(datatype(null),'STRING') stars
-eject
*
*        test arithmetic operators
*
         test = differ(3 + 2,5) stars
         test = differ(3 - 2,1) stars
         test = differ(3 * 2,6) stars
         test = differ(5 / 2,2) stars
         test = differ(2 ** 3,8) stars
         test = differ(3 + 1,4) stars
         test = differ(3 - 1,2) stars
         test = differ('3' + 2,5) stars
         test = differ(3 + '-2',1) stars
         test = differ('1' + '0',1) stars
         test = differ(5 + null,5) stars
         test = differ(-5,0 - 5) stars
         test = differ(+'4',4) stars
         test = differ(2.0 + 3.0,5.0) stars
         test = differ(3.0 - 1.0,2.0) stars
         test = differ(3.0 * 2.0,6.0) stars
         test = differ(3.0 / 2.0,1.5) stars
         test = differ(3.0 ** 3,27.0) stars
         test = differ(-1.0,0.0 - 1.0) stars
*
*        test mixed mode
*
         test = differ(1 + 2.0,3.0) stars
         test = differ(3.0 / 2,1.5) stars
-eject
*
*        test functions
*
*        first, a simple test of a factorial function
*
         define('fact(n)')                  :(factend)
fact     fact = eq(n,1) 1         :s(return)
         fact = n * fact(n - 1)             :(return)
factend  test = ne(fact(5),120) stars
         test = differ(opsyn(.facto,'fact')) stars
         test = differ(facto(4),24) stars
*
*        see if alternate entry point works ok
*
         define('fact2(n)',.fact2ent)       :(fact2endf)
fact2ent fact2 = eq(n,1) 1        :s(return)
         fact2 = n * fact2(n - 1) :(return)
fact2endf output = ne(fact(6),720) stars
*
*        test function redefinition and case of argument = func name
*
         test = differ(define('fact(fact)','fact3')) stars
.                                           :(fact2end)
fact3    fact = ne(fact,1) fact * fact(fact - 1)
.                                           :(return)
fact2end
         test = ne(fact(4),24) stars
*
*        test out locals
*
         define('lfunc(a,b,c)d,e,f')        :(lfuncend)
lfunc    test = ~(ident(a,'a') ident(b,'b') ident(c,'c')) stars
         test = ~(ident(d) ident(e) ident(f)) stars
         a = 'aa' ; b = 'bb' ; c = 'cc' ; d = 'dd' ; e = 'ee' ; f = 'ff'
.                                 :(return)
lfuncend aa = 'a' ; bb = 'b' ; cc = 'c'
         d = 'd' ; e = 'e' ; f = 'f'
         a = 'x' ; b = 'y' ; c = 'z'
         test = differ(lfunc(aa,bb,cc)) stars
         test = ~(ident(a,'x') ident(b,'y') ident(c,'z')) stars
         test = ~(ident(aa,'a') ident(bb,'b') ident(cc,'c')) stars
         test = ~(ident(d,'d') ident(e,'e') ident(f,'f')) stars
*
*        test nreturn
*
         define('ntest()')                  :(endntest)
ntest    ntest = .a                         :(nreturn)
endntest a = 27
         test = differ(ntest(),27) stars    :f(st59) ;st59
         ntest() = 26                       :f(st60) ;st60
         test = differ(a,26) stars
-eject
*
*        continue test of functions
*
*
*        test failure return
*
         define('failure()')                :(failend)
failure                           :(freturn)
failend  test = failure() stars
-eject
*
*        test opsyn for operators
*
         opsyn('@',.dupl,2)
         opsyn('|',.size,1)
         test = differ('a' @ 4,'aaaa') stars
         test = differ(|'string',6) stars
*
*        test out array facility
*
         a = array(3)
         test = differ(a<1>) stars
         a<2> = 4.5
         test = differ(a<2>,4.5) stars
         test = ?a<4> stars
         test = ?a<0> stars
         test = differ(prototype(a),'3') stars
         b = array(3,10)
         test = differ(b<2>,10) stars
         b = array('3')
         b<2> = 'a'
         test = differ(b<2>,'a') stars
         c = array('2,2')
         c<1,2> = '*'
         test = differ(c<1,2>,'*') stars
         test = differ(prototype(c),'2,2') stars
         d = array('-1:1,2')
         d<-1,1> = 0
         test = differ(d<-1,1>,0) stars
         test = ?d<-2,1> stars
         test = ?d<2,1> stars
-eject
*
*        test program defined datatype functions
*
         data('node(val,lson,rson)')
         a = node('x','y','z')
         test = differ(datatype(a),'NODE') stars
         test = differ(val(a),'x') stars
         b = node()
         test = differ(rson(b)) stars
         lson(b) = a
         test = differ(rson(lson(b)),'z') stars
         test = differ(value('b'),b) stars
*
*        test multiple use of field function name
*
         data('clunk(value,lson)')
         test = differ(rson(lson(b)),'z') stars
         test = differ(value('b'),b) stars
         c = clunk('a','b')
         test = differ(lson(c),'b') stars
-eject
*
*        test numerical predicates
*
         test = lt(5,4) stars
         test = lt(4,4) stars
         test = ~lt(4,5) stars
         test = le(5,2) stars
         test = ~le(4,4) stars
         test = ~le(4,10) stars
         test = eq(4,5) stars
         test = eq(5,4) stars
         test = ~eq(5,5) stars
         test = ne(4,4) stars
         test = ~ne(4,6) stars
         test = ~ne(6,4) stars
         test = gt(4,6) stars
         test = gt(4,4) stars
         test = ~gt(5,2) stars
         test = ge(5,7) stars
         test = ~ge(4,4) stars
         test = ~ge(7,5) stars
         test = ne(4,5 - 1) stars
         test = gt(4,3 + 1) stars
         test = le(20,5 + 6) stars
         test = eq(1.0,2.0) stars
         test = gt(-2.0,-1.0) stars
         test = gt(-3.0,4.0) stars
         test = ne('12',12) stars
         test = ne('12',12.0) stars
         test = ~convert(bal,'pattern') stars
-eject
*
*        test integer
*
         test = integer('abc') stars
         test = ~integer(12) stars
         test = ~integer('12') stars
*
*        test size
*
         test = ne(size('abc'),3) stars
         test = ne(size(12),2) stars
         test = ne(size(null),0) stars
*
*        test lgt
*
         test = lgt('abc','xyz') stars
         test = lgt('abc','abc') stars
         test = ~lgt('xyz','abc') stars
         test = lgt(null,'abc') stars
         test = ~lgt('abc',null) stars
*
*        test indirect addressing
*
         test = differ($'bal',bal) stars
         test = differ($.bal,bal) stars
         $'qq' = 'x'
         test = differ(qq,'x') stars
         test = differ($'garbage') stars
         a = array(3)
         a<2> = 'x'
         test = differ($.a<2>,'x') stars
*
*        test concatenation
*
         test = differ('a' 'b','ab')        stars
         test = differ('a' 'b' 'c','abc') stars
         test = differ(1 2,'12') stars
         test = differ(2 2 2,'222') stars
         test = differ(1 3.4,'13.4') stars
         test = differ(bal null,bal)        stars
         test = differ(null bal,bal) stars
-eject
*
*        test remdr
*
         test = differ(remdr(10,3),1) stars
         test = differ(remdr(11,10),1) stars
*
*        test dupl
*
         test = differ(dupl('abc',2),'abcabc') stars
         test = differ(dupl(null,10),null) stars
         test = differ(dupl('abcdefg',0),null) stars
         test = differ(dupl(1,10),'1111111111')  stars
*
*        test table facility
*
         t = table(10)
         test = differ(t<'cat'>) stars
         t<'cat'> = 'dog'
         test = differ(t<'cat'>,'dog')   stars
         t<7> = 45
         test = differ(t<7>,45)   stars
         test = differ(t<'cat'>,'dog')  stars
         ta = convert(t,'array')
         test = differ(prototype(ta),'2,2') stars
         ata = convert(ta,'table')
         test = differ(ata<7>,45) stars
         test = differ(ata<'cat'>,'dog') stars
*
*        test item function
*
         aaa = array(10)
         item(aaa,1) = 5
         test = differ(item(aaa,1),5) stars
         test = differ(aaa<1>,5) stars
         aaa<2> = 22
         test = differ(item(aaa,2),22) stars
         ama = array('2,2,2,2')
         item(ama,1,2,1,2) = 1212
         test = differ(item(ama,1,2,1,2),1212) stars
         test = differ(ama<1,2,1,2>,1212) stars
         ama<2,1,2,1> = 2121
         test = differ(item(ama,2,1,2,1),2121) stars
-eject
*
*        test eval
*
         expr = *('abc' 'def')
         test = differ(eval(expr),'abcdef') stars
         q = 'qqq'
         sexp = *q
         test = differ(eval(sexp),'qqq') stars
         fexp = *ident(1,2)
         test = eval(fexp) stars
*
*        test arg
*
jlab     define('jlab(a,b,c)d,e,f')
         test = differ(arg(.jlab,1),'A') stars
         test = differ(arg(.jlab,3),'C') stars
         test = arg(.jlab,0) stars
         test = arg(.jlab,4) stars
*
*        test local
*
         test = differ(local(.jlab,1),'D') stars
         test = differ(local(.jlab,3),'F') stars
         test = local(.jlab,0) stars
         test = local(.jlab,4) stars
*
*        test apply
*
         test = apply(.eq,1,2) stars
         test = ~apply(.eq,1,1) stars
         test = ~ident(apply(.trim,'abc '),'abc') stars
-eject
*
*        final processing
*
         output = '************************************************'
         diagnostics = 1000000 - &trace
         eq(diagnostics,0)        :s(terminate)
         &dump = 2
         output = '****    number of errors detected  '
.                                 diagnostics '    ****'
         output = '**** e n d    o f     d i a g n o s t i c s ****'
         output = '************************************************'
.                                           :(end)
terminate output = '**** n o     e r r o r s    d e t e c t e d ****'
         output = '**** e n d    o f     d i a g n o s t i c s ****'
         output = '************************************************'
 :(end)
*
*        error handling routine
*
errors   eq(&errtype,0)                     :(continue)
         output = '****  error at '
.        lpad(&lastno,4)   '      &errtype = ' lpad(&errtype,7,' ')
.                                           ' ****'
         &trace = &trace - 1
         setexit(.errors)                   :(continue)
end

programs/diag1.sno

* title snobol test program #2 -- diagnostics phase two
*
*
*        this is the standard test program for spitbol which
*        tests pattern matching using both fullscan and quickscan
*
         &dump = 2
         define('error()')
         &trace = 1000
         &errlimit = 00
         trace(.errtype,'keyword')
         &fullscan = 0
         output = '**********************************************'
         output = '**** snobol  diagnostics -- phase two     ****'
         output = '**********************************************'
floop    errcount = 0
         output = '****           &fullscan = ' &fullscan
.        '              ****'
         test = 'abcdefghijklmnopqrstuvwxyz'
*
*        test pattern matching against simple string
*
         test  'abc' :s(s01) ; error()
s01      test 'bcd' :s(s02) ; error()
s02      test 'xyz' :s(s03) ; error()
s03      test 'abd' :f(s04) ; error()
s04      &anchor = 1
         test 'abc' :s(s05) ; error()
s05      test 'bcd' :f(s06) ; error()
s06      test test :s(s06a) ; error()
*
*        test simple cases of $
*
s06a     test 'abc' $ var :s(s07) ; error()
s07      ident(var,'abc') :s(s08) ; error()
s08      test 'abc' . vard :s(s09) ; error()
s09      ident(vard,'abc') :s(s10) ; error()
*
*        test len
*
s10      &anchor = 0
         test len(3) $ varl :s(s11) ; error()
s11      ident(varl,'abc') :s(s12) ; error()
s12      test len(26) $ varl :s(s13) ; error()
s13      ident(varl,test) :s(s14) ; error()
s14      test len(27) :f(s15) ; error()
*
*        test tab
*
s15      test tab(3) $ vart :s(s16) ; error()
s16      ident(vart,'abc') :s(s17) ; error()
s17      test tab(26) $ vart :s(s18) ; error()
s18      ident(test,vart) :s(s19) ; error()
s19      test tab(0) $ vart :s(s20) ; error()
s20      ident(vart) :s(s21) ; error()
-eject
*
*        test arb
*
s21      test arb $ vara 'c' :s(s22) ; error()
s22      ident(vara,'ab') :s(s23) ; error()
s23      &anchor = 1
         test arb $ vara pos(60) :f(s24) ; error()
s24      ident(vara,test) :s(s25) ; error()
*
*        test pos
*
s25      test arb $ vara pos(2) $ varp :s(s26) ; error()
s26      (ident(vara,'ab') ident(varp)) :s(s27) ; error()
s27      &anchor = 0
         test arb $ vara pos(26) $ varp :s(s28) ; error()
s28      (ident(vara,test) ident(varp)) : s(s29) ; error()
s29      test arb $ vara pos(0) $ varp :s(s30) ; error()
s30      ident(vara varp) :s(s31) ; error()
s31      test pos(0) arb $ vara pos(26) :s(s32) ; error()
s32      ident(test,vara) :s(s33) ; error()
s33      test pos(2) arb $ vara pos(3) :s(s34) ; error()
s34      ident(vara,'c') :s(s35) ; error()
s35      test pos(27) :f(s36) ; error()
*
*        test rpos
*
s36      test arb $ vara rpos(25) :s(s37) ; error()
s37      ident(vara,'a') :s(s38) ; error()
s38      test arb $ vara rpos(0) :s(s39) ; error()
s39      ident(test,vara) :s(s39a) ; error()
s39a     test arb $ vara rpos(26) :s(s40) ; error()
s40      ident(vara) :s(s41) ; error()
s41      test rpos(27) :f(s42) ; error()
*
*        test rtab
*
s42      test rtab(26) $ vara :s(s43) ; error()
s43      ident(vara) :s(s44) ; error()
s44      test rtab(27) :f(s45) ; error()
s45      test rtab(0) $ vara :s(s46) ; error()
s46      ident(vara,test) :s(s47) ; error()
s47      test rtab(25) $ vara :s(s48) ; error()
s48      ident(vara,'a') :s(s49) ; error()
*
*        test @
*
s49      test len(6) @vara :s(s50) ; error()
s50      ident(vara,6) :s(s51) ; error()
s51      test @vara :s(s52) ; error()
s52      ident(vara,0) :s(s53) ; error()
s53      test len(26) @vara :s(s54) ; error()
s54      ident(vara,26) :s(s55) ; error()
-eject
*
*        test break
*
s55      test break('c') $ vara :s(s56) ; error()
s56      ident(vara,'ab') :s(s57) ; error()
s57      test break('z()') $ vara :s(s58)     ; error()
s58      ident(vara,'abcdefghijklmnopqrstuvwxy') :s(s59) ; error()
s59      test break(',') :f(s60) ; error()
s60
*
*        test span
*
s63      test span(test) $ vara :s(s64) ; error()
s64      ident(test,vara) :s(s65) ;error()
s65      test span('cdq') $ vara :s(s66) ; error()
s66      ident(vara,'cd') :s(s67) ; error()
s67      test span(',') :f(s68) ; error()
s68
*
*
*        test any
*
s73      test any('mxz') $ vara :s(s74) ; error()
s74      ident(vara,'m') :s(s75) ; error()
s75      test any(',.') :f(s76) ; error()
-eject
*
*        test notany
*
s76      test notany('abcdefghjklmpqrstuwxyz') $ vara :s(s77) ; error()
s77      ident(vara,'i') :s(s78) ; error()
s78      test notany(test) :f(s79) ; error()
*
*        test rem
*
s79      test rem $ vara :s(s80) ; error()
s80      ident(vara,test) :s(s81) ; error()
s81      test len(26) rem $ vara :s(s82) ; error()
s82      ident(vara) :s(s83) ; error()
*
*        test alternation
*
s83      test ('abd' | 'ab') $ vara :s(d84) ; error()
d84      ident(vara,'ab') :s(d85) ; error()
d85      test (test 'a' | test) $ varl :s(d86) ; error()
d86      ident(varl,test) :s(d00) ; error()
*
*        test deferred strings
*
d00      test *'abc' :s(d01) ; error()
d01      test *'abd' :f(d06) ; error()
*
*        test $ . with deferred name arguments
*
d06      test 'abc' $ *var :s(d07) ; error()
d07      ident(var,'abc') :s(d08) ; error()
d08      test 'abc' . *$'vard' :s(d09) ; error()
d09      ident(vard,'abc') :s(d10) ; error()
*
*        test len with deferred argument
*
d10      &anchor = 0
         test len(*3) $ varl :s(d11) ; error()
d11      ident(varl,'abc') :s(d15) ; error()
*
*        test tab with deferred argument
*
d15      test tab(*3) $ vart :s(d16) ; error()
d16      ident(vart,'abc') :s(d21) ; error()
-eject
*
*        test pos with deferred argument
*
d21      &anchor = 1
         test arb $ vara pos(*2) $ varp :s(d26) ; error()
d26      (ident(vara,'ab') ident(varp)) :s(d27) ; error()
d27      &anchor = 0
         test arb $ vara pos(*0) $ varp :s(d35) ; error()
d35      ident(vara varp) :s(d36) ; error()
*
*        test rpos with deferred argument
*
d36      test arb $ vara rpos(*25) :s(d37) ; error()
d37      ident(vara,'a') :s(d38) ; error()
*
*        test rtab with deferred argument
*
d38      test rtab(*26) $ vara :s(d43) ; error()
d43      ident(vara) :s(d49) ; error()
*
*        test @ with deferred argument
*
d49      test len(6) @*vara :s(d50) ; error()
d50      ident(vara,6) :s(d51) ; error()
d51      test @*$'vara' :s(d52) ; error()
d52      ident(vara,0) :s(d55) ; error()
*
*        test break with deferred argument
*
d55      test break(*'c') $ vara :s(d56) ; error()
d56      ident(vara,'ab') :s(d57) ; error()
*
*        test span with deferred argument
*
d57      test span(*test) $ vara :s(d64) ; error()
d64      ident(test,vara) :s(d70) ; error()
*
*        test breakx with deferred argument
*
d70
*      (test test) pos(*0) breakx(*'e') $ vara '.' :f(d71) ; error()
*d71      ident(vara,test 'abcd') :s(d73) ; error()
-eject
*
*        test any with deferred argument
*
d73      test any(*'mxz') $ vara :s(d74) ; error()
d74      ident(vara,'m') :s(d75) ; error()
*
*        test notany with deferred argument
*
d75      test notany(*'abcdefghjklmpqrstuwxyz') $ vara :s(d77) ; error()
d77      ident(vara,'i') :s(d79) ; error()
d79      :(alldone)
         eject
*
*        error handling routine
*
error    output = '****** error detected at ' &lastno ' ********'
         errcount = errcount + 1
         output = '***** resuming execution *******'       :(return)
*
*        termination routine
*
alldone
         errcount = errcount + &errlimit - 100
         &errlimit = 100
         output = eq(errcount,0)
.                 '****           no errors detected         ****'
         output = '**********************************************'
         &fullscan = eq(&fullscan,0) 1           :s(floop)
         output = '****           end of diagnostics         ****'
         output = '**********************************************'
end

programs/diag2.sno

Many thanks to the SNOBOL4 in C team, Philip L. Budne, and the other contributors.

Ralph Griswold sure did some amazing design work.

Be sure to check out the SourceForge link given above, and grab a copy of the distribution kit.

CSNOBOL4 License obligation

Copyright © 1993-2015, Philip L. Budne
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.

Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

fizzbuzz

FizzBuzz without modulo. Chase the fizz.

FizzBuzz is a task on Rosetta Code, Unicon on rosettacode.org. Most entries use some form of modulo test, this one (idea from a COBOL entry by Steve Williams) simply adds to the fizz and the buzz during the loop.

#
# fizzbuzz, chase the fizz
#
link wrap
procedure main()
    fizz := 3; buzz := 5;
    every i := 1 to 100 do {
        write(wrap(left(
            ((i = fizz = buzz & fizz +:= 3 & buzz +:= 5 & "fizzbuzz, ") |
            (i = fizz & fizz +:= 3 & "fizz, ") |
            (i = buzz & buzz +:= 5 & "buzz, ") |
            i || ", ") \ 1
        , 10), 60))
    }
    write(trim(wrap(), ', '))
end

programs/fizzbuzz.icn

And a sample run:

prompt$ unicon -s fizzbuzz.icn -x
1,        2,        fizz,     4,        buzz,     fizz,     
7,        8,        fizz,     buzz,     11,       fizz,     
13,       14,       fizzbuzz, 16,       17,       fizz,     
19,       buzz,     fizz,     22,       23,       fizz,     
buzz,     26,       fizz,     28,       29,       fizzbuzz, 
31,       32,       fizz,     34,       buzz,     fizz,     
37,       38,       fizz,     buzz,     41,       fizz,     
43,       44,       fizzbuzz, 46,       47,       fizz,     
49,       buzz,     fizz,     52,       53,       fizz,     
buzz,     56,       fizz,     58,       59,       fizzbuzz, 
61,       62,       fizz,     64,       buzz,     fizz,     
67,       68,       fizz,     buzz,     71,       fizz,     
73,       74,       fizzbuzz, 76,       77,       fizz,     
79,       buzz,     fizz,     82,       83,       fizz,     
buzz,     86,       fizz,     88,       89,       fizzbuzz, 
91,       92,       fizz,     94,       buzz,     fizz,     
97,       98,       fizz,     buzz

eval

A poor person’s expensive eval procedure.

Putting the multi-tasker to work with on the fly compilation, load of new code and co-expression reflective properties.

#
# uval.icn, an eval function
#
$define base "/tmp/child-xyzzy"

link ximage

#
# try an evaluation
#
global cache
procedure main()
    cache := table()
    program := "# temporary file for eval, purge at will\n_
        global var\n_
        procedure main()\n_
            var := 5\n_
            suspend ![1,2,3] do var +:= 5\n_
        end"

    while e := eval(program) do {
        v := variable("var", cache[program])
        write("child var: ", v, " e: ", ximage(e))
    }

    # BUG HERE, can't refresh the task space: ^cache[program]

    # test cache
    v := &null
    e := eval(program)
    v := variable("var", cache[program])
    write("child var: ", v)
    write("e: ", ximage(e))

    # eval and return a list
    program := "# temporary file for eval, purge at will\n_
        procedure main()\n_
            return [1,2,3]\n_
        end"
    e := eval(program)
    write("e: ", ximage(e))

end

#
# eval, given string (either code or filename with isfile)
#
procedure eval(s, isfile)
    local f, code, status, child, result

    if \isfile then {
        f := open(s, "r") | fail
        code ||:= every(!read(f))
    } else code := s

    # if cached, just refresh the co-expression
    # otherwise, compile and load the code
    if member(cache, code) then write("^cache[code]")
    else {
        codefile := open(base || ".icn", "w") | fail
        write(codefile, code)
        close(codefile)

        status := system("unicon -s -o " || base  || " " ||
                         base || ".icn 2>/dev/null")
        if \status then
            cache[code] := load(base)
    }

    # if there is code, activate the co-expression
    if \cache[code] then result := @cache[code]

    remove(base || ".icn")
    remove(base)

    return \result | fail
end

programs/uval.icn

And a sample run:

prompt$ unicon -s uval.icn -x
child var: 5 e: 1
^cache[code]
child var: 10 e: 2
^cache[code]
child var: 15 e: 3
^cache[code]
^cache[code]
child var: 20
e: 3
e: L1 := list(3)
   L1[1] := 1
   L1[2] := 2
   L1[3] := 3

unilist

Creating list results with loadfunc.

This is a pass at coming to grips with building heterogeneous lists from C functions.

First the C side:

/* unilist.c, trials with C functions and Unicon lists */
#include <stdio.h>
#include <stdlib.h>
#include <time.h>
#include "icall.h"

/* access src/runtime/rstruct.r low level put */
void c_put(descriptor *, descriptor *);

/* some characters for random strings */
#define ALPHABET "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
#define ALPHASIZE (sizeof(ALPHABET) - 1)

/* replace all character positions with a random element from ALPHABET */
char *
randomize(char *str)
{
    int i;
    unsigned int rnd;
    static unsigned int seed;
    char *p = str;

    if (seed == 0) {
        seed = ((unsigned) time(NULL)<<8) ^ (unsigned)clock();
    }
    srand(seed++);
    while (*p) {
        rnd = rand() % ALPHASIZE;
        *p++ = (ALPHABET)[rnd];
    }
    return str;
}


/*
  Build out a heterogeneous list
*/
int
unilist(int argc, descriptor argv[])
{
    char *str;
    int len;
    int size;
    int limit;

    double dbl;

    descriptor listReturn;
    descriptor stringReturn;
    descriptor fileReturn;
    descriptor realReturn;

    /*
      Cheating, need list to work with
      todo: create your own list ya lazy git
    */
    ArgList(1);

    /* set a limit on randomized string lengths */
    ArgInteger(2);
    limit = IntegerVal(argv[2]);
    
    /* make a randomized string, 0 to limit, don't care about bias */
    size = 0;
    while (size < 1) {
        size = ((float)rand()) / RAND_MAX * limit+1;
    }

    str = malloc(size);
    if (!str) exit(1);
    memset(str, ' ', size);
    str[size-1] = '\0';
    len = size;
    randomize(str);

    /* add string to end of list */
    Protect(StringAddr(stringReturn) = alcstr(str, len), Error(306));
    StringLen(stringReturn) = len;
    c_put(&argv[1], &stringReturn);
    free(str);

    /* random real from [0, size], ignoring bias */
    dbl = ((double)rand() / (double)(RAND_MAX)) * (size-1);
    realReturn.dword = D_Real;
#if defined(DescriptorDouble)
    realReturn.vword.realval = dbl;
#else
    Protect(realReturn = alcreal(dbl), Error(307));
    realReturn.vword.bptr = (union block *)realReturn;
#endif
    /* add real to end of list */
    c_put(&argv[1], &realReturn);

    /* return string size */    
    RetInteger(size-1);
}

programs/unilist.c

Then a Unicon test pass:

#
# unilist.icn, demonstrate heterogeneous lists from loadfunc
#
# tectonics:
#   gcc -o unilist.so -shared -fPIC unilist.c
#
procedure main()
    allocated()
    unilist := loadfunc("./unilist.so", "unilist")

    # pass in an empty list, and limit on random string length
    L := []
    limit := 32

    # do a reasonably fat pass
    every i := 1 to 1000 do {
        rc := unilist(L, limit)
        L := put(L, rc)
    }
    write(i, " ", image(L))

    # dump out the first 10 triplets
    every i := 1 to 30 by 3 do write(left(L[i+2], 3),
                                     left(":" || L[i] || ":", limit+2),
                                     L[i + 1])
    allocated()
end

# Display current memory region allocations
procedure allocated()
    local allocs

    allocs := [] ; every put(allocs, &allocated)

    write()
    write("&allocated")
    write("----------")
    write("Heap   : ", allocs[1])
    write("Static : ", allocs[2])
    write("String : ", allocs[3])
    write("Block  : ", allocs[4])
    write()
end

programs/unilist.icn

Build the loadable:

prompt$ gcc -o unilist.so -shared -fPIC unilist.c

Run the test under valgrind to watch for leaks, should be 0.

prompt$ valgrind unicon -s unilist.icn -x
==15012== Memcheck, a memory error detector
==15012== Copyright (C) 2002-2015, and GNU GPL'd, by Julian Seward et al.
==15012== Using Valgrind-3.11.0 and LibVEX; rerun with -h for copyright info
==15012== Command: /home/btiffin/unicon/bin/unicon -s unilist.icn -x
==15012== 
==15013== Warning: invalid file descriptor -1 in syscall close()
==15014== 
==15014== HEAP SUMMARY:
==15014==     in use at exit: 10,018 bytes in 54 blocks
==15014==   total heap usage: 61 allocs, 7 frees, 10,730 bytes allocated
==15014== 
==15014== LEAK SUMMARY:
==15014==    definitely lost: 0 bytes in 0 blocks
==15014==    indirectly lost: 0 bytes in 0 blocks
==15014==      possibly lost: 0 bytes in 0 blocks
==15014==    still reachable: 10,018 bytes in 54 blocks
==15014==         suppressed: 0 bytes in 0 blocks
==15014== Rerun with --leak-check=full to see details of leaked memory
==15014== 
==15014== For counts of detected and suppressed errors, rerun with: -v
==15014== ERROR SUMMARY: 0 errors from 0 contexts (suppressed: 0 from 0)
==15013== 
==15013== HEAP SUMMARY:
==15013==     in use at exit: 1,853 bytes in 54 blocks
==15013==   total heap usage: 59 allocs, 5 frees, 2,037 bytes allocated
==15013== 
==15013== LEAK SUMMARY:
==15013==    definitely lost: 0 bytes in 0 blocks
==15013==    indirectly lost: 0 bytes in 0 blocks
==15013==      possibly lost: 0 bytes in 0 blocks
==15013==    still reachable: 1,853 bytes in 54 blocks
==15013==         suppressed: 0 bytes in 0 blocks
==15013== Rerun with --leak-check=full to see details of leaked memory
==15013== 
==15013== For counts of detected and suppressed errors, rerun with: -v
==15013== ERROR SUMMARY: 0 errors from 0 contexts (suppressed: 0 from 0)

&allocated
----------
Heap   : 34528
Static : 0
String : 0
Block  : 34528

1000 list_2(3000)
26 :EWwuqaRKVtXhBnmyBFgJWypxEo:     7.976012585673487
28 :esoQGSgImLKIEmZVSrjUWjXzDuSU:   26.0229447512063
15 :VdxZiCmGogCaPVg:                0.04474801246297919
5  :jDBla:                          0.4990262144706334
27 :cOqOfaIsTcCFtVbYJdiKDTVQvMQ:    17.60529972082251
21 :XHzEqltHTqxPqMBgWjDSP:          4.275426712946699
28 :VySciitZUiKzFQGOQbqFJHjyEeeR:   24.94490008658958
1  :d:                              0.925599309115484
17 :mGfcdKgppBigjzvyQ:              3.63345873338797
18 :CelTVZHAfsFhrZsavu:             14.27003796597479

&allocated
----------
Heap   : 102192
Static : 0
String : 17184
Block  : 85008

tcc

Embedding and integrating Tiny C with loadfunc.

This is a pass at building loadfunc dynamic shared object files with Tiny C.

As a first trial, the unilist.c and unilist.icn listed above is used:

Build the loadable:

prompt$ tcc -o unilist.so -shared unilist.c

Run the test:

prompt$ unicon -s unilist.icn -x

&allocated
----------
Heap   : 34528
Static : 0
String : 0
Block  : 34528

1000 list_2(3000)
26 :yReiIRdYpvjeLCBWSuUVLtzXyd:     8.201178525668187
18 :avmVambKIjqkzSAEnZ:             13.86347961978218
29 :hEySEDwoAHfrKHEulUzUVqMVelxFP:  21.5565808799847
14 :GkAsbAKCcqydDI:                 12.87488207448036
27 :ECaPYfKNwoCAKPmPoAsHZTwhEAR:    9.19167436109468
21 :zONoLESbPbnFFzdTdaCLf:          11.28015323694802
19 :TEecmHvqVzwmoUGOyTH:            4.371352590793443
4  :JaaY:                           3.363448390440758
21 :zxWZVtVtxrgItpeSoCcfE:          9.128290828377143
22 :DCQluRJGyBBbhwgGJoNgQX:         20.42847560179814

&allocated
----------
Heap   : 101866
Static : 0
String : 16858
Block  : 85008

So, tcc can be used to build Unicon loadable shared libraries. gcc produced a 12K shared object file, tcc produced an 8K file.

Embedded tcc

And then, to embed a C compiler in a Unicon function:

/* program.c description */
#include <stdlib.h>
#include <stdio.h>
#include <string.h>

#include "libtcc.h"
#include "icall.h"

int
unitcc(int argc, descriptor argv[])
{
    /* Crank up tcc */
    TCCState *s;
    int (*func)(int);

    int result;

    /* First arg is the C code */
    ArgString(1);
    /* Second arg is the integer parameter */
    ArgInteger(2);

    s = tcc_new();
    if (!s) {
        fprintf(stderr, "Could not create tcc state\n");
        exit(1);
    }

    /* if tcclib.h and libtcc1.a are not installed, where can we find them */
    /* 
    if (argc == 2 && !memcmp(argv[1], "lib_path=",9))
        tcc_set_lib_path(s, argv[1]+9);
    */

    /* MUST BE CALLED before any compilation */
    tcc_set_output_type(s, TCC_OUTPUT_MEMORY);

    if (tcc_compile_string(s, StringVal(argv[1])) == -1)
        return 1;

    /* as a test, we add a symbol that the compiled program can use.
       You may also open a dll with tcc_add_dll() and use symbols from that */
    /*
    tcc_add_symbol(s, "add", add);
    */

    /* relocate the code */
    if (tcc_relocate(s, TCC_RELOCATE_AUTO) < 0)
        return 1;

    /* get entry symbol, Unicon passes code that compiles trytcc */
    func = tcc_get_symbol(s, "trytcc");
    if (!func)
        return 1;

    /* run the code */
    result = func(IntegerVal(argv[2]));

    /* delete the state */
    tcc_delete(s);

    RetInteger(result);
}

programs/unitcc.c

Unicon test file, expects to find a post compile symbol of trytcc that takes an integer and returns that parameter multiplied by seven.

#
# unitcc.icn, demonstrate an embedded Tiny C compiler
#
# tectonics:
#   tcc -o unitcc.so unitcc.c -ltcc -L\usr\local\lib
#
procedure main()
    tcc := loadfunc("./unitcc.so", "unitcc")

    # compile some code with unitcc and pass an integer argument
    result := tcc(

        "int trytcc(int i) {\n_
            printf(\"Hello, world\n\");\n_
            return i*7;\n_
         }", 6)

    # the inner trytcc function, compiled by tcc is invoked with arg 
    write("result from tcc: ", result)
end

programs/unitcc.icn

Build the loadable using libtcc.so from /usr/local/lib.

prompt$ tcc -o unitcc.so -shared unitcc.c -ltcc -L/usr/local/lib

This test loads the external function, which is an embedded C compiler, and then compiles and links a C function, trytcc directly into memory. The external function trial expects the trytcc entry point and invokes the function with an integer that is passed by Unicon along with the code. We expect to see “Hello, world” and a result that returns 6 * 7. Six is passed from Unicon and the C code multiples the input parameter by seven.

Note that the loadfunc DSO was created by tcc.

prompt$ unicon -s unitcc.icn -x
Hello, world
result from tcc: 42

Tiny C is very neat. And not really a toy. It’s a full fledged ANSI C compiler, that even includes an inline assembler. Originally by Fabrice Bellard, now famous for designing and developing QEMU.

http://bellard.org/tcc/

C code, compiled on the fly from Unicon, then invoked with arguments, and results returned using the features of loadfunc.


Index | Previous: Icon Program Library | Next: Multilanguage