Show Posts

This section allows you to view all posts made by this member. Note that you can only see posts made in areas you currently have access to.


Topics - Support

Pages: [1] 2 3 ... 11
1
Documentation / ScriptBasic Support
« on: January 02, 2021, 11:09:09 am »


The ScriptBasic (MIT Common License) open source project is maintained by John Spikowski. (Peter Verhas - original author) I'm a senior developer offering affordable programming support for ScriptBasic, Sage 100 and Quickbooks accounting packages.


EMAIL: support@scriptbasic.org
LINKEDIN: John Spikowski
PHONE/TEXT: 360-941-0452
LOCATION: Anacortes, WA USA


2
What's New / ScriptBasic - Raspberry Pi
« on: March 30, 2019, 09:25:38 pm »
I'm pleased  to announce a release of ScriptBasic for the Raspberry Pi. You can do a traditional install with a .deb file or as an AppImage

This version of the binaries do NOT work on the Raspberry Pi Zero.
(Requires ARM v7 or greater)

DEB Install:

sudo apt install ./scriptbasic-2.1-linux-armhf.deb
DEB Uninstall:

sudo apt remove scriptbasic-2.1-linux-armhf
To run a script use scriba <script nane> when using the DEB Install.

To use the AppImage version ScriptBasic, unzip the file in the /usr/local/bin (or a directory in the system path) and use sb <script_name> to run your scripts. To remove ScriptBasic, remove the sb file.

I have added scriptbasic-rpi-zero.deb as an attachment. This version will run on ALL versions of the Raspberry Pi where the scriptbasic-2.1-linux-armhf.deb and AppImage versiosn will only run on the ARM v7 versions of the boards. The same instructions apply just change the name of the .deb file.


ScriptBasic User and Developer Guides

Most of the ScriptBasic development activity is happening on the All BASIC Forum.

Language Features
  • Tradional BASIC syntax
  • Variant style variables (no definition or declaration  needed)
  • Indexed, associative arrays (or combo of both) no practical limits
  • Muilt-threaded - asynchronous / synchronous execution
  • Unlimited seamless expansion via the extension API
  • Embeddable API
  • Footprint less than 800 KB
  • Runs on everything with a single source tree (written in ANSI C)
  • Application proxy web server that runs ScriptBasic code
  • Cascading pre-processor support
  • Debugger with single step execution, break points and more

Extension Modules
  • libcurl + SSL
  • MySQL
  • SQLite
  • ODBC
  • json
  • XML
  • regex
  • CGI
  • zlib
  • SBT - thread support
  • IUP - cross platform portable GUI
  • SDL_gfx graphics primatives with alpha channel support
  • BBC BASIC graphic library
  • more ..

Free - Open Source - MIT License

Raspberry Pi Downloads Attached

3
What's New / Script BASIC Wiki
« on: August 14, 2018, 11:33:53 pm »
I have updated the Script BASIC Wiki to the latest version of Mediawiki. (what runs Wikipedia)

Direct Link
https://scriptbasic.org/wiki

I plan to document the Script BASIC COM extension module in the updated wiki. The wiki has been a resource I have neglected for some time.  :(


4
Download / Script BASIC Windows 32 bit Inno Install
« on: July 14, 2018, 07:19:29 am »
I have attached a current Script BASIC Windows 32 bit Inno install. Give a try and let me know if you have any issues.


5
General Discussions / Script BASIC Arrays
« on: November 02, 2017, 09:58:53 pm »
One of my most favorite features of Script BASIC is its array (matrix) functionality. You don't have to define or dimension anything and there are no practical limits on indices. (associative, indexed or a combination of both)

' Test  Associative Array by Index

obj{"Name"}{"Value"} = undef
obj{"Name"}{"Product"} = "ALL"
obj{"Name"}{"Required"} = TRUE
obj{"ID"}{"Value"} = undef
obj{"ID"}{"Product"} = "SOME"
obj{"ID"}{"Required"} = FALSE

this{"Extension"}{"Value"} = "Default"
this{"Extension"}{"Product"} = "FEW"
this{"Extension"}{"Required"} = "MAYBE"

obj{"Version"} = this{"Extension"}

FOR o = 0 TO UBOUND(obj) STEP 2
  PRINT obj[o],"\n"
  FOR p = 0 TO UBOUND(obj[o + 1]) STEP 2
    PRINT obj[o + 1, p]," - ",obj[o + 1, p + 1],"\n"
  NEXT
NEXT

PRINT "-------------------------------","\n"

PRINT obj[0],"\n"
PRINT obj[1,0]," - ",obj[1,1],"\n"
PRINT obj[1,2]," - ",obj[1,3],"\n"
PRINT obj[1,4]," - ",obj[1,5],"\n"
PRINT obj[2],"\n"
PRINT obj[3,0]," - ",obj[3,1],"\n"
PRINT obj[3,2]," - ",obj[3,3],"\n"
PRINT obj[3,4]," - ",obj[3,5],"\n"
PRINT obj[4],"\n"
PRINT obj[5,0]," - ",obj[5,1],"\n"
PRINT obj[5,2]," - ",obj[5,3],"\n"
PRINT obj[5,4]," - ",obj[5,5],"\n"


PRINT "-------------------------------","\n"

PRINT obj[2],"\n"
FOR z = 0 TO UBOUND(obj{"ID"}) STEP 2
  PRINT obj{"ID"}[z]," - ",obj{"ID"}[z + 1],"\n"
NEXT
 

Name
Value - undef
Product - ALL
Required - -1
ID
Value - undef
Product - SOME
Required - 0
Version
Value - Default
Product - FEW
Required - MAYBE
-------------------------------
Name
Value - undef
Product - ALL
Required - -1
ID
Value - undef
Product - SOME
Required - 0
Version
Value - Default
Product - FEW
Required - MAYBE
-------------------------------
ID
Value - undef
Product - SOME
Required - 0


6
Extension Modules / Script BASIC JavaScript Extension Module (Linux)
« on: October 19, 2017, 05:25:25 am »
The Script BASIC JS extension module for Linux is based on the Cesanta's V7 JavaScript Engine. It claims to be the world's smallest footprint JavaScript 5.1 compatible embeddable engine. There are no other dependencies required.

JavaScript Programmers Guide

V7 JavaScript Documentation

Features:
  • Dynamically create JavaScript code in Script BASIC and execute the script.,
  • Call JavaScript functions and access variables from Script BASIC
  • Create / change JavaScript object properties and methods from Script BASIC
  • and much more ...

Note: The \ character is used by Script BASIC as a string escape character and must be inserted in the JavaScript code to make the \ just text. Loading JavaScript code from a file doesn't have the escape character issue and can be run verbatim.

js.inc
MODULE JS

' CORE
DECLARE SUB      js_create                  ALIAS "js_create"                 LIB "js"
DECLARE SUB      js_destroy                 ALIAS "js_destroy"                LIB "js"
DECLARE SUB      js_get_global              ALIAS "js_get_global"             LIB "js"
DECLARE SUB      js_get_this                ALIAS "js_get_this"               LIB "js"
DECLARE SUB      js_get_arguments           ALIAS "js_get_arguments"          LIB "js"
DECLARE SUB      js_arg                     ALIAS "js_arg"                    LIB "js"
DECLARE SUB      js_argc                    ALIAS "js_argc"                   LIB "js"
DECLARE SUB      js_own                     ALIAS "js_own"                    LIB "js"
DECLARE SUB      js_disown                  ALIAS "js_disown"                 LIB "js"
DECLARE SUB      js_set_gc_enabled          ALIAS "js_set_gc_enabled"         LIB "js"
DECLARE SUB      js_interrupt               ALIAS "js_interrupt"              LIB "js"
DECLARE SUB      js_get_parser_error        ALIAS "js_get_parser_error"       LIB "js"

' PRIMITIVES
DECLARE SUB      js_mk_number               ALIAS "js_mk_number"              LIB "js"
DECLARE SUB      js_get_double              ALIAS "js_get_double"             LIB "js"
DECLARE SUB      js_get_int                 ALIAS "js_get_int"                LIB "js"
DECLARE SUB      js_is_number               ALIAS "js_is_number"              LIB "js"
DECLARE SUB      js_mk_boolean              ALIAS "js_mk_boolean"             LIB "js"
DECLARE SUB      js_get_bool                ALIAS "js_get_bool"               LIB "js"
DECLARE SUB      js_is_boolean              ALIAS "js_is_boolean"             LIB "js"
DECLARE SUB      js_mk_null                 ALIAS "js_mk_null"                LIB "js"
DECLARE SUB      js_is_null                 ALIAS "js_is_null"                LIB "js"
DECLARE SUB      js_mk_undefined            ALIAS "js_mk_undefined"           LIB "js"
DECLARE SUB      js_is_undefined            ALIAS "js_is_undefined"           LIB "js"
DECLARE SUB      js_mk_foreign              ALIAS "js_mk_foreign"             LIB "js"
DECLARE SUB      js_get_ptr                 ALIAS "js_get_ptr"                LIB "js"
DECLARE SUB      js_is_foreign              ALIAS "js_is_foreign"             LIB "js"

' STRINGS
DECLARE SUB      js_mk_string               ALIAS "js_mk_string"              LIB "js"
DECLARE SUB      js_is_string               ALIAS "js_is_string"              LIB "js"
DECLARE SUB      js_get_string              ALIAS "js_get_string"             LIB "js"
DECLARE SUB      js_get_cstring             ALIAS "js_get_cstring"            LIB "js"

' OBJECTS
DECLARE SUB      js_mk_object               ALIAS "js_mk_object"              LIB "js"
DECLARE SUB      js_is_object               ALIAS "js_is_object"              LIB "js"
DECLARE SUB      js_get_proto               ALIAS "js_get_proto"              LIB "js"
DECLARE SUB      js_set_proto               ALIAS "js_set_proto"              LIB "js"
DECLARE SUB      js_get                     ALIAS "js_get"                    LIB "js"
DECLARE SUB      js_def                     ALIAS "js_def"                    LIB "js"
DECLARE SUB      js_set                     ALIAS "js_set"                    LIB "js"
DECLARE SUB      js_del                     ALIAS "js_del"                    LIB "js"
DECLARE SUB      js_init_prop_iter_ctx      ALIAS "js_init_prop_iter_ctx"     LIB "js"
DECLARE SUB      js_next_prop               ALIAS "js_next_prop"              LIB "js"
DECLARE SUB      js_destruct_prop_iter_ctx  ALIAS "js_destruct_prop_iter_ctx" LIB "js"
DECLARE SUB      js_is_instanceof           ALIAS "js_is_instanceof"          LIB "js"
DECLARE SUB      js_is_instanceof_v         ALIAS "js_is_instanceof_v"        LIB "js"

' ARRAYS
DECLARE SUB      js_mk_array                ALIAS "js_mk_array"               LIB "js"
DECLARE SUB      js_is_array                ALIAS "js_is_array"               LIB "js"
DECLARE SUB      js_array_length            ALIAS "js_array_length"           LIB "js"
DECLARE SUB      js_array_push              ALIAS "js_array_push"             LIB "js"
DECLARE SUB      js_array_get               ALIAS "js_array_get"              LIB "js"
DECLARE SUB      js_array_set               ALIAS "js_array_set"              LIB "js"
DECLARE SUB      js_array_del               ALIAS "js_array_del"              LIB "js"

' EXECUTION
DECLARE SUB      js_exec                    ALIAS "js_exec"                   LIB "js"
DECLARE SUB      js_exec_file               ALIAS "js_exec_file"              LIB "js"
DECLARE SUB      js_apply                   ALIAS "js_apply"                  LIB "js"
DECLARE SUB      js_parse_json              ALIAS "js_parse_json"             LIB "js"
DECLARE SUB      js_parse_json_file         ALIAS "js_parse_json_file"        LIB "js"

'REGEX
DECLARE SUB      js_mk_regexp               ALIAS "js_mk_regexp"              LIB "js"
DECLARE SUB      js_is_regexp               ALIAS "js_is_regexp"              LIB "js"

' UTILITY
DECLARE SUB      js_stringify               ALIAS "js_stringify"              LIB "js"
DECLARE SUB      js_println                 ALIAS "js_println"                LIB "js"

DECLARE SUB      SB_shifts                  ALIAS "SB_shifts"                 LIB "js"
DECLARE COMMAND  js_iif                     ALIAS "js_iif"                    LIB "js"


' JS Global Module Variables
OBJ = 0
SYS = 0

' Stringify Modes
DEFAULT = 0
JSON    = 1
DEBUG   = 2

' Property Attribute Support

CONST V7_PROPERTY_NON_WRITABLE              = 1
CONST V7_PROPERTY_NON_ENUMERABLE            = 2
CONST V7_PROPERTY_NON_CONFIGURABLE          = 4
CONST V7_PROPERTY_GETTER                    = 8
CONST V7_PROPERTY_SETTER                    = 16
CONST _V7_PROPERTY_HIDDEN                   = 32
CONST _V7_PROPERTY_OFF_HEAP                 = 64
CONST _V7_PROPERTY_USER_DATA_AND_DESTRUCTOR = 128
CONST _V7_DESC_PRESERVE_VALUE               = 256
CONST _V7_DESC_MASK                         = &HFFFF

CONST PROPERTY_DEFAULT = 0

' TRUE or FALSE. Whether the property's value can be set.
FUNCTION WRITABLE(v)
  IF v THEN
    WRITABLE = PROPERTY_DEFAULT
  ELSE
    WRITABLE = V7_PROPERTY_NON_WRITABLE
  END IF
END FUNCTION

' TRUE or FALSE. Whether the property shows in some loop constructs.
FUNCTION ENUMERABLE(v)
  IF v THEN
    ENUMERABLE = PROPERTY_DEFAULT
  ELSE
    ENUMERABLE = V7_PROPERTY_NON_ENUMERABLE
  END IF
END FUNCTION

' TRUE or FALSE. Whether the property can be deleted and whether its attributes can be changed.
FUNCTION CONFIGURABLE(v)
  IF v THEN
    CONFIGURABLE = PROPERTY_DEFAULT
  ELSE
    CONFIGURABLE = V7_PROPERTY_NON_CONFIGURABLE
  END IF
END FUNCTION

' TRUE or FALSE. When a property is accessed the value is generated by calling a function implicitly.
FUNCTION GETTER(v)
  IF v THEN
    GETTER = V7_PROPERTY_GETTER
  ELSE
    GETTER = FALSE
  END IF
END FUNCTION

' TRUE or FALSE. When a property is set it will implicitly call a function and pass a
' value as argument, and the return value of the function is set to the property.
FUNCTION SETTER(v)
  IF v THEN
    SETTER = V7_PROPERTY_SETTER
  ELSE
    SETTER = FALSE
  END IF
END FUNCTION

FUNCTION PRESERVE_VALUE
    PRESERVE_VALUE = _V7_DESC_PRESERVE_VALUE
END FUNCTION

FUNCTION HIDDEN(v)
  IF v THEN
    HIDDEN = V7_PROPERTY_HIDDEN
  ELSE
    HIDDEN = FALSE
  END IF
END FUNCTION

FUNCTION OFF_HEAP(v)
  IF v THEN
    OFF_HEAP = _V7_PROPERTY_OFF_HEAP
  ELSE
    OFF_HEAP = FALSE
  END IF
END FUNCTION


' JS API Function Wrappers

' Create V7 instance
FUNCTION CREATE
  OBJ = js_create()
  SYS = js_get_global(OBJ)
  CREATE = OBJ
END FUNCTION

' Destroy V7 instance
SUB DESTROY
  js_destroy(OBJ)
  UNDEF OBJ
END SUB

' Return root level (`global`) object of the given V7 instance
FUNCTION GET_GLOBAL
  GET_GLOBAL = js_get_global(OBJ)
END FUNCTION

' Return current `this` object
FUNCTION GET_THIS
  GET_THIS = js_get_this(OBJ)
END FUNCTION

' Return current `arguments` array
FUNCTION GET_ARGUMENTS
  GET_ARGUMENTS = js_get_arguments(OBJ)
END FUNCTION

' Return i-th argument
FUNCTION ARG(i)
  ARG = js_arg(OBJ, i)
END FUNCTION

' Return the length (`count`) of `arguments`
FUNCTION ARGC
  ARGC = js_argc(OBJ)
END FUNCTION

' Tells the GC about a JS value variable/field owned by `C` code.
SUB OWN(v)
  js_own(OBJ, v)
END SUB

' User code should also explicitly disown the variables with v7_disown
' once it goes out of scope or the structure containing the v7_val_t field is freed.
' Returns 1 if value is found, 0 otherwise
FUNCTION DISOWN(v)
  DISOWN = js_disown(OBJ, v)
END FUNCTION

' Enable or disable GC
SUB SET_GC_ENABLED(enabled)
  js_set_gc_enabled(OBJ, enabled)
END SUB

' It sets a flag that will cause the interpreter to throw an Interrupted Error
SUB INTERRUPT
  js_interrupt(OBJ)
END SUB

' Returns last parser error message
FUNCTION GET_ERROR
  GET_ERROR = js_get_parser_error(OBJ)
END FUNCTION

' Make numeric primitive value
FUNCTION MK_NUMBER(num)
  MK_NUMBER = js_mk_number(OBJ, num)
END FUNCTION

' Returns number value stored in `v7_val_t` as `double`
FUNCTION GET_DOUBLE(v)
  GET_DOUBLE = js_get_double(OBJ, v)
END FUNCTION

' Returns number value stored in `v7_val_t` as `int`. If the number
' value is not an integer, the fraction part will be discarded.
FUNCTION GET_INT(v)
  GET_INT = js_get_int(OBJ, v)
END FUNCTION

' Returns true if given value is a primitive number value
FUNCTION IS_NUMBER(v)
  IS_NUMBER = js_is_number(v)
END FUNCTION

' Make boolean primitive value (either `true` or `false`)
FUNCTION MK_BOOLEAN(is_true)
  MK_BOOLEAN = js_mk_boolean(OBJ, is_true)
END FUNCTION

' Returns boolean stored in `v7_val_t`: 0 for `false` or
' non-boolean, non-0 for `true`
FUNCTION GET_BOOL(v)
  GET_BOOL = js_get_bool(OBJ, v)
END FUNCTION

' Returns `true` if given value is a primitive boolean value
FUNCTION IS_BOOLEAN(v)
  IS_BOOLEAN = js_is_boolean(v)
END FUNCTION

' Make `null` primitive value
FUNCTION MK_NULL
  MK_NULL = js_mk_null()
END FUNCTION

' Returns true if given value is a primitive `null` value
FUNCTION IS_NULL(v)
  IS_NULL = js_is_null(v)
END FUNCTION

' Make `undefined` primitive value
FUNCTION MK_UNDEFINED
  MK_UNDEFINED = js_mk_undefined()
END FUNCTION

' Returns true if given value is a primitive `undefined` value
FUNCTION IS_UNDEFINED(v)
  IS_UNDEFINED = js_is_undefined(v)
END FUNCTION

' Make JavaScript value that holds C/C++ `void *` pointer
FUNCTION MK_FOREIGN
  MK_FOREIGN = js_mk_foreign(OBJ)
END FUNCTION

' Returns `void *` pointer stored in `v7_val_t`
' Returns NULL `undef` if the value is not a foreign pointer
FUNCTION GET_PTR(v)
  GET_PTR = js_get_ptr(OBJ, v)
END FUNCTION

' Returns true if given value holds `void *` pointer
FUNCTION IS_FOREIGN(v)
  IS_FOREIGN = js_is_foreign(v)
END FUNCTION

' Creates a string primitive value
FUNCTION MK_STRING(strval)
  MK_STRING = js_mk_string(OBJ, strval, LEN(strval), 1)
END FUNCTION

' Returns true if given value is a primitive string value
FUNCTION IS_STRING(v)
  IS_STRING = js_is_string(v)
END FUNCTION

' Returns a pointer to the string stored in `v7_val_t`
FUNCTION GET_STRING(v)
  GET_STRING = js_get_string(OBJ, v)
END FUNCTION

' Returns a pointer to the string stored in `v7_val_t`
' Returns NULL `undef` if the value is not a string or
' if the string is not compatible with a C string
FUNCTION GET_CSTRING(v)
  GET_CSTRING = js_get_cstring(OBJ, v)
END FUNCTION

' Make an empty object
FUNCTION MK_OBJECT
  MK_OBJECT = js_mk_object(OBJ)
END FUNCTION

' Returns true if the given value is an object or function
FUNCTION IS_OBJECT(v)
  IS_OBJECT = js_is_object(v)
END FUNCTION

' Get object's prototype.
FUNCTION GET_PROTO(object)
  GET_PROTO = js_get_proto(OBJ, object)
END FUNCTION

' Set object's prototype. Return old prototype or undefined on error
FUNCTION SET_PROTO(object, proto)
  SET_PROTO = js_set_proto(OBJ, object, proto)
END FUNCTION

' Lookup property `name` in object `obj`. If `obj` holds no such property,
' an `undefined` value is returned
FUNCTION GETS(object, objname)
  GETS = js_get(OBJ, object, objname, LEN(objname))
END FUNCTION

' Define object property, similar to JavaScript `Object.defineProperty()`
FUNCTION DEF(object, objname, attr, value)
  DEF = js_def(OBJ, object, objname, LEN(objname), attr, value)
END FUNCTION

' Set object property. Behaves just like JavaScript assignment
FUNCTION SETS(object, objname, value)
  SETS = js_set(OBJ, object, objname, LEN(objname), value)
END FUNCTION

' Delete own property `name` of the object `obj`
' Does not follow the prototype chain
FUNCTION DEL(object, objname)
  DEL = js_del(OBJ, object, objname, LEN(objname))
END FUNCTION

' Returns true if the object is an instance of a given constructor / class name
FUNCTION IS_INSTANCEOF(object, classname)
  IS_INSTANCEOF = js_is_instanceof(OBJ, object, classname)
END FUNCTION

' Returns true if the object is an instance of a given constructor object class
FUNCTION IS_INSTANCEOF_V(object, objclass)
  IS_INSTANCEOF_V = js_is_instanceof_v(OBJ, object, objclass)
END FUNCTION

' Custom multi-property `GET` function
FUNCTION GET_PROPERTIES(object, proparray)
  LOCAL objname, value, attr, propcnt
  objname = ""
  value = 0
  attr = 0
  propcnt = 1
 ' UNDEF proparray
 js_init_prop_iter_ctx(OBJ, object)
  WHILE js_next_prop(OBJ, objname, value, attr) <> undef
    proparray[propcnt, 0] = js_get_string(OBJ, objname)
    proparray[propcnt, 1] = js_get_int(OBJ, value)
    proparray[propcnt, 2] = attr
    propcnt += 1
  WEND
  js_destruct_prop_iter_ctx(OBJ)
  GET_PROPERTIES = propcnt - 1
END FUNCTION

' Make an empty array object
FUNCTION MK_ARRAY
  MK_ARRAY = js_mk_array(OBJ)
END FUNCTION

' Returns true if given value is an array object
FUNCTION IS_ARRAY(object)
  IS_ARRAY = js_is_array(OBJ, object)
END FUNCTION

' Returns length on an array. If `object` is not an array, 0 is returned
FUNCTION ARRAY_LENGTH(object)
  ARRAY_LENGTH = js_array_length(OBJ, object)
END FUNCTION

' Insert `value` in `object` at the end of the array
FUNCTION ARRAY_PUSH(object, value)
  ARRAY_PUSH = js_array_push(OBJ, object, value)
END FUNCTION

'  Return array member at index `index`. If `index` is out of bounds, undefined is returned
FUNCTION ARRAY_GET(object, index)
  ARRAY_GET = js_array_get(OBJ, object, index)
END FUNCTION

' Insert value `v` into `arr` at 'index`
FUNCTION ARRAY_SET(object, index, value)
  ARRAY_SET = js_array_set(OBJ, object, index, value)
END FUNCTION

' Delete value in array `arr` at index `index`, if it exists
SUB ARRAY_DEL(object, index)
   js_array_del(OBJ, object, index)
END SUB

' Execute JavaScript `js_code`
' The result of evaluation is stored in the `return` variable
' The 'ok' argument will contain the function's execution success status flag
FUNCTION EXEC(code, ok)
  EXEC = js_exec(OBJ, code, ok)
END FUNCTION

' Same as `v7_exec()`, but loads source code from `path` file
FUNCTION EXEC_FILE(codepath, ok)
  EXEC_FILE = js_exec_file(OBJ, codepath, ok)
END FUNCTION

' Parse `json_code`
' The result of evaluation is stored in the `return` variable
' The 'ok' argument will contain the function's parse success status flag
FUNCTION PARSE_JSON(json_code, ok)
  PARSE_JSON = js_parse_json(OBJ, json_code, ok)
END FUNCTION

' Same as `v7_parse_json()`, but loads `json_code` from `path` file
FUNCTION PARSE_JSON_FILE(json_code_file, ok)
  PARSE_JSON_FILE = js_parse_json_file(OBJ, json_code_file, ok)
END FUNCTION

' Call function `func` with arguments `args`, using `object` as `this`
' `args` should be an array containing arguments or `undefined`
FUNCTION APPLY(func, object, args)
  APPLY = js_apply(OBJ, func, object, args)
END FUNCTION

' Make RegExp object. For example, `regex` is `(.+)`, `flags` is `gi`.
FUNCTION MK_REGEXP(regex, flags, rcode)
  MK_REGEXP = js_mk_regexp(OBJ, regex, LEN(regex), flags, LEN(flags), rcode)
END FUNCTION

' Returns true if given value is a JavaScript RegExp object
FUNCTION IS_REGEXP(object)
  IS_REGEXP = js_is_regexp(OBJ, object)
END FUNCTION

' Generate string representation of the JavaScript value
FUNCTION STRINGIFY(object, convtype)
  STRINGIFY = js_stringify(OBJ, object, convtype)
END FUNCTION

' Output a string representation of the value to stdout followed by a newline
SUB PRINTIFY(object)
  js_println(OBJ, object)
END SUB


END MODULE
 

Hello JavaScript
IMPORT js.inc

JS::CREATE
PRINT JS::GET_INT(JS::EXEC("1 + 1")),"\n"
JS::DESTROY
 

jrs@jrs-laptop:~/sb/examples/js$ time scriba js_hello2.sb
2

real   0m0.026s
user   0m0.016s
sys   0m0.008s
jrs@jrs-laptop:~/sb/examples/js$


Fibonacci
IMPORT js.inc

jscode = """
function fibonacci(n) {
  if (n <= 2) {
    return 1;
  } else {
    return fibonacci(n - 1) + fibonacci(n - 2);
  }
}

print(fibonacci(24));
"
""

JS::CREATE
JS::EXEC(jscode)
JS::DESTROY
 

jrs@jrs-laptop:~/sb/examples/js$ scriba js_fibonacci.sb
46368
jrs@jrs-laptop:~/sb/examples/js$


Create object, property and attributes
IMPORT js.inc

JS::CREATE
myobj = JS::MK_OBJECT()
JS::DEF(myobj, "test", 0, JS::MK_NUMBER(64))
JS::SETS(myobj, "test", JS::MK_NUMBER(32))
JS::DEF(myobj, "test", JS::WRITABLE(FALSE) OR JS::PRESERVE_VALUE(),JS::MK_NULL())
JS::SETS(myobj, "test", JS::MK_NUMBER(16))
PRINT "test = ",JS::GET_INT(JS::GETS(myobj, "test")),"\n"
JS::DESTROY
 

jrs@jrs-laptop:~/sb/examples/js$ scriba js_deftest.sb
test = 32
jrs@jrs-laptop:~/sb/examples/js$


Load .js file and get properties
IMPORT js.inc

JS::CREATE
JS::EXEC_FILE "properties.js"
propcnt = JS::GET_PROPERTIES(JS::GETS(JS::SYS,"test"), proparray)
PRINT "Property\tValue\tAttribute\n"
FOR i = 1 to propcnt
  PRINT proparray[i,0],"\t\t",proparray[i,1],"\t",proparray[i,2],"\n"
NEXT
JS::DESTROY
 
properties.js
var test = {};

Object.defineProperty(test, 'a', {
  value: 1,
  writable: true,
  enumerable: true,
  configurable: true
});

Object.defineProperty(test, 'b', {
  value: 2,
  writable: false,
  enumerable: false,
  configurable: false
});
 

jrs@jrs-laptop:~/sb/examples/js$ scriba js_propfile.sb
Property   Value   Attribute
b      2   7
a      1   0
jrs@jrs-laptop:~/sb/examples/js$


Call JavaScript function
IMPORT js.inc

jscode = """
var sum = function(a, b, c) {
  print (c);
  return a + b; };
"
""

JS::CREATE()
JS::EXEC(jscode)
func = JS::GETS(JS::SYS, "sum")
args = JS::MK_ARRAY()
JS::ARRAY_PUSH(args, JS::MK_NUMBER(123.0))
JS::ARRAY_PUSH(args, JS::MK_NUMBER(0.456))
JS::ARRAY_PUSH(args, JS::MK_STRING("Script BASIC"))
result = JS::APPLY(func, 0, args, rcode)
PRINT FORMAT("Result: %g\n", JS::GET_DOUBLE(result))
JS::DESTROY
 

jrs@jrs-laptop:~/sb/examples/js$ scriba js_callfunc.sb
Script BASIC
Result: 123.456
jrs@jrs-laptop:~/sb/examples/js$


Describe Properties with JavaScript
IMPORT js.inc

' Create JavaScript instance
JS::CREATE

' Create JavaScript object
JS::EXEC("var myobj = {};")
myobj = JS::GETS(JS::SYS, "myobj")

' Create object property
JS::DEF(myobj, "test", JS::WRITABLE(TRUE), JS::MK_NUMBER(64))

' Describe object properties with JavaScript
jscode = """
var descriptors = {};

Object.keys(myobj).forEach(function(key) {
    descriptors[key] = Object.getOwnPropertyDescriptor(myobj, key);
});

var objdesc = JSON.stringify(descriptors);
"
""
JS::EXEC(jscode)

' Return JSON formatted result string
PRINT JS::GET_STRING(JS::GETS(JS::SYS, "objdesc")),"\n"

' Release JavaScript instance
JS::DESTROY
 

jrs@jrs-laptop:~/sb/examples/js$ scriba js_defobj.sb
{"test":{"configurable":true,"enumerable":true,"writable":true,"value":64}}
jrs@jrs-laptop:~/sb/examples/js$


JSON / Stringify
IMPORT js.inc

JS::CREATE
myobj = JS::MK_OBJECT()
JS::DEF(myobj, "myprop_1", 0, JS::MK_NUMBER(64))
JS::DEF(myobj, "myprop_2", 0, JS::MK_NUMBER(1.23))
JS::DEF(myobj, "myprop_3", 0, JS::MK_STRING("JavaScript"))
PRINT JS::STRINGIFY(myobj, JS::JSON),"\n"
JS::DESTROY
 

jrs@jrs-laptop:~/sb/examples/js$ scriba js_stringify.sb
{"myprop_3":"JavaScript","myprop_2":1.23,"myprop_1":64}
jrs@jrs-laptop:~/sb/examples/js$


JavaScript Regular Expression
IMPORT js.inc

jscode = """
var output = ['---------- Original String\\n', names + '\\n'];

// Prepare two regular expression patterns and array storage.
// Split the string into array elements.

// pattern: possible white space then semicolon then possible white space
var pattern = /\\s*;\\s*/;

// Break the string into pieces separated by the pattern above and
// store the pieces in an array called nameList
var nameList = names.split(pattern);

// new pattern: one or more characters then spaces then characters.
// Use parentheses to "
memorize" portions of the pattern.
// The memorized portions are referred to later.
pattern = /(\\w+)\\s+(\\w+)/;

// New array for holding names being processed.
var bySurnameList = [];

// Display the name array and populate the new array
// with comma-separated names, last first.
//
// The replace method removes anything matching the pattern
// and replaces it with the memorized string—second memorized portion
// followed by comma space followed by first memorized portion.
//
// The variables $1 and $2 refer to the portions
// memorized while matching the pattern.

output.push('---------- After Split by Regular Expression');

var i, len;
for (i = 0, len = nameList.length; i < len; i++) {
  output.push(nameList[i]);
  bySurnameList[i] = nameList[i].replace(pattern, '$2, $1');
}

// Display the new array.
output.push('---------- Names Reversed');
for (i = 0, len = bySurnameList.length; i < len; i++) {
  output.push(bySurnameList[i]);
}

// Sort by last name, then display the sorted array.
bySurnameList.sort();
output.push('---------- Sorted');
for (i = 0, len = bySurnameList.length; i < len; i++) {
  output.push(bySurnameList[i]);
}

output.push('---------- End');

var retstr = output.join('\\n');
"
""

' The name string contains multiple spaces and tabs,
' and may have multiple spaces between first and last names.

JS::CREATE
JS::EXEC("var names = 'Harry Trump ;Fred Barney; Helen Rigby ; Bill Abel ; Chris Hand ';")
JS::EXEC(jscode)
PRINT JS::GET_STRING(JS::GETS(JS::SYS, "retstr"))
JS::DESTROY
 

jrs@jrs-laptop:~/sb/examples/js$ time scriba js_regexp.sb
---------- Original String

Harry Trump ;Fred Barney; Helen Rigby ; Bill Abel ; Chris Hand

---------- After Split by Regular Expression
Harry Trump
Fred Barney
Helen Rigby
Bill Abel
Chris Hand
---------- Names Reversed
Trump, Harry
Barney, Fred
Rigby, Helen
Abel, Bill
Hand, Chris
---------- Sorted
Abel, Bill
Barney, Fred
Hand, Chris
Rigby, Helen
Trump, Harry
---------- End
real   0m0.030s
user   0m0.028s
sys   0m0.000s
jrs@jrs-laptop:~/sb/examples/js$


7
What's New / Script BASIC Windows 32 bit - Download Available
« on: February 14, 2017, 10:57:04 pm »
I have finally assembled an Inno install for Script BASIC for Windows 32 bit with extension modules and their dependencies included. This is my first public release in this format and would appreciate any feedback you're willing to offer to make Script BASIC even better for everyone.

If you plan on using the MySQL extension module or use the SBHTTPD proxy web server, I highly recommend installing the 32 bit version of the XAMPP package (and any of the other free packages they offer) for your local  database and Apache web server environment.

Script BASIC Examples and Source


Note: Download is currently being rebuilt to add new features. Check Back Again Soon.

8
Extension Modules / JavaScript Extension Module
« on: November 18, 2016, 06:34:36 pm »
The Script BASIC JS extension module is based on Cesanta's V7 JavaScript Engine. It claims to be the world's smallest footprint JavaScript 5.1 compatible embeddable engine. There are no other dependencies required. I have attached a Ubuntu 16.04 64 bit binary shared object (.so) and interface include file. The js.inc is briefly documented but hopefully the following examples will get you started. This is just a first round beta and I would appreciate any feedback or examples you may be willing to share.

js.inc
MODULE JS

' CORE
DECLARE SUB      js_create                  ALIAS "js_create"                 LIB "js"
DECLARE SUB      js_destroy                 ALIAS "js_destroy"                LIB "js"
DECLARE SUB      js_get_global              ALIAS "js_get_global"             LIB "js"
DECLARE SUB      js_get_this                ALIAS "js_get_this"               LIB "js"
DECLARE SUB      js_get_arguments           ALIAS "js_get_arguments"          LIB "js"
DECLARE SUB      js_arg                     ALIAS "js_arg"                    LIB "js"
DECLARE SUB      js_argc                    ALIAS "js_argc"                   LIB "js"
DECLARE SUB      js_own                     ALIAS "js_own"                    LIB "js"
DECLARE SUB      js_disown                  ALIAS "js_disown"                 LIB "js"
DECLARE SUB      js_set_gc_enabled          ALIAS "js_set_gc_enabled"         LIB "js"
DECLARE SUB      js_interrupt               ALIAS "js_interrupt"              LIB "js"
DECLARE SUB      js_get_parser_error        ALIAS "js_get_parser_error"       LIB "js"

' PRIMITIVES
DECLARE SUB      js_mk_number               ALIAS "js_mk_number"              LIB "js"
DECLARE SUB      js_get_double              ALIAS "js_get_double"             LIB "js"
DECLARE SUB      js_get_int                 ALIAS "js_get_int"                LIB "js"
DECLARE SUB      js_is_number               ALIAS "js_is_number"              LIB "js"
DECLARE SUB      js_mk_boolean              ALIAS "js_mk_boolean"             LIB "js"
DECLARE SUB      js_get_bool                ALIAS "js_get_bool"               LIB "js"
DECLARE SUB      js_is_boolean              ALIAS "js_is_boolean"             LIB "js"
DECLARE SUB      js_mk_null                 ALIAS "js_mk_null"                LIB "js"
DECLARE SUB      js_is_null                 ALIAS "js_is_null"                LIB "js"
DECLARE SUB      js_mk_undefined            ALIAS "js_mk_undefined"           LIB "js"
DECLARE SUB      js_is_undefined            ALIAS "js_is_undefined"           LIB "js"
DECLARE SUB      js_mk_foreign              ALIAS "js_mk_foreign"             LIB "js"
DECLARE SUB      js_get_ptr                 ALIAS "js_get_ptr"                LIB "js"
DECLARE SUB      js_is_foreign              ALIAS "js_is_foreign"             LIB "js"

' STRINGS
DECLARE SUB      js_mk_string               ALIAS "js_mk_string"              LIB "js"
DECLARE SUB      js_is_string               ALIAS "js_is_string"              LIB "js"
DECLARE SUB      js_get_string              ALIAS "js_get_string"             LIB "js"
DECLARE SUB      js_get_cstring             ALIAS "js_get_cstring"            LIB "js"

' OBJECTS
DECLARE SUB      js_mk_object               ALIAS "js_mk_object"              LIB "js"
DECLARE SUB      js_is_object               ALIAS "js_is_object"              LIB "js"
DECLARE SUB      js_get_proto               ALIAS "js_get_proto"              LIB "js"
DECLARE SUB      js_set_proto               ALIAS "js_set_proto"              LIB "js"
DECLARE SUB      js_get                     ALIAS "js_get"                    LIB "js"
DECLARE SUB      js_def                     ALIAS "js_def"                    LIB "js"
DECLARE SUB      js_set                     ALIAS "js_set"                    LIB "js"
DECLARE SUB      js_del                     ALIAS "js_del"                    LIB "js"
DECLARE SUB      js_init_prop_iter_ctx      ALIAS "js_init_prop_iter_ctx"     LIB "js"
DECLARE SUB      js_next_prop               ALIAS "js_next_prop"              LIB "js"
DECLARE SUB      js_destruct_prop_iter_ctx  ALIAS "js_destruct_prop_iter_ctx" LIB "js"
DECLARE SUB      js_is_instanceof           ALIAS "js_is_instanceof"          LIB "js"
DECLARE SUB      js_is_instanceof_v         ALIAS "js_is_instanceof_v"        LIB "js"

' ARRAYS
DECLARE SUB      js_mk_array                ALIAS "js_mk_array"               LIB "js"
DECLARE SUB      js_is_array                ALIAS "js_is_array"               LIB "js"
DECLARE SUB      js_array_length            ALIAS "js_array_length"           LIB "js"
DECLARE SUB      js_array_push              ALIAS "js_array_push"             LIB "js"
DECLARE SUB      js_array_get               ALIAS "js_array_get"              LIB "js"
DECLARE SUB      js_array_set               ALIAS "js_array_set"              LIB "js"
DECLARE SUB      js_array_del               ALIAS "js_array_del"              LIB "js"

' EXECUTION
DECLARE SUB      js_exec                    ALIAS "js_exec"                   LIB "js"
DECLARE SUB      js_exec_file               ALIAS "js_exec_file"              LIB "js"
DECLARE SUB      js_apply                   ALIAS "js_apply"                  LIB "js"
DECLARE SUB      js_parse_json              ALIAS "js_parse_json"             LIB "js"
DECLARE SUB      js_parse_json_file         ALIAS "js_parse_json_file"        LIB "js"

'REGEX
DECLARE SUB      js_mk_regexp               ALIAS "js_mk_regexp"              LIB "js"
DECLARE SUB      js_is_regexp               ALIAS "js_is_regexp"              LIB "js"

' UTILITY
DECLARE SUB      js_stringify               ALIAS "js_stringify"              LIB "js"
DECLARE SUB      js_println                 ALIAS "js_println"                LIB "js"

DECLARE SUB      SB_shifts                  ALIAS "SB_shifts"                 LIB "js"
DECLARE COMMAND  js_iif                     ALIAS "js_iif"                    LIB "js"


' JS Global Module Variables
OBJ = 0
SYS = 0

' Stringify Modes
DEFAULT = 0
JSON    = 1
DEBUG   = 2

' Property Attribute Support

CONST V7_PROPERTY_NON_WRITABLE              = 1
CONST V7_PROPERTY_NON_ENUMERABLE            = 2
CONST V7_PROPERTY_NON_CONFIGURABLE          = 4
CONST V7_PROPERTY_GETTER                    = 8
CONST V7_PROPERTY_SETTER                    = 16
CONST _V7_PROPERTY_HIDDEN                   = 32
CONST _V7_PROPERTY_OFF_HEAP                 = 64
CONST _V7_PROPERTY_USER_DATA_AND_DESTRUCTOR = 128
CONST _V7_DESC_PRESERVE_VALUE               = 256
CONST _V7_DESC_MASK                         = &HFFFF

CONST PROPERTY_DEFAULT = 0

' TRUE or FALSE. Whether the property's value can be set.
FUNCTION WRITABLE(v)
  IF v THEN
    WRITABLE = PROPERTY_DEFAULT
  ELSE
    WRITABLE = V7_PROPERTY_NON_WRITABLE
  END IF
END FUNCTION

' TRUE or FALSE. Whether the property shows in some loop constructs.
FUNCTION ENUMERABLE(v)
  IF v THEN
    ENUMERABLE = PROPERTY_DEFAULT
  ELSE
    ENUMERABLE = V7_PROPERTY_NON_ENUMERABLE
  END IF
END FUNCTION

' TRUE or FALSE. Whether the property can be deleted and whether its attributes can be changed.
FUNCTION CONFIGURABLE(v)
  IF v THEN
    CONFIGURABLE = PROPERTY_DEFAULT
  ELSE
    CONFIGURABLE = V7_PROPERTY_NON_CONFIGURABLE
  END IF
END FUNCTION

' TRUE or FALSE. When a property is accessed the value is generated by calling a function implicitly.
FUNCTION GETTER(v)
  IF v THEN
    GETTER = V7_PROPERTY_GETTER
  ELSE
    GETTER = FALSE
  END IF
END FUNCTION

' TRUE or FALSE. When a property is set it will implicitly call a function and pass a
' value as argument, and the return value of the function is set to the property.
FUNCTION SETTER(v)
  IF v THEN
    SETTER = V7_PROPERTY_SETTER
  ELSE
    SETTER = FALSE
  END IF
END FUNCTION

FUNCTION PRESERVE_VALUE
    PRESERVE_VALUE = _V7_DESC_PRESERVE_VALUE
END FUNCTION

FUNCTION HIDDEN(v)
  IF v THEN
    HIDDEN = V7_PROPERTY_HIDDEN
  ELSE
    HIDDEN = FALSE
  END IF
END FUNCTION

FUNCTION OFF_HEAP(v)
  IF v THEN
    OFF_HEAP = _V7_PROPERTY_OFF_HEAP
  ELSE
    OFF_HEAP = FALSE
  END IF
END FUNCTION


' JS API Function Wrappers

' Create V7 instance
FUNCTION CREATE
  OBJ = js_create()
  SYS = js_get_global(OBJ)
  CREATE = OBJ
END FUNCTION

' Destroy V7 instance
SUB DESTROY
  js_destroy(OBJ)
  UNDEF OBJ
END SUB

' Return root level (`global`) object of the given V7 instance
FUNCTION GET_GLOBAL
  GET_GLOBAL = js_get_global(OBJ)
END FUNCTION

' Return current `this` object
FUNCTION GET_THIS
  GET_THIS = js_get_this(OBJ)
END FUNCTION

' Return current `arguments` array
FUNCTION GET_ARGUMENTS
  GET_ARGUMENTS = js_get_arguments(OBJ)
END FUNCTION

' Return i-th argument
FUNCTION ARG(i)
  ARG = js_arg(OBJ, i)
END FUNCTION

' Return the length (`count`) of `arguments`
FUNCTION ARGC
  ARGC = js_argc(OBJ)
END FUNCTION

' Tells the GC about a JS value variable/field owned by `C` code.
SUB OWN(v)
  js_own(OBJ, v)
END SUB

' User code should also explicitly disown the variables with v7_disown
' once it goes out of scope or the structure containing the v7_val_t field is freed.
' Returns 1 if value is found, 0 otherwise
FUNCTION DISOWN(v)
  DISOWN = js_disown(OBJ, v)
END FUNCTION

' Enable or disable GC
SUB SET_GC_ENABLED(enabled)
  js_set_gc_enabled(OBJ, enabled)
END SUB

' It sets a flag that will cause the interpreter to throw an Interrupted Error
SUB INTERRUPT
  js_interrupt(OBJ)
END SUB

' Returns last parser error message
FUNCTION GET_ERROR
  GET_ERROR = js_get_parser_error(OBJ)
END FUNCTION

' Make numeric primitive value
FUNCTION MK_NUMBER(num)
  MK_NUMBER = js_mk_number(OBJ, num)
END FUNCTION

' Returns number value stored in `v7_val_t` as `double`
FUNCTION GET_DOUBLE(v)
  GET_DOUBLE = js_get_double(OBJ, v)
END FUNCTION

' Returns number value stored in `v7_val_t` as `int`. If the number
' value is not an integer, the fraction part will be discarded.
FUNCTION GET_INT(v)
  GET_INT = js_get_int(OBJ, v)
END FUNCTION

' Returns true if given value is a primitive number value
FUNCTION IS_NUMBER(v)
  IS_NUMBER = js_is_number(v)
END FUNCTION

' Make boolean primitive value (either `true` or `false`)
FUNCTION MK_BOOLEAN(is_true)
  MK_BOOLEAN = js_mk_boolean(OBJ, is_true)
END FUNCTION

' Returns boolean stored in `v7_val_t`: 0 for `false` or
' non-boolean, non-0 for `true`
FUNCTION GET_BOOL(v)
  GET_BOOL = js_get_bool(OBJ, v)
END FUNCTION

' Returns `true` if given value is a primitive boolean value
FUNCTION IS_BOOLEAN(v)
  IS_BOOLEAN = js_is_boolean(v)
END FUNCTION

' Make `null` primitive value
FUNCTION MK_NULL
  MK_NULL = js_mk_null()
END FUNCTION

' Returns true if given value is a primitive `null` value
FUNCTION IS_NULL(v)
  IS_NULL = js_is_null(v)
END FUNCTION

' Make `undefined` primitive value
FUNCTION MK_UNDEFINED
  MK_UNDEFINED = js_mk_undefined()
END FUNCTION

' Returns true if given value is a primitive `undefined` value
FUNCTION IS_UNDEFINED(v)
  IS_UNDEFINED = js_is_undefined(v)
END FUNCTION

' Make JavaScript value that holds C/C++ `void *` pointer
FUNCTION MK_FOREIGN
  MK_FOREIGN = js_mk_foreign(OBJ)
END FUNCTION

' Returns `void *` pointer stored in `v7_val_t`
' Returns NULL `undef` if the value is not a foreign pointer
FUNCTION GET_PTR(v)
  GET_PTR = js_get_ptr(OBJ, v)
END FUNCTION

' Returns true if given value holds `void *` pointer
FUNCTION IS_FOREIGN(v)
  IS_FOREIGN = js_is_foreign(v)
END FUNCTION

' Creates a string primitive value
FUNCTION MK_STRING(strval)
  MK_STRING = js_mk_string(OBJ, strval, LEN(strval), 1)
END FUNCTION

' Returns true if given value is a primitive string value
FUNCTION IS_STRING(v)
  IS_STRING = js_is_string(v)
END FUNCTION

' Returns a pointer to the string stored in `v7_val_t`
FUNCTION GET_STRING(v)
  GET_STRING = js_get_string(OBJ, v)
END FUNCTION

' Returns a pointer to the string stored in `v7_val_t`
' Returns NULL `undef` if the value is not a string or
' if the string is not compatible with a C string
FUNCTION GET_CSTRING(v)
  GET_CSTRING = js_get_cstring(OBJ, v)
END FUNCTION

' Make an empty object
FUNCTION MK_OBJECT
  MK_OBJECT = js_mk_object(OBJ)
END FUNCTION

' Returns true if the given value is an object or function
FUNCTION IS_OBJECT(v)
  IS_OBJECT = js_is_object(v)
END FUNCTION

' Get object's prototype.
FUNCTION GET_PROTO(object)
  GET_PROTO = js_get_proto(OBJ, object)
END FUNCTION

' Set object's prototype. Return old prototype or undefined on error
FUNCTION SET_PROTO(object, proto)
  SET_PROTO = js_set_proto(OBJ, object, proto)
END FUNCTION

' Lookup property `name` in object `obj`. If `obj` holds no such property,
' an `undefined` value is returned
FUNCTION GETS(object, objname)
  GETS = js_get(OBJ, object, objname, LEN(objname))
END FUNCTION

' Define object property, similar to JavaScript `Object.defineProperty()`
FUNCTION DEF(object, objname, attr, value)
  DEF = js_def(OBJ, object, objname, LEN(objname), attr, value)
END FUNCTION

' Set object property. Behaves just like JavaScript assignment
FUNCTION SETS(object, objname, value)
  SETS = js_set(OBJ, object, objname, LEN(objname), value)
END FUNCTION

' Delete own property `name` of the object `obj`
' Does not follow the prototype chain
FUNCTION DEL(object, objname)
  DEL = js_del(OBJ, object, objname, LEN(objname))
END FUNCTION

' Returns true if the object is an instance of a given constructor / class name
FUNCTION IS_INSTANCEOF(object, classname)
  IS_INSTANCEOF = js_is_instanceof(OBJ, object, classname)
END FUNCTION

' Returns true if the object is an instance of a given constructor object class
FUNCTION IS_INSTANCEOF_V(object, objclass)
  IS_INSTANCEOF_V = js_is_instanceof_v(OBJ, object, objclass)
END FUNCTION

' Custom multi-property `GET` function
FUNCTION GET_PROPERTIES(object, proparray)
  LOCAL objname, value, attr, propcnt
  objname = ""
  value = 0
  attr = 0
  propcnt = 1
 ' UNDEF proparray
 js_init_prop_iter_ctx(OBJ, object)
  WHILE js_next_prop(OBJ, objname, value, attr) <> undef
    proparray[propcnt, 0] = js_get_string(OBJ, objname)
    proparray[propcnt, 1] = js_get_int(OBJ, value)
    proparray[propcnt, 2] = attr
    propcnt += 1
  WEND
  js_destruct_prop_iter_ctx(OBJ)
  GET_PROPERTIES = propcnt - 1
END FUNCTION

' Make an empty array object
FUNCTION MK_ARRAY
  MK_ARRAY = js_mk_array(OBJ)
END FUNCTION

' Returns true if given value is an array object
FUNCTION IS_ARRAY(object)
  IS_ARRAY = js_is_array(OBJ, object)
END FUNCTION

' Returns length on an array. If `object` is not an array, 0 is returned
FUNCTION ARRAY_LENGTH(object)
  ARRAY_LENGTH = js_array_length(OBJ, object)
END FUNCTION

' Insert `value` in `object` at the end of the array
FUNCTION ARRAY_PUSH(object, value)
  ARRAY_PUSH = js_array_push(OBJ, object, value)
END FUNCTION

'  Return array member at index `index`. If `index` is out of bounds, undefined is returned
FUNCTION ARRAY_GET(object, index)
  ARRAY_GET = js_array_get(OBJ, object, index)
END FUNCTION

' Insert value `v` into `arr` at 'index`
FUNCTION ARRAY_SET(object, index, value)
  ARRAY_SET = js_array_set(OBJ, object, index, value)
END FUNCTION

' Delete value in array `arr` at index `index`, if it exists
SUB ARRAY_DEL(object, index)
   js_array_del(OBJ, object, index)
END SUB

' Execute JavaScript `js_code`
' The result of evaluation is stored in the `return` variable
' The 'ok' argument will contain the function's execution success status flag
FUNCTION EXEC(code, ok)
  EXEC = js_exec(OBJ, code, ok)
END FUNCTION

' Same as `v7_exec()`, but loads source code from `path` file
FUNCTION EXEC_FILE(codepath, ok)
  EXEC_FILE = js_exec_file(OBJ, codepath, ok)
END FUNCTION

' Parse `json_code`
' The result of evaluation is stored in the `return` variable
' The 'ok' argument will contain the function's parse success status flag
FUNCTION PARSE_JSON(json_code, ok)
  PARSE_JSON = js_parse_json(OBJ, json_code, ok)
END FUNCTION

' Same as `v7_parse_json()`, but loads `json_code` from `path` file
FUNCTION PARSE_JSON_FILE(json_code_file, ok)
  PARSE_JSON_FILE = js_parse_json_file(OBJ, json_code_file, ok)
END FUNCTION

' Call function `func` with arguments `args`, using `object` as `this`
' `args` should be an array containing arguments or `undefined`
FUNCTION APPLY(func, object, args)
  APPLY = js_apply(OBJ, func, object, args)
END FUNCTION

' Make RegExp object. For example, `regex` is `(.+)`, `flags` is `gi`.
FUNCTION MK_REGEXP(regex, flags, rcode)
  MK_REGEXP = js_mk_regexp(OBJ, regex, LEN(regex), flags, LEN(flags), rcode)
END FUNCTION

' Returns true if given value is a JavaScript RegExp object
FUNCTION IS_REGEXP(object)
  IS_REGEXP = js_is_regexp(OBJ, object)
END FUNCTION

' Generate string representation of the JavaScript value
FUNCTION STRINGIFY(object, convtype)
  STRINGIFY = js_stringify(OBJ, object, convtype)
END FUNCTION

' Output a string representation of the value to stdout followed by a newline
SUB PRINTIFY(object)
  js_println(OBJ, object)
END SUB


END MODULE
 

Hello JavaScript
IMPORT js.inc

JS::CREATE
PRINT JS::GET_INT(JS::EXEC("1 + 1")),"\n"
JS::DESTROY
 

jrs@jrs-laptop:~/sb/examples/js$ scriba js_hello2.sb
2
jrs@jrs-laptop:~/sb/examples/js$


Fibonacci
IMPORT js.inc

jscode = """
function fibonacci(n) {
  if (n <= 2) {
    return 1;
  } else {
    return fibonacci(n - 1) + fibonacci(n - 2);
  }
}

print(fibonacci(24));
"
""

JS::CREATE
JS::EXEC(jscode)
JS::DESTROY
 

jrs@jrs-laptop:~/sb/examples/js$ scriba js_fibonacci.sb
46368
jrs@jrs-laptop:~/sb/examples/js$


Create object, property and attributes
IMPORT js.inc

JS::CREATE
myobj = JS::MK_OBJECT()
JS::DEF(myobj, "test", 0, JS::MK_NUMBER(64))
JS::SETS(myobj, "test", JS::MK_NUMBER(32))
JS::DEF(myobj, "test", JS::WRITABLE(FALSE) OR JS::PRESERVE_VALUE(),JS::MK_NULL())
JS::SETS(myobj, "test", JS::MK_NUMBER(16))
PRINT "test = ",JS::GET_INT(JS::GETS(myobj, "test")),"\n"
JS::DESTROY
 

jrs@jrs-laptop:~/sb/examples/js$ scriba js_deftest.sb
test = 32
jrs@jrs-laptop:~/sb/examples/js$


Load .js file and get properties
IMPORT js.inc

JS::CREATE
JS::EXEC_FILE "properties.js"
propcnt = JS::GET_PROPERTIES(JS::GETS(JS::SYS,"test"), proparray)
PRINT "Property\tValue\tAttribute\n"
FOR i = 1 to propcnt
  PRINT proparray[i,0],"\t\t",proparray[i,1],"\t",proparray[i,2],"\n"
NEXT
JS::DESTROY
 
properties.js
var test = {};

Object.defineProperty(test, 'a', {
  value: 1,
  writable: true,
  enumerable: true,
  configurable: true
});

Object.defineProperty(test, 'b', {
  value: 2,
  writable: false,
  enumerable: false,
  configurable: false
});
 

jrs@jrs-laptop:~/sb/examples/js$ scriba js_propfile.sb
Property   Value   Attribute
b      2   7
a      1   0
jrs@jrs-laptop:~/sb/examples/js$


Call JavaScript function
IMPORT js.inc

jscode = """
var sum = function(a, b, c) {
  print (c);
  return a + b; };
"
""

JS::CREATE()
JS::EXEC(jscode)
func = JS::GETS(JS::SYS, "sum")
args = JS::MK_ARRAY()
JS::ARRAY_PUSH(args, JS::MK_NUMBER(123.0))
JS::ARRAY_PUSH(args, JS::MK_NUMBER(0.456))
JS::ARRAY_PUSH(args, JS::MK_STRING("Script BASIC"))
result = JS::APPLY(func, 0, args, rcode)
PRINT FORMAT("Result: %g\n", JS::GET_DOUBLE(result))
JS::DESTROY
 

jrs@jrs-laptop:~/sb/examples/js$ scriba js_callfunc.sb
Script BASIC
Result: 123.456
jrs@jrs-laptop:~/sb/examples/js$


JSON / Stringify
IMPORT js.inc

JS::CREATE
myobj = JS::MK_OBJECT()
JS::DEF(myobj, "myprop_1", 0, JS::MK_NUMBER(64))
JS::DEF(myobj, "myprop_2", 0, JS::MK_NUMBER(1.23))
JS::DEF(myobj, "myprop_3", 0, JS::MK_STRING("JavaScript"))
PRINT JS::STRINGIFY(myobj, JS::JSON),"\n"
JS::DESTROY
 

jrs@jrs-laptop:~/sb/examples/js$ scriba js_stringify.sb
{"myprop_3":"JavaScript","myprop_2":1.23,"myprop_1":64}
jrs@jrs-laptop:~/sb/examples/js$


FYI: - A Windows 32 bit version may materialize if I can get by the unexplainable issues on this platform. Windows isn't generally supported by Cesanta.


9
Business BASIC Migrations / ProvideX Linux 64 IUP
« on: June 11, 2015, 06:00:34 am »
Here is an example of an online dictionary program written in ProvideX (PxBasic) for Ubuntu 64 bit and using the IUP (Portable User Interface) with an interface shared object I wrote.

Update: I included a screen shot of the Windows version of ProvideX and IUP. Theming isn't working but the goal was to show the same PVX code running native GUI on Linux and Windows.

! Online Dictionary - Px* + IUP

BEGIN

lib = DLL(ADDR "/home/jrs/pxbasic/pxbiup.so")

DIM servers$[0]
servers$[0]="dict.org"

about$ = "ProvideX IUP Binding"

! Initialize IUP
ok = DLL(lib, "IupOpen")

! Create main window

win = DLL(lib, "IupCreate", "dialog"+$00$)
  ok = DLL(lib, "IupSetAttributes", win, "TITLE="+QUO+"Online Dictionary - ProvideX/IUP"+QUO+", SIZE=500x300"+$00$)
  ok = DLL(lib, "PxBSetCallback", win,"CLOSE_CB"+$00$)

! Create container to house ALL GUI objects

vbox = DLL(lib, "IupCreate", "vbox"+$00$)
  ok = DLL(lib, "IupSetAttributes", vbox, "MARGIN=10x10"+$00$)

! Create server panel

topBox = DLL(lib, "IupCreate", "hbox"+$00$)
  ok = DLL(lib, "IupSetAttributes", topBox, "GAP=10"+$00$)
  ok = DLL(lib, "IupAppend", vbox, topBox)
serverFrame = DLL(lib, "IupCreate", "frame"+$00$)
  ok = DLL(lib, "IupSetAttributes", serverFrame, "TITLE=Servers, EXPAND=YES"+$00$)
  ok = DLL(lib, "IupAppend", topBox, serverFrame)
serverBox = DLL(lib, "IupCreate", "hbox"+$00$)
  ok = DLL(lib, "IupSetAttributes", serverBox, "GAP=5"+$00$)
  ok = DLL(lib, "IupAppend", serverFrame, serverBox)
serverCombo = DLL(lib, "IupCreate", "list"+$00$)
  ok = DLL(lib, "IupSetAttributes", serverCombo, "DROPDOWN=YES, SIZE=120x, EXPAND=HORIZONTAL, VALUE=1"+$00$)
  ok = DLL(lib, "IupAppend", serverBox, serverCombo)
  ok = DLL(lib, "PxBSetCallback", serverCombo, "ACTION"+$00$)
btnFetch = DLL(lib, "IupCreate", "button"+$00$)
  ok = DLL(lib, "IupSetAttributes", btnFetch, "TITLE=Fetch, SIZE = 50x"+$00$)
  ok = DLL(lib, "IupAppend", serverBox, btnFetch)
  ok = DLL(lib, "PxBSetCallback", btnFetch, "ACTION"+$00$)

! Create control panel

controlFrame = DLL(lib, "IupCreate", "frame"+$00$)
  ok = DLL(lib, "IupSetAttributes", controlFrame, "TITLE=Controls"+$00$)
  ok = DLL(lib, "IupAppend", topBox, controlFrame)
controlBox = DLL(lib, "IupCreate", "hbox"+$00$)
  ok = DLL(lib, "IupSetAttributes", controlBox, "GAP=5"+$00$)
  ok = DLL(lib, "IupAppend", controlFrame, controlBox)
btnAbout = DLL(lib, "IupCreate", "button"+$00$)
  ok = DLL(lib, "IupSetAttributes", btnAbout, "TITLE=About, SIZE = 50x"+$00$)
  ok = DLL(lib, "IupAppend", controlBox, btnAbout)
  ok = DLL(lib, "PxBSetCallback", btnAbout, "ACTION"+$00$)
btnClear = DLL(lib, "IupCreate", "button"+$00$)
  ok = DLL(lib, "IupSetAttributes", btnClear, "TITLE=Clear, SIZE = 50x"+$00$)
  ok = DLL(lib, "IupAppend", controlBox, btnClear)
  ok = DLL(lib, "PxBSetCallback", btnClear, "ACTION"+$00$)
btnExit = DLL(lib, "IupCreate", "button"+$00$)
  ok = DLL(lib, "IupSetAttributes", btnExit, "TITLE=Exit, SIZE = 50x"+$00$)
  ok = DLL(lib, "IupAppend", controlBox, btnExit)
  ok = DLL(lib, "PxBSetCallback", btnExit,"ACTION"+$00$)

! Create dictionary panel

dictFrame = DLL(lib, "IupCreate", "frame"+$00$)
  ok = DLL(lib, "IupSetAttributes", dictFrame, "TITLE=Dictionaries"+$00$)
  ok = DLL(lib, "IupAppend", vbox, dictFrame)
serverList = DLL(lib, "IupCreate", "list"+$00$)
  ok = DLL(lib, "IupSetAttributes", serverList, "EXPAND=YES, VISIBLELINES=1"+$00$)
  ok = DLL(lib, "IupAppend", dictFrame, serverList)
  ok = DLL(lib, "PxBSetCallback", serverList, "ACTION"+$00$)

! Create text part

transFrame = DLL(lib, "IupCreate", "frame"+$00$)
  ok = DLL(lib, "IupSetAttributes", transFrame, "TITLE=Translation"+$00$)
  ok = DLL(lib, "IupAppend", vbox, transFrame)
text = DLL(lib, "IupCreate", "text"+$00$)
  ok = DLL(lib, "IupSetAttributes", text, "MULTILINE=YES, EXPAND=YES"+$00$)
  ok = DLL(lib, "IupAppend", transFrame, text)

! Create entry and search button

bottomBox = DLL(lib, "IupCreate", "hbox"+$00$)
  ok = DLL(lib, "IupSetAttributes", bottomBox, "GAP=10"+$00$)
  ok = DLL(lib, "IupAppend", vbox, bottomBox)
label = DLL(lib, "IupCreate", "label"+$00$)
  ok = DLL(lib, "IupSetAttributes", label, "TITLE="+QUO+"Enter Word to Search For:"+QUO+", SIZE=x12"+$00$)
  ok = DLL(lib, "IupAppend", bottomBox, label)
entry = DLL(lib, "IupCreate", "text"+$00$)
  ok = DLL(lib, "IupSetAttributes", entry, "EXPAND=HORIZONTAL"+$00$)
  ok = DLL(lib, "IupAppend", bottomBox, entry)
btnSearch = DLL(lib, "IupCreate", "button"+$00$)
  ok = DLL(lib, "IupSetAttributes", btnSearch, "TITLE=Search, SIZE=50x"+$00$)
  ok = DLL(lib, "IupAppend", bottomBox, btnSearch)
  ok = DLL(lib, "PxBSetCallback", btnSearch, "ACTION"+$00$)
chkAll = DLL(lib, "IupCreate","toggle"+$00$)
  ok = DLL(lib, "IupSetAttributes", chkAll, "TITLE=ALL, SIZE=x12"+$00$)
  ok = DLL(lib, "IupAppend", bottomBox, chkAll)
chkUTF = DLL(lib, "IupCreate", "toggle"+$00$)
  ok = DLL(lib, "IupSetAttributes", chkUTF, "TITLE=UTF-8, SIZE=x12"+$00$)
  ok = DLL(lib, "IupAppend", bottomBox, chkUTF)

! Add the main GUI container to the Window

ok = DLL(lib, "IupAppend", win, vbox)

! Setup dialog defaults

ok = DLL(lib, "IupShow", win)
ok = DLL(lib, "IupSetFocus", btnFetch)
FOR i = 0 TO DIM(READ MAX(servers$))
  ok = DLL(lib, "IupSetAttribute", serverCombo, "APPENDITEM"+$00$, servers$[i]+$00$)
NEXT
ok = DLL(lib, "IupSetAttribute", serverCombo, "VALUE"+$00$, "1"+$00$)
ok = DLL(lib, "IupUpdate", serverCombo)
server_selection$ = servers$[0]

! Main processing loop

REPEAT
  WAIT: ok = DLL(lib, "IupLoopStepWait")
  this_event = DLL(lib, "GetEvent")
  IF NOT(this_event) THEN GOTO WAIT
  SWITCH this_event
    CASE serverCombo
      GOSUB serverCombo_selected
      BREAK
    CASE btnFetch
      GOSUB btnFetch_clicked
      BREAK
    CASE btnAbout
      GOSUB btnAbout_clicked
      BREAK
    CASE btnClear
      GOSUB btnClear_clicked
      BREAK
    CASE serverList
      GOSUB serverList_selected
      BREAK
    CASE btnSearch
      GOSUB btnSearch_clicked
      BREAK
  END SWITCH
UNTIL this_event = win OR this_event = btnExit
ok = DLL(lib, "IupClose")
ok = DLL(DROP lib)
END

! Callback routines

btnAbout_clicked:
  ok = DLL(lib, "IupMessage", "ABOUT"+$00$, about$)
RETURN

serverCombo_selected:
  DIM server_selection$(1024)
  ok = DLL(lib, "GetListSelectedText", server_selection$)
  server_selection$ = STP(server_selection$, 2)
RETURN

serverList_selected:
  DIM whichDictionary$(1024)
  ok = DLL(lib, "GetListSelectedText", whichDictionary$)
  whichDictionary$ = STP(whichDictionary$, 2)
RETURN

btnFetch_clicked:
  dat$ = ""
  DIM _total$[*]
  count = 1
  OPEN (1,BSZ=16384)"[TCP]"+server_selection$+";2628;NoDelay;stream"
  WRITE (1)"SHOW DB"+$0D0A$
  REPEAT
    READ(1)raw_data$
    dat$ = dat$ + raw_data$
  UNTIL POS("250 ok" = raw_data$)
  WRITE(1)"QUIT"+$0D0A$
  CLOSE(1)
  REPEAT
    eol = POS($0D0A$=dat$)
    _total$[count] = dat$(1,eol - 1)
    dat$ = dat$(eol + 2)
    count += 1
  UNTIL dat$ = ""
  FOR cnt = 3 TO count - 3
    ok = DLL(lib, "IupSetAttribute", serverList, "APPENDITEM"+$00$, _total$[cnt]+$00$)
   NEXT cnt
  ok = DLL(lib, "IupSetAttribute", serverList, "APPENDITEM"+$00$, _total$[3]+$00$)
  ok = DLL(lib, "IupSetAttribute", serverList, "VALUE"+$00$, "1"+$00$)
  ok = DLL(lib, "IupUpdate", serverCombo)
  whichDictionary$ = _total$[3]
RETURN

G_NetError:
  PRINT "Server ",server_selection$," not available. (",ERROR,")"
RETURN

btnClear_clicked:
  ok = DLL(lib, "IupSetAttribute", serverList,"1"+$00$)
  ok = DLL(lib, "IupSetAttribute", text, "VALUE"+$00$, ""+$00$)
  ok = DLL(lib, "IupSetAttribute", entry, "VALUE"+$00$, ""+$00$)
RETURN

btnSearch_clicked:
  dict$ = ""
  dat$ = ""
  total$ = ""
  info$ = ""
  ok = DLL(lib, "IupSetAttribute", text, "VALUE"+$00$, "Fetching...."+$00$)
  dict$ = whichDictionary$(1, POS(" " = whichDictionary$) - 1)
  OPEN (1,BSZ=16384)"[TCP]"+server_selection$+";2628;NoDelay;stream"
  chkval$ = FNIupGetString$(DLL(lib, "IupGetAttribute", chkAll, "VALUE"+$00$))
  IF chkval$ = "ON" THEN {
    WRITE(1)"DEFINE * " + FNIupGetString$(DLL(lib, "IupGetAttribute", entry,"VALUE"+$00$)) + $0D0A$
  } ELSE {
    WRITE(1)"DEFINE " + dict$ + " " + FNIupGetString$(DLL(lib, "IupGetAttribute", entry,"VALUE"+$00$)) + $0D0A$
  }
  REPEAT
    READ(1)raw_data$
    data_str$ = data_str$ + raw_data$
  UNTIL POS("250 ok [d/m/c =" = raw_data$)
  WRITE(1)"QUIT"+$0D0A$
  CLOSE(1)
  ! Remove header
  data_str$ = data_str$(POS($0D0A$=data_str$, 1, 2) + 2)
  REPEAT
    eol = POS($0D0A$=data_str$)
    dat$ = data_str$(1,eol - 1)
    data_str$ = data_str$(eol + 2)
    IF dat$(1, 3) <> "151" THEN GOTO IT
      entstr$ = FNIupGetString$(DLL(lib, "IupGetAttribute", entry, "VALUE"+$00$))
      total$ = total$ + "------------------------------" + $0D0A$
      total$ = total$ + dat$(2 + LEN(entstr$) + LEN(dict$)) + $0D0A$
      total$ = total$ + "------------------------------"+ $0D0A$
      REPEAT
        eol = POS($0D0A$=data_str$)
        info$ = data_str$(1,eol - 1)
        data_str$ = data_str$(eol + 2)
        info$ = SUB(info$, CHR(34), CHR(92) + CHR(34))
        IF LEN(info$) AND info$(1, 1) <> "." THEN total$ += STP(info$, 2) + $0D0A$
      UNTIL info$ > "" AND info$(1, 1) = "."
      total$ += $0D0A$
    IT:
  UNTIL data_str$(1, 3) = "250" OR NUM(data_str$(1, 3)) > 499
  IF dat$(1, 3) = "552" THEN total$ = "No match found."
  IF dat$(1, 3) = "501" THEN total$ = "Select a dictionary first!"
  IF dat$(1, 3) = "550" THEN total$ = "Invalid database!"
  ok = DLL(lib, "IupSetAttribute", text, "VALUE"+$00$, total$+$00$)
RETURN

L_NetError:
  dat$ = "Could not lookup word! (" + STR(ERR) + ")"
  ok = DLL(lib, "IupSetAttribute", text, "VALUE"+$00$, dat$+$00$)
RETURN

! DLL() return string emulator

DEF FNIupGetString$(LOCAL i_ptr)
  LOCAL strlen, pxbuff$
  DIM pxbuff$(4096)
  strlen = DLL(lib, "ptr2pxbstr", i_ptr, pxbuff$)
  RETURN pxbuff$(1,strlen)
END DEF
 

10
What's New / dbgcon - Script BASIC remote debugger
« on: May 06, 2015, 02:47:55 am »
A few years ago I made some bug fixes to Peter's Verhas's experimental sdbg remote Script BASIC debugger. I wrote my own console client in SB which works great. I plan on using some of Dave Zimmer's enhancements to his VB/COM IDE/Debugger preprocessor project to view array contents and trace the call stack. The remote socket based Script BASIC debugger works with both local desktop scripts and remote sbhttpd proxy server web applications.

dbgcon.sb
' ScriptBasic Remote Console Debugger

cmdln = TRIM(COMMAND())
IF cmdln = "" THEN
  PRINT "Usage: dbgcon [prog2debug]\n"
  END
END IF
exitcode = EXECUTE("/usr/bin/scriba -i sdbg " & cmdln,-1,PID)
OPEN "127.0.0.1:6647" FOR SOCKET AS #1
WHILE NOT EOF(1)
  LINE INPUT #1, dbgs
  IF dbgs = ".\n" THEN
    PRINT "-> "
    LINE INPUT dbgc
    IF LCASE(CHOMP(dbgc)) = "h" THEN
PRINT """h help
s step one line
S step one line, do not step into functions or subs
o step until getting out of the current function
  (if you stepped into but changed your mind)
? var  print the value of a variable
u step one level up in the stack
d step one level down in the stack (for variable printing)
D step down in the stack to current execution depth
G list all global variables
L list all local variables
l [n-m] list the source lines
r [n] run to line n
R [n] run to line n but do not stop in recursive function call
b [n] set breakpoint on the line n or the current line
B [n-m] remove breakpoints from lines
q quit the program
"
""
    END IF
    PRINT #1, dbgc
    IF CHOMP(dbgc) = "q" THEN GOTO Done
  ELSE
    dbgcmd = CHOMP(dbgs)
' l - List Source  
   IF INSTR(dbgcmd,"Break-Point: ")<>undef THEN
      p = INSTR(dbgcmd,"Break-Point: ")
      IF MID(dbgcmd,p+13,1) = "0" THEN
        PRINT " "
      ELSE
        PRINT "*"
      END IF
      GOTO IT
    END IF
    IF INSTR(dbgcmd,"Line-Number: ")<>undef THEN
      p = INSTR(dbgcmd,"Line-Number: ")
      PRINT FORMAT("%~[0000] ~",VAL(MID(dbgcmd,p+13)))
      online = TRUE
      GOTO IT
    END IF
    IF INSTR(dbgcmd,"Line: ")<>undef THEN
      p = INSTR(dbgcmd,"Line: ")
      IF online THEN
        PRINT MID(dbgcmd,p+6),"\n"
      ELSE
        PRINT MID(dbgcmd,p),"\n"
      END IF        
      online = FALSE
      GOTO IT
    END IF
    IF INSTR(dbgcmd,"Global-Variable")<>undef THEN
      p = INSTR(dbgcmd,"Global-Variable")
      PRINT "G-Var" & MID(dbgcmd,p+15) & "\n"
      GOTO IT
    END IF
' Unprocessed out
  PRINT dbgs
  END IF
IT:
WEND
 
Done:
PRINT #1,"q"
CLOSE(1)
PRINT "Debug session closed.\n"
END
 
testarray.sb
' Long / Double / String
i = 1
d = .99
s = "JRS"
' Indices array
a[0,0] = 0
a[0,1] = 123
a[0,2] = 1.23
a[0,3] = "One,Two,Three"
a[1,10] = "Zero"
a[1,11] = 321
a[1,12] = 32.1
a[1,13] = "Three,Two,One"
' Asscociative array
b{"One"} = 1
b{"Two"} = .2
b{"Three"} = "*3*"
' Mix asscociative & indices array
c{"JRS"}[1] = 1
c{"JRS"}[2] = .2
c{"JRS"}[3] = "*3*"
PRINT "Done\n"
 
Output

jrs@laptop:~/sb/sb22/sbt$ scriba dbgcon.sb testarray.sb
Application: ScriptBasic Remote Debugger - Linux
Version: 1.0
Source-File-Count: 1
Source-File: testarray.sb
Line: 2
-> b15
Message: done
Line: 2
-> l1-
 [0001] ' Long / Double / String
 [0002] i = 1
 [0003] d = .99
 [0004] s = "JRS"
 [0005] ' Indices array
 [0006] a[0,0] = 0
 [0007] a[0,1] = 123
 [0008] a[0,2] = 1.23
 [0009] a[0,3] = "One,Two,Three"
 [0010] a[1,10] = "Zero"
 [0011] a[1,11] = 321
 [0012] a[1,12] = 32.1
 [0013] a[1,13] = "Three,Two,One"
 [0014] ' Asscociative array
*[0015] b{"One"} = 1
 [0016] b{"Two"} = .2
 [0017] b{"Three"} = "*3*"
 [0018] ' Mix asscociative & indices array
 [0019] c{"JRS"}[1] = 1
 [0020] c{"JRS"}[2] = .2
 [0021] c{"JRS"}[3] = "*3*"
 [0022] PRINT "Done\n"
Line: 2
-> r
Line: 15
-> r22
Line: 22
-> G
G-Var-Name: VT=0 @ 0x014BBD18 VN=main::i
G-Var-Value: 1
G-Var-Name: VT=1 @ 0x014C9258 VN=main::d
G-Var-Value: 0.990000
G-Var-Name: VT=2 @ 0x014C92B8 VN=main::s
G-Var-Value: "JRS"
G-Var-Name: VT=3 @ 0x014C9378 LB=0 : UB=1 VN=main::a
G-Var-Value: 
LB=0 : UB=3 VN=[0]
[0] VT=3 @ 0x014C9468 
[0] VT=0 @ 0x014C9558 0
[1] VT=0 @ 0x014C96D8 123
[2] VT=1 @ 0x014C9898 1.230000
[3] VT=2 @ 0x014BC0A8 "One,Two,Three"
LB=10 : UB=13 VN=[1]
[1] VT=3 @ 0x014BC1C8 
[10] VT=2 @ 0x014BC228 "Zero"
[11] VT=0 @ 0x014BC3A8 321
[12] VT=1 @ 0x014BC568 32.100000
[13] VT=2 @ 0x014BC6D8 "Three,Two,One"
G-Var-Name: VT=3 @ 0x014BC798 LB=0 : UB=5 VN=main::b
G-Var-Value: 
[0] VT=2 @ 0x014BC7F8 "One"
[1] VT=0 @ 0x014BC8B8 1
[2] VT=2 @ 0x014BC968 "Two"
[3] VT=1 @ 0x014BCA28 0.200000
[4] VT=2 @ 0x014BCAE8 "Three"
[5] VT=2 @ 0x014BCB48 "*3*"
G-Var-Name: VT=3 @ 0x014BCBA8 LB=0 : UB=1 VN=main::c
G-Var-Value: 
[0] VT=2 @ 0x014BCC08 "JRS"
LB=1 : UB=3 VN=[1]
[1] VT=3 @ 0x014BCCC8 
[1] VT=0 @ 0x014BCD88 1
[2] VT=1 @ 0x014BCEA8 0.200000
[3] VT=2 @ 0x014BD5C8 "*3*"
Line: 22
-> ?s
Value: "JRS"
Line: 22
-> ?b
Value: 
[0] VT=2 @ 0x014BC7F8 "One"
[1] VT=0 @ 0x014BC8B8 1
[2] VT=2 @ 0x014BC968 "Two"
[3] VT=1 @ 0x014BCA28 0.200000
[4] VT=2 @ 0x014BCAE8 "Three"
[5] VT=2 @ 0x014BCB48 "*3*"
Line: 22
-> r
Done
Debug session closed.
jrs@laptop:~/sb/sb22/sbt$


11
What's New / SBT - Script BASIC Tutorial API extension module
« on: May 06, 2015, 01:14:26 am »
I have embedded Script BASIC into itself as an easy to use example of the embedding and extension API's. I used the C BASIC C preprocessor defines to extend Script BASIC's extensive macro and define definitions in the interface.c design for readability.

Current SBT Download Attached


SBT interface.c
/*  SBT (Script BASIC Tutorial) - Extension Module */

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <math.h>
#include <time.h>
#include <unistd.h>
#include "../../basext.h"
#include "../../scriba.h"
#include "cbasic.h"


/****************************
 Extension Module Functions
****************************/


besVERSION_NEGOTIATE
  RETURN_FUNCTION((int)INTERFACE_VERSION);
besEND

besSUB_START
  DIM AS long PTR p;
  besMODULEPOINTER = besALLOC(sizeof(long));
  IF (besMODULEPOINTER EQ NULL) THEN_DO RETURN_FUNCTION(0);
  p = (long PTR)besMODULEPOINTER;
  RETURN_FUNCTION(0);
besEND

besSUB_FINISH
  DIM AS long PTR p;
  p = (long PTR)besMODULEPOINTER;
  IF (p EQ NULL) THEN_DO RETURN_FUNCTION(0);
  RETURN_FUNCTION(0);
besEND


/**********************
 Script BASIC Instance
**********************/


/******************
 Support Routines
******************/


struct _RunServiceProgram {
  char *pszProgramFileName;
  char *pszCmdLineArgs;
  char *pszConfigFileName;
  pSbProgram pTProgram;
  int iRestart;
  };
 
static void ExecuteProgramThread(void *p){
  pSbProgram pProgram;
  char szInputFile[1024];
  int iErrorCode;
  struct _RunServiceProgram *pRSP;
  pRSP = p;
  strcpy(szInputFile,pRSP->pszProgramFileName);
  pProgram = scriba_new(malloc,free);
  pRSP->pTProgram = pProgram;
  if( pProgram == NULL )return;
  scriba_SetFileName(pProgram,szInputFile);
  if (pRSP->pszConfigFileName != NULL){
        strcpy(szInputFile,pRSP->pszConfigFileName);
        scriba_LoadConfiguration(pProgram, pRSP->pszConfigFileName);
  }else{
        scriba_SetProcessSbObject(pProgram,pProgram);
  }    
  scriba_LoadSourceProgram(pProgram);
  if (pRSP->pszCmdLineArgs != NULL){
        strcpy(szInputFile,pRSP->pszCmdLineArgs);
    iErrorCode = scriba_Run(pProgram,pRSP->pszCmdLineArgs);
  }else{
    iErrorCode = scriba_Run(pProgram,NULL);
  }    
//  scriba_destroy(pProgram);
  return;
}

besFUNCTION(SB_New)
  DIM AS pSbProgram sbobj;
  sbobj = scriba_new(malloc,free);
  besRETURN_LONG(sbobj);
besEND

besFUNCTION(SB_Configure)
  DIM AS unsigned long sbobj;
  DIM AS char PTR cfgfilename;
  DIM AS int rtnval = -1;
  besARGUMENTS("iz")
    AT sbobj, AT cfgfilename
  besARGEND
  rtnval = scriba_LoadConfiguration(sbobj, cfgfilename);
  besRETURN_LONG(rtnval);
besEND

besFUNCTION(SB_Load)
  DIM AS unsigned long sbobj;
  DIM AS char PTR sbfilename;
  DIM AS int rtnval = -1;
  besARGUMENTS("iz")
    AT sbobj, AT sbfilename
  besARGEND
  rtnval = scriba_SetFileName(sbobj, sbfilename);
  scriba_LoadSourceProgram(sbobj);
  besRETURN_LONG(rtnval);
besEND

besFUNCTION(SB_LoadStr)
  DIM AS unsigned long sbobj;
  DIM AS char PTR sbpgm;
  DIM AS int rtnval = -1;
  besARGUMENTS("iz")
    AT sbobj, AT sbpgm
  besARGEND
  scriba_SetFileName(sbobj, "fake");
  rtnval = scriba_LoadProgramString(sbobj, sbpgm, strlen(sbpgm));
  besRETURN_LONG(rtnval);
besEND

besFUNCTION(SB_Run)
  DIM AS unsigned long sbobj;
  DIM AS int rtnval;
  DIM AS char PTR sbcmdline;
  besARGUMENTS("iz")
    AT sbobj, AT sbcmdline
  besARGEND
  IF (besARGNR < 2) THEN_DO sbcmdline = "";
  rtnval = scriba_Run(sbobj, sbcmdline);
  besRETURN_LONG(rtnval);
besEND

besFUNCTION(SB_NoRun)
  DIM AS unsigned long sbobj;
  DIM AS int rtnval;
  besARGUMENTS("i")
    AT sbobj
  besARGEND
  rtnval = scriba_NoRun(sbobj);
  besRETURN_LONG(rtnval);
besEND

besFUNCTION(SB_ThreadStart)
  DIM AS struct _RunServiceProgram PTR pRSP;
  DIM AS THREADHANDLE T;
  DIM AS char PTR pszProgramFileName;
  DIM AS char PTR pszCmdLineArgs;
  DIM AS char PTR pszConfigFileName;
  DIM AS unsigned long rtnval;
  besARGUMENTS("z[z][z]")
    AT pszProgramFileName, AT pszCmdLineArgs, AT pszConfigFileName
  besARGEND
  pRSP = (struct _RunServiceProgram PTR)malloc( sizeof(struct _RunServiceProgram) );
  pRSP->pszProgramFileName = (char PTR)malloc(strlen(pszProgramFileName) + 1);  
  strcpy(pRSP->pszProgramFileName,pszProgramFileName);
  IF (pszCmdLineArgs NE NULL) THEN
    pRSP->pszCmdLineArgs = (char PTR)malloc(strlen(pszCmdLineArgs) + 1);  
    strcpy(pRSP->pszCmdLineArgs,pszCmdLineArgs);
  ELSE
        pRSP->pszCmdLineArgs = NULL;
  END_IF
  IF (pszConfigFileName NE NULL) THEN
    pRSP->pszConfigFileName = (char PTR)malloc(strlen(pszConfigFileName) + 1);  
    strcpy(pRSP->pszConfigFileName,pszConfigFileName);
  ELSE
        pRSP->pszConfigFileName = NULL;
  END_IF
  pRSP->iRestart = 0;
  thread_CreateThread(AT T,ExecuteProgramThread,pRSP);
  usleep(500);
  rtnval = pRSP->pTProgram;
  besRETURN_LONG(rtnval);
besEND

besFUNCTION(SB_ThreadEnd)
  thread_ExitThread();
  besRETURNVALUE = NULL;
besEND

besFUNCTION(SB_Destroy)
  DIM AS unsigned long sbobj;
  besARGUMENTS("i")
    AT sbobj
  besARGEND
  scriba_destroy(sbobj);
  RETURN_FUNCTION(0);
besEND

besFUNCTION(SB_CallSub)
  DIM AS unsigned long sbobj;
  DIM AS int funcsernum;
  DIM AS char PTR funcname;
  besARGUMENTS("iz")
    AT sbobj, AT funcname
  besARGEND
  funcsernum = scriba_LookupFunctionByName(sbobj, funcname);
  besRETURN_LONG(scriba_Call(sbobj, funcsernum));
besEND

besFUNCTION(SB_CallSubArgs)
  DIM AS VARIABLE Argument;
  DIM AS SbData ArgData[8];
  DIM AS SbData FunctionResult;
  DIM AS unsigned long sbobj;
  DIM AS char PTR funcname;
  DIM AS int i, sbtype, fnsn;

  Argument = besARGUMENT(1);
  besDEREFERENCE(Argument);
  sbobj = LONGVALUE(Argument);

  Argument = besARGUMENT(2);
  besDEREFERENCE(Argument);
  funcname = STRINGVALUE(Argument);

  DEF_FOR (i = 3 TO i <= besARGNR STEP INCR i)
  BEGIN_FOR
    Argument = besARGUMENT(i);
    besDEREFERENCE(Argument);
    SELECT_CASE (sbtype = TYPE(Argument))
    BEGIN_SELECT
      CASE VTYPE_LONG:
        ArgData[i-3] = PTR scriba_NewSbLong(sbobj, LONGVALUE(Argument));
        END_CASE
      CASE VTYPE_DOUBLE:
        ArgData[i-3] = PTR scriba_NewSbDouble(sbobj, DOUBLEVALUE(Argument));
        END_CASE
      CASE VTYPE_STRING:
        ArgData[i-3] = PTR scriba_NewSbString(sbobj, STRINGVALUE(Argument));
        END_CASE
      CASE_ELSE
        ArgData[i-3] = PTR scriba_NewSbUndef(sbobj);
        END_CASE
    END_SELECT
  NEXT

  fnsn = scriba_LookupFunctionByName(sbobj, funcname);
  scriba_CallArgEx(sbobj, fnsn, AT FunctionResult, besARGNR - 2, AT ArgData);

  SELECT_CASE (FunctionResult.type)
  BEGIN_SELECT
    CASE SBT_LONG:
      besRETURN_LONG(FunctionResult.v.l);
      END_CASE
    CASE SBT_DOUBLE:
      besRETURN_DOUBLE(FunctionResult.v.d);
      END_CASE
    CASE SBT_STRING:
      besRETURN_STRING(FunctionResult.v.s);
      END_CASE
    CASE SBT_UNDEF:
      besRETURNVALUE = NULL;
      END_CASE
  END_SELECT
besEND

besFUNCTION(SB_GetVar)
  DIM AS pSbData varobj;
  DIM AS unsigned long sbobj;
  DIM AS int vsn;
  DIM AS char PTR varname;
  besARGUMENTS("iz")
    AT sbobj, AT varname
  besARGEND
  vsn = scriba_LookupVariableByName(sbobj, varname);
  scriba_GetVariable(sbobj, vsn, AT varobj);
  SELECT_CASE (scriba_GetVariableType(sbobj, vsn))
  BEGIN_SELECT
    CASE SBT_LONG   :
      besRETURN_LONG(varobj[0].v.l);
      END_CASE
    CASE SBT_DOUBLE :
      besRETURN_DOUBLE(varobj[0].v.d);
      END_CASE
    CASE SBT_STRING :
      besRETURN_STRING(varobj[0].v.s);
      END_CASE
    CASE SBT_UNDEF  :
      besRETURNVALUE = NULL;;
      END_CASE
  END_SELECT
besEND

besFUNCTION(SB_SetUndef)
  DIM AS pSbData varobj;
  DIM AS unsigned long sbobj;
  DIM AS int vsn;
  DIM AS char PTR varname;
  besARGUMENTS("iz")
    AT sbobj, AT varname
  besARGEND
  vsn = scriba_LookupVariableByName(sbobj, varname);
  besRETURN_LONG(scriba_SetVariable(sbobj, vsn, SBT_UNDEF, NULL, 0, "", 0));
besEND

besFUNCTION(SB_SetInt)
  DIM AS VARIABLE Argument;
  DIM AS pSbData varobj;
  DIM AS unsigned long sbobj;
  DIM AS int vsn, usrval, i;
  DIM AS char PTR varname;
  IF (besARGNR < 3) THEN_DO RETURN_FUNCTION(EX_ERROR_TOO_FEW_ARGUMENTS);
  DEF_FOR (i = 1 TO i <= 3 STEP INCR i)
  BEGIN_FOR
    Argument = besARGUMENT(i);
    besDEREFERENCE(Argument);
    IF (i EQ 1) THEN_DO sbobj = LONGVALUE(Argument);
    IF (i EQ 2) THEN_DO varname = STRINGVALUE(Argument);
    IF (i EQ 3) THEN_DO usrval = LONGVALUE(Argument);
  NEXT
  vsn = scriba_LookupVariableByName(sbobj, varname);
  besRETURN_LONG(scriba_SetVariable(sbobj, vsn, SBT_LONG, usrval, 0, "", 0));
besEND

besFUNCTION(SB_SetDbl)
  DIM AS VARIABLE Argument;
  DIM AS pSbData varobj;
  DIM AS unsigned long sbobj;
  DIM AS int vsn, i;
  DIM AS char PTR varname;
  DIM AS double usrval;
  IF (besARGNR < 3) THEN_DO RETURN_FUNCTION(EX_ERROR_TOO_FEW_ARGUMENTS);
  DEF_FOR (i = 1 TO i <= 3 STEP INCR i)
  BEGIN_FOR
    Argument = besARGUMENT(i);
    besDEREFERENCE(Argument);
    IF (i EQ 1) THEN_DO sbobj = LONGVALUE(Argument);
    IF (i EQ 2) THEN_DO varname = STRINGVALUE(Argument);
    IF (i EQ 3) THEN_DO usrval = DOUBLEVALUE(Argument);
  NEXT
  vsn = scriba_LookupVariableByName(sbobj, varname);
  besRETURN_LONG(scriba_SetVariable(sbobj, vsn,  SBT_DOUBLE, 0, usrval, "", 0));
besEND

besFUNCTION(SB_SetStr)
  DIM AS VARIABLE Argument;
  DIM AS pSbData varobj;
  DIM AS unsigned long sbobj;
  DIM AS int vsn, i;
  DIM AS char PTR varname;
  DIM AS char PTR usrval;
  IF (besARGNR < 3) THEN_DO RETURN_FUNCTION(EX_ERROR_TOO_FEW_ARGUMENTS);
  DEF_FOR (i = 1 TO i <= 3 STEP INCR i)
  BEGIN_FOR
    Argument = besARGUMENT(i);
    besDEREFERENCE(Argument);
    IF (i EQ 1) THEN_DO sbobj = LONGVALUE(Argument);
    IF (i EQ 2) THEN_DO varname = STRINGVALUE(Argument);
    IF (i EQ 3) THEN_DO usrval = STRINGVALUE(Argument);
  NEXT
  vsn = scriba_LookupVariableByName(sbobj, varname);
  besRETURN_LONG(scriba_SetVariable(sbobj, vsn,  SBT_STRING, 0, 0, usrval, strlen(usrval)));
besEND

besFUNCTION(SB_ResetVars)
  DIM AS unsigned long sbobj;
  besARGUMENTS("i")
    AT sbobj
  besARGEND
  scriba_ResetVariables(sbobj);
  besRETURNVALUE = NULL;
besEND
 
sbt.inc
DECLARE SUB SB_New ALIAS "SB_New" LIB "sbt"
DECLARE SUB SB_Configure ALIAS "SB_Configure" LIB "sbt"
DECLARE SUB SB_Load ALIAS "SB_Load" LIB "sbt"
DECLARE SUB SB_LoadStr ALIAS "SB_LoadStr" LIB "sbt"
DECLARE SUB SB_Run ALIAS "SB_Run" LIB "sbt"
DECLARE SUB SB_NoRun ALIAS "SB_NoRun" LIB "sbt"
DECLARE SUB SB_ThreadStart ALIAS "SB_ThreadStart" LIB "sbt"
DECLARE SUB SB_ThreadEnd ALIAS "SB_ThreadEnd" LIB "sbt"
DECLARE SUB SB_GetVar ALIAS "SB_GetVar" LIB "sbt"
DECLARE SUB SB_SetUndef ALIAS "SB_SetUndef" LIB "sbt"
DECLARE SUB SB_SetInt ALIAS "SB_SetInt" LIB "sbt"
DECLARE SUB SB_SetDbl ALIAS "SB_SetDbl" LIB "sbt"
DECLARE SUB SB_SetStr ALIAS "SB_SetStr" LIB "sbt"
DECLARE SUB SB_ResetVars ALIAS "SB_ResetVars" LIB "sbt"
DECLARE SUB SB_CallSub ALIAS "SB_CallSub" LIB "sbt"
DECLARE SUB SB_CallSubArgs ALIAS "SB_CallSubArgs" LIB "sbt"
DECLARE SUB SB_Destroy ALIAS "SB_Destroy" LIB "sbt"
 
sbtdemo.sb
' SBT (Script BASIC Tutorial) - Example Script

IMPORT sbt.inc

sb_code = """
FUNCTION prtvars(a, b, c)
  PRINT a,"
\\n"
  PRINT FORMAT("
%g\\n", b)
  PRINT c,"
\\n"
  prtvars = "
Function Return"
END FUNCTION

a = 0
b = 0
c = "
"
"
""

sb = SB_New()
SB_Configure sb, "/etc/scriba/basic.conf"
SB_LoadStr sb, sb_code
SB_NoRun sb
funcrtn = SB_CallSubArgs(sb,"main::prtvars", 123, 1.23, "One, Two, Three")
PRINT funcrtn,"\n"
SB_Run sb, ""
SB_SetInt sb, "main::a", 321
SB_SetDbl sb, "main::b", 32.1
SB_SetStr sb, "main::c", "Three,Two,One"
SB_CallSubArgs sb, "main::prtvars", _
          SB_GetVar(sb, "main::a"), _
          SB_GetVar(sb, "main::b"), _
          SB_GetVar(sb, "main::c")      
SB_Destroy sb
 
Output

jrs@laptop:~/sb/sb22/sbt$ time scriba sbtdemo.sb
123
1.23
One, Two, Three
Function Return
321
32.1
Three,Two,One

real   0m0.007s
user   0m0.007s
sys   0m0.000s
jrs@laptop:~/sb/sb22/sbt$


12
Business BASIC Migrations / Business BASIC Helper Library
« on: May 04, 2015, 08:30:51 am »
Here are a few ProvideX Business Basic like functions that can be used to help with your conversion to Script BASIC.

' BB Function Helper Library


' BB_ATH - Business BASIC ATH() function
'
' Converts a text string of hex character pairs to ASCII values.
'
FUNCTION BB_ATH(HexStr)

  LOCAL LenHex, AsciiStr, HexTable, ScanPos, HiByte, LowByte
  LenHex = LEN(HexStr)
  IF LenHex % 2 = 0 THEN
    HexTable = "0123456789ABCDEF"
    FOR ScanPos = 1 TO LenHex STEP 2
      HiByte = INSTR(HexTable,UCASE(MID(HexStr, ScanPos, 1))) - 1
      LowByte = INSTR(HexTable,UCASE(MID(HexStr, ScanPos + 1, 1))) - 1
      IF ISINTEGER(HiByte) AND ISINTEGER(LowByte) THEN
        AsciiStr &= CHR(HiByte * 16 + LowByte)
      ELSE
        AsciiStr = ""
        GOTO Exit_For        
      END IF
    NEXT ScanPos
    Exit_For:
  ELSE
    AsciiStr = ""
  END IF
  BB_ATH = AsciiStr

END FUNCTION


' BB_CVS - Business Basic CVS() function
'
' Action:
'  1   = Remove Leading characters
'  2   = Remove Trailing characters
'  4   = Convert String to Upper Case
'  8   = Convert String to Lower Case
'  16  = Replace characters < 32 with the control character
'  32  = Replace multiple occurrence of the character with one
'  64  = * Replace $ with defined Windows currency symbol
'  128 = * Replace defined Windows currency, comma and thousand symbol
'  256 = * Ucase first char of each word, rest to lower
'    * = Not implemented yet.
'
FUNCTION BB_CVS(StrExpr, Action, CtrlChar)

  LOCAL Char, ExprLen, TempStr, ScanPos
  IF CtrlChar = undef THEN CtrlChar = " "
  Char = ASC(CtrlChar)
 
  ' Remove Leading characters
 IF (Action AND 1) THEN  
    ExprLen = LEN(StrExpr)
    IF CtrlChar = " " THEN
      StrExpr = LTRIM(StrExpr)
    ELSE
      TempStr = ""
      FOR ScanPos = 1 TO ExprLen
        IF MID(StrExpr, ScanPos, 1) <> CtrlChar THEN TempStr &= MID(StrExpr, ScanPos, 1)
      NEXT ScanPos
      StrExpr = TempStr
    END IF
  END IF
 
  ' Remove Trailing characters
 IF (Action AND 2) THEN  
    ExprLen = LEN(StrExpr)
    IF CtrlChar = " " THEN
      StrExpr = RTRIM(StrExpr)
    ELSE
      TempStr = ""
      FOR ScanPos = ExprLen TO 1 STEP - 1
        IF MID(StrExpr, ScanPos, 1) = CtrlChar THEN TempStr = LEFT(StrExpr, ScanPos - 1)
      NEXT ScanPos
      IF LEN(TempStr) THEN StrExpr = TempStr
    END IF
  END IF
 
  ' Convert String to Upper Case
 IF (Action AND 4) THEN  
    StrExpr = UCASE(StrExpr)
  END IF
 
  ' Convert String to Lower Case
 IF (Action AND 8) THEN  
    StrExpr = LCASE(StrExpr)
  END IF
 
  ' Replace characters < 32 with the control character
 IF (Action AND 16) THEN  
    FOR ScanPos = 1 TO LEN(StrExpr)
         IF ASC(MID(StrExpr, ScanPos, 1)) < 32 THEN StrExpr = LEFT(StrExpr, ScanPos -1) & CtrlChar & MID(StrExpr, ScanPos + 1)
    NEXT ScanPos
  END IF
 
  ' Replace multiple occurence of the character with one
 IF (Action AND 32) THEN  
    HitCnt = 0
    StartPos = 1
    NextPos:
    ScanPos = INSTR(StrExpr,CtrlChar,StartPos)
    IF ISINTEGER(ScanPos) THEN
      IF HitCnt THEN  
        IF ASC(MID(StrExpr, ScanPos,1)) = CtrlChar THEN TeStrExpr = LEFT(StrExpr, ScanPos -1) & MID(StrExpr, ScanPos + 1)
      ELSE
        HitCnt += 1
      END IF
      StartPos += 1
      GOTO NextPos
    END IF
  END IF        
  BB_CVS = StrExpr

END FUNCTION


' BB_DEC - Business BASIC DEC() function
'
' Returns a two's complement binary equivalent of the string.
'
FUNCTION BB_DEC(BinStr)                                  

  LOCAL i, d                                      
  FOR i = LEN(BinStr) TO 1 STEP -1                        
    d += ASC(MID(BinStr,i,1)) * 256 ^ ABS(i - LEN(BinStr))
  NEXT i                                                    
  BB_DEC = d                                                

END FUNCTION                                              


' BB_HTA - Business BASIC HTA() function
'
' Returns the hexadecimal text string of the pasted argument string.
'
FUNCTION BB_HTA(AsciiStr)
  LOCAL AsciiLen,ScanPos,HexStr
  AsciiLen = LEN(AsciiStr)
  IF AsciiLen THEN
    FOR ScanPos = 1 TO AsciiLen
      HexStr &= RIGHT("0" & HEX(ASC(MID(AsciiStr, ScanPos, 1))),2)
    NEXT ScanPos
  ELSE
    HexStr = ""
  END IF
  BB_HTA = HexStr
END FUNCTION


' BB_JUL - Business BASIC JUL() function
'
' Converts a date from year, month, day to a Julian date.
'
FUNCTION BB_JUL(Y,M,D)

  IF Y = undef AND M = undef AND D = undef THEN
    BB_JUL = NOW
  ELSE
    BB_JUL = TIMEVALUE(Y,M,D)
  END IF
 
END FUNCTION


' BB_LRC - Business Basic LRC() function.
'
' Returns a one byte string containing the longitudinal redundancy checksum of a character string.
'
FUNCTION BB_LRC(ArgStr)

  LOCAL ArgStrLen, ScanPos, LRCVal
  LRCVal = 0
  ArgStrLen = LEN(ArgStr)
  IF ArgStrLen THEN
    FOR ScanPos = 1 TO ArgStrLen
      LRCVal += LRCVal XOR ASC(MID(ArgStr, ScanPos, 1))
    NEXT ScanPos
    BB_LRC = CHR(LRCVal)
  ELSE
    BB_LRC = CHR(&H00)
  END IF

END FUNCTION


' BB_PAD - Business BASIC PAD() funtion
'
' Returns a character string of the length specified (NumExpr)
'
' NOTE: StrExpr    = String to be processed
'       NewLen     = Desired length of string
'       HowToPad   = This parameter defines how to pad the string
'                     0 - Pad on left  (right justify)
'                     1 - Pad on right (left justify)
'                     2 - Center in string
'       StrPad     = First character of this string used to pad StrExpr
'
FUNCTION BB_PAD(StrExpr,NewLen,HowToPad,StrPad)

  LOCAL StrExpr,NewLen,HowToPad,StrPad,PadVal,StrExprLen,ResultStr,RLPLen
  IF HowToPad = undef THEN
    PadVal = 1
  ELSE IF HowToPad = 0 OR UCASE(HowToPad) = "L" THEN
    PadVal = 0
  ELSE IF HowToPad = 1 OR UCASE(HowToPad) = "R" THEN  
    PadVal = 1
  ELSE IF HowToPad = 2 OR UCASE(HowToPad) = "C" THEN      
    PadVal = 2
  ELSE
    BB_ERR = 41
    BB_PAD = ""
    EXIT FUNCTION
  END IF
 
  IF StrPad = undef THEN StrPad = " "
  StrExprLen = LEN(StrExpr)
 
  IF PadVal = 0 THEN
    IF NewLen < StrExprLen THEN
      ResultStr = RIGHT(StrExpr, NewLen)
    ELSE
      ResultStr = STRING(NewLen - StrExprLen, StrPad) & StrExpr
    END IF
  END IF

  IF PadVal = 1 THEN
    IF NewLen < StrExprLen THEN
      ResultStr = LEFT(StrExpr, NewLen)
    ELSE
      ResultStr = StrExpr & STRING(NewLen - StrExprLen, StrPad)
    END IF
  END IF

  IF PadVal = 2 THEN
    IF NewLen < StrExprLen THEN
      ResultStr = LEFT(StrExpr, NewLen)
    ELSE
      RLPLen = (NewLen - StrExprLen) / 2
      IF RLPLen % 2 THEN
        ResultStr = STRING(FIX(RLPLen),StrPad) & StrExpr & STRING(FIX(RLPLen) + 1,StrPad)
      ELSE
        ResultStr = STRING(RLPLen,StrPad) & StrExpr & STRING(RLPLen,StrPad)
      END IF
    ENDIF
  END IF

  BB_PAD = ResultStr
 
END FUNCTION


' BB_POS - Business Basic POS() function
'
' BB_POS follows these logic steps:
'
' 1. If stringA or StringB is null, return 0
' 2. Start with first byte in stringB if intA is positive, or the Nth byte
'    from the end of stringB if intA is negatine (-N).
' 3. If past either the begining or end of stringB then return 0
'    (or occurrence count if intB is 0)
' 4. Compare stringA with the substring at the current position in stringB.
'    The length of substring will be either the length of stringA or the
'    remainder of stringB, whichever is shorter.
' 5. If a given releationship is true and if this was the Nth successful
'    try (specified by intB=N) then return the current scan position.
' 6. If the relation was not satisfied then bump the scan position
'    (possibly backwards if intA is negative) and go to step 3 and try again.
'
' Relationship Operators:
'
' "="   -   Equal To
' "<"   -   Less Than
' ">"   -   Greater Than
' "<="  -   Less Than Or Equal To
' ">="  -   Greater Than Or Equal To
' "<>"  -   Not Equal To
' ":"   -   Equal to Any
' "^"   -   Not Equal To Any
'
FUNCTION BB_POS(MatchStr,ScanStr,Relate,IncVal,OccurVal)
 
  LOCAL LenMatchStr,LenScanStr,ScanPos,OccurCnt,Item,StartVal,EndVal
  IF Relate = undef THEN Relate = "="
  IF IncVal = undef  THEN IncVal = 1
  IF OccurVal = undef  THEN OccurVal = 1
  LenMatchStr = LEN(MatchStr)
  IF INSTR(":^", Relate) THEN LenMatchStr = 1
  LenScanStr = LEN(ScanStr)
  IF LenMatchStr = 0 OR LenScanStr = 0 OR OccurVal < 0 THEN
    BB_POS = 0
    EXIT FUNCTION
  END IF
  IF IncVal > 0 THEN
    StartVal = 1
    EndVal = LenScanStr
  ELSE
    StartVal = LenScanStr
    EndVal = 1
  END IF
  FOR ScanPos = StartVal TO EndVal STEP IncVal
    Item = MID(ScanStr, ScanPos, LenMatchStr)
    IF Relate = "=" THEN
      IF MatchStr = Item THEN OccurCnt += 1
    ELSE IF Relate = "<" THEN
      IF MatchStr < Item THEN OccurCnt += 1
    ELSE IF Relate = ">" THEN
      IF MatchStr > Item THEN OccurCnt += 1
    ELSE IF Relate = "<=" OR Relate = "=<" THEN
      IF MatchStr <= Item THEN OccurCnt += 1
    ELSE IF Relate = ">=" OR Relate = "=>" THEN
      IF MatchStr >= Item THEN OccurCnt += 1
    ELSE IF Relate = "<>" OR Relate = "><" THEN
      IF MatchStr <> Item THEN OccurCnt += 1
    ELSE IF Relate = ":" THEN
      IF INSTR(MatchStr, Item) THEN OccurCnt += 1
    ELSE IF Relate = "^" THEN
      IF NOT ISNUMERIC(INSTR(MatchStr, Item)) THEN OccurCnt += 1
    ELSE
      BB_POS = 0
      EXIT FUNCTION
    END IF
    IF OccurVal > 0 THEN
      IF OccurCnt = OccurVal THEN GOTO Done
    END IF
  NEXT ScanPos
 
  Done:
 
  IF OccurVal = 0 THEN
    BB_POS = OccurCnt
  ELSE IF OccurCnt THEN
    BB_POS = ScanPos
  ELSE
    BB_POS = 0  
  END IF
 
END FUNCTION
 
bbtest.sb
' bb.inc test script

IMPORT bb.inc


PRINT "HTA()\n"
hta = BB_HTA("Script BASIC")
PRINT hta,"\n\n"
PRINT "ATH()\n"
PRINT BB_ATH(hta),"\n\n"
PRINT "PAD()\n"
s = BB_PAD("BASIC",10,2," ")
PRINT "|" & s & "|\n\n"
PRINT "POS()\n"
s = "The quick brown fox"
' yields 5
PRINT BB_POS("q",s,"="),"\n"
' yields 0
PRINT BB_POS("z",s,"="),"\n"
' yields 13
PRINT BB_POS("o",s,"=") ,"\n"
' yields 18 - Scan from end (fox)
PRINT BB_POS("o",s,"=",-1),"\n"
' yields 18 - Second occurrence (fox)
PRINT BB_POS("o",s,"=",1,2),"\n"
' yields 13 - Checks every 2nd position
PRINT BB_POS("o",s,"=",2),"\n"
' yields 6 - "u" is first char. > "r"
PRINT BB_POS("r",s,"<"),"\n"
PRINT "CVS()\n"
s = "  sb  "
PRINT "|" & BB_CVS(s,3," "),"|\n"
PRINT "|" & BB_CVS(s,4,""),"|\n\n"
 
Output

jrs@laptop:~/sb/sb22/PHB$ time scriba bbtest.sb
HTA()
536372697074204241534943

ATH()
Script BASIC

PAD()
|  BASIC  |

POS()
5
0
13
18
18
13
6
CVS()
|sb|
|  SB  |


real   0m0.026s
user   0m0.022s
sys   0m0.004s
jrs@laptop:~/sb/sb22/PHB$


13
MY-BASIC / MY-BASIC Extension Module
« on: April 25, 2015, 04:35:40 am »
Here is an example of the new MY-BASIC extension module for Script BASIC. Attached is the Windows 32 bit and Linux (Ubuntu) 64 bit shared objects. (dll/so)

interface.c
// MY-BASIC - Script BASIC extension module

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <stdarg.h>
#include <ctype.h>
#include <math.h>
#include <time.h>
#include "../../basext.h"
#include "cbasic.h"

#include "my_basic.h"


/****************************
 Extension Module Functions
****************************/


besVERSION_NEGOTIATE
  RETURN_FUNCTION((int)INTERFACE_VERSION);
besEND

besSUB_START
  DIM AS long PTR p;
  besMODULEPOINTER = besALLOC(sizeof(long));
  IF (besMODULEPOINTER EQ NULL) THEN_DO RETURN_FUNCTION(0);
  p = (long PTR)besMODULEPOINTER;
  RETURN_FUNCTION(0);
besEND

besSUB_FINISH
  DIM AS long PTR p;
  p = (long PTR)besMODULEPOINTER;
  IF (p EQ NULL) THEN_DO RETURN_FUNCTION(0);
  RETURN_FUNCTION(0);
besEND


/********************
 MY-BASIC Functions
********************/


static struct mb_interpreter_t* bas = 0;

static int watch(struct mb_interpreter_t* s, void** l) {
  int result = MB_FUNC_OK;
  int_t arg = 0;
  mb_assert(s && l);
  mb_check(mb_attempt_open_bracket(s, l));
  mb_check(mb_pop_int(s, l, &arg)); // That's it!
  mb_check(mb_attempt_close_bracket(s, l));
  // arg is what you want.
  return result;
}

besFUNCTION(mbas_init)
  besRETURN_LONG(mb_init());
besEND

besFUNCTION(mbas_dispose)
  besRETURN_LONG(mb_dispose());
besEND

besFUNCTION(mbas_open)
  besRETURN_LONG(mb_open(AT bas));
besEND

besFUNCTION(mbas_close)
  besRETURN_LONG(mb_close(AT bas));
besEND

besFUNCTION(mbas_load_str)
  DIM AS const char PTR pgm;
  besARGUMENTS("z")
    AT pgm
  besARGEND
  besRETURN_LONG(mb_load_string(bas, pgm));
besEND

besFUNCTION(mbas_load_file)
  DIM AS const char PTR pgm;
  besARGUMENTS("z")
    AT pgm
  besARGEND
  besRETURN_LONG(mb_load_file(bas, pgm));
besEND

besFUNCTION(mbas_run)
  besRETURN_LONG(mb_run(bas));
besEND

besFUNCTION(mbas_reset)
  besRETURN_LONG(mb_reset(bas, false));
besEND

besFUNCTION(mbas_getint)
  DIM AS mb_value_t mbval;
  DIM AS const char PTR varname;
  besARGUMENTS("z")
    AT varname
  besARGEND
  mbval.type = MB_DT_INT;
  mb_debug_get(bas, varname, &mbval);
  besRETURN_LONG(mbval.value.integer);
besEND

besFUNCTION(mbas_getdbl)
  DIM AS mb_value_t mbval;
  DIM AS const char PTR varname;
  besARGUMENTS("z")
    AT varname
  besARGEND
  mbval.type = MB_DT_REAL;
  mb_debug_get(bas, varname, &mbval);
  besRETURN_DOUBLE(mbval.value.float_point);
besEND

besFUNCTION(mbas_getstr)
  DIM AS mb_value_t mbval;
  DIM AS const char PTR varname;
  besARGUMENTS("z")
    AT varname
  besARGEND
  mbval.type = MB_DT_STRING;
  mb_debug_get(bas, varname, &mbval);
  besRETURN_STRING(mbval.value.string);
besEND

besFUNCTION(mbas_setint)
  DIM AS VARIABLE Argument;
  DIM AS mb_value_t mbval;
  DIM AS int usrval, i, rtnval;
  DIM AS const char PTR varname;
  IF (besARGNR < 2) THEN_DO RETURN_FUNCTION(EX_ERROR_TOO_FEW_ARGUMENTS);
  DEF_FOR (i = 1 TO i <= 2 STEP INCR i)
  BEGIN_FOR
    Argument = besARGUMENT(i);
    besDEREFERENCE(Argument);
    IF (i EQ 1) THEN_DO varname = STRINGVALUE(Argument);
    IF (i EQ 2) THEN_DO usrval = LONGVALUE(Argument);
  NEXT
  mbval.type = MB_DT_INT;
  mbval.value.integer = usrval;
  rtnval = mb_debug_set(bas, varname, mbval);
  besRETURN_LONG(rtnval);
besEND

besFUNCTION(mbas_setdbl)
  DIM AS VARIABLE Argument;
  DIM AS mb_value_t mbval;
  DIM AS int i, rtnval;
  DIM AS double usrval;
  DIM AS const char PTR varname;
  IF (besARGNR < 2) THEN_DO RETURN_FUNCTION(EX_ERROR_TOO_FEW_ARGUMENTS);
  DEF_FOR (i = 1 TO i <= 2 STEP INCR i)
  BEGIN_FOR
    Argument = besARGUMENT(i);
    besDEREFERENCE(Argument);
    IF (i EQ 1) THEN_DO varname = STRINGVALUE(Argument);
    IF (i EQ 2) THEN_DO usrval = DOUBLEVALUE(Argument);
  NEXT
  mbval.type = MB_DT_REAL;
  mbval.value.float_point = usrval;
  rtnval = mb_debug_set(bas, varname, mbval);
  besRETURN_LONG(rtnval);
besEND

besFUNCTION(mbas_setstr)
  DIM AS VARIABLE Argument;
  DIM AS mb_value_t mbval;
  DIM AS int i, rtnval;
  DIM AS const char PTR varname;
  DIM AS const char PTR usrval;
  IF (besARGNR < 2) THEN_DO RETURN_FUNCTION(EX_ERROR_TOO_FEW_ARGUMENTS);
  DEF_FOR (i = 1 TO i <= 2 STEP INCR i)
  BEGIN_FOR
    Argument = besARGUMENT(i);
    besDEREFERENCE(Argument);
    IF (i EQ 1) THEN_DO varname = STRINGVALUE(Argument);
    IF (i EQ 2) THEN_DO usrval = STRINGVALUE(Argument);
  NEXT
  mbval.type = MB_DT_STRING;
  usrval = mb_memdup(usrval, strlen(usrval) + 1);
  mbval.value.string = usrval;
  besRETURN_LONG(mb_debug_set(bas, varname, mbval));
besEND
 
mbvars.sb
DECLARE SUB mb_init ALIAS "mbas_init" LIB "mb"
DECLARE SUB mb_dispose ALIAS "mbas_dispose" LIB "mb"
DECLARE SUB mb_open ALIAS "mbas_open" LIB "mb"
DECLARE SUB mb_close ALIAS "mbas_close" LIB "mb"
DECLARE SUB mb_load_str ALIAS "mbas_load_str" LIB "mb"
DECLARE SUB mb_load_file ALIAS "mbas_load_file" LIB "mb"
DECLARE SUB mb_run ALIAS "mbas_run" LIB "mb"
DECLARE SUB mb_getint ALIAS "mbas_getint" LIB "mb"
DECLARE SUB mb_getdbl ALIAS "mbas_getdbl" LIB "mb"
DECLARE SUB mb_getstr ALIAS "mbas_getstr" LIB "mb"
DECLARE SUB mb_setint ALIAS "mbas_setint" LIB "mb"
DECLARE SUB mb_setdbl ALIAS "mbas_setdbl" LIB "mb"
DECLARE SUB mb_setstr ALIAS "mbas_setstr" LIB "mb"
DECLARE SUB mb_reset ALIAS "mbas_reset" LIB "mb"

mb_init
mb_open
mb_load_file "setvars.bas"
mb_run
mb_setint "A", 123
mb_setdbl "B", 1.23
mb_setstr "C$", "One,Two,Three"
PRINT mb_getint("A"),"\n"
PRINT FORMAT("%g\n", mb_getdbl("B"))
PRINT mb_getstr("C$"),"\n"
mb_close
mb_dispose
 
setvars.bas
Code: [Select]
a = 0
b = 0.0
c$ = ""

Output - Linux 64 bit

jrs@laptop:~/sb/sb22/mybasic$ time scriba mbvars.sb
123
1.23
One,Two,Three

real   0m0.006s
user   0m0.005s
sys   0m0.005s
jrs@laptop:~/sb/sb22/mybasic$


Output - Windows 32 bit

C:\sb22\mybasic>scriba mbvars.sb
123
1.23
One,Two,Three

C:\sb22\mybasic>


14
What's New / Perl Extension Module
« on: April 08, 2015, 04:07:07 pm »
I'm done with the Perl extension module in its current form. I see no purpose going through all the work of calling Perl functions from C directly and having to do all the crazy low level stack stuff. The Perl Eval function does everything I need at the moment and works like the TinyScheme extension module.

DECLARE SUB pl_Init ALIAS "pl_Init" LIB "sbperl"
DECLARE SUB pl_Eval ALIAS "pl_Eval" LIB "sbperl"
DECLARE SUB pl_GetInt ALIAS "pl_GetInt" LIB "sbperl"
DECLARE SUB pl_GetDbl ALIAS "pl_GetDbl" LIB "sbperl"
DECLARE SUB pl_GetStr ALIAS "pl_GetStr" LIB "sbperl"
DECLARE SUB pl_Destroy ALIAS "pl_Destroy" LIB "sbperl"

pl_Init

pl_code = """
sub Average{
   # get total number of arguments passed.
   $n = scalar(@_);
   $sum = 0;

   foreach $item (@_){
      $sum += $item;
   }
   $average = $sum / $n;

   return $average;
}
"
""
pl_Eval pl_code
pl_Eval "$num = Average(10, 20, 30);"
PRINT pl_GetInt("num"),"\n"

pl_Destroy
 

jrs@laptop:~/sb/sb22/test$ scriba perlfunc.sb
20
jrs@laptop:~/sb/sb22/test$


15
What's New / Array Sort
« on: March 30, 2015, 04:59:07 am »
One feature I have always wanted to add to Script BASIC was an array sort function. My first thought was to add the function to the existing T (Tools) extension module. This extension module already contains a wealth of string / array functions written in C. I took a peek at the C qsort function and the source to the GNU sort command line utility.

I decided on prototyping the array sort routine in Script BASIC first before committing to a direction. As it turns out my merge sort effort satisfies my immediate requirements for an array sort function and I added it to the T include.

Note: Duplicates are returned in the result array as one instance.

(T)ools Include File
MODULE T                                                                        
                                                                                 
DECLARE SUB     ::md5              ALIAS "md5fun"         LIB "t"                
DECLARE COMMAND ::ArrayToString    ALIAS "serialize"      LIB "t"                
DECLARE COMMAND ::ArrayToXML       ALIAS "xmlserialize"   LIB "t"                
DECLARE SUB     ::StringToArray    ALIAS "unserialize"    LIB "t"                
DECLARE COMMAND ::Array2String     ALIAS "serialize"      LIB "t"                
DECLARE COMMAND ::Array2XML        ALIAS "xmlserialize"   LIB "t"                
DECLARE SUB     ::String2Array     ALIAS "unserialize"    LIB "t"                
DECLARE COMMAND ::ArrayToStringMD5 ALIAS "md5serialize"   LIB "t"                
DECLARE SUB     ::StringToArrayMD5 ALIAS "md5unserialize" LIB "t"                
DECLARE COMMAND ::Array2StringMD5  ALIAS "md5serialize"   LIB "t"                
DECLARE SUB     ::String2ArrayMD5  ALIAS "md5unserialize" LIB "t"                
DECLARE SUB     ::SaveString       ALIAS "savestring"     LIB "t"                
DECLARE SUB     ::LoadString       ALIAS "loadstring"     LIB "t"                
DECLARE SUB     ::Exit             ALIAS "toolExit"       LIB "t"                
                                                                                 
SUB merge(left_side, right_side, result)                                        
  LOCAL left_size, left_ptr, right_size, right_ptr, result_ptr                  
  left_size = UBOUND(left_side)                                                  
  left_ptr = 0                                                                  
  right_size = UBOUND(right_side)                                                
  right_ptr = 0                                                                  
  result_ptr = 0                                                                
  WHILE left_ptr <= left_size AND right_ptr <= right_size                        
    IF left_side[left_ptr] <= right_side[right_ptr] THEN                        
      result[result_ptr] = left_side[left_ptr]                                  
      left_ptr += 1                                                              
      result_ptr += 1                                                            
    ELSE                                                                        
      result[result_ptr] = right_side[right_ptr]                                
      right_ptr += 1                                                            
      result_ptr += 1                                                            
    END IF                                                                      
  WEND                                                                          
  WHILE left_ptr <= left_size                                                    
    result[result_ptr] = left_side[left_ptr]                                    
    left_ptr += 1                                                                
    result_ptr += 1                                                              
  WEND                                                                          
  WHILE right_ptr <= right_size                                                  
    result[result_ptr] = right_side[right_ptr]                                  
    right_ptr += 1                                                              
    result_ptr += 1                                                              
  WEND                                                                          
END SUB                                                                          
                                                                                 
SUB sort(unsorted)                                                              
  LOCAL left_side, right_side, the_middle, array_size, result, x, y, z          
  array_size = UBOUND(unsorted)                                                  
  IF array_size = 0 THEN                                                        
    EXIT SUB                                                                
  END IF                                                                        
  the_middle = FIX((array_size + 1) / 2)                                        
  y = 0                                                                          
  FOR x = 0 TO the_middle - 1                                                    
    left_side[y] = unsorted[x]                                                  
    y += 1                                                                      
  NEXT                                                                          
  z = 0                                                                          
  FOR x = the_middle TO array_size                                              
    right_side[z] = unsorted[x]                                                  
    z += 1                                                                      
  NEXT                                                                          
  sort(left_side)                                                                
  sort(right_side)                                                              
  merge(left_side, right_side, result)                                          
  unsorted = result                                                              
END SUB                                                                          
                                                                                 
END MODULE                                                                      
 
Example Use
' Script BASIC Array Sort

IMPORT t.bas

s = "pear,cranberry,orange,apple,carrot,banana,grape"
SPLITA s BY "," TO a

t::sort(a)

FOR x = 0 TO UBOUND(a)
  PRINT a[x],"\n"
NEXT
 
Output

jrs@laptop:~/sb/sb22/test$ time scriba sort.sb
apple
banana
carrot
cranberry
grape
orange
pear

real   0m0.008s
user   0m0.007s
sys   0m0.000s
jrs@laptop:~/sb/sb22/test$


As a stress test, I thought I would sort each line in a text version of the Bible. (30383 lines / 4,047,392 bytes)

' Script BASIC Array Sort

IMPORT t.bas

OPEN "bible.txt" FOR INPUT AS #1
s = INPUT(LOF(1),1)
SPLITA s BY "\n" TO a

t::sort(a)

FOR x = UBOUND(a) - 10 TO UBOUND(a)
  PRINT a[x],"\n"
NEXT
 
Output
Code: [Select]
jrs@laptop:~/sb/sb22/test$ time scriba sort.sb
Zebulun and Naphtali were a people that jeoparded their lives unto the death in the high places of the field.
Zebulun shall dwell at the haven of the sea; and he shall be for an haven of ships; and his border shall be unto Zidon.
Zedekiah was one and twenty years old when he began to reign, and he reigned eleven years in Jerusalem. And his mother's name was Hamutal the daughter of Jeremiah of Libnah.
Zedekiah was one and twenty years old when he began to reign, and reigned eleven years in Jerusalem.
Zelek the Ammonite, Naharai the Berothite, the armourbearer of Joab the son of Zeruiah,
Zelek the Ammonite, Nahari the Beerothite, armourbearer to Joab the son of Zeruiah,
Zenan, and Hadashah, and Migdalgad,
Zion heard, and was glad; and the daughters of Judah rejoiced because of thy judgments, O LORD.
Zion shall be redeemed with judgment, and her converts with righteousness.
Zion spreadeth forth her hands, and there is none to comfort her: the LORD hath commanded concerning Jacob, that his adversaries should be round about him: Jerusalem is as a menstruous woman among them.
Ziph, and Telem, and Bealoth,

real 0m13.069s
user 0m12.173s
sys 0m0.810s
jrs@laptop:~/sb/sb22/test$

The array sort routine also works with associative arrays and isn't restricted to a single indies array.

' Script BASIC Array Sort

IMPORT t.bas

s = "pear,apple,cranberry,orange,carrot,banana,grape"
SPLITA s BY "," TO a{"food"}

t::sort(a{"food"})

FOR x = 0 TO UBOUND(a{"food"})
  PRINT a{"food"}[x],"\n"
NEXT  
 

jrs@laptop:~/sb/sb22/test$ scriba arraysort.sb
apple
banana
carrot
cranberry
grape
orange
pear
jrs@laptop:~/sb/sb22/test$


Pages: [1] 2 3 ... 11