diff --git a/CHANGELOG.md b/CHANGELOG.md
index c33baf4e..db110147 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,15 +1,17 @@
# Changelog
-## TBD (Tenatively 0.4.1)
+## TBD (Tenatively 0.5)
Features
+- Cyclone now has support in the interpreter for loading libraries via `import`. This is probably the most important change in this release and allows `icyc` to be used to its full potential.
- Store parameter objects in such a way that changes to a parameter object do not affect other threads that use the same parameter object.
The specific requirement from R7RS is:
> `parameterize` must not change the associated values of any parameters in any thread other than the current thread and threads created inside the `parameterize` body.
+- Added bignum support to SRFI 60 - integers as bits.
- Normalize the result of `string->number` such that bignums are only returned if the result truly is a bignum.
- Allow Cyclone to find `(cyclone)` prefixed libraries installed in Cyclone's system folder.
- Allow a library to export identifiers that are exported by another library. Previously a library could only export identifiers that it defined directly.
diff --git a/Makefile b/Makefile
index bb6235aa..dd54d793 100644
--- a/Makefile
+++ b/Makefile
@@ -40,7 +40,7 @@ example :
cd $(EXAMPLE_DIR) ; make
clean :
- rm -rf test.txt a.out *.o *.a *.out tags cyclone icyc scheme/*.o scheme/*.c scheme/*.meta srfi/*.c srfi/*.meta srfi/*.o scheme/cyclone/*.o scheme/cyclone/*.c scheme/cyclone/*.meta cyclone.c dispatch.c icyc.c generate-c.c generate-c
+ rm -rf test.txt a.out *.so *.o *.a *.out tags cyclone icyc scheme/*.o scheme/*.so scheme/*.c scheme/*.meta srfi/*.c srfi/*.meta srfi/*.o srfi/*.so scheme/cyclone/*.o scheme/cyclone/*.so scheme/cyclone/*.c scheme/cyclone/*.meta cyclone.c dispatch.c icyc.c generate-c.c generate-c
cd $(EXAMPLE_DIR) ; make clean
rm -rf html tests/*.o tests/*.c
@@ -53,12 +53,15 @@ install : libs install-libs install-includes install-bin
$(MKDIR) $(DESTDIR)$(DATADIR)/srfi/sorting
$(INSTALL) -m0644 scheme/*.sld $(DESTDIR)$(DATADIR)/scheme
$(INSTALL) -m0644 scheme/*.o $(DESTDIR)$(DATADIR)/scheme
+ $(INSTALL) -m0755 scheme/*.so $(DESTDIR)$(DATADIR)/scheme
$(INSTALL) -m0644 scheme/cyclone/*.sld $(DESTDIR)$(DATADIR)/scheme/cyclone
$(INSTALL) -m0644 scheme/cyclone/*.scm $(DESTDIR)$(DATADIR)/scheme/cyclone
$(INSTALL) -m0644 scheme/cyclone/test.meta $(DESTDIR)$(DATADIR)/scheme/cyclone
$(INSTALL) -m0644 scheme/cyclone/*.o $(DESTDIR)$(DATADIR)/scheme/cyclone
+ $(INSTALL) -m0755 scheme/cyclone/*.so $(DESTDIR)$(DATADIR)/scheme/cyclone
$(INSTALL) -m0644 srfi/*.sld $(DESTDIR)$(DATADIR)/srfi
$(INSTALL) -m0644 srfi/*.o $(DESTDIR)$(DATADIR)/srfi
+ $(INSTALL) -m0755 srfi/*.so $(DESTDIR)$(DATADIR)/srfi
$(INSTALL) -m0644 srfi/*.meta $(DESTDIR)$(DATADIR)/srfi
$(INSTALL) -m0644 srfi/list-queues/*.scm $(DESTDIR)$(DATADIR)/srfi/list-queues
$(INSTALL) -m0644 srfi/sets/*.scm $(DESTDIR)$(DATADIR)/srfi/sets
@@ -162,6 +165,7 @@ runtime.o : runtime.c $(HEADERS)
-DCYC_CC_PROG=\"$(CC_PROG)\" \
-DCYC_CC_EXEC=\"$(CC_EXEC)\" \
-DCYC_CC_LIB=\"$(CC_LIB)\" \
+ -DCYC_CC_SO=\"$(CC_SO)\" \
$< -o $@
libcyclone.a : runtime.o gc.o dispatch.o mstreams.o
diff --git a/Makefile.config b/Makefile.config
index c0eb6c25..32e01cc2 100644
--- a/Makefile.config
+++ b/Makefile.config
@@ -5,18 +5,19 @@
# Configuration options for the makefile
# Compiler options
-CFLAGS ?= -O2 -Wall -Iinclude -L.
-COMP_CFLAGS ?= -O2 -Wall -I$(PREFIX)/include -L$(PREFIX)/lib
+CFLAGS ?= -O2 -fPIC -rdynamic -Wall -Iinclude -L.
+COMP_CFLAGS ?= -O2 -fPIC -rdynamic -Wall -I$(PREFIX)/include -L$(PREFIX)/lib
# Use these lines instead for debugging or profiling
#CFLAGS = -g -Wall
#CFLAGS = -g -pg -Wall
CC ?= cc
-LIBS = -pthread -lcyclone -lck -lm -ltommath
+LIBS = -pthread -lcyclone -lck -lm -ltommath -ldl
# Commands "baked into" cyclone for invoking the C compiler
CC_PROG ?= "$(CC) ~src-file~ $(COMP_CFLAGS) -c -o ~exec-file~.o"
CC_EXEC ?= "$(CC) ~exec-file~.o ~obj-files~ $(LIBS) $(COMP_CFLAGS) -o ~exec-file~"
CC_LIB ?= "$(CC) ~src-file~ $(COMP_CFLAGS) -c -o ~exec-file~.o"
+CC_SO ?= "$(CC) -shared -rdynamic -o ~exec-file~.so ~exec-file~.o"
AR ?= ar
#CD ?= cd
diff --git a/cyclone.scm b/cyclone.scm
index 6ee9e670..4b904c40 100644
--- a/cyclone.scm
+++ b/cyclone.scm
@@ -370,7 +370,7 @@
(read-all port))))
;; Compile and emit:
-(define (run-compiler args cc? cc-prog cc-exec cc-lib append-dirs prepend-dirs)
+(define (run-compiler args cc? cc-prog cc-exec cc-lib cc-so append-dirs prepend-dirs)
(let* ((in-file (car args))
(expander (base-expander))
(in-prog-raw (read-file in-file))
@@ -454,15 +454,25 @@
(let ((comp-lib-cmd
(string-replace-all
(string-replace-all
- ;(Cyc-compilation-environment 'cc-lib)
(get-comp-env 'cc-lib cc-lib)
"~src-file~" src-file)
- "~exec-file~" exec-file)))
+ "~exec-file~" exec-file))
+ (comp-so-cmd
+ (string-replace-all
+ (string-replace-all
+ (get-comp-env 'cc-so cc-so)
+ "~src-file~" src-file)
+ "~exec-file~" exec-file))
+ )
(cond
(cc?
- (system comp-lib-cmd))
+ (system comp-lib-cmd)
+ (system comp-so-cmd)
+ )
(else
(display comp-lib-cmd)
+ (newline)
+ (display comp-so-cmd)
(newline))))))))
;; Collect values for the given command line arguments and option.
@@ -499,6 +509,7 @@
(cc-prog (apply string-append (collect-opt-values args "-CP")))
(cc-exec (apply string-append (collect-opt-values args "-CE")))
(cc-lib (apply string-append (collect-opt-values args "-CL")))
+ (cc-so (apply string-append (collect-opt-values args "-CS")))
(append-dirs (collect-opt-values args "-A"))
(prepend-dirs (collect-opt-values args "-I")))
;; Set optimization level(s)
@@ -525,6 +536,8 @@
an executable.
-CL cc-commands Specify a custom command line for the C compiler to compile
a library module.
+ -CS cc-commands Specify a custom command line for the C compiler to compile
+ a shared object module.
-Ox Optimization level, higher means more optimizations will
be used. Set to 0 to disable optimizations.
-d Only generate intermediate C files, do not compile them
@@ -547,5 +560,5 @@
(display "cyclone: no input file")
(newline))
(else
- (run-compiler non-opts compile? cc-prog cc-exec cc-lib append-dirs prepend-dirs))))
+ (run-compiler non-opts compile? cc-prog cc-exec cc-lib cc-so append-dirs prepend-dirs))))
diff --git a/docs/User-Manual.md b/docs/User-Manual.md
index 19b3826a..a308f717 100644
--- a/docs/User-Manual.md
+++ b/docs/User-Manual.md
@@ -123,6 +123,7 @@ File Extension | Notes
`.meta` | These text files contain the expanded version of any macros exported by a Scheme library, and allow other modules to easily use those macros during compilation. This file is not generated when compiling a program.
`.c` | C code file generated by Cyclone.
`.o` | Object file generated by the C compiler from the corresponding `.c` file.
+`.so` | Shared Object files generated by the C compiler from the corresponding `.c` file. These are only generated for Scheme libraries and are used to allow loading a library at runtime.
(None) | Final executable file generated by the C compiler when compiling a program.
## Interpreter
diff --git a/icyc.scm b/icyc.scm
index 424333a1..87af4428 100644
--- a/icyc.scm
+++ b/icyc.scm
@@ -29,7 +29,7 @@
(display *Cyc-version-banner*))
(else #f))
-(define *icyc-env* (setup-environment))
+;(define *icyc-env* (setup-environment))
(define (repl:next-line)
(call/cc
(lambda (k)
@@ -57,7 +57,7 @@
(define (repl)
(display "cyclone> ")
- (let ((c (eval (read) *icyc-env*)))
+ (let ((c (eval (read) #;*icyc-env*)))
(cond
((not (eof-object? c))
(write c)
@@ -68,11 +68,11 @@
(exit 0)))))
;; Use a special version of load to pull defs into the repl's env
-(define (load2 f)
- (load f *icyc-env*))
-(env:define-variable! 'load load2 *icyc-env*)
+;(define (load2 f)
+; (load f *icyc-env*))
+;(env:define-variable! 'load load2 *icyc-env*)
(let ((args (command-line-arguments)))
(if (= (length args) 1)
- (load (car args) *icyc-env*))
+ (load (car args) #;*icyc-env*))
(repl:next-line))
diff --git a/include/cyclone/runtime.h b/include/cyclone/runtime.h
index f62cd9f6..8a497b64 100644
--- a/include/cyclone/runtime.h
+++ b/include/cyclone/runtime.h
@@ -275,6 +275,21 @@ object Cyc_io_read_line(void *data, object cont, object port);
*/
/**@{*/
+#define unboxed_inexact_double_op(data, ptr, OP, z) \
+ double unboxed; \
+ Cyc_check_num(data, z); \
+ if (obj_is_int(z)) { \
+ unboxed = OP(obj_obj2int(z)); \
+ } else if (type_of(z) == integer_tag) { \
+ unboxed = OP(((integer_type *)z)->value); \
+ } else if (type_of(z) == bignum_tag) { \
+ unboxed = OP(mp_get_double(&bignum_value(z))); \
+ } else { \
+ unboxed = OP(((double_type *)z)->value); \
+ } \
+ assign_double(ptr, unboxed); \
+ return ptr;
+
#define return_inexact_double_op(data, cont, OP, z) \
make_double(d, 0.0); \
Cyc_check_num(data, z); \
@@ -349,6 +364,9 @@ object Cyc_num_op_va_list(void *data, int argc,
object(fn_op(void *, common_type *, object)),
int default_no_args, int default_one_arg, object n,
va_list ns, common_type * buf);
+void Cyc_int2bignum(int n, mp_int *bn);
+object Cyc_bignum_normalize(void *data, object n);
+int Cyc_bignum_cmp(bn_cmp_type type, object x, int tx, object y, int ty);
double MRG32k3a (double seed);
/**@}*/
/**
@@ -649,6 +667,16 @@ object find_or_add_symbol(const char *name);
char *_strdup(const char *s);
/**@}*/
+/**
+ * \defgroup prim_glo Library table
+ *
+ * @brief A table of scheme libraries that are loaded.
+ */
+/**@{*/
+object is_library_loaded(const char *name);
+object register_library(const char *name);
+/**@}*/
+
/**
* \defgroup prim_glo Global table
*
diff --git a/include/cyclone/types.h b/include/cyclone/types.h
index f59f73e6..86ed9f9d 100644
--- a/include/cyclone/types.h
+++ b/include/cyclone/types.h
@@ -18,6 +18,7 @@
#include
#include
#include
+#include
#include "tommath.h"
/**
@@ -1059,4 +1060,5 @@ void *gc_alloc_from_bignum(gc_thread_data *data, bignum_type *src);
int gc_minor(void *data, object low_limit, object high_limit, closure cont,
object * args, int num_args);
+void Cyc_import_shared_object(void *data, object cont, object filename, object entry_pt_fnc);
#endif /* CYCLONE_TYPES_H */
diff --git a/runtime.c b/runtime.c
index a45d33e6..b998c144 100644
--- a/runtime.c
+++ b/runtime.c
@@ -148,6 +148,7 @@ char **_cyc_argv = NULL;
static symbol_type __EOF = { {0}, eof_tag, ""}; // symbol_type in lieu of custom type
const object Cyc_EOF = &__EOF;
+static ck_hs_t lib_table;
static ck_hs_t symbol_table;
static int symbol_table_initial_size = 4096;
static pthread_mutex_t symbol_table_lock;
@@ -265,6 +266,13 @@ static bool set_insert(ck_hs_t * hs, const void *value)
*/
void gc_init_heap(long heap_size)
{
+ if (!ck_hs_init(&lib_table,
+ CK_HS_MODE_OBJECT | CK_HS_MODE_SPMC,
+ hs_hash, hs_compare,
+ &my_allocator, 32, 43423)) {
+ fprintf(stderr, "Unable to initialize library table\n");
+ exit(1);
+ }
if (!ck_hs_init(&symbol_table,
CK_HS_MODE_OBJECT | CK_HS_MODE_SPMC,
hs_hash, hs_compare,
@@ -386,6 +394,30 @@ object find_or_add_symbol(const char *name)
/* END symbol table */
+/* Library table */
+object is_library_loaded(const char *name)
+{
+ symbol_type tmp = { {0}, symbol_tag, name};
+ object result = set_get(&lib_table, &tmp);
+ if (result)
+ return boolean_t;
+ return boolean_f;
+}
+
+object register_library(const char *name)
+{
+ symbol_type sym = { {0}, symbol_tag, _strdup(name)};
+ symbol_type *psym = malloc(sizeof(symbol_type));
+ memcpy(psym, &sym, sizeof(symbol_type));
+ // Reuse mutex since lib inserts will be rare
+ pthread_mutex_lock(&symbol_table_lock); // Only 1 "writer" allowed
+ set_insert(&lib_table, psym);
+ pthread_mutex_unlock(&symbol_table_lock);
+ return boolean_t;
+}
+/* END Library table */
+
+
/* Global table */
list global_table = NULL;
@@ -2156,6 +2188,11 @@ object Cyc_compilation_environment(void *data, object cont, object var)
snprintf(buf, sizeof(buf), "%s", CYC_CC_LIB);
make_string(str, buf);
_return_closcall1(data, cont, &str);
+ } else if (strncmp(((symbol) var)->desc, "cc-so", 6) == 0) {
+ char buf[1024];
+ snprintf(buf, sizeof(buf), "%s", CYC_CC_SO);
+ make_string(str, buf);
+ _return_closcall1(data, cont, &str);
}
}
Cyc_rt_raise2(data,
@@ -5587,3 +5624,31 @@ double MRG32k3a (double seed)
return ((p1 - p2) * norm);
}
/* END RNG */
+
+
+/** Dynamic loading */
+void Cyc_import_shared_object(void *data, object cont, object filename, object entry_pt_fnc)
+{
+ char buffer[256];
+ void *handle;
+ function_type entry_pt;
+ Cyc_check_str(data, filename);
+ Cyc_check_str(data, entry_pt_fnc);
+ handle = dlopen(string_str(filename), RTLD_GLOBAL | RTLD_LAZY);
+ if (handle == NULL) {
+ snprintf(buffer, 256, "%s", dlerror());
+ make_string(s, buffer);
+ Cyc_rt_raise2(data, "Unable to import library", &s);
+ }
+ dlerror(); /* Clear any existing error */
+
+ entry_pt = (function_type) dlsym(handle, string_str(entry_pt_fnc));
+ if (entry_pt == NULL) {
+ snprintf(buffer, 256, "%s, %s, %s", string_str(filename), string_str(entry_pt_fnc), dlerror());
+ make_string(s, buffer);
+ Cyc_rt_raise2(data, "Unable to load symbol", &s);
+ }
+ mclosure1(clo, entry_pt, cont);
+ entry_pt(data, 0, &clo, &clo);
+}
+
diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld
index 5bfc26fe..f092b223 100644
--- a/scheme/cyclone/cgen.sld
+++ b/scheme/cyclone/cgen.sld
@@ -1421,6 +1421,9 @@
(emit* "}")
(emit* "void c_" (lib:name->string lib-name) "_entry_pt(data, argc, cont,value) void *data; int argc; closure cont; object value;{ ")
+ (emit* " register_library(\""
+ (lib:name->unique-string lib-name)
+ "\");")
(if (null? lib-pass-thru-exports)
(emit* " c_" (lib:name->string lib-name) "_entry_pt_first_lambda(data, argc, cont,value);")
; GC to ensure objects are moved when exporting exports.
diff --git a/scheme/cyclone/common.sld b/scheme/cyclone/common.sld
index ff6fdee0..2de255b1 100644
--- a/scheme/cyclone/common.sld
+++ b/scheme/cyclone/common.sld
@@ -15,7 +15,7 @@
*version-banner*
*c-file-header-comment*)
(begin
-(define *version-number* "0.4.1")
+(define *version-number* "0.5")
(define *version-name* "")
(define *version* (string-append *version-number* " " *version-name* ""))
diff --git a/scheme/cyclone/libraries.sld b/scheme/cyclone/libraries.sld
index a3650373..dddc77c4 100644
--- a/scheme/cyclone/libraries.sld
+++ b/scheme/cyclone/libraries.sld
@@ -25,6 +25,7 @@
lib:name
lib:name->string
lib:name->symbol
+ lib:name->unique-string
lib:result
lib:exports
lib:rename-exports
@@ -119,6 +120,16 @@
(define (lib:name->string name)
(apply string-append (map mangle (lib:import->library-name name))))
+;; Convert name (as list of symbols) to a mangled string guaranteed to be unique
+(define (lib:name->unique-string name)
+ (foldl
+ (lambda (s acc)
+ (if (> (string-length acc) 0)
+ (string-append acc "_" s)
+ s))
+ ""
+ (map mangle (lib:import->library-name name))))
+
;; Convert library name to a unique symbol
(define (lib:name->symbol name)
(string->symbol
@@ -245,7 +256,7 @@
(tagged-list? 'srfi import)
(tagged-list? 'cyclone import))
(Cyc-installation-dir 'sld)
- "")))
+ "./")))
(call/cc
(lambda (return)
(for-each
diff --git a/scheme/eval.sld b/scheme/eval.sld
index ba517bfe..5ed800b4 100644
--- a/scheme/eval.sld
+++ b/scheme/eval.sld
@@ -10,7 +10,7 @@
(define-library (scheme eval)
(import
(scheme cyclone util)
- ;(scheme cyclone libraries) ;; for handling import sets
+ (scheme cyclone libraries) ;; for handling import sets
(scheme base)
(scheme file)
(scheme write) ;; Only used for debugging
@@ -21,6 +21,8 @@
eval-from-c ; non-standard
create-environment ; non-standard
setup-environment ; non-standard
+ ;; Dynamic import
+ %import
)
(begin
@@ -322,11 +324,11 @@
;; (define (primitive-procedure? proc)
;; (equal? proc 'cons))
-(define (setup-environment)
+(define (setup-environment . env)
(let ((initial-env
- (env:extend-environment (primitive-procedure-names)
- (primitive-procedure-objects)
- env:the-empty-environment)))
+ (if (not (null? env))
+ (car env)
+ (create-initial-environment))))
(cond-expand
(cyclone
;; Also include compiled variables
@@ -335,7 +337,13 @@
(map (lambda (v) (cdr v)) (Cyc-global-vars))
initial-env))
(else initial-env))))
-(define *global-environment* (setup-environment))
+
+(define (create-initial-environment)
+ (env:extend-environment (primitive-procedure-names)
+ (primitive-procedure-objects)
+ env:the-empty-environment))
+(define *initial-environment* (create-initial-environment))
+(define *global-environment* (setup-environment (create-initial-environment)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This step separates syntactic analysis from execution.
@@ -367,6 +375,9 @@
(not (null? (cdr exp))))
(analyze-lambda exp env))
+ ((tagged-list? 'import exp)
+ (analyze-import exp env))
+
;; experimenting with passing these back to eval
((compound-procedure? exp)
(lambda (env) exp)) ;; TODO: good enough? update env?
@@ -424,6 +435,13 @@
; ;(lambda (env)
; (make-macro `(lambda ,vars ,@(lambda-body exp)))))
+(define (analyze-import exp env)
+ (lambda (env)
+ ;; FUTURE: allow %import to take env?
+ ;(write `(%import ,(cdr exp)))
+ (apply %import (cdr exp))
+ 'ok))
+
(define (analyze-if exp a-env)
(let ((pproc (analyze (if-predicate exp) a-env))
(cproc (analyze (if-consequent exp) a-env))
@@ -578,4 +596,42 @@
; (loop))
;(loop)
+
+;; TODO: right now this is a hack, just get all the imports sets and call their entry point
+;; function to initialize them. longer-term will need to only load the specific identifiers
+;; called out in the import sets
+;;
+;; TODO: for some imports (prefix, maybe other stuff), can we do the renaming in the env??
+(define (%import . import-sets)
+ (let (;; Libraries explicitly listed in the import expression
+ (explicit-lib-names
+ (map lib:import->library-name (lib:list->import-set import-sets)))
+ ;; All dependent libraries
+ (lib-names (lib:get-all-import-deps import-sets '() '())))
+ (for-each
+ (lambda (lib-name)
+ (let* ((us (lib:name->unique-string lib-name))
+ (loaded? (c:lib-loaded? us)))
+ (if (or (not loaded?)
+ (member lib-name explicit-lib-names))
+ (c:import-shared-obj
+ (lib:import->filename lib-name ".so")
+ (string-append
+ "c_" (lib:name->string lib-name) "_entry_pt_first_lambda"))
+ ;(begin (write `(,lib-name ,us ,loaded? is already loaded skipping)) (newline))
+ )))
+ lib-names)
+ (set! *global-environment* (setup-environment *initial-environment*))
+ #t))
+
+;; Wrapper around the actual shared object import function
+(define-c c:import-shared-obj
+ "(void *data, int argc, closure _, object k, object fn, object entry_fnc)"
+ " Cyc_import_shared_object(data, k, fn, entry_fnc); ")
+
+(define-c c:lib-loaded?
+ "(void *data, int argc, closure _, object k, object name)"
+ " Cyc_check_str(data, name);
+ return_closcall1(data, k, is_library_loaded(string_str(name))); ")
+
))
diff --git a/scheme/inexact.sld b/scheme/inexact.sld
index 200227e6..f31055ad 100644
--- a/scheme/inexact.sld
+++ b/scheme/inexact.sld
@@ -68,7 +68,16 @@
(/ (c-log z1) (c-log z2*)))))
(define-c c-log
"(void *data, int argc, closure _, object k, object z)"
- " return_inexact_double_op(data, k, log, z);")
+ " return_inexact_double_op(data, k, log, z);"
+; TODO: experimenting with how an inline definition might look.
+; need something that can both work within the same module and
+; also when imported into another module.
+ ;; Inline arguments:
+ "(void *data, object ptr, object z)"
+ ;; must always return an object
+ ;; Inline body:
+ " unboxed_inexact_double_op(data, ptr, log, z);"
+ )
(define-c sin
"(void *data, int argc, closure _, object k, object z)"
" return_inexact_double_op(data, k, sin, z);")
diff --git a/srfi/60.scm b/srfi/60.scm
index 17f459ca..33533f96 100644
--- a/srfi/60.scm
+++ b/srfi/60.scm
@@ -1,38 +1,101 @@
-#|
- | Copyright (c) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer
- | Copyright (c) 2017, Koz Ross
- |
- | All rights reserved.
- |
- | Redistribution and use in source and binary forms, with or without
- | modification, are permitted provided that the following conditions are met:
- | * Redistributions of source code must retain the above copyright
- | notice, this list of conditions and the following disclaimer.
- | * Redistributions in binary form must reproduce the above copyright
- | notice, this list of conditions and the following disclaimer in the
- | documentation and/or other materials provided with the distribution.
- | * Neither the name of Cyclone nor the
- | names of its contributors may be used to endorse or promote products
- | derived from this software without specific prior written permission.
- |
- | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- | DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY
- | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
- | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
- | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
- | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
- | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- |#
+;;;; Cyclone Scheme
+;;;; https://github.com/justinethier/cyclone
+;;;;
+;;;; Copyright (c) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer
+;;;; Copyright (c) 2017, Koz Ross, Justin Ethier
+;;;;
+;;;; All rights reserved.
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions are met:
+;;;; * Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;; * Redistributions in binary form must reproduce the above copyright
+;;;; notice, this list of conditions and the following disclaimer in the
+;;;; documentation and/or other materials provided with the distribution.
+;;;; * Neither the name of Cyclone nor the
+;;;; names of its contributors may be used to endorse or promote products
+;;;; derived from this software without specific prior written permission.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+;;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;;;; DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY
+;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;
-(define-c raw-logand
- "(void* data, int argc, closure _, object k, object x, object y)"
+(define-syntax binop
+ (er-macro-transformer
+ (lambda (expr rename compare)
+ (let* ((fnc (cadr expr))
+ (args
+ "(void* data, int argc, closure _, object k, object x, object y)")
+ (int-code (caddr expr))
+ (bn-op-code (cadddr expr))
+ (body
+ (string-append
"Cyc_check_int(data, x);
- Cyc_check_int(data, y);
- int result = ((int)unbox_number(x)) & ((int)unbox_number(y));
- return_closcall1(data, k, obj_int2obj(result));")
+ Cyc_check_int(data, y);
+
+ if (obj_is_int(x) && obj_is_int(y)) {"
+ int-code
+ "} else {
+ int result;
+ alloc_bignum(data, bn);
+ mp_int *xx, *yy;
+ mp_int tmpx, tmpy;
+
+ if (obj_is_int(x)) {
+ mp_init(&tmpx);
+ Cyc_int2bignum(obj_obj2int(x), &tmpx);
+ xx = &tmpx;
+ } else {
+ xx = &bignum_value(x);
+ }
+
+ if (obj_is_int(y)) {
+ mp_init(&tmpy);
+ Cyc_int2bignum(obj_obj2int(y), &tmpy);
+ yy = &tmpy;
+ } else {
+ yy = &bignum_value(y);
+ }
+
+ "
+ bn-op-code
+ "
+ if (MP_OKAY != result) {
+ char buffer[128];
+ snprintf(buffer, 127, \"Bignum error: %s\", mp_error_to_string(result));
+ Cyc_rt_raise_msg(data, buffer);
+ }
+ return_closcall1(data, k, Cyc_bignum_normalize(data, bn));
+ }
+ ")))
+ `(define-c ,fnc ,args ,body)))))
+
+(begin
+ (binop
+ raw-logand
+ " int result = ((int)unbox_number(x)) & ((int)unbox_number(y));
+ return_closcall1(data, k, obj_int2obj(result)); "
+ " result = mp_and(xx, yy, &(bignum_value(bn))); ")
+ (binop
+ raw-logior
+ " int result = ((int)unbox_number(x)) | ((int)unbox_number(y));
+ return_closcall1(data, k, obj_int2obj(result)); "
+ " result = mp_or(xx, yy, &(bignum_value(bn))); ")
+ (binop
+ raw-logxor
+ " int result = ((int)unbox_number(x)) ^ ((int)unbox_number(y));
+ return_closcall1(data, k, obj_int2obj(result)); "
+ " result = mp_xor(xx, yy, &(bignum_value(bn))); ")
+ )
(define (logand x . rest)
(if (null? rest)
@@ -41,13 +104,6 @@
(define bitwise-and logand)
-(define-c raw-logior
- "(void* data, int argc, closure _, object k, object x, object y)"
- "Cyc_check_int(data, x);
- Cyc_check_int(data, y);
- int result = ((int)unbox_number(x)) | ((int)unbox_number(y));
- return_closcall1(data, k, obj_int2obj(result));")
-
(define (logior x . rest)
(if (null? rest)
x
@@ -55,13 +111,6 @@
(define bitwise-ior logior)
-(define-c raw-logxor
- "(void* data, int argc, closure _, object k, object x, object y)"
- "Cyc_check_int(data, x);
- Cyc_check_int(data, y);
- int result = ((int)unbox_number(x)) ^ ((int)unbox_number(y));
- return_closcall1(data, k, obj_int2obj(result));")
-
(define (logxor x . rest)
(if (null? rest)
x
@@ -72,20 +121,33 @@
(define-c lognot
"(void* data, int argc, closure _, object k, object x)"
"Cyc_check_int(data, x);
- int result = ~((int)unbox_number(x));
- return_closcall1(data, k, obj_int2obj(result));")
+ alloc_bignum(data, bn);
+ if (Cyc_is_bignum(x) == boolean_t) {
+ mp_copy(&bignum_value(x), &bignum_value(bn));
+ } else {
+ Cyc_int2bignum((int)unbox_number(x), &bignum_value(bn));
+ }
+
+ // From https://github.com/libtom/libtommath/issues/30
+ /* A one's complement, aka bitwise NOT, is actually just -a - 1 */
+ //CHECK_ERROR(mp_neg(&op->mp, &out->mp));
+ //CHECK_ERROR(mp_sub_d(&out->mp, 1, &out->mp));
+ mp_neg(&bignum_value(bn), &bignum_value(bn));
+ mp_sub_d(&bignum_value(bn), 1, &bignum_value(bn));
+ return_closcall1(data, k, Cyc_bignum_normalize(data, bn));
+ ")
(define bitwise-not lognot)
(define-c bitwise-if
"(void* data, int argc, closure _, object k,
object mask, object n0, object n1)"
- "Cyc_check_int(data, mask);
- Cyc_check_int(data, n0);
- Cyc_check_int(data, n1);
- int m = unbox_number(mask);
- int result = (m & ((int)unbox_number(n0))) | ((~m) & ((int)unbox_number(n1)));
- return_closcall1(data, k, obj_int2obj(result));")
+ "Cyc_check_fixnum(data, mask); // TODO: bignum support
+ Cyc_check_fixnum(data, n0);
+ Cyc_check_fixnum(data, n1);
+ int m = unbox_number(mask);
+ int result = (m & ((int)unbox_number(n0))) | ((~m) & ((int)unbox_number(n1)));
+ return_closcall1(data, k, obj_int2obj(result));")
(define bitwise-merge bitwise-if)
@@ -111,13 +173,19 @@
(define-c integer-length
"(void* data, int argc, closure _, object k, object x)"
"Cyc_check_int(data, x);
- int input = (int)unbox_number(x);
- int res = 0;
- while (input) {
- res++;
- input >>= 1;
- };
- return_closcall1(data, k, obj_int2obj(res));")
+ if (Cyc_is_bignum(x) == boolean_t) {
+ int res;
+ mp_radix_size(&bignum_value(x), 2, &res);
+ return_closcall1(data, k, obj_int2obj((res - 1)));
+ } else {
+ int input = (int)unbox_number(x);
+ int res = 0;
+ while (input) {
+ res++;
+ input >>= 1;
+ };
+ return_closcall1(data, k, obj_int2obj(res));
+ }")
(define (log2-binary-factors n)
(- (integer-length (raw-logand n (- n))) 1))
@@ -143,23 +211,57 @@
(ash from start)
to))
-(define-c ash
- "(void* data, int argc, closure _, object k, object x, object y)"
- "Cyc_check_int(data, x);
- Cyc_check_int(data,y);
- int bf = (int)unbox_number(x);
- int shift = (int)unbox_number(y);
- int i;
- if (shift > 0) {
- for (i = 0; i < shift; i++) {
- bf *= 2;
- }
- } else {
- for (i = 0; i < abs(shift); i++) {
- bf /= 2;
- }
- }
- return_closcall1(data, k, obj_int2obj(bf))")
+;(define-c ash
+; "(void* data, int argc, closure _, object k, object x, object y)"
+; "Cyc_check_int(data, x);
+; Cyc_check_int(data,y);
+; int bf = (int)unbox_number(x);
+; int shift = (int)unbox_number(y);
+; //int i;
+; if (shift > 0) {
+; bf <<= shift;
+; } else {
+; bf >>= abs(shift);
+; }
+;// if (shift > 0) {
+;// for (i = 0; i < shift; i++) {
+;// bf *= 2;
+;// }
+;// } else {
+;// for (i = 0; i < abs(shift); i++) {
+;// bf /= 2;
+;// }
+;// }
+; return_closcall1(data, k, obj_int2obj(bf))")
+
+ (define-c ash
+ "(void* data, int argc, closure _, object k, object x, object y)"
+ "Cyc_check_int(data, x);
+ Cyc_check_fixnum(data,y);
+ int shift, i;
+ //int result;
+ alloc_bignum(data, bn);
+
+ if (Cyc_is_bignum(x) == boolean_t){
+ mp_copy(&bignum_value(x), &bignum_value(bn));
+ } else {
+ Cyc_int2bignum((int)unbox_number(x), &bignum_value(bn));
+ }
+
+// Inefficient but always works without overflow
+// Should be able to do pure fixnum math in some cases, though
+ shift = (int)unbox_number(y);
+ if (shift > 0) {
+ for (i = 0; i < shift; i++) {
+ mp_mul_2(&bignum_value(bn), &bignum_value(bn));
+ }
+ } else {
+ for (i = 0; i < abs(shift); i++) {
+ mp_div_2(&bignum_value(bn), &bignum_value(bn));
+ }
+ }
+
+ return_closcall1(data, k, Cyc_bignum_normalize(data, bn));")
(define arithmetic-shift ash)