Programs¶
Sample programs and integrations¶
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:
- Integer
- Real numbers
- String
- List (arrays) (from S-Lang array, single dimension, cast to
double)
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;
}
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
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/
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.
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
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.
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
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;
}
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
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;
}
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
// 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();
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
==12765== Memcheck, a memory error detector
==12765== Copyright (C) 2002-2015, and GNU GPL'd, by Julian Seward et al.
==12765== Using Valgrind-3.11.0 and LibVEX; rerun with -h for copyright info
==12765== Command: ./uniduk
==12765==
==12766== Warning: invalid file descriptor -1 in syscall close()
==12767==
==12767== HEAP SUMMARY:
==12767== in use at exit: 10,182 bytes in 59 blocks
==12767== total heap usage: 66 allocs, 7 frees, 10,894 bytes allocated
==12767==
==12767== LEAK SUMMARY:
==12767== definitely lost: 0 bytes in 0 blocks
==12767== indirectly lost: 0 bytes in 0 blocks
==12767== possibly lost: 0 bytes in 0 blocks
==12767== still reachable: 10,182 bytes in 59 blocks
==12767== suppressed: 0 bytes in 0 blocks
==12767== Rerun with --leak-check=full to see details of leaked memory
==12767==
==12767== For counts of detected and suppressed errors, rerun with: -v
==12767== ERROR SUMMARY: 0 errors from 0 contexts (suppressed: 0 from 0)
==12766==
==12766== HEAP SUMMARY:
==12766== in use at exit: 2,017 bytes in 59 blocks
==12766== total heap usage: 64 allocs, 5 frees, 2,201 bytes allocated
==12766==
==12766== LEAK SUMMARY:
==12766== definitely lost: 0 bytes in 0 blocks
==12766== indirectly lost: 0 bytes in 0 blocks
==12766== possibly lost: 0 bytes in 0 blocks
==12766== still reachable: 2,017 bytes in 59 blocks
==12766== suppressed: 0 bytes in 0 blocks
==12766== Rerun with --leak-check=full to see details of leaked memory
==12766==
==12766== For counts of detected and suppressed errors, rerun with: -v
==12766== 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);
}
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
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.
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);
}
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
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);
}
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
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): [37341048,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;
}
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
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;
}
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
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
*
* Fortran 77 form
*
PROGRAM HELLO
PRINT *,'Hello, world'
END
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
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);
}
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
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
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.5.0-12ubuntu1~16.04) 5.5.0 20171010"
.section .note.GNU-stack,"",@progbits
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])));
}
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.
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
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);
}
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.
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
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;
}
}
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.
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
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;
}
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: 2019-10-27 04:47:56
Running: Linux 4.4.0-166-generic #195-Ubuntu SMP Tue Oct 1 09:3...
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
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.
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
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;
}
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;
}
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();
}
#
# 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
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;
}
#
# 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
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>
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);
}
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
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
>RACE = 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
>RACE = 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
*-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
* 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
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
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
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);
}
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
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
==13080== Memcheck, a memory error detector
==13080== Copyright (C) 2002-2015, and GNU GPL'd, by Julian Seward et al.
==13080== Using Valgrind-3.11.0 and LibVEX; rerun with -h for copyright info
==13080== Command: /home/btiffin/unicon-git/bin/unicon -s unilist.icn -x
==13080==
==13081== Warning: invalid file descriptor -1 in syscall close()
==13082==
==13082== HEAP SUMMARY:
==13082== in use at exit: 10,182 bytes in 59 blocks
==13082== total heap usage: 66 allocs, 7 frees, 10,894 bytes allocated
==13082==
==13082== LEAK SUMMARY:
==13082== definitely lost: 0 bytes in 0 blocks
==13082== indirectly lost: 0 bytes in 0 blocks
==13082== possibly lost: 0 bytes in 0 blocks
==13082== still reachable: 10,182 bytes in 59 blocks
==13082== suppressed: 0 bytes in 0 blocks
==13082== Rerun with --leak-check=full to see details of leaked memory
==13082==
==13082== For counts of detected and suppressed errors, rerun with: -v
==13082== ERROR SUMMARY: 0 errors from 0 contexts (suppressed: 0 from 0)
==13081==
==13081== HEAP SUMMARY:
==13081== in use at exit: 2,017 bytes in 59 blocks
==13081== total heap usage: 64 allocs, 5 frees, 2,201 bytes allocated
==13081==
==13081== LEAK SUMMARY:
==13081== definitely lost: 0 bytes in 0 blocks
==13081== indirectly lost: 0 bytes in 0 blocks
==13081== possibly lost: 0 bytes in 0 blocks
==13081== still reachable: 2,017 bytes in 59 blocks
==13081== suppressed: 0 bytes in 0 blocks
==13081== Rerun with --leak-check=full to see details of leaked memory
==13081==
==13081== For counts of detected and suppressed errors, rerun with: -v
==13081== 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 :awwzMgYndhMwynwdUCZxCQBeUv : 11.78188327224082
12 :tmozsvFOocmr : 1.270245228554236
13 :EkmbYGllxOzxU : 12.50222392124227
26 :SXqqNLEEiuLmQudXEeNvXrYaSs : 1.930505571854536
14 :pSkMSKEKZoxYQY : 11.33679437606446
13 :qTaEfqKxmoCLm : 8.013381141709806
9 :pvcsZdwBR : 8.034004245900551
3 :Zda : 0.4723513910883811
23 :JizDvAHinsqUUOpXShuWruC : 12.92860017527295
25 :AlYRBvPZFccYBywLOVHACtQDl : 2.311242605704461
&allocated
----------
Heap : 101672
Static : 0
String : 16664
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 :dCWPdGVgFtmtXJDnTwMpAtGtpE : 16.68325871074724
3 :CHT : 0.7857088259354741
3 :yCC : 1.737006439239255
0 : : 0.0
31 :xvtCajUdJgrXKtOWSHYXhflbjVTjSJu :22.86220726736924
15 :xROQcudXSCleYLJ : 11.90941194859772
17 :hYOFDQbiPQFmaSMNh : 8.148456246661235
11 :cYVfICCQrzd : 7.36686932498909
7 :rKhMiec : 3.090304294643134
12 :VUcCdAEAHAOS : 0.4853149542982294
&allocated
----------
Heap : 101564
Static : 0
String : 16556
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);
}
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
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.
C code, compiled on the fly from Unicon, then invoked with arguments, and results returned using the features of loadfunc.
Index | Previous: Use case scenarios | Next: Multilanguage
