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)