mirror of
https://github.com/justinethier/cyclone.git
synced 2025-05-23 20:15:05 +02:00
Merge branch 'so-dev'
This commit is contained in:
Justin Ethier
commit
36f9ebc25b
15 changed files with 401 additions and 104 deletions
|
|
@ -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.
|
||||
|
|
|
|||
6
Makefile
6
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
23
cyclone.scm
23
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))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
12
icyc.scm
12
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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
*
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
65
runtime.c
65
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);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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* ""))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))); ")
|
||||
|
||||
))
|
||||
|
|
|
|||
|
|
@ -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);")
|
||||
|
|
|
|||
260
srfi/60.scm
260
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 <COPYRIGHT HOLDER> 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 <COPYRIGHT HOLDER> 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)
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue