Merge branch 'so-dev'

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 R<sup>7</sup>RS 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.

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 

Makefile.config

@@ -5,18 +5,19 @@
 # Configuration options for the makefile
 
 # Compiler options
-CFLAGS       ?= -O2 -Wall -Iinclude -L.
+CFLAGS       ?= -O2 -fPIC -rdynamic -Wall -Iinclude -L.
-COMP_CFLAGS  ?= -O2 -Wall -I$(PREFIX)/include -L$(PREFIX)/lib
+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

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))))
 

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

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)
+;(define (load2 f)
-  (load f *icyc-env*))
+;  (load f *icyc-env*))
-(env:define-variable! 'load load2 *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))

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
  *

include/cyclone/types.h

@@ -18,6 +18,7 @@
 #include <time.h>
 #include <pthread.h>
 #include <stdint.h>
+#include <dlfcn.h>
 #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 */

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);
+}
+

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.

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* ""))
 

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

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)
+         (if (not (null? env))
-                             (primitive-procedure-objects)
+             (car env)
-                             env:the-empty-environment)))
+             (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))); ")
+
   ))

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);")

srfi/60.scm

@@ -1,38 +1,101 @@
-#|
+;;;; Cyclone Scheme
- | Copyright (c) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer
+;;;; https://github.com/justinethier/cyclone
- | Copyright (c) 2017, Koz Ross 
+;;;; 
- |
+;;;; Copyright (c) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer
- | All rights reserved.
+;;;; Copyright (c) 2017, Koz Ross, Justin Ethier 
- |
+;;;; 
- | Redistribution and use in source and binary forms, with or without
+;;;; All rights reserved.
- | modification, are permitted provided that the following conditions are met:
+;;;; 
- |     * Redistributions of source code must retain the above copyright
+;;;; Redistribution and use in source and binary forms, with or without
- |       notice, this list of conditions and the following disclaimer.
+;;;; modification, are permitted provided that the following conditions are met:
- |     * Redistributions in binary form must reproduce the above copyright
+;;;;     * Redistributions of source code must retain the above copyright
- |       notice, this list of conditions and the following disclaimer in the
+;;;;       notice, this list of conditions and the following disclaimer.
- |       documentation and/or other materials provided with the distribution.
+;;;;     * Redistributions in binary form must reproduce the above copyright
- |     * Neither the name of Cyclone nor the
+;;;;       notice, this list of conditions and the following disclaimer in the
- |       names of its contributors may be used to endorse or promote products
+;;;;       documentation and/or other materials provided with the distribution.
- |       derived from this software without specific prior written permission.
+;;;;     * Neither the name of Cyclone nor the
- |
+;;;;       names of its contributors may be used to endorse or promote products
- | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+;;;;       derived from this software without specific prior written permission.
- | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;;; 
- | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- | DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY
+;;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY
- | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
- | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
- | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
- | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;; 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
+(define-syntax binop
-  "(void* data, int argc, closure _, object k, object x, object y)"
+  (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));")
+   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,17 +121,30 @@
 (define-c lognot
   "(void* data, int argc, closure _, object k, object x)"
   "Cyc_check_int(data, x);
-  int result = ~((int)unbox_number(x));
+   alloc_bignum(data, bn);
-  return_closcall1(data, k, obj_int2obj(result));")
+   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_fixnum(data, mask); // TODO: bignum support
-  Cyc_check_int(data, n0);
+   Cyc_check_fixnum(data, n0);
-  Cyc_check_int(data, n1);
+   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));")
@@ -111,13 +173,19 @@
 (define-c integer-length
   "(void* data, int argc, closure _, object k, object x)"
   "Cyc_check_int(data, x);
+   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));")
+     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) {
+;     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_int(data,y);
+    Cyc_check_fixnum(data,y);
-  int bf = (int)unbox_number(x);
+    int shift, i;
-  int shift = (int)unbox_number(y);
+    //int result;
-  int i;
+    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++) {
-                 bf *= 2;
+         mp_mul_2(&bignum_value(bn), &bignum_value(bn));
       }
     } else {
       for (i = 0; i < abs(shift); i++) {
-                bf /= 2; 
+         mp_div_2(&bignum_value(bn), &bignum_value(bn));
       }
     }
-  return_closcall1(data, k, obj_int2obj(bf))")
+
+    return_closcall1(data, k, Cyc_bignum_normalize(data, bn));")
 
 (define arithmetic-shift ash)