TinyScheme is a lightweight Scheme interpreter that implements as large a subset of R5RS as was possible without getting very large and complicated. It is meant to be used as an embedded scripting interpreter for other programs. As such, it does not offer IDEs or extensive toolkits although it does sport a small top-level loop, included conditionally. A lot of functionality in TinyScheme is included conditionally, to allow developers freedom in balancing features and footprint.
As an embedded interpreter, it allows multiple interpreter states to coexist in the same program, without any interference between them. Programmatically, foreign functions in C can be added and values can be defined in the Scheme environment. Being a quite small program, it is easy to comprehend, get to grips with, and use. TinyScheme was grown out of the MiniScheme distribution during the development of Ovrimos.
//
// Tiny example of embedding TinyScheme in your code
// by Dmitry Chestnykh <dmitry@codingrobots.com>
// Public domain
//
//
// Compile
// --------
// $ cc example.c -L./ -ltinyscheme -o example
//
// Note: if you want to statically, link, first compile tinyscheme as NOT standalone.
// To do this, change scheme.h: # define STANDALONE 0 (instead of 1)
// Then 'make'. Forget about errors. Remove libtinyscheme.so (leave only static library .a)
// And then compile this example as written above.
//
//
// Run
// ---
// $ ./example
//
// Output
// --------------
// Hello, world!
// Answer: 42
#include <stdio.h>
#define USE_INTERFACE 1
#include "scheme.h"
#include "scheme-private.h"
// display -- scheme function
// Example: (display "Hello")
// This version only displays strings
pointer display(scheme *sc, pointer args) {
if (args!=sc->NIL) {
if (sc->vptr->is_string(sc->vptr->pair_car(args))) {
char *str = sc->vptr->string_value(sc->vptr->pair_car(args));
printf("%s", str);
}
}
return sc->NIL;
}
// square -- scheme function
// Example: (square 3)
pointer square(scheme *sc, pointer args) {
if (args!=sc->NIL) {
if(sc->vptr->is_number(sc->vptr->pair_car(args))) {
double v=sc->vptr->rvalue(sc->vptr->pair_car(args));
return sc->vptr->mk_real(sc,v*v);
}
}
return sc->NIL;
}
int main(void) {
scheme *sc;
// Init Scheme interpreter
sc = scheme_init_new();
// Load init.scm
FILE *finit = fopen("init.scm", "r");
scheme_load_file(sc, finit);
fclose(finit);
// Define square
sc->vptr->scheme_define(
sc,
sc->global_env,
sc->vptr->mk_symbol(sc, "square"),
sc->vptr->mk_foreign_func(sc, square));
// Define display
sc->vptr->scheme_define(
sc,
sc->global_env,
sc->vptr->mk_symbol(sc, "display"),
sc->vptr->mk_foreign_func(sc, display));
// Run first example
char *hello_scm = "(display \"Hello, world!\\n\")";
scheme_load_string(sc, hello_scm);
// Run second example
char *square_scm = "(display "
" (string-append \"Answer: \" "
" (number->string (square 6.480740698407859)) \"\\n\"))";
scheme_load_string(sc, square_scm);
// Bye!
scheme_deinit(sc);
return 0;
}
' Tiny Scheme - extension module example
DECLARE SUB InitNew ALIAS "TS_init_new" LIB "ts"
DECLARE SUB Deinit ALIAS "TS_deinit" LIB "ts"
DECLARE SUB LoadStr ALIAS "TS_load_string" LIB "ts"
sc = InitNew()
LoadStr(sc, "(display \"Hello, world!\n\")")
Deinit(sc)
// Tiny Scheme - Script BASIC extension module
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <math.h>
#include <time.h>
#include "../../basext.h"
#include "cbasic.h"
#define USE_INTERFACE 1
#include "scheme.h"
#include "scheme-private.h"
pointer display(scheme *sc, pointer args) {
if (args!=sc->NIL) {
if (sc->vptr->is_string(sc->vptr->pair_car(args))) {
char *str = sc->vptr->string_value(sc->vptr->pair_car(args));
printf("%s", str);
}
}
return sc->NIL;
}
/****************************
Extension Module Functions
****************************/
besVERSION_NEGOTIATE
RETURN_FUNCTION((int)INTERFACE_VERSION);
besEND
besSUB_START
DIM AS long *p;
besMODULEPOINTER = besALLOC(sizeof(long));
IF (besMODULEPOINTER EQ NULL) THEN_DO RETURN_FUNCTION(0);
p = (long*)besMODULEPOINTER;
RETURN_FUNCTION(0);
besEND
besSUB_FINISH
DIM AS long *p;
p = (long*)besMODULEPOINTER;
IF (p EQ NULL) THEN_DO RETURN_FUNCTION(0);
RETURN_FUNCTION(0);
besEND
/***********************
Tiny Scheme Functions
***********************/
besFUNCTION(TS_init_new)
DIM AS scheme PTR sc;
sc = scheme_init_new();
sc->vptr->scheme_define(
sc,
sc->global_env,
sc->vptr->mk_symbol(sc, "display"),
sc->vptr->mk_foreign_func(sc, display));
besRETURN_LONG(sc);
besEND
besFUNCTION(TS_deinit)
DIM AS scheme PTR sc;
besARGUMENTS("i")
AT sc
besARGEND
scheme_deinit(sc);
besRETURNVALUE = NULL;
besEND
besFUNCTION(TS_load_string)
DIM AS scheme PTR sc;
DIM AS char PTR cmdstr;
besARGUMENTS("iz")
AT sc, AT cmdstr
besARGEND
scheme_load_string(sc, cmdstr);
besRETURNVALUE = NULL;
besEND
jrs@laptop:~/tinyscheme/tinyscheme-1.41$ ./scheme
TinyScheme 1.41
ts> (define grid '())
(define mapped-grid '())
(define modulus
(lambda (n d)
(let (( r (floor (/ n d))))
(- n (* r d)))))
(define cadr
(lambda (L)
(car (cdr L))))
(define sqrt
(lambda (x)
(exp (/ (log x) 2))))
(define sq (lambda(x) (* x x)))
(define 1- (lambda (x) (- x 1)))
(define 1+ (lambda (x) (+ x 1)))
(define level
(lambda (i x y rc ic it orb)
(if (or (= i it) (> orb 4)) i
(level (1+ i) (+ rc (- (sq x) (sq y))) (+ ic (* 2 x y)) rc ic it (+ (sq x) (sq y))))))
(define mlevel
(lambda (L)
(level 0 (cadr L) (car L) (cadr L) (car L) 11 0)))
(define fill-grid
(lambda (nrx xo dx nry yo dy matrix dup)
(if (and (= 0 nrx) (= 0 nry)) matrix
(if (= 0 nry) (fill-grid (1- nrx) xo dx dup yo dy matrix dup)
(fill-grid nrx xo dx (1- nry) yo dy
(cons (list (+ xo (* nrx dx)) (+ yo (* nry dy))) matrix) dup)))))
(define square-grid
(lambda (nr x y dz)
(fill-grid (1- nr) (+ x dz) dz nr y dz '() nr)))
(define map-grid
(lambda (L)
(map mlevel L)))
(define print*
(lambda (x)
(if (> x 9)
(print x)
(sequence (print x) (print '" ")) )))
(define print-grid
(lambda (i it L)
(if (null? L) T
(if (= i it) (sequence (print* (car L)) (newline) (print-grid 0 it L))
(sequence (print* (car L)) (print-grid (1+ i) it (cdr L)))))))
(define main
(lambda ()
(set! grid (square-grid 30 -1.7 -2.3 0.1))
(set! mapped-grid (map-grid grid))
(print-grid 0 30 mapped-grid)
))grid
ts> mapped-grid
ts> modulus
ts> cadr
ts> sqrt
ts> sq
ts> 1-
ts> 1+
ts> level
ts> mlevel
ts> fill-grid
ts> square-grid
ts> map-grid
ts> print*
ts> print-grid
ts> (main)
main
ts> Error: eval: unbound variable: sequence
/**
* hello-scheme for illustration how to embed
* the tiny scheme interpreter in a C program
*
* 2012, OL
*/
#include <stdio.h>
#include <string.h>
#include "scheme.h"
#include "dynload.h"
/* scheme_load_string does not like
carriage returns so strip them out */
void strip_cr( char *p, int max_len )
{
int i;
for( i=0; i < max_len && p[i]!='\0'; ++i )
;
if( i > 0 && p[i-1]=='\n' )
p[i-1] = '\0';
}
/**
* illustration of a C function binding
*/
pointer func1(scheme *sc, pointer args)
{
pointer arg;
pointer retval;
char *strarg;
double realnumber;
int intnumber;
int i = 1;
while( args != sc->NIL )
{
if( is_string( arg = pair_car(args)) )
{
strarg = string_value( arg );
printf( "argument %d is string %s\n", i++, strarg );
}
else if( is_real( arg = pair_car(args) ) )
{
realnumber = rvalue( arg );
printf( "argument %d is real number %lf\n", i++, realnumber );
}
else if( is_integer( arg = pair_car(args) ) )
{
intnumber = ivalue( arg );
printf( "argument %d is integer number %d\n", i++, intnumber );
}
args = pair_cdr( args );
}
if( i > 1 )
retval = sc -> T;
else
retval = sc -> F;
return(retval);
}
/*
* Simple REPL
*/
int main( int argc, char* argv[] )
{
scheme sc;
char cmd_str[80];
/* intialize the scheme object */
if( !scheme_init(&sc) ) {
fprintf(stderr,"Could not initialize!\n");
return 2;
}
/* set standard input and output ports */
scheme_set_input_port_file(&sc, stdin);
scheme_set_output_port_file(&sc, stdout);
/* illustration how to define a "foreign" function
implemented in C */
scheme_define(&sc,sc.global_env,mk_symbol(&sc,"func1"),mk_foreign_func(&sc, func1));
puts("Tiny Scheme REPL:");
puts("try e.g. the following commands:");
puts(" (write (+ 1 2))");
puts(" (func1 \"hello\" 42 1.24)\n");
do {
printf("\n>");
fgets( cmd_str, 80, stdin );
strip_cr( cmd_str, 80 );
if (strncmp(cmd_str,"(quit)",6)==0) break;
scheme_load_string( &sc, cmd_str );
} while(1);
scheme_deinit(&sc);
return 0;
}
' Tiny Scheme - extension module example
DECLARE SUB InitNew ALIAS "TS_init_new" LIB "ts"
DECLARE SUB Deinit ALIAS "TS_deinit" LIB "ts"
DECLARE SUB LoadStr ALIAS "TS_load_string" LIB "ts"
sc = InitNew()
LoadStr sc, "(write (+ 2 2)) (newline)"
Deinit sc
jrs@laptop:~/tinyscheme/tinyscheme-1.41$ ./scheme
TinyScheme 1.41
ts> (load "mbrot.scm")
Loading mbrot.scm
Error: (mbrot.scm : 64) eval: unbound variable: print
jrs@laptop:~/tinyscheme/tinyscheme-1.41$
jrs@laptop:~/tinyscheme/tinyscheme-1.41$ time ./scheme mbrot.scm
1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1
1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1
1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1
1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 3 3 3 3 3 2 2 2 2 2 2 2 2 2 2 1
1 1 1 1 1 1 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 1
1 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 115 4 4 3 3 2 2 2 2 1
1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 5 7 9 114 4 3 3 2 2 2 1
1 1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 9 118 5 4 4 3 3 3 2 1
1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 8 1111116 5 5 4 3 3 3 1
1 1 1 1 2 3 3 3 3 3 3 3 4 4 4 5 7 8 8 101111119 6 6 5 4 3 3 1
1 1 1 2 3 3 3 3 3 3 3 4 4 5 5 6 11111111111111111111114 3 3 1
1 1 1 2 3 3 3 3 3 4 5 5 5 5 6 8 111111111111111111117 5 3 3 1
1 1 1 3 3 3 3 4 5 7 7 7 7 7 7 11111111111111111111119 5 4 3 1
1 1 1 3 4 4 4 5 5 7 111111119 1111111111111111111111116 4 3 1
1 1 1 4 4 4 5 5 6 8 11111111111111111111111111111111115 4 3 1
1 1 1 4 4 6 6 7 1111111111111111111111111111111111118 5 4 3 1
1 1 1111111111111111111111111111111111111111111111117 5 4 3 1
1 1 1 4 4 6 6 7 1111111111111111111111111111111111118 5 4 3 1
1 1 1 4 4 4 5 5 6 8 11111111111111111111111111111111115 4 3 1
1 1 1 3 4 4 4 5 5 7 111111119 1111111111111111111111116 4 3 1
1 1 1 3 3 3 3 4 5 7 7 7 7 7 7 11111111111111111111119 5 4 3 1
1 1 1 2 3 3 3 3 3 4 5 5 5 5 6 8 111111111111111111117 5 3 3 1
1 1 1 2 3 3 3 3 3 3 3 4 4 5 5 6 11111111111111111111114 3 3 1
1 1 1 1 2 3 3 3 3 3 3 3 4 4 4 5 7 8 8 101111119 6 6 5 4 3 3 1
1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 8 1111116 5 5 4 3 3 3 1
1 1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 9 118 5 4 4 3 3 3 2 1
1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 5 7 9 114 4 3 3 2 2 2 1
1 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 115 4 4 3 3 2 2 2 2 1
1 1 1 1 1 1 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 1
1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 3 3 3 3 3 2 2 2 2 2 2 2 2 2 2 Error: (mbrot.scm : 64) eval: unbound variable: t
Errors encountered reading mbrot.scm
real 0m2.293s
user 0m2.288s
sys 0m0.000s
jrs@laptop:~/tinyscheme/tinyscheme-1.41$
(define grid '())
(define mapped-grid '())
(define modulus
(lambda (n d)
(let (( r (floor (/ n d))))
(- n (* r d)))))
(define cadr
(lambda (L)
(car (cdr L))))
(define sqrt
(lambda (x)
(exp (/ (log x) 2))))
(define sq (lambda(x) (* x x)))
(define 1- (lambda (x) (- x 1)))
(define 1+ (lambda (x) (+ x 1)))
(define level
(lambda (i x y rc ic it orb)
(if (or (= i it) (> orb 4)) i
(level (1+ i) (+ rc (- (sq x) (sq y))) (+ ic (* 2 x y)) rc ic it (+ (sq x) (sq y))))))
(define mlevel
(lambda (L)
(level 0 (cadr L) (car L) (cadr L) (car L) 11 0)))
(define fill-grid
(lambda (nrx xo dx nry yo dy matrix dup)
(if (and (= 0 nrx) (= 0 nry)) matrix
(if (= 0 nry) (fill-grid (1- nrx) xo dx dup yo dy matrix dup)
(fill-grid nrx xo dx (1- nry) yo dy
(cons (list (+ xo (* nrx dx)) (+ yo (* nry dy))) matrix) dup)))))
(define square-grid
(lambda (nr x y dz)
(fill-grid (1- nr) (+ x dz) dz nr y dz '() nr)))
(define map-grid
(lambda (L)
(map mlevel L)))
(define display*
(lambda (x)
(if (> x 9)
(display x)
(begin (display x) (display '" ")) )))
(define print-grid
(lambda (i it L)
(if (null? L) #t
(if (= i it) (begin (display* (car L)) (newline) (print-grid 0 it L))
(begin (display* (car L)) (print-grid (1+ i) it (cdr L)))))))
(define main
(lambda ()
(set! grid (square-grid 30 -1.7 -2.3 0.1))
(set! mapped-grid (map-grid grid))
(print-grid 0 30 mapped-grid)
))
(main)
(quit)
jrs@laptop:~/tinyscheme/tinyscheme-1.41$ time ./scheme mbrot.scm
1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1
1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1
1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1
1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 3 3 3 3 3 2 2 2 2 2 2 2 2 2 2 1
1 1 1 1 1 1 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 1
1 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 115 4 4 3 3 2 2 2 2 1
1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 5 7 9 114 4 3 3 2 2 2 1
1 1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 9 118 5 4 4 3 3 3 2 1
1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 8 1111116 5 5 4 3 3 3 1
1 1 1 1 2 3 3 3 3 3 3 3 4 4 4 5 7 8 8 101111119 6 6 5 4 3 3 1
1 1 1 2 3 3 3 3 3 3 3 4 4 5 5 6 11111111111111111111114 3 3 1
1 1 1 2 3 3 3 3 3 4 5 5 5 5 6 8 111111111111111111117 5 3 3 1
1 1 1 3 3 3 3 4 5 7 7 7 7 7 7 11111111111111111111119 5 4 3 1
1 1 1 3 4 4 4 5 5 7 111111119 1111111111111111111111116 4 3 1
1 1 1 4 4 4 5 5 6 8 11111111111111111111111111111111115 4 3 1
1 1 1 4 4 6 6 7 1111111111111111111111111111111111118 5 4 3 1
1 1 1111111111111111111111111111111111111111111111117 5 4 3 1
1 1 1 4 4 6 6 7 1111111111111111111111111111111111118 5 4 3 1
1 1 1 4 4 4 5 5 6 8 11111111111111111111111111111111115 4 3 1
1 1 1 3 4 4 4 5 5 7 111111119 1111111111111111111111116 4 3 1
1 1 1 3 3 3 3 4 5 7 7 7 7 7 7 11111111111111111111119 5 4 3 1
1 1 1 2 3 3 3 3 3 4 5 5 5 5 6 8 111111111111111111117 5 3 3 1
1 1 1 2 3 3 3 3 3 3 3 4 4 5 5 6 11111111111111111111114 3 3 1
1 1 1 1 2 3 3 3 3 3 3 3 4 4 4 5 7 8 8 101111119 6 6 5 4 3 3 1
1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 8 1111116 5 5 4 3 3 3 1
1 1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 9 118 5 4 4 3 3 3 2 1
1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 5 7 9 114 4 3 3 2 2 2 1
1 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 115 4 4 3 3 2 2 2 2 1
1 1 1 1 1 1 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 1
1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 3 3 3 3 3 2 2 2 2 2 2 2 2 2 2
real 0m2.377s
user 0m2.368s
sys 0m0.004s
jrs@laptop:~/tinyscheme/tinyscheme-1.41$
TinyScheme, looks complete and powerful
(newline)
(newline)
(display "Ascii Mandelbrot TinyScheme") (newline)
(display "---------------------------") (newline)
(define sq
(lambda (x) (* x x)))
(define (1+ x) (+ x 1))
(define (1- x) (- x 1))
(define level
(lambda (i x y rc ic it orb)
(if (or (= i it) (> orb 4)) i
(level (1+ i) (+ rc (- (sq x) (sq y))) (+ ic (* 2 x y)) rc ic it (+ (sq x) (sq y))))))
(define mlevel
(lambda (L)
(level 0 (cadr L) (car L) (cadr L) (car L) 11 0)))
(define (main)
(let ((cnt 0) (lvl 0) (xo -1.7) (yo -2.3) (dz 0.1) )
(do ((i 0 (1+ i)))
((= i 30))
(do ((j 0 (1+ j)))
((= 30 j))
(set! lvl (mlevel (list (+ xo (* i dz)) (+ yo (* j dz)) )))
(if (< lvl 10)
(begin (display lvl) (display " "))
(display lvl))
(set! cnt (1+ cnt))
(when (= 30 cnt)
(set! cnt 0)
(newline))
))))
(main)
(quit)
jrs@laptop:~/tinyscheme/tinyscheme-1.41$ time ./scheme mbrot2.scm
Ascii Mandelbrot TinyScheme
---------------------------
1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 3 3 3 3 3 2 2 2 2 2 2 2 2 2
1 1 1 1 1 1 1 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2
1 1 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 115 4 4 3 3 2 2 2
1 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 5 7 9 114 4 3 3 2 2
1 1 1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 9 118 5 4 4 3 3 3
1 1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 8 1111116 5 5 4 3 3
1 1 1 1 1 2 3 3 3 3 3 3 3 4 4 4 5 7 8 8 101111119 6 6 5 4 3
1 1 1 1 2 3 3 3 3 3 3 3 4 4 5 5 6 11111111111111111111114 3
1 1 1 1 2 3 3 3 3 3 4 5 5 5 5 6 8 111111111111111111117 5 3
1 1 1 1 3 3 3 3 4 5 7 7 7 7 7 7 11111111111111111111119 5 4
1 1 1 1 3 4 4 4 5 5 7 111111119 1111111111111111111111116 4
1 1 1 1 4 4 4 5 5 6 8 11111111111111111111111111111111115 4
1 1 1 1 4 4 6 6 7 1111111111111111111111111111111111118 5 4
1 1 1 1111111111111111111111111111111111111111111111117 5 4
1 1 1 1 4 4 6 6 7 1111111111111111111111111111111111118 5 4
1 1 1 1 4 4 4 5 5 6 8 11111111111111111111111111111111115 4
1 1 1 1 3 4 4 4 5 5 7 111111119 1111111111111111111111116 4
1 1 1 1 3 3 3 3 4 5 7 7 7 7 7 7 11111111111111111111119 5 4
1 1 1 1 2 3 3 3 3 3 4 5 5 5 5 6 8 111111111111111111117 5 3
1 1 1 1 2 3 3 3 3 3 3 3 4 4 5 5 6 11111111111111111111114 3
1 1 1 1 1 2 3 3 3 3 3 3 3 4 4 4 5 7 8 8 101111119 6 6 5 4 3
1 1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 8 1111116 5 5 4 3 3
1 1 1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 9 118 5 4 4 3 3 3
1 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 5 7 9 114 4 3 3 2 2
1 1 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 115 4 4 3 3 2 2 2
1 1 1 1 1 1 1 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2
real 0m0.660s
user 0m0.608s
sys 0m0.000s
jrs@laptop:~/tinyscheme/tinyscheme-1.41$
#if USE_NO_FEATURES
define USE_MATH 1
# define USE_CHAR_CLASSIFIERS 0
# define USE_ASCII_NAMES 0
# define USE_STRING_PORTS 0
# define USE_ERROR_HOOK 0
# define USE_TRACING 0
# define USE_COLON_HOOK 0
# define USE_DL 0
# define USE_PLIST 0
#endif
I think it's possible to allocate more memory-segments from within the script -- (without any need to recompile )
#include <stdio.h>
int main()
{
int n1, n2=5000, i, j, flag;
for(i=n1+1; i<n2; ++i)
{
flag=0;
for(j=2; j<=i/2; ++j)
{
if(i%j==0)
{
flag=1;
break;
}
}
if(flag==0)
printf("%d ",i);
}
return 0;
TinyScheme RE (Regular Expressions) extension
---------------------------------------------
Version 1.2, August 2002
The bulk of this directory is the regular expression library written
by Henry Spencer (see file README and COPYRIGHT).
Two files were added to produce the TinyScheme regular expression
library, re.so: re.c and re.makefile. The included re.makefile was contributed
initially by Stephen Gildea and should be adaptable to all Unix systems.
The makefile produces a DLL named re.so. For now, it contains just
a single foreign function (re-match <pattern> <string>). It returns
true (string matches pattern) or false. If it is called with an
extra parameter, which should be a vector, overwrites as many elements
of the vector as needed with the strings that matched the corresponding
parenthesized subexpressions inside <pattern>.
It is not fully tested, so use with caution.
Load the extension from inside TinyScheme using
(load-extension "re/re")
assuming that re.so is in the directory "re".
Load "re.scm" if you wish to use v.1.1 behavior.
;; return the substring of STRING matched in MATCH-VECTOR,
;; the Nth subexpression match (default 0).
(define (re-match-nth string match-vector . n)
(let ((n (if (pair? n) (car n) 0)))
(substring string (car (vector-ref match-vector n))
(cdr (vector-ref match-vector n)))))
(define (re-before-nth string match-vector . n)
(let ((n (if (pair? n) (car n) 0)))
(substring string 0 (car (vector-ref match-vector n)))))
(define (re-after-nth string match-vector . n)
(let ((n (if (pair? n) (car n) 0)))
(substring string (cdr (vector-ref match-vector n))
(string-length string))))
Please Test!
Regrets, oh.... excuse me... Regards,
Any chance we might see TinyScheme embedded in FBSL? (via libtinyscheme.dll)
It would be more reasonable to move all this macro hell directly into the engine IMO.
(just need to define (gcd ) for you (now denominator etc ... can be defined)
TinyScheme 1.39
> (define a (fr# 1 3))
a
there's also SLIB , but do not know any one connected it with TinyScheme (for Bigloo this extension can be linked)
Things that keep missing, or that need fixing
---------------------------------------------
There are no hygienic macros. No rational or
complex numbers. No unwind-protect and call-with-values.
Maybe (a subset of) SLIB will work with TinySCHEME...
Although it is a descendant of tinyScheme, s7 is closest as a Scheme dialect to Guile 1.8. I believe it is compatible with r5rs and r7rs: you can just ignore all the additions discussed in this file. It has continuations, ratios, complex numbers, macros, keywords, hash-tables, multiprecision arithmetic, generalized set!, unicode, and so on. It does not have syntax-rules or any of its friends, and it does not think there is any such thing as an inexact integer.
Quasiquoting
Scheme offers a very powerful facility called "quasiquoting" for creating lists that is especially useful for creating macros -- because the output of a macro body is expected to be a list. Quasiquoting is quite well-documented and so I won't go into too much detail about it, but the general premise is that code that has been quasiquoted will by default not be evaluated (just as with quoting), however, you can optionally 'unquote' parts of the expression.
This form of list generation generally results in macros that are much more recognizable with regard to the code being generated. For example, the body of the preceding 'when' macro would appear as follows in quasiquote notation:
`(if ,(cadr form)
(begin
,@(cddr form) ))
NOTE: this is precisely how the 'when' macro is defined in GIMP's "script-fu.init" file.
jrs@laptop:~/tinyscheme/tinyscheme-1.41$ nm libtinyscheme.so
0000000000007c22 t Eval_Cycle
0000000000211db0 a _DYNAMIC
00000000000079f2 t _Error_1
0000000000211fe8 a _GLOBAL_OFFSET_TABLE_
w _ITM_deregisterTMCloneTable
w _ITM_registerTMCloneTable
w _Jv_RegisterClasses
0000000000011608 r __FRAME_END__
0000000000211ca0 d __JCR_END__
0000000000211ca0 d __JCR_LIST__
0000000000213bc0 d __TMC_END__
0000000000213bc0 A __bss_start
U __ctype_b_loc@@GLIBC_2.3
U __ctype_tolower_loc@@GLIBC_2.3
U __ctype_toupper_loc@@GLIBC_2.3
w __cxa_finalize@@GLIBC_2.2.5
00000000000056b0 t __do_global_dtors_aux
0000000000211c98 t __do_global_dtors_aux_fini_array_entry
0000000000212340 d __dso_handle
U __fprintf_chk@@GLIBC_2.3.4
0000000000211c90 t __frame_dummy_init_array_entry
w __gmon_start__
U __isoc99_sscanf@@GLIBC_2.7
U __printf_chk@@GLIBC_2.3.4
U __snprintf_chk@@GLIBC_2.3.4
U __stack_chk_fail@@GLIBC_2.4
U __strcat_chk@@GLIBC_2.3.4
U __strcpy_chk@@GLIBC_2.3.4
0000000000007817 T _cons
0000000000213bc0 A _edata
0000000000213bf0 A _end
000000000000eb14 T _fini
0000000000004fb0 T _init
0000000000005f15 t _s_return
U access@@GLIBC_2.2.5
U acos@@GLIBC_2.2.5
00000000000059d6 t alloc_cellseg
U asin@@GLIBC_2.2.5
00000000000079de t assign_syntax
U atan2@@GLIBC_2.2.5
U atan@@GLIBC_2.2.5
0000000000007026 t atom2str
0000000000006d3e t backchar
0000000000005620 t call_gmon_start
U ceil@@GLIBC_2.2.5
00000000000057ac T charvalue
0000000000005894 T closure_code
0000000000005899 T closure_env
0000000000213bc0 b completed.6976
U cos@@GLIBC_2.2.5
0000000000005640 t deregister_tm_clones
0000000000212520 d dispatch_table
U dlerror@@GLIBC_2.2.5
U dlopen@@GLIBC_2.2.5
U dlsym@@GLIBC_2.2.5
000000000000cad4 T eqv
U exp@@GLIBC_2.2.5
U fclose@@GLIBC_2.2.5
U fgetc@@GLIBC_2.2.5
0000000000005d9b t file_interactive
0000000000005ba8 t fill_vector
0000000000005b29 t find_consecutive_cells
0000000000005e5c t find_slot_in_env
U floor@@GLIBC_2.2.5
U fmod@@GLIBC_2.2.5
U fopen@@GLIBC_2.2.5
U fputc@@GLIBC_2.2.5
U fputs@@GLIBC_2.2.5
00000000000056f0 t frame_dummy
U free@@GLIBC_2.2.5
U fwrite@@GLIBC_2.2.5
0000000000006276 t gc
000000000000791e T gensym
00000000000065e2 t get_cell
00000000000064e3 t get_cell_x
U getenv@@GLIBC_2.2.5
0000000000005e2c t hash_fn
0000000000006cc8 t inchar
0000000000006043 t is_any
000000000000577d T is_character
0000000000005876 T is_closure
000000000000589e T is_continuation
00000000000058bc T is_environment
000000000000585e T is_foreign
00000000000058cb T is_immutable
00000000000057c0 T is_inport
00000000000077a2 T is_integer
0000000000006030 t is_list
0000000000005885 T is_macro
00000000000077f0 t is_nonneg
000000000000574e T is_number
0000000000005e01 t is_one_of
00000000000057e3 T is_outport
0000000000005806 T is_pair
00000000000057b1 T is_port
000000000000584f T is_proc
00000000000058ad T is_promise
000000000000575d T is_real
0000000000005730 T is_string
000000000000582f T is_symbol
0000000000005847 T is_syntax
000000000000573f T is_vector
000000000000579a T ivalue
0000000000005fa5 T list_length
0000000000009540 t list_star
U log@@GLIBC_2.2.5
000000000000e591 T main
U malloc@@GLIBC_2.2.5
0000000000005c7b t mark
U memcpy@@GLIBC_2.14
U memset@@GLIBC_2.2.5
000000000000820e t mk_atom
000000000000664a T mk_character
00000000000067e0 t mk_closure
00000000000066ed T mk_counted_string
000000000000b532 T mk_empty_string
000000000000662b T mk_foreign_func
000000000000666f T mk_integer
00000000000066c5 t mk_number
000000000000676d t mk_port
0000000000006692 T mk_real
0000000000006a29 t mk_sharp_const
0000000000006741 T mk_string
00000000000078ef T mk_symbol
0000000000006806 t mk_vector
U modf@@GLIBC_2.2.5
0000000000009f9b t new_frame_in_env
000000000000a083 t new_slot_in_env
0000000000009fe4 t new_slot_spec_in_env
00000000000058da t num_eq
00000000000059ba t num_ge
000000000000592a t num_gt
00000000000059c8 t num_le
0000000000005972 t num_lt
0000000000213bd0 b num_one
0000000000213be0 b num_zero
0000000000005791 T nvalue
000000000000785b t oblist_add_by_name
000000000000610e t oblist_find_by_name
000000000000a0e9 t opexe_0
000000000000d348 t opexe_1
000000000000b587 t opexe_2
000000000000cc12 t opexe_3
00000000000095b7 t opexe_4
0000000000008509 t opexe_5
0000000000007fa8 t opexe_6
0000000000005815 T pair_car
000000000000581a T pair_cdr
0000000000006049 t port_close
000000000000678c t port_from_string
0000000000005dcf t port_rep_from_file
U pow@@GLIBC_2.2.5
00000000000076e2 t printatom
00000000000065a6 t push_recent_alloc
000000000000698a T putcharacter
U puts@@GLIBC_2.2.5
00000000000061f9 T putstr
0000000000006d7f t readstr_upto
0000000000006176 t realloc_port_string
0000000000005670 t register_tm_clones
0000000000006903 t reserve_cells
000000000000778f T rvalue
0000000000009f88 t s_cons
0000000000009f75 t s_immutable_cons
0000000000008483 t s_save
000000000000a09e T scheme_define
000000000000e309 T scheme_deinit
000000000000e228 T scheme_init
000000000000ddb0 T scheme_init_custom_alloc
000000000000e244 T scheme_init_new
000000000000e1ec T scheme_init_new_custom_alloc
000000000000e57e T scheme_load_file
000000000000e45e T scheme_load_named_file
0000000000007ed3 T scheme_load_string
000000000000e301 T scheme_set_external_data
000000000000e273 T scheme_set_input_port_file
000000000000e2a3 T scheme_set_input_port_string
000000000000e2ba T scheme_set_output_port_file
000000000000e2ea T scheme_set_output_port_string
000000000000e970 T scm_load_ext
000000000000581f T set_car
0000000000005827 T set_cdr
0000000000005c4d t set_vector_elem
00000000000058d3 T setimmutable
U sin@@GLIBC_2.2.5
U snprintf@@GLIBC_2.2.5
U sqrt@@GLIBC_2.2.5
U stderr@@GLIBC_2.2.5
U stdin@@GLIBC_2.2.5
U stdout@@GLIBC_2.2.5
0000000000006082 t store_string
U strcasecmp@@GLIBC_2.2.5
U strcpy@@GLIBC_2.2.5
000000000000578c T string_value
00000000000069f0 t strlwr
U strrchr@@GLIBC_2.2.5
U strstr@@GLIBC_2.2.5
U strtod@@GLIBC_2.2.5
U strtol@@GLIBC_2.2.5
000000000000583e T symname
000000000000586d T syntaxname
U tan@@GLIBC_2.2.5
0000000000211cc0 d tests
0000000000006dfb t token
U ungetc@@GLIBC_2.2.5
0000000000005c24 t vector_elem
0000000000212360 d vtbl
jrs@laptop:~/tinyscheme/tinyscheme-1.41$
#define edelib_scheme_set_output_port_string scheme_set_output_port_string
Set character array as output port. You should give pointer to the first element and pointer to the last.
include "dllcinc.sb"
lispbuf=string(0x10000,chr(0))
lispstrptr=dllsptr(lispbuf)
lispstrend=lispstrptr+0x10000 - 1
dllprnt hex(lispstrptr) & "\n" & hex(lispstrend) & "\n"
dlllnpt "Press Enter"
' ...
' TinyScheme Script BASIC DLLC Example
DECLARE SUB dllfile ALIAS "dllfile" LIB "dllc"
DECLARE SUB dllproc ALIAS "dllproc" LIB "dllc"
DECLARE SUB dllcall ALIAS "dllcall" LIB "dllc"
DECLARE SUB dllsptr ALIAS "dllsptr" LIB "dllc"
ts = dllfile("libtinyscheme.dll")
InitNew = dllproc(ts, "scheme_init_new i = ()")
RtnStr = dllproc(ts, "scheme_set_output_port_string (i sc, i startptr, i endptr)")
Deinit = dllproc(ts, "scheme_deinit (i sc)")
LoadStr = dllproc(ts, "scheme_load_string (i sc, c *cmd)")
sc = dllcall(InitNew)
lispbuf = string(1024,CHR(0))
lispstrptr = dllsptr(lispbuf)
lispstrend = lispstrptr + 1024 - 1
dllcall(RtnStr, sc, lispstrptr, lispstrend)
dllcall(LoadStr, sc, "(display \"Thank You Charles!\")")
strlen = INSTR(lispbuf, CHR(0))
PRINT LEFT(lispbuf, strlen - 1),"\n"
dllcall(Deinit, sc)
dllfile()
' TinyScheme Script BASIC DLLC Example
DECLARE SUB dllfile ALIAS "dllfile" LIB "dllc"
DECLARE SUB dllproc ALIAS "dllproc" LIB "dllc"
DECLARE SUB dllcall ALIAS "dllcall" LIB "dllc"
DECLARE SUB dllsptr ALIAS "dllsptr" LIB "dllc"
ts = dllfile("libtinyscheme.dll")
InitNew = dllproc(ts, "scheme_init_new i = ()")
RtnStr = dllproc(ts, "scheme_set_output_port_string (i sc, i startptr, i endptr)")
Deinit = dllproc(ts, "scheme_deinit (i sc)")
LoadStr = dllproc(ts, "scheme_load_string (i sc, c *cmd)")
sc = dllcall(InitNew)
lispbuf = string(4096,CHR(0))
lispstrptr = dllsptr(lispbuf)
lispstrend = lispstrptr + 4096 - 1
dllcall(RtnStr,sc, lispstrptr, lispstrend)
dllcall(LoadStr, sc, "(load \"init.scm\")")
dllcall(LoadStr, sc, "(load \"mbrot2.scm\")")
strlen = INSTR(lispbuf, CHR(0))
PRINT LEFT(lispbuf, strlen - 1),"\n"
dllcall(Deinit, sc)
dllfile()
C:\SB22\TS>ptime scriba dllchellots.sb
ptime 1.0 for Win32, Freeware - http://www.pc-tools.net/
Copyright(C) 2002, Jem Berkes <jberkes@pc-tools.net>
=== scriba dllchellots.sb ===
Ascii Mandelbrot TinyScheme
---------------------------
1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 3 3 3 3 3 2 2 2 2 2 2 2 2 2
1 1 1 1 1 1 1 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2
1 1 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 115 4 4 3 3 2 2 2
1 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 5 7 9 114 4 3 3 2 2
1 1 1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 9 118 5 4 4 3 3 3
1 1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 8 1111116 5 5 4 3 3
1 1 1 1 1 2 3 3 3 3 3 3 3 4 4 4 5 7 8 8 101111119 6 6 5 4 3
1 1 1 1 2 3 3 3 3 3 3 3 4 4 5 5 6 11111111111111111111114 3
1 1 1 1 2 3 3 3 3 3 4 5 5 5 5 6 8 111111111111111111117 5 3
1 1 1 1 3 3 3 3 4 5 7 7 7 7 7 7 11111111111111111111119 5 4
1 1 1 1 3 4 4 4 5 5 7 111111119 1111111111111111111111116 4
1 1 1 1 4 4 4 5 5 6 8 11111111111111111111111111111111115 4
1 1 1 1 4 4 6 6 7 1111111111111111111111111111111111118 5 4
1 1 1 1111111111111111111111111111111111111111111111117 5 4
1 1 1 1 4 4 6 6 7 1111111111111111111111111111111111118 5 4
1 1 1 1 4 4 4 5 5 6 8 11111111111111111111111111111111115 4
1 1 1 1 3 4 4 4 5 5 7 111111119 1111111111111111111111116 4
1 1 1 1 3 3 3 3 4 5 7 7 7 7 7 7 11111111111111111111119 5 4
1 1 1 1 2 3 3 3 3 3 4 5 5 5 5 6 8 111111111111111111117 5 3
1 1 1 1 2 3 3 3 3 3 3 3 4 4 5 5 6 11111111111111111111114 3
1 1 1 1 1 2 3 3 3 3 3 3 3 4 4 4 5 7 8 8 101111119 6 6 5 4 3
1 1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 8 1111116 5 5 4 3 3
1 1 1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 9 118 5 4 4 3 3 3
1 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 5 7 9 114 4 3 3 2 2
1 1 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 115 4 4 3 3 2 2 2
1 1 1 1 1 1 1 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2
Execution time: 1.086 s
C:\SB22\TS>
' Boot (Main / Launcher)
DECLARE SUB dlltran ALIAS "dlltran" LIB "dllc"
DECLARE SUB dllclos ALIAS "dllclos" LIB "dllc"
DECLARE SUB dllfile ALIAS "dllfile" LIB "dllc"
t1 = dlltran("T1.sb","main::main",1)
t2 = dlltran("T2.sb","main::main",2)
LINE INPUT wait
dllclos t1, t2
dllfile
' Thread #1 Script
DECLARE SUB dllfile ALIAS "dllfile" LIB "dllc"
DECLARE SUB dllproc ALIAS "dllproc" LIB "dllc"
DECLARE SUB dllcall ALIAS "dllcall" LIB "dllc"
DECLARE SUB dllsptr ALIAS "dllsptr" LIB "dllc"
ts = dllfile("libtinyscheme.dll")
InitNew = dllproc(ts, "scheme_init_new i = ()")
RtnStr = dllproc(ts, "scheme_set_output_port_string (i sc, i startptr, i endptr)")
Deinit = dllproc(ts, "scheme_deinit (i sc)")
LoadStr = dllproc(ts, "scheme_load_string (i sc, c *cmd)")
FUNCTION main(pProg)
sc = dllcall(InitNew)
lispbuf = string(4096,CHR(0))
lispstrptr = dllsptr(lispbuf)
lispstrend = lispstrptr + 4096 - 1
dllcall(RtnStr,sc, lispstrptr, lispstrend)
dllcall(LoadStr, sc, "(display \"Thread 1\")")
strlen = INSTR(lispbuf, CHR(0))
PRINT LEFT(lispbuf, strlen - 1),"\n"
dllcall(Deinit, sc)
END FUNCTION
besFUNCTION(TS_load_string)
DIM AS scheme PTR sc;
DIM AS char PTR cmdstr;
DIM AS char PTR tsbuf[16384];
besARGUMENTS("iz")
AT sc, AT cmdstr
besARGEND
scheme_set_output_port_string (sc, (int)*tsbuf, (int)*tsbuf + 16383);
scheme_load_string(sc, cmdstr);
besRETURN_STRING(tsbuf);
besEND
besFUNCTION(TS_load_string)
DIM AS scheme PTR sc;
DIM AS char PTR cmdstr;
DIM AS char tsbuf[16384];
besARGUMENTS("iz")
AT sc, AT cmdstr
besARGEND
scheme_set_output_port_string (sc, (char*) tsbuf, (char*) tsbuf + 16383);
scheme_load_string(sc, cmdstr);
besRETURN_STRING(tsbuf);
besEND
To return a string trimmed to the right length, you will have to create an SB string copy of the buffer, to the required length. (excluding null terminator for SB strings)
besFUNCTION(TS_load_string)
DIM AS scheme PTR sc;
DIM AS char PTR cmdstr;
DIM AS char tsbuf[16384];
besARGUMENTS("iz")
AT sc, AT cmdstr
besARGEND
scheme_set_output_port_string (sc, (char*) tsbuf, (char*) tsbuf + 16383);
scheme_load_string(sc, cmdstr);
besRETURN_STRING(rtrim(tsbuf));
besEND
' Tiny Scheme - extension module example
DECLARE SUB InitNew ALIAS "TS_init_new" LIB "ts"
DECLARE SUB Deinit ALIAS "TS_deinit" LIB "ts"
DECLARE SUB LoadStr ALIAS "TS_load_string" LIB "ts"
sc = InitNew()
LoadStr(sc, "(load \"init.scm\")")
PRINT LoadStr(sc, "(load \"mbrot2.scm\")"),"\n"
Deinit sc
jrs@laptop:~/sb/sb22/sblisp$ time scriba tsmbrot.sb
Ascii Mandelbrot TinyScheme
---------------------------
1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 3 3 3 3 3 2 2 2 2 2 2 2 2 2
1 1 1 1 1 1 1 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2
1 1 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 115 4 4 3 3 2 2 2
1 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 5 7 9 114 4 3 3 2 2
1 1 1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 9 118 5 4 4 3 3 3
1 1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 8 1111116 5 5 4 3 3
1 1 1 1 1 2 3 3 3 3 3 3 3 4 4 4 5 7 8 8 101111119 6 6 5 4 3
1 1 1 1 2 3 3 3 3 3 3 3 4 4 5 5 6 11111111111111111111114 3
1 1 1 1 2 3 3 3 3 3 4 5 5 5 5 6 8 111111111111111111117 5 3
1 1 1 1 3 3 3 3 4 5 7 7 7 7 7 7 11111111111111111111119 5 4
1 1 1 1 3 4 4 4 5 5 7 111111119 1111111111111111111111116 4
1 1 1 1 4 4 4 5 5 6 8 11111111111111111111111111111111115 4
1 1 1 1 4 4 6 6 7 1111111111111111111111111111111111118 5 4
1 1 1 1111111111111111111111111111111111111111111111117 5 4
1 1 1 1 4 4 6 6 7 1111111111111111111111111111111111118 5 4
1 1 1 1 4 4 4 5 5 6 8 11111111111111111111111111111111115 4
1 1 1 1 3 4 4 4 5 5 7 111111119 1111111111111111111111116 4
1 1 1 1 3 3 3 3 4 5 7 7 7 7 7 7 11111111111111111111119 5 4
1 1 1 1 2 3 3 3 3 3 4 5 5 5 5 6 8 111111111111111111117 5 3
1 1 1 1 2 3 3 3 3 3 3 3 4 4 5 5 6 11111111111111111111114 3
1 1 1 1 1 2 3 3 3 3 3 3 3 4 4 4 5 7 8 8 101111119 6 6 5 4 3
1 1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 8 1111116 5 5 4 3 3
1 1 1 1 1 1 2 3 3 3 3 3 3 3 3 4 4 4 4 5 6 9 118 5 4 4 3 3 3
1 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 5 7 9 114 4 3 3 2 2
1 1 1 1 1 1 1 2 2 2 3 3 3 3 3 3 3 3 4 4 4 115 4 4 3 3 2 2 2
1 1 1 1 1 1 1 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2
real 0m0.661s
user 0m0.656s
sys 0m0.000s
jrs@laptop:~/sb/sb22/sblisp$
Well, I try to do everything in Lisp, but whatever they tell , for top speed calculus it's better to use something as Oxygen , FB , C etc...
you can write programs mutating themselves , save the mutant and run the mutant -- in the mean time, we can smoke the cigarette and drink the whiskey ...
' King's Reward
IMPORT ts.inc
scm = TS_New()
TS_Cmd scm, "(load \"init.scm\")"
reward = """
(define (grains x)
(let loop ((i 1) (j 1.0))
(display " field ") (display i)
(display " number of grains ")(display j) (newline)
(when (< i x) (loop (+ i 1) (* 2 j) ))))
(define (main)
(display "The reward of the King") (newline)
(display "----------------------") (newline)
(newline)
(grains 64))
(main)
"""
PRINT TS_Cmd(scm, reward)
TS_Close scm
// Tiny Scheme - Script BASIC extension module
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <math.h>
#include <time.h>
#include "../../basext.h"
#include "cbasic.h"
#define USE_INTERFACE 1
#include "scheme.h"
#include "scheme-private.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
/***********************
Tiny Scheme Functions
***********************/
besFUNCTION(TS_init_new)
DIM AS scheme PTR sc;
sc = scheme_init_new();
besRETURN_LONG(sc);
besEND
besFUNCTION(TS_deinit)
DIM AS scheme PTR sc;
besARGUMENTS("i")
AT sc
besARGEND
scheme_deinit(sc);
besRETURNVALUE = NULL;
besEND
besFUNCTION(TS_load_string)
DIM AS scheme PTR sc;
DIM AS char PTR cmdstr;
DIM AS char tsbuf[16384];
besARGUMENTS("iz")
AT sc, AT cmdstr
besARGEND
scheme_set_output_port_string (sc, (char PTR) tsbuf, (char PTR) tsbuf + 16383);
scheme_load_string(sc, cmdstr);
besRETURN_STRING(RTRIM(tsbuf));
besEND
' TinyScheme
DECLARE SUB TS_New ALIAS "TS_init_new" LIB "ts"
DECLARE SUB TS_Close ALIAS "TS_deinit" LIB "ts"
DECLARE SUB TS_Cmd ALIAS "TS_load_string" LIB "ts"
' Kings Reward
grains = 1
PRINT "The reward of the King\n----------------------\n\n"
FOR field = 1 to 64
PRINT FORMAT("field %g number of grains %d\n", field, grains)
grains = grains * 2
NEXT
how to mark the number is inexact : use 1.0 i.o. 1 (otherwise it will run out of capable numbers)
' King's Reward
DECLARE SUB InitNew ALIAS "TS_init_new" LIB "ts"
DECLARE SUB Deinit ALIAS "TS_deinit" LIB "ts"
DECLARE SUB LoadStr ALIAS "TS_load_string" LIB "ts"
sc = InitNew()
LoadStr(sc, "(load \"init.scm\")")
reward = """
(define (grains x)
(let loop ((i 1) (j 1))
(display " field ") (display i)
(display " number of grains ")(display j) (newline)
(when (< i x) (loop (+ i 1) (* 2 j) ))))
(define (main)
(display "The reward of the King") (newline)
(display "----------------------") (newline)
(newline)
(grains 64))
(main)
"""
PRINT LoadStr(sc, reward)
Deinit sc
A worker in southern China was left hanging from 100 feet up the side of a high-rise apartment building when a 10-year-old boy, apparently annoyed at the construction racket outside his window, decided to cut the safety line on the man's rappelling apparatus.
Xinhua says the boy was watching cartoons in his eighth-floor apartment in Guizhou province as the worker was outside installing lighting. So, the boy took a knife and sliced through the rope that allows the worker to move up and down.
According to an English translation of the Xinhua article on the Shanghaiist website, the worker was left dangling midair. He yelled down to a co-worker, who called firemen; he was rescued about 40 minutes later.
a = STRING(5," ")
b = TS_Cmd(scm, "(+ 2 2)", a)
Use the right tool for the job.
The Scheme should be there, to analyze complex structures, run binary trees , very high level abstractions etc ...
' Character Mandelbrot
IMPORT ts.inc
sc = TS_New()
TS_Cmd sc, "(load \"init.scm\")"
mbrot = """
(newline)
(newline)
(display "Ascii Mandelbrot TinyScheme") (newline)
(display "---------------------------") (newline)
(define sq
(lambda (x) (* x x)))
(define (1+ x) (+ x 1))
(define (1- x) (- x 1))
(define level
(lambda (i x y rc ic it orb)
(if (or (= i it) (> orb 4)) i
(level (1+ i) (+ rc (- (sq x) (sq y))) (+ ic (* 2 x y)) rc ic it (+ (sq x) (sq y))))))
(define mlevel
(lambda (L)
(level 0 (cadr L) (car L) (cadr L) (car L) 11 0)))
(define (main)
(let ((cnt 0) (lvl 0) (xo -1.7) (yo -2.3) (dz 0.1) )
(do ((i 0 (1+ i)))
((= i 30))
(do ((j 0 (1+ j)))
((= 30 j))
(set! lvl (mlevel (list (+ xo (* i dz)) (+ yo (* j dz)) )))
(if (< lvl 10)
(begin (display lvl) (display " "))
(display lvl))
(set! cnt (1+ cnt))
(when (= 30 cnt)
(set! cnt 0)
(newline))
))))
(main)
"""
PRINT TS_Cmd(sc, mbrot),"\n"
TS_Close sc
' ScriptBasic GFX - Mandelbrot
IMPORT gfx.inc
s = gfx::Window(640,480,"ScriptBasic GFX Mandelbrot")
ts = gfx::Time()
FOR y = 0 TO 479
FOR x = 0 TO 639
cx = (x - 320) / 120
cy = (y - 240) / 120
rit = gfx::Mandelbrot(cx, cy, 510)
gfx::PixelRGBA s, x, y, rit * 12, rit * 8, rit * 4, 255
NEXT
NEXT
te = gfx::Time()
gfx::stringColor s, 20, 15, "Time: " & FORMAT("%.4f",(te-ts)/1000) & " Seconds." & CHR(0), 0x000000ff
gfx::Update
WHILE gfx::KeyName(1) <> "+escape"
WEND
gfx::Close
besFUNCTION(gfx_Mandelbrot)
DIM AS double cx, cy, zx, zy, tp;
DIM AS int iter;
besARGUMENTS("rri")
AT cx, AT cy, AT iter
besARGEND
DEF_WHILE (zx * zx + zy * zy < 4 AND iter > 0)
BEGIN_WHILE
tp = zx * zx - zy * zy + cx;
zy = 2 * zx * zy + cy;
zx = tp;
iter = iter - 1;
WEND
besRETURN_LONG(iter);
besEND
Critical orbits of complex numbers
Graphically speaking, a function of the form f (x) = x2 + c (where c is a complex number) is a special function under iteration. If you plot the results of the iterations (starting at x = 0) in the complex plane, you obtain what is called the critical orbits of c. If these critical orbits repeat (where the same point in the complex plane repeats), the complex number is in the Mandelbrot set. If the critical orbits simply move further and further away from the origin, the complex numbers are not in the Mandelbrot set.
tsx_mysql(1) API Reference tsx_mysql(1)
NAME
tsx_mysql.so <-> a mysql extension for tiny scheme
SYNOPSIS
(load-extension "tsx_mysql")
Load the MySQL extension into the tiny scheme environment.
(mysql-connect hostname username password database)
Connect to a MySQL database. This function takes four string
arguments: hostname, username, password, database.
(mysql-disconnect)
Disconnect from a MySQL database.
(mysql-query sql)
Query a MySQL database. This function takes a string containing
SQL statements. The query results will be returned as a list of
strings.
(mysql-error)
Returns the current MySQL error string.
FILES
tsx_mysql.so
AUTHOR
A. Carl Douglas (carl.douglas@gmail.com)
tsx_mysql.so 11 July 2011 tsx_mysql(1)
ts> (load-extension "tsx")
#t
ts> (time)
(114 8 1 17 59 44)
ts> (gettimeofday)
(1409619622 865397)
ts> (file-size "init.scm")
24511
ts> (system "ls -l init.scm")
-rw-rw-r-- 1 jrs jrs 24511 Sep 1 16:45 init.scm
0
ts>
(define (ack m n)
(cond ((= m 0) (+ n 1))
((= n 0) (ack (- m 1) 1))
(else (ack (- m 1) (ack m (- n 1))))))
(define (main . args)
(run-benchmark
"ack"
ack-iters
(lambda (result) (equal? result 4093))
(lambda (m n) (lambda () (ack m n)))
3
9))
.section .data
_ack_1:
.long 2 + 256<<2
.text
# compute initial value for global variable
# jump past the body of the lambda
jmp _ack_2
.section .rodata
# align pointers so they end in binary 00
.align 4
_ack_3:
.long 0xca11ab1e
.long _ack_4
.long 0
.text
.type _ack_4, @function
_ack_4:
# compute desired %esp on return in %ebx and push it
# the extra offset of 4 skips over the return address
lea 4(%esp,%edx,4), %ebx
push %ebx
push %ebp
lea 12(%esp), %ebp
cmpl $2, %edx
jnz argument_count_wrong
# discarding useless value in %eax
pop %eax
# %ifeq
push %eax
movl 0(%ebp), %eax
push %eax
movl $1 + 0<<2, %eax
cmpl %eax, (%esp)
pop %eax
pop %eax
jnz _ack_5
push %eax
movl $1 + 1<<2, %eax
push %eax
movl 4(%ebp), %eax
# inlined integer add
call ensure_integer
xchg %eax, (%esp)
call ensure_integer
pop %ebx
add %ebx, %eax
dec %eax
jmp _ack_6
_ack_5:
# %ifeq
push %eax
movl 4(%ebp), %eax
push %eax
movl $1 + 0<<2, %eax
cmpl %eax, (%esp)
pop %eax
pop %eax
jnz _ack_7
push %eax
movl $1 + 1<<2, %eax
push %eax
movl $1 + 1<<2, %eax
push %eax
movl 0(%ebp), %eax
# inlined integer subtract
call ensure_integer
xchg %eax, (%esp)
call ensure_integer
sub %eax, (%esp)
pop %eax
inc %eax
# get procedure
push %eax
movl (_ack_1), %eax
# apply procedure
# Tail call; nargs = 2
# Note %esp points at the last thing pushed,
# not the next thing to push. So for 1 arg, we want %ebx=%esp
lea 4(%esp), %ebx
movl -4(%ebp), %edx
movl -8(%ebp), %esp
movl -12(%ebp), %ebp
push 0(%ebx)
push -4(%ebx)
push %edx
call ensure_procedure
movl 4(%eax), %ebx
movl $2, %edx
jmp *%ebx
jmp _ack_8
_ack_7:
push %eax
movl $1 + 1<<2, %eax
push %eax
movl 4(%ebp), %eax
# inlined integer subtract
call ensure_integer
xchg %eax, (%esp)
call ensure_integer
sub %eax, (%esp)
pop %eax
inc %eax
push %eax
movl 0(%ebp), %eax
# get procedure
push %eax
movl (_ack_1), %eax
# apply procedure
call ensure_procedure
movl 4(%eax), %ebx
movl $2, %edx
call *%ebx
push %eax
movl $1 + 1<<2, %eax
push %eax
movl 0(%ebp), %eax
# inlined integer subtract
call ensure_integer
xchg %eax, (%esp)
call ensure_integer
sub %eax, (%esp)
pop %eax
inc %eax
# get procedure
push %eax
movl (_ack_1), %eax
# apply procedure
# Tail call; nargs = 2
# Note %esp points at the last thing pushed,
# not the next thing to push. So for 1 arg, we want %ebx=%esp
lea 4(%esp), %ebx
movl -4(%ebp), %edx
movl -8(%ebp), %esp
movl -12(%ebp), %ebp
push 0(%ebx)
push -4(%ebx)
push %edx
call ensure_procedure
movl 4(%eax), %ebx
movl $2, %edx
jmp *%ebx
_ack_8:
_ack_6:
# procedure epilogue
# get return address
movl -4(%ebp), %edx
movl -8(%ebp), %esp
movl -12(%ebp), %ebp
jmp *%edx
.size _ack_4, .-_ack_4
_ack_2:
push %eax
movl $_ack_3, %eax
# initialize global variable with value
movl %eax, (_ack_1)
pop %eax
.section .data
_main_1:
.long 2 + 256<<2
.text
# compute initial value for global variable
# jump past the body of the lambda
jmp _main_2
.section .rodata
# align pointers so they end in binary 00
.align 4
_main_3:
.long 0xca11ab1e
.long _main_4
.long 0
.text
.type _main_4, @function
_main_4:
# make space for variadic argument list
pop %ebx
push %ebx
push %ebx
# push desired %esp on return
lea 8(%esp,%edx,4), %ebx
push %ebx
push %ebp
lea 12(%esp), %ebp
call package_up_variadic_args
# discarding useless value in %eax
pop %eax
push %eax
movl $1 + 9<<2, %eax
push %eax
movl $1 + 3<<2, %eax
# jump past the body of the lambda
jmp _main_5
.section .rodata
# align pointers so they end in binary 00
.align 4
_main_6:
.long 0xca11ab1e
.long _main_7
.long 0
.text
.type _main_7, @function
_main_7:
# compute desired %esp on return in %ebx and push it
# the extra offset of 4 skips over the return address
lea 4(%esp,%edx,4), %ebx
push %ebx
push %ebp
lea 12(%esp), %ebp
cmpl $2, %edx
jnz argument_count_wrong
# discarding useless value in %eax
pop %eax
# move arg from stack to heap: m
push %eax
movl 0(%ebp), %eax
# moving top of stack to newly allocated heap var
# allocate bytes: 8
push %eax
movl (arena_pointer), %eax
add $8, (arena_pointer)
cmpl $end_arena, (arena_pointer)
ja arena_full
# now %eax points to newly allocated memory
movl $0x1ce11ed, (%eax)
pop 4(%eax)
# move arg from stack to heap: n
push %eax
movl 4(%ebp), %eax
# moving top of stack to newly allocated heap var
# allocate bytes: 8
push %eax
movl (arena_pointer), %eax
add $8, (arena_pointer)
cmpl $end_arena, (arena_pointer)
ja arena_full
# now %eax points to newly allocated memory
movl $0x1ce11ed, (%eax)
pop 4(%eax)
# jump past the body of the lambda
jmp _main_8
.text
.type _main_9, @function
_main_9:
# compute desired %esp on return in %ebx and push it
# the extra offset of 4 skips over the return address
lea 4(%esp,%edx,4), %ebx
push %ebx
push %ebp
lea 12(%esp), %ebp
cmpl $0, %edx
jnz argument_count_wrong
# fetch artifact from closure: 0 m
push 12(%eax)
# fetch artifact from closure: 1 n
push 16(%eax)
# discarding useless value in %eax
pop %eax
# fetching heap var pointer 1
push %eax
movl -20(%ebp), %eax
# fetch current value from the heap
movl 4(%eax), %eax
# fetching heap var pointer 0
push %eax
movl -16(%ebp), %eax
# fetch current value from the heap
movl 4(%eax), %eax
# get procedure
push %eax
movl (_ack_1), %eax
# apply procedure
# Tail call; nargs = 2
# Note %esp points at the last thing pushed,
# not the next thing to push. So for 1 arg, we want %ebx=%esp
lea 4(%esp), %ebx
movl -4(%ebp), %edx
movl -8(%ebp), %esp
movl -12(%ebp), %ebp
push 0(%ebx)
push -4(%ebx)
push %edx
call ensure_procedure
movl 4(%eax), %ebx
movl $2, %edx
jmp *%ebx
# procedure epilogue
# get return address
movl -4(%ebp), %edx
movl -8(%ebp), %esp
movl -12(%ebp), %ebp
jmp *%edx
.size _main_9, .-_main_9
_main_8:
# allocate bytes: 20
push %eax
movl (arena_pointer), %eax
add $20, (arena_pointer)
cmpl $end_arena, (arena_pointer)
ja arena_full
# now %eax points to newly allocated memory
movl %eax, %ebx
movl $0xca11ab1e, (%ebx)
movl $_main_9, 4(%ebx)
movl $2, 8(%ebx)
# fetching heap var pointer 0
push %eax
movl -16(%ebp), %eax
movl %eax, 12(%ebx)
pop %eax
# fetching heap var pointer 1
push %eax
movl -20(%ebp), %eax
movl %eax, 16(%ebx)
pop %eax
# procedure epilogue
# get return address
movl -4(%ebp), %edx
movl -8(%ebp), %esp
movl -12(%ebp), %ebp
jmp *%edx
.size _main_7, .-_main_7
_main_5:
push %eax
movl $_main_6, %eax
# jump past the body of the lambda
jmp _main_10
.section .rodata
# align pointers so they end in binary 00
.align 4
_main_11:
.long 0xca11ab1e
.long _main_12
.long 0
.text
.type _main_12, @function
_main_12:
# compute desired %esp on return in %ebx and push it
# the extra offset of 4 skips over the return address
lea 4(%esp,%edx,4), %ebx
push %ebx
push %ebp
lea 12(%esp), %ebp
cmpl $1, %edx
jnz argument_count_wrong
# discarding useless value in %eax
pop %eax
push %eax
movl $1 + 4093<<2, %eax
push %eax
movl 0(%ebp), %eax
# get procedure
push %eax
movl (_equalP_1), %eax
# apply procedure
# Tail call; nargs = 2
# Note %esp points at the last thing pushed,
# not the next thing to push. So for 1 arg, we want %ebx=%esp
lea 4(%esp), %ebx
movl -4(%ebp), %edx
movl -8(%ebp), %esp
movl -12(%ebp), %ebp
push 0(%ebx)
push -4(%ebx)
push %edx
call ensure_procedure
movl 4(%eax), %ebx
movl $2, %edx
jmp *%ebx
# procedure epilogue
# get return address
movl -4(%ebp), %edx
movl -8(%ebp), %esp
movl -12(%ebp), %ebp
jmp *%edx
.size _main_12, .-_main_12
_main_10:
push %eax
movl $_main_11, %eax
push %eax
movl (_main_13), %eax
.section .rodata
# align pointers so they end in binary 00
.align 4
_main_14:
.long 0xbabb1e
.long 3
.ascii "ack"
.text
push %eax
movl $_main_14, %eax
# get procedure
push %eax
movl (_main_15), %eax
# apply procedure
# Tail call; nargs = 6
# Note %esp points at the last thing pushed,
# not the next thing to push. So for 1 arg, we want %ebx=%esp
lea 20(%esp), %ebx
movl -4(%ebp), %edx
movl -8(%ebp), %esp
movl -12(%ebp), %ebp
push 0(%ebx)
push -4(%ebx)
push -8(%ebx)
push -12(%ebx)
push -16(%ebx)
push -20(%ebx)
push %edx
call ensure_procedure
movl 4(%eax), %ebx
movl $6, %edx
jmp *%ebx
# procedure epilogue
# get return address
movl -4(%ebp), %edx
movl -8(%ebp), %esp
movl -12(%ebp), %ebp
jmp *%edx
.size _main_4, .-_main_4
_main_2:
push %eax
movl $_main_3, %eax
# initialize global variable with value
movl %eax, (_main_1)
pop %eax
compiler.ss.zip (25.82 kB - downloaded 1 times.)
Where are all the other parts of this compiler package?
This is WAY over my head and I'm glad you have shown some interest in this for the Lisp in BASIC projects.
Yet the experience has been really entertaining and instructive.
' Kings Reward
grains = 1
PRINT "The reward of the King\n----------------------\n\n"
FOR field = 1 to 64
PRINT FORMAT("field %g number of grains %d\n", field, grains)
grains = grains * 2
NEXT
C:\sb22_64\TS>scriba king.sb
The reward of the King
----------------------
field 1 number of grains 1
field 2 number of grains 2
field 3 number of grains 4
field 4 number of grains 8
field 5 number of grains 16
field 6 number of grains 32
field 7 number of grains 64
field 8 number of grains 128
field 9 number of grains 256
field 10 number of grains 512
field 11 number of grains 1024
field 12 number of grains 2048
field 13 number of grains 4096
field 14 number of grains 8192
field 15 number of grains 16384
field 16 number of grains 32768
field 17 number of grains 65536
field 18 number of grains 131072
field 19 number of grains 262144
field 20 number of grains 524288
field 21 number of grains 1048576
field 22 number of grains 2097152
field 23 number of grains 4194304
field 24 number of grains 8388608
field 25 number of grains 16777216
field 26 number of grains 33554432
field 27 number of grains 67108864
field 28 number of grains 134217728
field 29 number of grains 268435456
field 30 number of grains 536870912
field 31 number of grains 1073741824
field 32 number of grains -2147483648
field 33 number of grains -2147483648
field 34 number of grains -2147483648
field 35 number of grains -2147483648
field 36 number of grains -2147483648
field 37 number of grains -2147483648
field 38 number of grains -2147483648
field 39 number of grains -2147483648
field 40 number of grains -2147483648
field 41 number of grains -2147483648
field 42 number of grains -2147483648
field 43 number of grains -2147483648
field 44 number of grains -2147483648
field 45 number of grains -2147483648
field 46 number of grains -2147483648
field 47 number of grains -2147483648
field 48 number of grains -2147483648
field 49 number of grains -2147483648
field 50 number of grains -2147483648
field 51 number of grains -2147483648
field 52 number of grains -2147483648
field 53 number of grains -2147483648
field 54 number of grains -2147483648
field 55 number of grains -2147483648
field 56 number of grains -2147483648
field 57 number of grains -2147483648
field 58 number of grains -2147483648
field 59 number of grains -2147483648
field 60 number of grains -2147483648
field 61 number of grains -2147483648
field 62 number of grains -2147483648
field 63 number of grains -2147483648
field 64 number of grains -2147483648
C:\sb22_64\TS>
% filename "t.exe"
includepath "$/inc/"
include "RTL64.inc"
include "console.inc"
' Kings Reward
sys grains = 1
PRINT "The reward of the King"
FOR field = 1 to 64
PRINTL "field number of grains " & field & ", " & grains
grains = grains * 2
NEXT
waitkey
/*
The reward of the King
field number of grains 1, 1
field number of grains 2, 2
field number of grains 3, 4
field number of grains 4, 8
field number of grains 5, 16
field number of grains 6, 32
field number of grains 7, 64
field number of grains 8, 128
field number of grains 9, 256
field number of grains 10, 512
field number of grains 11, 1024
field number of grains 12, 2048
field number of grains 13, 4096
field number of grains 14, 8192
field number of grains 15, 16384
field number of grains 16, 32768
field number of grains 17, 65536
field number of grains 18, 131072
field number of grains 19, 262144
field number of grains 20, 524288
field number of grains 21, 1048576
field number of grains 22, 2097152
field number of grains 23, 4194304
field number of grains 24, 8388608
field number of grains 25, 16777216
field number of grains 26, 33554432
field number of grains 27, 67108864
field number of grains 28, 134217728
field number of grains 29, 268435456
field number of grains 30, 536870912
field number of grains 31, 1073741824
field number of grains 32, 2147483648
field number of grains 33, 4294967296
field number of grains 34, 8589934592
field number of grains 35, 17179869184
field number of grains 36, 34359738368
field number of grains 37, 68719476736
field number of grains 38, 137438953472
field number of grains 39, 274877906944
field number of grains 40, 549755813888
field number of grains 41, 1099511627776
field number of grains 42, 2199023255552
field number of grains 43, 4398046511104
field number of grains 44, 8796093022208
field number of grains 45, 17592186044416
field number of grains 46, 35184372088832
field number of grains 47, 70368744177664
field number of grains 48, 140737488355328
field number of grains 49, 281474976710656
field number of grains 50, 562949953421312
field number of grains 51, 1125899906842624
field number of grains 52, 2251799813685248
field number of grains 53, 4503599627370496
field number of grains 54, 9007199254740992
field number of grains 55, 18014398509481984
field number of grains 56, 36028797018963968
field number of grains 57, 72057594037927936
field number of grains 58, 14411518807585587
field number of grains 59, 28823037615171174
field number of grains 60, 57646075230342349
field number of grains 61, 1.152921504606847E+18
field number of grains 62, 2.305843009213694E+18
field number of grains 63, 4.6116860184273879E+18
field number of grains 64, -9.2233720368547758E+18
*/
'
'================================
'MONSTROUS INTEGER MULTIPLICATION
'================================
'------------------------------------------------------
function multiply(ia as string, ib as string) as string
'======================================================
dim as string a,b,c,d
dim as long pa,pb,pc,pd,la,lb,lc,ld
dim as long nd,sh,qa
a=ia
b=ib
la=len a
lb=len b
lc=la+lb'+10
ld=lc'+20
c=nuls lc 'LINE ACCUMULATOR
d=nuls ld 'BLOCK ACCUMULATOR
pa=*a
pb=*b
pc=*c
pd=*d
pushad
'SETUP POINTERS
'==============
mov esi,pa : add esi,la
mov edi,pb : add edi,lb
mov edx,pc : add edx,lc
mov ebx,pa
mov qa,esi 'RIGHT START POSITION FOR NUMBER A
mov nd,edi 'SETUP NEXT DIGIT POINTER (B NUMBER)
mov sh,edx 'SETUP POSITION SHIFT POINTER
'CONVERT FROM ASCII TO BINARY CODED DECIMAL
'==========================================
mov edi,pa
mov ecx,la
(
dec ecx
jl exit
sub byte [edi],48
inc edi
repeat
)
mov edi,pb
mov ecx,lb
(
dec ecx : jl exit
sub byte [edi],48
inc edi
repeat
)
nextline:
'========
'MULTIPLY BY ONE DIGIT
'WORKING FROM RIGHT TO LEFT
dec edi
mov cl,[edi]
mov ch,0
(
dec esi
cmp esi,ebx : jl exit
mov al,[esi]
mov ah,0
mul cl
add al,ch 'ADD CARRY VALUE
mov ch,0 'CLEAR CARRY VALUE
(
cmp al,10
jl exit 'NO CARRY
mov ch,10 'DIVISOR
div ch '
mov ch,al 'CARRY VAL IN CH
mov al,ah 'REMAINDER NOW IN AL
)
dec edx
mov [edx],al
repeat
)
'FINAL CARRY
(
cmp ch,0
jz exit
dec edx
mov [edx],ch
)
'ADD TO BLOCK ACCUMULATOR
'========================
mov esi,pc : add esi,lc
mov edi,pd : add edi,ld
mov ah,0
mov ebx,pc
'BCD ADDITION
'
'WORKING FROM RIGHT TO LEFT
(
dec esi
cmp esi,ebx : jl exit
dec edi
mov al,0
xchg al,[esi] 'LOAD AND THEN CLEAR LINE DIGIT
mov cl,[edi]
add al,ah 'PREVIOUS CARRY
add al,cl 'OPERAND
(
mov ah,0
cmp al,10 : jl exit
sub al,10
inc ah
)
mov [edi],al
repeat
)
mov ebx,pa
mov esi,qa 'START POSITION FOR NUMBER A
mov edi,nd 'NEXT DIGIT IN NUMBER B
dec edi
mov nd,edi
cmp edi,pb : jle fwd done
'SHIFT OUTPUT TO LINE ACCUM
mov edx,sh
dec edx
mov sh,edx
jmp long nextline
done:
'CONVERT FROM BCD TO ASCII
'=========================
mov edi,pd
mov ecx,ld
add ecx,edi
(
cmp edi,ecx : jge exit
add byte [edi],48 : inc edi
repeat
)
'TRIM LEADING ZEROS
'==================
mov edi,pd
mov ecx,ld
add ecx,edi
(
cmp edi,ecx : jge exit
mov al,[edi]
inc edi
cmp al,48 : jg exit
repeat
)
sub edi,pd
mov nd,edi
popad
function=mid(d,nd,ld)
end function
=====
'MAIN
=====
===================
'https://defuse.ca/big-number-calculator.htm
===================
dim as string a,b,ans
a="1"
for i=1 to 10000
a=multiply(a,"2")
next
cr=chr(13,10)
t="2^" i-1 "=" cr a cr
print t
putfile "t.txt",t
===================
2^10000=
19950631168807583848837421626835850838234968318861924548520089498529438830221946631919961684036194597899331129423209124271556491349413781117593785932096323957855730046793794526765246551266059895520550086918193311542508608460618104685509074866089624888090489894838009253941633257850621568309473902556912388065225096643874441046759871626985453222868538161694315775629640762836880760732228535091641476183956381458969463899410840960536267821064621427333394036525565649530603142680234969400335934316651459297773279665775606172582031407994198179607378245683762280037302885487251900834464581454650557929601414833921615734588139257095379769119277800826957735674444123062018757836325502728323789270710373802866393031428133241401624195671690574061419654342324638801248856147305207431992259611796250130992860241708340807605932320161268492288496255841312844061536738951487114256315111089745514203313820202931640957596464756010405845841566072044962867016515061920631004186422275908670900574606417856951911456055068251250406007519842261898059237118054444788072906395242548339221982707404473162376760846613033778706039803413197133493654622700563169937455508241780972810983291314403571877524768509857276937926433221599399876886660808368837838027643282775172273657572744784112294389733810861607423253291974813120197604178281965697475898164531258434135959862784130128185406283476649088690521047580882615823961985770122407044330583075869039319604603404973156583208672105913300903752823415539745394397715257455290510212310947321610753474825740775273986348298498340756937955646638621874569499279016572103701364433135817214311791398222983845847334440270964182851005072927748364550578634501100852987812389473928699540834346158807043959118985815145779177143619698728131459483783202081474982171858011389071228250905826817436220577475921417653715687725614904582904992461028630081535583308130101987675856234343538955409175623400844887526162643568648833519463720377293240094456246923254350400678027273837755376406726898636241037491410966718557050759098100246789880178271925953381282421954028302759408448955014676668389697996886241636313376393903373455801407636741877711055384225739499110186468219696581651485130494222369947714763069155468217682876200362777257723781365331611196811280792669481887201298643660768551639860534602297871557517947385246369446923087894265948217008051120322365496288169035739121368338393591756418733850510970271613915439590991598154654417336311656936031122249937969999226781732358023111862644575299135758175008199839236284615249881088960232244362173771618086357015468484058622329792853875623486556440536962622018963571028812361567512543338303270029097668650568557157505516727518899194129711337690149916181315171544007728650573189557450920330185304847113818315407324053319038462084036421763703911550639789000742853672196280903477974533320468368795868580237952218629120080742819551317948157624448298518461509704888027274721574688131594750409732115080498190455803416826949787141316063210686391511681774304792596709376
I'm trying to understand these warning messages of downgrading my integers.
I attached the complete TinyScheme source a few posts back...
If your unable to help...
And the idea to embed NewLisp ??
Wine has some nice themes nowadays -- some looking better than the original window gadget 8) )
Enjoy and never call me a fool or a spado again.
Can I rerun the msvcbuild.bat again without any warnings with what you uploaded?
If you compiled with no changes to scheme.c, you will not have 64 bit range.
See my example changing long to long long and the fprint %ll change. I had a bunch of warnings saying that integers were truncated but it worked.
(define (grains x)
(let loop ((i 1) (j 1))
(display " field ") (display i)
(display " number of grains ")(display j) (newline)
(when (< i x) (loop (+ i 1) (* 2 j) )))) ; 'when' is an alias to 'if'
(define (main)
(display "The reward of the King") (newline)
(display "----------------------") (newline)
(newline)
(grains 64))
(main)
(newline)
(quit)
-- running everything in 32 bit ---- (sadly)
John, glad to read you could compile it , imho NewLISP is au pair with languages as Perl and Python --
First and foremost, be prepared that conversion will be a multi-stage process.
A moment, you say?
I was in deep thought about what I'm going to have to do to fix SB Win 64...
So why then don't you try and compile the original TS sources with MinGW GCC on 64 bits to see how its maths and print behave without modification?
I feel the only outstanding issue with using MinGW-TDM-64 is getting printf() correctly printing 64 bit values with a %l format option.
} else if (is_number(l)) {
p = sc->strbuff;
if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ {
if (num_is_integer(l)) {
snprintf(p, STRBUFFSIZE, "%I64d", ivalue_unchecked(l));
}
else {
snprintf(p, STRBUFFSIZE, "%.20g", rvalue_unchecked(l));
/* r5rs says there must be a '.' (unless 'e'?) */
f = (int)strcspn(p, ".e");
if (p[f] == 0) {
p[f] = '.'; /* not found, so add '.0' at the end */
p[f+1] = '0';
p[f+2] = 0;
}
}
} else {
__int64 v = ivalue(l);
if (f == 16) {
if (v >= 0)
snprintf(p, STRBUFFSIZE, "%I64x", v);
else
snprintf(p, STRBUFFSIZE, "-%I64x", -v);
}
else if (f == 8) {
if (v >= 0)
snprintf(p, STRBUFFSIZE, "%I64o", v);
else
snprintf(p, STRBUFFSIZE, "-%I64o", -v);
}
else if (f == 2) {
unsigned __int64 b = (v < 0) ? -v : v;
p = &p[STRBUFFSIZE - 1];
*p = 0;
do { *--p = (b & 1) ? '1' : '0'; b >>= 1; } while (b != 0);
if (v < 0) *--p = '-';
}
}
else if (*name == 'o') {/* #o (octal) */
snprintf(tmp, STRBUFFSIZE, "0%s", name+1);
sscanf(tmp, "%I64o", (__int64 unsigned *)&x);
return (mk_integer(sc, x));
} else if (*name == 'd') { /* #d (decimal) */
sscanf(name + 1, "%I64d", (__int64 *)&x);
return (mk_integer(sc, x));
} else if (*name == 'x') { /* #x (hex) */
snprintf(tmp, STRBUFFSIZE, "0x%s", name+1);
sscanf(tmp, "%I64x", (__int64 unsigned *)&x);
return (mk_integer(sc, x));
@Mike - Would you be interested in helping me setup a new All BASIC forum and be a co-admin / moderator?
It would save me some time if you were to post your working code. Is there any additional includes needed or type casting to eliminate warnings?
I think this will fix your console output for long numbers.
I made your changes on a fresh copy of the source and we are still getting zeros from fields 33 to 64.
So no more PITA for you with your extension module to your ScriptBASIC.
gcc.exe -Wall -O3 -Wno-unused -fno-strict-aliasing -fno-common -c dynload.c -o ./obj/dynload.o
gcc.exe -Wall -O3 -Wno-unused -fno-strict-aliasing -fno-common -c scheme.c -o ./obj/scheme.o
g++.exe -o tinyscheme.exe ./obj/dynload.o ./obj/scheme.o -s
It's a pity Rob doesn't run 64 bits.
member of the gang now ,
Has anyone heard from Rob lately?Nope.