├── AUTHORS ├── BUGS ├── COPYING ├── COPYING.LIB ├── Doxyfile ├── INSTALL ├── Makefile.am ├── NEWS ├── README ├── TODO ├── bootstrap.sh ├── buildhere └── make-git-snapshot.sh ├── configure.ac ├── core-lib ├── conditions.scm ├── objects.scm ├── std-lib.scm └── system.scm ├── data └── UnicodeData.txt ├── dfsch ├── backquote.h ├── bignum.h ├── compiler.h ├── conditions.h ├── defines.h ├── dfsch.h ├── eqhash.h ├── format.h ├── generate.h ├── generic.h ├── hash.h ├── introspect.h ├── lib │ ├── cdebug.h │ ├── cinspect.h │ ├── cmdopts.h │ ├── collections.h │ ├── console.h │ ├── crypto.h │ ├── csv.h │ ├── curl.h │ ├── extref.h │ ├── ffi.h │ ├── gcollect.h │ ├── gd.h │ ├── http.h │ ├── inet.h │ ├── ini-file.h │ ├── json.h │ ├── minizip.h │ ├── os.h │ ├── pcre.h │ ├── posix-regex.h │ ├── process.h │ ├── random.h │ ├── shtml.h │ ├── socket-port.h │ ├── sxml.h │ ├── threads.h │ ├── tk-gui.h │ ├── tokyo-cabinet.h │ ├── tokyo-tyrant.h │ ├── unix.h │ ├── xml.h │ └── zlib.h ├── load.h ├── magic.h ├── mkhash.h ├── number.h ├── object.h ├── parse.h ├── ports.h ├── random.h ├── serdes.h ├── sha256.h ├── specializers.h ├── strhash.h ├── strings.h ├── types.h ├── util.h ├── weak.h └── writer.h ├── doc ├── dfsch-repl.1 ├── example-module │ ├── AUTHORS │ ├── ChangeLog │ ├── Makefile.am │ ├── NEWS │ ├── README │ ├── bootstrap.sh │ ├── configure.ac │ ├── dfsch-ext │ │ └── example.h │ └── src │ │ ├── example.c │ │ └── example_mod.c ├── indent.el ├── index.html ├── manual.md └── notes.md ├── examples ├── calculator.scm ├── http-server-demo.scm └── tk-gui-demo.scm ├── ext ├── fastlz │ ├── 6pack.c │ ├── 6unpack.c │ ├── LICENSE │ ├── README.TXT │ ├── fastlz.c │ └── fastlz.h ├── minizip │ ├── ioapi.c │ ├── ioapi.h │ ├── unzip.c │ ├── unzip.h │ ├── zip.c │ ├── zip.c~ │ └── zip.h └── upskirt │ ├── BSDmakefile │ ├── GNUmakefile │ ├── LICENSE │ ├── README │ ├── array.c │ ├── array.h │ ├── benchmark.c │ ├── buffer.c │ ├── buffer.h │ ├── expanded_markdown.sh │ ├── kilt.c │ ├── lace.c │ ├── markdown.c │ ├── markdown.h │ ├── renderers.c │ └── renderers.h ├── gen-doc.sh ├── gen-git-rev.sh ├── gen-module-docs.sh ├── git-make-stamp.sh ├── lib-scm ├── dfsch-unit.scm ├── http-server.scm ├── markdown-tools.scm ├── match.scm ├── os-utils.scm ├── simple-tests.scm ├── sql.scm ├── stream-functions.scm └── tk-gui.scm ├── lib ├── cdebug.c ├── cdebug_mod.c ├── cinspect.c ├── cinspect_mod.c ├── cmdopts.c ├── cmdopts_mod.c ├── collections.c ├── collections_mod.c ├── console.c ├── console_mod.c ├── crypto │ ├── aes.c │ ├── aes_tab.h │ ├── blowfish.c │ ├── crypto.c │ ├── curve25519.c │ ├── fe25519.c │ ├── fe25519.h │ ├── ge25519.c │ ├── ge25519.h │ ├── hmac.c │ ├── internal.h │ ├── macros.h │ ├── md4.c │ ├── md5.c │ ├── modes.c │ ├── module.c │ ├── prng.c │ ├── rc4.c │ ├── rsa-pad.c │ ├── rsa.c │ ├── salsa20.c │ ├── sc25519.c │ ├── sc25519.h │ ├── sha1.c │ ├── sha256-desc.c │ ├── sha512.c │ ├── sign25519.c │ └── xtea.c ├── csv.c ├── csv_mod.c ├── curl.c ├── curl_mod.c ├── extref.c ├── extref_mod.c ├── fastlz_mod.c ├── ffi.c ├── ffi_mod.c ├── gcollect.c ├── gd.c ├── gd_mod.c ├── http.c ├── http_mod.c ├── inet.c ├── inet_mod.c ├── ini-file.c ├── ini-file_mod.c ├── json.c ├── json_mod.c ├── markdown_mod.c ├── minizip.c ├── minizip_mod.c ├── os.c ├── os_mod.c ├── pcre.c ├── pcre_mod.c ├── posix-regex.c ├── posix-regex_mod.c ├── process.c ├── process_mod.c ├── random.c ├── rrd_mod.c ├── shtml.c ├── shtml_mod.c ├── socket-port.c ├── socket-port_mod.c ├── sql │ ├── dbi.c │ ├── sql-support.c │ ├── sqlite.c │ └── sqlite3.c ├── sxml.c ├── sxml_mod.c ├── threads.c ├── threads_mod.c ├── tk-gui.c ├── tk-gui_mod.c ├── tokyo-cabinet.c ├── tokyo-cabinet_mod.c ├── tokyo-tyrant.c ├── tokyo-tyrant_mod.c ├── unix.c ├── xml.c ├── xml_mod.c ├── zlib.c └── zlib_mod.c ├── make-version-h.sh ├── src ├── backquote.c ├── bignum.c ├── compiler.c ├── conditions.c ├── dfsch.c ├── eqhash.c ├── format.c ├── forms.c ├── generic.c ├── hash.c ├── internal.h ├── introspect.c ├── load.c ├── macros.c ├── mkhash.c ├── native_cxr.c ├── number.c ├── object.c ├── package.c ├── parse.c ├── ports.c ├── primitives.c ├── random.c ├── repl.c ├── run.c ├── serdes.c ├── sha256.c ├── source-tool.c ├── specializers.c ├── strhash.c ├── strings.c ├── system.c ├── types.c ├── types.h ├── udata-gen.c ├── util.c ├── util.h ├── version.c ├── weak.c └── writer.c ├── tests ├── c-api-test.c ├── compiler-tests.scm ├── fix-regression-tests.scm ├── interp-test.scm ├── json-parser-test.c ├── language-tests.scm ├── library-tests.scm ├── main.scm ├── platform-test.c ├── r5rs-tests.scm ├── scm-test-interp.sh ├── scm-test.sh └── test-macros.h └── tools ├── benchmarks ├── deriv.scm ├── let-tak.scm ├── manyadds.scm ├── parallel.scm └── tak.scm └── docgen.scm /AUTHORS: -------------------------------------------------------------------------------- 1 | * Ales Hakl < ales at hakl dot net > 2 | -------------------------------------------------------------------------------- /BUGS: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | This is dfsch - dfox's scheme implementation. It's essentialy an 2 | embeddable scheme interpreter. For now it's still lacking many 3 | scheme functions, but it's generally usable as embedded scripting 4 | language. 5 | 6 | An useful example how to use this library is binary `dfsch-repl' 7 | produced by compilation, it's source is `src/repl.c'. It's simple 8 | interactive interpreter with some additional convenience features. 9 | 10 | Interpreter depends on Boehm-Demers-Weiser conservative garbage 11 | collector, in theory it is possible to replace all calls to GC_MALLOC 12 | with malloc(3) for testing on platforms without working libgc (for 13 | example Interix), but running any non-toy code without working GC is 14 | not good idea. Console I/O library (used by REPL and debugger) is able 15 | to use readline, but can reasonably work without it. 16 | 17 | Platforms that generally work and are reasonably tested are: 18 | * Linux 2.6 on i386 19 | * Linux 2.6 on amd64 20 | * Linux 2.6 on Alpha 21 | * Linux 2.6 on Sparc (32b mode is more tested, but 64b should 22 | work too) 23 | * Windows 2003 - crosscompiled by mingw 24 | Platforms where it worked last time they was tested: 25 | * Linux 2.4 on StrongARM 26 | * Linux 2.6 on StrongARM 27 | * Solaris 10 on sparc 28 | * Cygwin 29 | Platform that almost worked last time I tried: 30 | * NetBSD 4.0.1 on sparc (pure 64b) 31 | - Problems with confused libgc shared library support 32 | Platforms that simply do not work: 33 | * Interix 34 | - No libgc port 35 | * Windows with MSVC 36 | - No support for C99 37 | Platforms that I'm interested in: 38 | * Linux on PowerPC 39 | * Bare hardware 40 | * Cross-compilation of some subset of dfsch to small embedded 41 | platforms (e.g. AVR) 42 | 43 | 44 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | The big interop idea: 2 | * Optimized weak-key-hash 3 | * Multiple inheritance (at least for user-defined classes, somehow) 4 | * FreeBSD 5 | 6 | Bugfixes: 7 | 8 | nearterm: 9 | * compact-list collection constructor 10 | * define-method as core-lib macro 11 | * weak-value-hash 12 | * weak-list (set?) 13 | * python-like iter() with sentinel 14 | * Iterator building blocks 15 | 16 | 0.4.1: 17 | * encodings 18 | * user defined collections, sequences, mappings, ports 19 | - overriding of type methods 20 | * Allow at least call-next-method in methods with C wrapper 21 | * Futures 22 | * batch compiler 23 | - package API as special forms or something 24 | 25 | Non-version-specific: 26 | * More tests 27 | * Documentation 28 | 29 | 0.4.x fetaures 30 | * Pretty-printer 31 | * Parser rewrite (recursive descent) 32 | - read macros 33 | * non-trivial loop 34 | 35 | Sometimes: 36 | * Unicode 37 | - Normalization 38 | - Collation 39 | 40 | External modules and libraries: 41 | * Sound I/O 42 | * DOM-like API on top of SXML 43 | * AMQP 44 | * Zbar 45 | * Python FFI 46 | -------------------------------------------------------------------------------- /bootstrap.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | VERSION= 3 | 4 | if [ "x$1" != "x" ]; then 5 | VERSION=-$1 6 | fi 7 | 8 | if [ -d "./.git" ]; then 9 | git log > ChangeLog 10 | fi 11 | 12 | autoheader \ 13 | && aclocal$VERSION \ 14 | && libtoolize \ 15 | && automake$VERSION --add-missing \ 16 | && autoconf 17 | -------------------------------------------------------------------------------- /buildhere/make-git-snapshot.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | REV=+`date --iso=date` 4 | 5 | if git rev-parse --verify HEAD >/dev/null 2>&1; then 6 | REV=_git-`git describe` 7 | fi 8 | 9 | if make distcheck; then 10 | mv dfsch-0.4.0-dev.tar.gz dfsch-0.4.0-dev$REV.tar.gz 11 | echo dfsch-0.4.0-dev$REV.tar.gz packaged sucessfully 12 | ln -sf dfsch-0.4.0-dev$REV.tar.gz dfsch-current-snapshot.tar.gz 13 | exit 0 14 | fi 15 | 16 | exit 1 17 | 18 | -------------------------------------------------------------------------------- /core-lib/std-lib.scm: -------------------------------------------------------------------------------- 1 | ;;; dfsch - Scheme-like Lisp dialect 2 | ;;; Standard macros 3 | ;;; Copyright (c) 2010, 2011 Ales Hakl 4 | ;;; 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining 6 | ;;; a copy of this software and associated documentation files (the 7 | ;;; "Software"), to deal in the Software without restriction, including 8 | ;;; without limitation the rights to use, copy, modify, merge, publish, 9 | ;;; distribute, sublicense, and/or sell copies of the Software, and to 10 | ;;; permit persons to whom the Software is furnished to do so, subject to 11 | ;;; the following conditions: 12 | ;;; 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | ;;; 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 20 | ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 21 | ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 22 | ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | ;; General state of interpreter is unknown when this gets loaded 25 | (dfsch:define-package :dfsch%implementation 26 | :uses '(:dfsch :dfsch%internal :dfsch-lang) 27 | :exports '() 28 | :documentation 29 | "Internal package used by self-hosted standard library") 30 | 31 | (dfsch:in-package :dfsch%implementation) 32 | 33 | ;; Exported symbols are explicitly placed into dfsch package, 34 | ;; dfsch%implementation is not intended to be directly used by user code 35 | ;; dfsch%internal presents low level functionality required to implement some 36 | ;; core functionality in scheme code 37 | 38 | (define-macro (dfsch:with-gensyms gensyms &body body) 39 | `@(let ,(map (lambda (name) 40 | `(,name (make-symbol ',(symbol-name name)))) 41 | gensyms) 42 | ,@body)) 43 | 44 | (define-macro (dfsch:loop &body exprs) 45 | (with-gensyms (tag) 46 | `@(catch ',tag 47 | (let () 48 | (define (dfsch:break value) (throw ',tag value)) 49 | (%loop ,@exprs))))) 50 | 51 | (define-macro (dfsch:multiple-value-bind variables values-form &body body) 52 | `(destructuring-bind (&optional ,@variables &rest ,(gensym)) 53 | (%get-values ,values-form) 54 | ,@body)) 55 | -------------------------------------------------------------------------------- /core-lib/system.scm: -------------------------------------------------------------------------------- 1 | ;;; dfsch - Scheme-like Lisp dialect 2 | ;;; System-related macros 3 | ;;; Copyright (c) 2010, 2011 Ales Hakl 4 | ;;; 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining 6 | ;;; a copy of this software and associated documentation files (the 7 | ;;; "Software"), to deal in the Software without restriction, including 8 | ;;; without limitation the rights to use, copy, modify, merge, publish, 9 | ;;; distribute, sublicense, and/or sell copies of the Software, and to 10 | ;;; permit persons to whom the Software is furnished to do so, subject to 11 | ;;; the following conditions: 12 | ;;; 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | ;;; 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 20 | ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 21 | ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 22 | ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | ;; General state of interpreter is unknown when this gets loaded 25 | (dfsch:define-package :dfsch%implementation 26 | :uses '(:dfsch :dfsch%internal :dfsch-lang) 27 | :exports '() 28 | :documentation 29 | "Internal package used by self-hosted standard library") 30 | 31 | (dfsch:in-package :dfsch%implementation) 32 | 33 | (define-macro (dfsch:with-open-file variable args &body body) 34 | (with-gensyms (result) 35 | `(let ((,variable (dfsch:open-file-port ,@args))) 36 | (unwind-protect (begin ,@body) 37 | (dfsch:close-file-port! ,variable))))) 38 | 39 | (define-macro (dfsch:with-input-from-port port &body body) 40 | `(bind-and-rebind %set-current-input-port! 41 | (current-input-port) 42 | ,port 43 | ,@body)) 44 | 45 | (define-macro (dfsch:with-output-to-port port &body body) 46 | `(bind-and-rebind %set-current-output-port! 47 | (current-output-port) 48 | ,port 49 | ,@body)) 50 | 51 | (define-macro (dfsch:with-input-from-string string &body body) 52 | `(with-input-from-port (string-input-port ,string) 53 | ,@body)) 54 | 55 | (define-macro (%with-output-to-string string? &body body) 56 | (with-gensyms (port) 57 | `(let ((,port (string-output-port))) 58 | (with-output-to-port ,port 59 | ,@body) 60 | (string-output-port-value ,port ,string?)))) 61 | 62 | (define-macro (dfsch:with-output-to-string &body body) 63 | `(%with-output-to-string #t ,@body)) 64 | (define-macro (dfsch:with-output-to-byte-vector &body body) 65 | `(%with-output-to-string #f ,@body)) 66 | 67 | -------------------------------------------------------------------------------- /dfsch/backquote.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - dfox's quick and dirty scheme implementation 3 | * Backquote implementation 4 | * Copyright (C) 2005-2010 Ales Hakl 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Lesser General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2.1 of the License, or (at your option) any later version. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19 | * 20 | */ 21 | 22 | #include 23 | 24 | dfsch_object_t* dfsch_backquote_expand(dfsch_object_t* arg); 25 | dfsch_object_t* dfsch_backquote_expand_immutable(dfsch_object_t* arg); 26 | -------------------------------------------------------------------------------- /dfsch/bignum.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - dfox's quick and dirty scheme implementation 3 | * Direct manipulation of bignums 4 | * Copyright (C) 2005-2010 Ales Hakl 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Lesser General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2.1 of the License, or (at your option) any later version. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19 | * 20 | */ 21 | 22 | /* 23 | * This is special direct interface to bignum implementation. Most code should 24 | * use interface in number.h. 25 | */ 26 | 27 | #ifndef H__dfsch__bignum__ 28 | #define H__dfsch__bignum__ 29 | 30 | #include 31 | #include 32 | #include 33 | #include 34 | 35 | typedef struct dfsch_bignum_t dfsch_bignum_t; 36 | 37 | dfsch_bignum_t* dfsch_bignum_from_number(dfsch_object_t* n); 38 | dfsch_object_t* dfsch_bignum_to_number(dfsch_bignum_t* b); 39 | 40 | #define DFSCH_BIGNUM_ARG(al, name) \ 41 | DFSCH_GENERIC_ARG(al, name, dfsch_bignum_t*, dfsch_bignum_from_number) 42 | #define DFSCH_BIGNUM_ARG_OPT(al, name, default) \ 43 | DFSCH_GENERIC_ARG_OPT(al, name, default, \ 44 | dfsch_bignum_t*, dfsch_bignum_from_number) 45 | 46 | dfsch_bignum_t* dfsch_make_bignum_uint64(uint64_t n); 47 | dfsch_bignum_t* dfsch_make_bignum_int64(int64_t n); 48 | 49 | int dfsch_bignum_cmp_abs(dfsch_bignum_t* a, dfsch_bignum_t* b); 50 | int dfsch_bignum_cmp(dfsch_bignum_t* a, dfsch_bignum_t* b); 51 | int dfsch_bignum_equal_p(dfsch_bignum_t* a, dfsch_bignum_t* b); 52 | int dfsch_bignum_sign(dfsch_bignum_t* a); 53 | int dfsch_bignum_even_p(dfsch_bignum_t* a); 54 | 55 | dfsch_bignum_t* dfsch_bignum_add(dfsch_bignum_t* a, dfsch_bignum_t* b); 56 | dfsch_bignum_t* dfsch_bignum_sub(dfsch_bignum_t* a, dfsch_bignum_t* b); 57 | dfsch_bignum_t* dfsch_bignum_neg(dfsch_bignum_t* a); 58 | dfsch_bignum_t* dfsch_bignum_abs(dfsch_bignum_t* a); 59 | dfsch_bignum_t* dfsch_bignum_mul(dfsch_bignum_t* a, dfsch_bignum_t* b); 60 | 61 | void dfsch_bignum_div(dfsch_bignum_t* a, dfsch_bignum_t* b, 62 | dfsch_bignum_t**qp, dfsch_bignum_t** rp); 63 | 64 | dfsch_bignum_t* dfsch_bignum_exp(dfsch_bignum_t* b, 65 | dfsch_bignum_t* e, 66 | dfsch_bignum_t* m); 67 | 68 | dfsch_bignum_t* dfsch_bignum_logand(dfsch_bignum_t* a, dfsch_bignum_t* b); 69 | dfsch_bignum_t* dfsch_bignum_logior(dfsch_bignum_t* a, dfsch_bignum_t* b); 70 | dfsch_bignum_t* dfsch_bignum_logxor(dfsch_bignum_t* a, dfsch_bignum_t* b); 71 | dfsch_bignum_t* dfsch_bignum_lognot(dfsch_bignum_t* a); 72 | dfsch_bignum_t* dfsch_bignum_shr(dfsch_bignum_t* b, size_t count); 73 | dfsch_bignum_t* dfsch_bignum_shl(dfsch_bignum_t* b, size_t count); 74 | 75 | 76 | char* dfsch_bignum_to_string(dfsch_bignum_t* b, unsigned base); 77 | 78 | dfsch_strbuf_t* dfsch_bignum_to_bytes(dfsch_bignum_t* b); 79 | dfsch_bignum_t* dfsch_bignum_from_bytes(uint8_t* buf, size_t len, int negative); 80 | 81 | int dfsch_bignum_to_uint64(dfsch_bignum_t* b, uint64_t* rp); 82 | int dfsch_bignum_to_int64(dfsch_bignum_t* b, int64_t* rp); 83 | double dfsch_bignum_to_double(dfsch_bignum_t* b); 84 | 85 | #endif 86 | -------------------------------------------------------------------------------- /dfsch/compiler.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch__compile__ 2 | #define H__dfsch__compile__ 3 | 4 | #include 5 | 6 | dfsch_object_t* dfsch_cons_ast_node(dfsch_object_t* head, 7 | dfsch_object_t* orig_expr, 8 | size_t count, 9 | ...); 10 | dfsch_object_t* dfsch_cons_ast_node_cdr(dfsch_object_t* head, 11 | dfsch_object_t* orig_expr, 12 | dfsch_object_t* cdr, 13 | size_t count, 14 | ...); 15 | dfsch_object_t* dfsch_compile_expression_list(dfsch_object_t* list, 16 | dfsch_object_t* env); 17 | dfsch_object_t* dfsch_compile_expression(dfsch_object_t* expression, 18 | dfsch_object_t* env); 19 | 20 | void dfsch_compiler_declare_variable(dfsch_object_t* env, 21 | dfsch_object_t* name); 22 | void dfsch_compiler_update_constant(dfsch_object_t* env, 23 | dfsch_object_t* name, 24 | dfsch_object_t* value); 25 | dfsch_object_t* 26 | dfsch_compiler_extend_environment_with_arguments(dfsch_object_t* environment, 27 | dfsch_object_t* arglist); 28 | 29 | 30 | void dfsch_compile_function(dfsch_object_t* function); 31 | void dfsch_precompile_function(dfsch_object_t* function); 32 | 33 | #endif 34 | -------------------------------------------------------------------------------- /dfsch/defines.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch__defines__ 2 | #define H__dfsch__defines__ 3 | 4 | #include 5 | 6 | #if !defined(__linux__) 7 | /* pthread_mutex_destroy() is noop on (at least) linux */ 8 | #define DFSCH_THREADS_FINALIZE 9 | #endif 10 | 11 | #if defined(__GNUC__) 12 | #define DFSCH_UNLIKELY(cond) __builtin_expect(!!(cond), 0) 13 | #define DFSCH_LIKELY(cond) __builtin_expect(!!(cond), 1) 14 | #define DFSCH_PREFETCH(addr) __builtin_prefetch(addr) 15 | #define DFSCH_FUNC_PURE __attributte((hot)) 16 | 17 | #else 18 | #define DFSCH_UNLIKELY(cond) (cond) 19 | #define DFSCH_LIKELY(cond) (cond) 20 | #define DFSCH_PREFETCH(addr) 21 | #define DFSCH_FUNC_PURE 22 | #endif 23 | 24 | #if (__GNUC__ > 4) && (__GNUC_MINOR__ > 3) 25 | #define DFSCH_FUNC_HOT __attributte((hot)) 26 | #define DFSCH_FUNC_COLD __attributte((hot)) 27 | #else 28 | #define DFSCH_FUNC_HOT 29 | #define DFSCH_FUNC_COLD 30 | #endif 31 | 32 | #if defined(GC_NEXT) && !defined(__CYGWIN__) 33 | #define DFSCH_GC_MALLOC_MANY 34 | #undef DFSCH_GC_MALLOC_MANY_PREALLOC 35 | #endif 36 | 37 | /* DFSCH_DOC_STRING has multiple arguments as to allow DFSCH_DOC_ARGUMENTS() 38 | * like hacks and remove also it's expansions when docstrings are omitted */ 39 | 40 | #ifdef DFSCH_OMIT_DOCUMENTATION 41 | #define DFSCH_DOC_STRING(str...) NULL 42 | #else 43 | #define DFSCH_DOC_STRING(str...) str 44 | #endif 45 | 46 | #endif 47 | -------------------------------------------------------------------------------- /dfsch/format.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - dfox's quick and dirty scheme implementation 3 | * Format implementation 4 | * Copyright (C) 2005-2010 Ales Hakl 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Lesser General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2.1 of the License, or (at your option) any later version. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19 | * 20 | */ 21 | 22 | #ifndef H__dfsch__format__ 23 | #define H__dfsch__format__ 24 | 25 | #include 26 | 27 | #ifdef __cplusplus 28 | extern "C" { 29 | #endif 30 | 31 | extern char* dfsch_format(char* string, 32 | dfsch_object_t* args); 33 | 34 | #ifdef __cplusplus 35 | } 36 | #endif 37 | 38 | #endif 39 | -------------------------------------------------------------------------------- /dfsch/generate.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch__generate__ 2 | #define H__dfsch__generate__ 3 | 4 | #include 5 | 6 | dfsch_object_t* dfsch_generate_make_macro(dfsch_object_t* proc_exp); 7 | dfsch_object_t* dfsch_generate_lambda(dfsch_object_t* name, 8 | dfsch_object_t* lambda_list, 9 | dfsch_object_t* body); 10 | dfsch_object_t* dfsch_generate_if(dfsch_object_t* cond, 11 | dfsch_object_t* cons, 12 | dfsch_object_t* alt); 13 | dfsch_object_t* dfsch_generate_begin(dfsch_object_t* exps); 14 | dfsch_object_t* dfsch_generate_let1(dfsch_object_t* bind, 15 | dfsch_object_t* exp); 16 | dfsch_object_t* dfsch_generate_let(dfsch_object_t* bind, 17 | dfsch_object_t* exp); 18 | dfsch_object_t* dfsch_generate_define_variable(dfsch_object_t* name, 19 | dfsch_object_t* value); 20 | dfsch_object_t* dfsch_generate_define_constant(dfsch_object_t* name, 21 | dfsch_object_t* value); 22 | dfsch_object_t* dfsch_generate_define_canonical_constant(dfsch_object_t* name, 23 | dfsch_object_t* value); 24 | dfsch_object_t* dfsch_generate_defined_p(dfsch_object_t* name); 25 | 26 | dfsch_object_t* dfsch_generate_instance_p(dfsch_object_t* obj, 27 | dfsch_object_t* klass); 28 | dfsch_object_t* dfsch_generate_error(char* message, 29 | dfsch_object_t* obj); 30 | dfsch_object_t* dfsch_generate_throw(dfsch_object_t* tag, 31 | dfsch_object_t* value); 32 | 33 | dfsch_object_t* dfsch_generate_cons(dfsch_object_t* car, dfsch_object_t* cdr); 34 | dfsch_object_t* dfsch_generate_quote(dfsch_object_t* value); 35 | dfsch_object_t* dfsch_get_append_primitive(); 36 | dfsch_object_t* dfsch_get_nconc_primitive(); 37 | dfsch_object_t* dfsch_generate_eval_list(dfsch_object_t* exps); 38 | dfsch_object_t* dfsch_generate_list_immutable(dfsch_object_t* exps); 39 | dfsch_object_t* dfsch_generate_copy_list_immutable(dfsch_object_t* list); 40 | dfsch_object_t* dfsch_generate_append_immutable(dfsch_object_t* list); 41 | dfsch_object_t* dfsch_generate_compile_time_constant(dfsch_object_t* expr); 42 | 43 | 44 | #endif 45 | -------------------------------------------------------------------------------- /dfsch/introspect.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch__introspect__ 2 | #define H__dfsch__introspect__ 3 | 4 | #include 5 | 6 | void dfsch_print_trace_buffer(); 7 | dfsch_object_t* dfsch_get_trace(); 8 | 9 | char* dfsch_format_trace(dfsch_object_t* trace); 10 | char* dfsch_format_trace_entry(dfsch_object_t* entry); 11 | 12 | void dfsch_introspect_register(dfsch_object_t* env); 13 | 14 | void dfsch_set_inspector(dfsch_object_t* proc); 15 | void dfsch_inspect_object(dfsch_object_t* obj); 16 | dfsch_object_t* dfsch_describe_object(dfsch_object_t* obj); 17 | dfsch_object_t* dfsch_sort_description_slots(dfsch_object_t* list); 18 | 19 | dfsch_object_t* dfsch_find_source_annotation(dfsch_object_t* list); 20 | 21 | typedef void (*dfsch_breakpoint_hook_t)(void* baton, 22 | dfsch_object_t* exp, 23 | dfsch_object_t* env); 24 | typedef void* (*dfsch_function_entry_hook_t)(void* baton, 25 | dfsch_object_t* func, 26 | dfsch_object_t* args, 27 | dfsch_object_t* context); 28 | typedef void (*dfsch_function_exit_hook_t)(void* baton, 29 | dfsch_object_t* func, 30 | dfsch_object_t* values, 31 | dfsch_object_t* context, 32 | void* entry_token); 33 | 34 | void dfsch_add_breakpoint(dfsch_object_t* expr, 35 | dfsch_breakpoint_hook_t hook, 36 | void* baton); 37 | void dfsch_remove_breakpoint(dfsch_object_t* expr); 38 | void dfsch_clear_breakpoints(); 39 | 40 | void dfsch_add_traced_function(dfsch_object_t* func, 41 | dfsch_function_entry_hook_t entry, 42 | dfsch_function_exit_hook_t exit, 43 | void* baton); 44 | void dfsch_remove_traced_function(dfsch_object_t* func); 45 | void dfsch_clear_traced_functions(); 46 | 47 | void dfsch_trace_function(dfsch_object_t* func); 48 | void dfsch_add_standard_breakpoint(dfsch_object_t* expr); 49 | void dfsch_add_function_breakpoint(dfsch_object_t* fun); 50 | 51 | void dfsch_prepare_trace_trap(dfsch_breakpoint_hook_t hook, 52 | void* baton); 53 | void dfsch_prepare_single_step_breakpoint(); 54 | int dfsch_have_trace_trap_p(); 55 | 56 | void dfsch_get_trace_hook(dfsch_breakpoint_hook_t* trace_hook, 57 | void** trace_baton); 58 | void dfsch_set_trace_hook(dfsch_breakpoint_hook_t trace_hook, 59 | void* trace_baton); 60 | 61 | 62 | #endif 63 | -------------------------------------------------------------------------------- /dfsch/lib/cdebug.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - Scheme-like Lisp dialect 3 | * Interactive debugger 4 | * Copyright (C) 2005-2008 Ales Hakl 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | * 20 | */ 21 | 22 | #ifndef H__dfsch__debug__ 23 | #define H__dfsch__debug__ 24 | 25 | #include 26 | 27 | void dfsch_cdebug_enter_debugger(dfsch_object_t* reason); 28 | dfsch_object_t* dfsch_cdebug_get_procedure(); 29 | void dfsch_cdebug_set_as_debugger(); 30 | 31 | #endif 32 | -------------------------------------------------------------------------------- /dfsch/lib/cinspect.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - Scheme-like Lisp dialect 3 | * Interactive debugger 4 | * Copyright (C) 2005-2008 Ales Hakl 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | * 20 | */ 21 | 22 | #ifndef H__dfsch__cinspect__ 23 | #define H__dfsch__cinspect__ 24 | 25 | #include 26 | 27 | void dfsch_cinspect_inspect_object(dfsch_object_t* object); 28 | dfsch_object_t* dfsch_cinspect_get_procedure(); 29 | void dfsch_cinspect_set_as_inspector(); 30 | 31 | #endif 32 | -------------------------------------------------------------------------------- /dfsch/lib/collections.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch_lib__collections__ 2 | #define H__dfsch_lib__collections__ 3 | 4 | #include 5 | 6 | extern dfsch_type_t dfsch_collections_priority_queue_type; 7 | #define DFSCH_COLLECTIONS_PRIORITY_QUEUE_TYPE \ 8 | (&dfsch_collections_priority_queue_type) 9 | 10 | dfsch_object_t* dfsch_collections_make_priority_queue(dfsch_object_t* lt); 11 | void dfsch_collections_priority_queue_push(dfsch_object_t* q, 12 | dfsch_object_t* o); 13 | dfsch_object_t* dfsch_collections_priority_queue_pop(dfsch_object_t* q); 14 | int dfsch_collections_priority_queue_empty_p(dfsch_object_t* q); 15 | 16 | extern dfsch_type_t dfsch_collections_bitvector_type; 17 | #define DFSCH_COLLECTIONS_BITVECTOR_TYPE (&dfsch_collections_bitvector_type) 18 | 19 | dfsch_object_t* dfsch_collections_make_bitvector(size_t length); 20 | dfsch_object_t* dfsch_collections_list_2_bitvector(dfsch_object_t* values); 21 | 22 | dfsch_object_t* dfsch_collections_bitvector_not(dfsch_object_t* bv); 23 | dfsch_object_t* dfsch_collections_bitvector_or(dfsch_object_t* bva, 24 | dfsch_object_t* bvb); 25 | dfsch_object_t* dfsch_collections_bitvector_and(dfsch_object_t* bva, 26 | dfsch_object_t* bvb); 27 | dfsch_object_t* dfsch_collections_bitvector_xor(dfsch_object_t* bva, 28 | dfsch_object_t* bvb); 29 | dfsch_object_t* dfsch_collections_bitvector_increment(dfsch_object_t* bv); 30 | 31 | dfsch_strbuf_t* dfsch_collections_bitvector_2_bytes(dfsch_object_t* bv); 32 | dfsch_object_t* dfsch_collections_bytes_2_bitvector(char* buf, size_t len, 33 | size_t res_len); 34 | 35 | 36 | int dfsch_collections_bitvector_all_zeros_p(dfsch_object_t* bv); 37 | int dfsch_collections_bitvector_all_ones_p(dfsch_object_t* bv); 38 | 39 | #endif 40 | -------------------------------------------------------------------------------- /dfsch/lib/console.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - Scheme-like Lisp dialect 3 | * Console input handling 4 | * Copyright (C) 2005-2008 Ales Hakl 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | * 20 | */ 21 | 22 | #ifndef H__dfsch__console__ 23 | #define H__dfsch__console__ 24 | 25 | #include 26 | #include 27 | 28 | char* dfsch_console_read_line(char* prompt); 29 | 30 | void dfsch_console_set_object_completion(); 31 | void dfsch_console_set_general_completion(); 32 | 33 | void dfsch_console_read_history(char* filename); 34 | void dfsch_console_save_history(char* filename, int count); 35 | 36 | dfsch_object_t* dfsch_console_read_object(char* prompt); 37 | 38 | typedef int (*dfsch_console_object_cb_t)(dfsch_object_t* obj, void* baton); 39 | 40 | typedef dfsch_object_t* (*dfsch_console_repl_eval_cb_t)(dfsch_object_t* obj, 41 | void* baton); 42 | 43 | typedef struct dfsch_console_repl_command_t dfsch_console_repl_command_t; 44 | 45 | int dfsch_console_read_objects_parser(char* prompt, 46 | dfsch_parser_ctx_t* parser, 47 | dfsch_console_repl_command_t* cmds); 48 | int dfsch_console_read_objects_list_parser(char* prompt, 49 | dfsch_parser_ctx_t* parser); 50 | 51 | 52 | dfsch_console_repl_command_t* dfsch_console_add_command(dfsch_console_repl_command_t* cmdlist, 53 | char* name, 54 | char* doc, 55 | void (*exec)(char* cmdline, void* baton), 56 | void* baton); 57 | 58 | int dfsch_console_read_objects(char* prompt, 59 | dfsch_console_object_cb_t cb, 60 | void* baton, 61 | dfsch_console_repl_command_t* commands); 62 | int dfsch_console_read_objects_list(char * prompt, 63 | dfsch_console_object_cb_t cb, 64 | void* baton); 65 | 66 | int dfsch_console_run_repl_eval(char* prompt, 67 | dfsch_console_repl_eval_cb_t evalfun, 68 | void* baton, 69 | dfsch_console_repl_command_t* cmds); 70 | int dfsch_console_run_repl(char* prompt, 71 | dfsch_object_t* env, 72 | dfsch_console_repl_command_t* commands); 73 | 74 | #endif 75 | -------------------------------------------------------------------------------- /dfsch/lib/csv.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch_lib__csv__ 2 | #define H__dfsch_lib__csv__ 3 | 4 | #include 5 | 6 | typedef struct dfsch_csv_params_t { 7 | char delim; 8 | char quote; 9 | char escape; 10 | } dfsch_csv_params_t; 11 | 12 | dfsch_object_t* dfsch_csv_read_line(dfsch_object_t* port, 13 | dfsch_csv_params_t* params); 14 | dfsch_object_t* dfsch_csv_read_file(dfsch_object_t* port, 15 | dfsch_csv_params_t* params); 16 | 17 | dfsch_csv_params_t* dfsch_csv_params(dfsch_object_t* args); 18 | 19 | #endif 20 | -------------------------------------------------------------------------------- /dfsch/lib/curl.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch_lib__curl__ 2 | #define H__dfsch_lib__curl__ 3 | 4 | #include 5 | #include 6 | 7 | typedef struct dfsch_curl_options_context_t dfsch_curl_options_context_t; 8 | 9 | dfsch_curl_options_context_t* dfsch_curl_make_options_context(); 10 | void dfsch_curl_cleanup(CURL* handle, 11 | dfsch_curl_options_context_t* ctx); 12 | 13 | void dfsch_curl_setopt(CURL* handle, 14 | dfsch_object_t* name, 15 | dfsch_object_t* value, 16 | dfsch_curl_options_context_t* ctx); 17 | 18 | dfsch_strbuf_t* dfsch_curl_perform(CURL* handle); 19 | 20 | #endif 21 | -------------------------------------------------------------------------------- /dfsch/lib/extref.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - dfox's quick and dirty scheme implementation 3 | * External object references 4 | * Copyright (C) 2005-2008 Ales Hakl 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | * 20 | */ 21 | 22 | #ifndef H__dfsch__lib__extref__ 23 | #define H__dfsch__lib__extref__ 24 | 25 | #include 26 | #include 27 | 28 | #define DFSCH_EXTREF_FROMNOW 0 29 | #define DFSCH_EXTREF_ONCEONLY 1 30 | #define DFSCH_EXTREF_REFRESH 2 31 | 32 | char* dfsch_extref_create(dfsch_object_t* object, time_t timeout, int mode); 33 | dfsch_object_t* dfsch_extref_ref(char* ref); 34 | 35 | dfsch_object_t* dfsch_module_extref_register(dfsch_object_t* env); 36 | 37 | #endif 38 | -------------------------------------------------------------------------------- /dfsch/lib/ffi.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch_lib__ffi__ 2 | #define H__dfsch_lib__ffi__ 3 | 4 | #include 5 | #include 6 | 7 | extern dfsch_type_t dfsch_ffi_library_type; 8 | #define DFSCH_FFI_LIBRARY_TYPE (&dfsch_ffi_library_type) 9 | extern dfsch_type_t dfsch_ffi_function_type; 10 | #define DFSCH_FFI_FUNCTION_TYPE (&dfsch_ffi_function_type) 11 | 12 | extern dfsch_type_t dfsch_ffi_pointer_type; 13 | #define DFSCH_FFI_POINTER_TYPE (&dfsch_ffi_pointer_type) 14 | 15 | dfsch_object_t* dfsch_ffi_load_library(char* filename); 16 | 17 | dfsch_object_t* dfsch_ffi_call(dfsch_object_t* lib, 18 | char* fun_name, 19 | dfsch_object_t* args); 20 | 21 | dfsch_object_t* dfsch_ffi_make_function(dfsch_object_t* lib, 22 | char* fun_name, 23 | dfsch_object_t* ret_type, 24 | dfsch_object_t* arg_types); 25 | 26 | dfsch_object_t* dfsch_ffi_wrap_pointer(void* ptr); 27 | void* dfsch_ffi_unwrap_pointer(dfsch_object_t* obj); 28 | 29 | #endif 30 | -------------------------------------------------------------------------------- /dfsch/lib/gcollect.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - dfox's quick and dirty scheme implementation 3 | * Garbage collector state 4 | * Copyright (C) 2005-2008 Ales Hakl 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | * 20 | */ 21 | 22 | #ifndef H__dfsch__lib__gcollect__ 23 | #define H__dfsch__lib__gcollect__ 24 | 25 | #include 26 | 27 | dfsch_object_t* dfsch_module_gcollect_register(dfsch_object_t* env); 28 | 29 | #endif 30 | -------------------------------------------------------------------------------- /dfsch/lib/gd.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch__lib__gd__ 2 | #define H__dfsch__lib__gd__ 3 | 4 | #include 5 | #include 6 | 7 | gdImagePtr dfsch_gd_image(dfsch_object_t* obj); 8 | dfsch_object_t* dfsch_gd_cons_image(gdImagePtr img); 9 | 10 | gdFontPtr dfsch_gd_font(dfsch_object_t* obj); 11 | dfsch_object_t* dfsch_gd_cons_font(gdFontPtr font); 12 | 13 | extern dfsch_type_t dfsch_gd_image_type; 14 | #define DFSCH_GD_IMAGE_TYPE (&dfsch_gd_image_type) 15 | 16 | extern dfsch_type_t dfsch_gd_font_type; 17 | #define DFSCH_GD_FONT_TYPE (&dfsch_gd_font_type) 18 | 19 | #define DFSCH_GD_IMAGE_ARG(al, name) \ 20 | DFSCH_GENERIC_ARG(al, name, gdImagePtr, dfsch_gd_image) 21 | 22 | #define DFSCH_GD_FONT_ARG(al, name) \ 23 | DFSCH_GENERIC_ARG(al, name, gdFontPtr, dfsch_gd_font) 24 | 25 | #endif 26 | -------------------------------------------------------------------------------- /dfsch/lib/inet.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - dfox's quick and dirty scheme implementation 3 | * Internet data handling 4 | * Copyright (C) 2005-2008 Ales Hakl 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | * 20 | */ 21 | 22 | #ifndef H__dfsch_lib__inet__ 23 | #define H__dfsch_lib__inet__ 24 | 25 | #include 26 | #include 27 | 28 | dfsch_object_t* dfsch_module_inet_register(dfsch_object_t* env); 29 | 30 | dfsch_object_t* dfsch_http_split_path(char* path); 31 | 32 | 33 | dfsch_object_t* dfsch_http_query_2_hash(char* query); 34 | dfsch_object_t* dfsch_http_query_2_alist(char* query); 35 | 36 | dfsch_strbuf_t* dfsch_inet_urldecode(dfsch_strbuf_t* str_buf); 37 | dfsch_strbuf_t* dfsch_inet_urlencode(dfsch_strbuf_t* str_buf); 38 | 39 | dfsch_strbuf_t* dfsch_inet_base64_decode(dfsch_strbuf_t* str_buf); 40 | dfsch_strbuf_t* dfsch_inet_base64_encode(dfsch_strbuf_t* str_buf, 41 | int wrap, 42 | int pad); 43 | dfsch_strbuf_t* dfsch_inet_uri_base64_decode(dfsch_strbuf_t* str_buf); 44 | dfsch_strbuf_t* dfsch_inet_uri_base64_encode(dfsch_strbuf_t* str_buf); 45 | 46 | char* dfsch_inet_xml_escape(char* str_buf); 47 | char* dfsch_inet_xml_unescape(char* str); 48 | 49 | typedef void (*dfsch_inet_header_cb_t)(void* baton, 50 | char* name, 51 | char* value); 52 | 53 | void dfsch_inet_read_822_headers(dfsch_object_t* port, 54 | dfsch_inet_header_cb_t cb, 55 | void* baton, 56 | size_t max_len, 57 | int max_count); 58 | 59 | dfsch_object_t* dfsch_inet_read_822_headers_list(dfsch_object_t* port, 60 | size_t max_len, 61 | int max_count); 62 | dfsch_object_t* dfsch_inet_read_822_headers_map(dfsch_object_t* port, 63 | dfsch_object_t* map, 64 | size_t max_len, 65 | int max_count); 66 | 67 | 68 | #endif 69 | -------------------------------------------------------------------------------- /dfsch/lib/ini-file.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch_lib__ini_file__ 2 | #define H__dfsch_lib__ini_file__ 3 | 4 | #include 5 | 6 | extern dfsch_type_t dfsch_ini_file_type; 7 | #define DFSCH_INI_FILE_TYPE (&dfsch_ini_file_type) 8 | 9 | dfsch_object_t* dfsch_make_empty_ini_file(); 10 | dfsch_object_t* dfsch_ini_file_read_file(char* fname); 11 | dfsch_object_t* dfsch_ini_file_read_port(dfsch_object_t* port); 12 | 13 | void dfsch_ini_file_set_defaults(dfsch_object_t* ifo, 14 | dfsch_object_t* defaults_ifo); 15 | 16 | void dfsch_ini_file_write_file(dfsch_object_t* ifo, 17 | char* fname); 18 | void dfsch_ini_file_write_port(dfsch_object_t* ifo, 19 | dfsch_object_t* port); 20 | 21 | int dfsch_ini_file_has_section_p(dfsch_object_t* ifo, 22 | char* section); 23 | int dfsch_ini_file_has_property_p(dfsch_object_t* ifo, 24 | char* section, 25 | char* property); 26 | 27 | void dfsch_ini_file_add_section(dfsch_object_t* ifo, 28 | char* section); 29 | void dfsch_ini_file_add_comment(dfsch_object_t* ifo, 30 | char* section, 31 | char* comment); 32 | 33 | char* dfsch_ini_file_get(dfsch_object_t* ifo, 34 | char* section, 35 | char* property); 36 | void dfsch_ini_file_set(dfsch_object_t* ifo, 37 | char* section, 38 | char* property, 39 | char* value); 40 | 41 | 42 | #endif 43 | -------------------------------------------------------------------------------- /dfsch/lib/json.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch_lib__json__ 2 | #define H__dfsch_lib__json__ 3 | 4 | #include 5 | #include 6 | 7 | extern dfsch_type_t dfsch_json_parser_type; 8 | #define DFSCH_JSON_PARSER_TYPE (&dfsch_json_parser_type) 9 | 10 | typedef struct dfsch_json_parser_t dfsch_json_parser_t; 11 | 12 | dfsch_json_parser_t* dfsch_make_json_parser(); 13 | void dfsch_json_parser_set_callback(dfsch_json_parser_t *jp, 14 | dfsch_parser_callback_t callback, 15 | void *baton); 16 | 17 | void dfsch_json_parser_feed(dfsch_json_parser_t* jp, 18 | char* buf); 19 | 20 | dfsch_object_t* dfsch_json_parse_file(char* filename, int list); 21 | dfsch_object_t* dfsch_json_parse_port(dfsch_object_t* port, int list); 22 | dfsch_object_t* dfsch_json_parse_buf(char* buf, size_t len, int list); 23 | dfsch_object_t* dfsch_json_parse_strbuf(dfsch_strbuf_t* b, int list); 24 | dfsch_object_t* dfsch_json_parse_cstr(char* s, int list); 25 | 26 | char* dfsch_json_emit_cstr(dfsch_object_t* obj); 27 | void dfsch_json_emit_port(dfsch_object_t* obj, dfsch_object_t* port); 28 | void dfsch_json_emit_file(dfsch_object_t* obj, char* filename); 29 | 30 | #endif 31 | -------------------------------------------------------------------------------- /dfsch/lib/minizip.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch_lib__minizip__ 2 | #define H__dfsch_lib__minizip__ 3 | 4 | #include 5 | 6 | extern dfsch_type_t dfsch_minizip_type; 7 | #define DFSCH_MINIZIP_TYPE (&dfsch_minizip_type) 8 | 9 | dfsch_object_t* dfsch_minizip_open(char* filename); 10 | 11 | #endif 12 | -------------------------------------------------------------------------------- /dfsch/lib/os.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch__lib_os__ 2 | #define H__dfsch__lib_os__ 3 | 4 | #include 5 | #include 6 | 7 | dfsch_object_t* dfsch_os_opendir(char* name); 8 | void dfsch_os_closedir(dfsch_object_t* dir_obj); 9 | char* dfsch_os_readdir(dfsch_object_t* dir_obj); 10 | dfsch_object_t* dfsch_os_make_stat_struct(); 11 | dfsch_object_t* dfsch_os_cons_stat_struct(struct stat* orig); 12 | struct stat* dfsch_os_get_stat(dfsch_object_t* stat); 13 | 14 | #endif 15 | -------------------------------------------------------------------------------- /dfsch/lib/pcre.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch_lib__pcre__ 2 | #define H__dfsch_lib__pcre__ 3 | 4 | #include 5 | #include 6 | 7 | extern dfsch_type_t dfsch_pcre_pattern_type; 8 | #define DFSCH_PCRE_PATTERN_TYPE (&dfsch_pcre_pattern_type) 9 | 10 | pcre* dfsch_pcre_get_pattern(dfsch_object_t* pat); 11 | 12 | #define DFSCH_PCRE_PATTERN_ARG(al, name) \ 13 | DFSCH_GENERIC_ARG(al, name, pcre*, dfsch_pcre_get_pattern) 14 | 15 | int dfsch_pcre_parse_options(dfsch_object_t* al); 16 | 17 | dfsch_object_t* dfsch_pcre_compile(char* pattern, 18 | int options); 19 | 20 | int dfsch_pcre_match(pcre* pattern, 21 | char* string, size_t len, 22 | int options); 23 | dfsch_object_t* dfsch_pcre_match_substrings(pcre* pattern, 24 | char* string, size_t len, 25 | int options, 26 | int share_buf); 27 | dfsch_object_t* dfsch_pcre_match_named_substrings(pcre* pattern, 28 | char* string, size_t len, 29 | int options, 30 | int share_buf); 31 | dfsch_object_t* dfsch_pcre_split(pcre* pattern, 32 | char* string, size_t len, 33 | int options, 34 | int share_buf); 35 | dfsch_strbuf_t* dfsch_pcre_replace(pcre* pattern, 36 | char* string, size_t len, 37 | char* template, size_t tlen, 38 | int options); 39 | dfsch_strbuf_t* dfsch_pcre_replace_func(pcre* pattern, 40 | char* string, size_t len, 41 | dfsch_object_t* exp, 42 | int options); 43 | 44 | #endif 45 | -------------------------------------------------------------------------------- /dfsch/lib/posix-regex.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - dfox's quick and dirty scheme implementation 3 | * Regular expressions 4 | * Copyright (C) 2005-2008 Ales Hakl 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | * 20 | */ 21 | 22 | #ifndef H__dfsch__regex__ 23 | #define H__dfsch__regex__ 24 | 25 | #include 26 | #include 27 | 28 | #ifdef __cplusplus 29 | extern "C" { 30 | #endif 31 | 32 | /** 33 | * Compile given regular expression into regex object. Flags are same as 34 | * for regcomp(3). 35 | */ 36 | dfsch_object_t* dfsch_regex_compile(char* expression, int flags); 37 | 38 | /** 39 | * Apply precompiled regex object to given string and return whetever 40 | * regular expression matches 41 | */ 42 | int dfsch_regex_match_p(dfsch_object_t* regex, char* string, int flags); 43 | 44 | /** 45 | * Apply precompiled regex object to given string and return vector of 46 | * matching substrings (each as vector of start offset, end offset and 47 | * matching string). 48 | */ 49 | dfsch_object_t* dfsch_regex_substrings(dfsch_object_t* regex, char* string, 50 | int flags); 51 | 52 | /** 53 | * Define regular expression primitives in given environment. 54 | */ 55 | dfsch_object_t* dfsch_module_regex_register(dfsch_object_t *ctx); 56 | 57 | int dfsch_regex_match_once_p(char* expression, 58 | int cflags, int mflags, 59 | char* string); 60 | dfsch_object_t* dfsch_regex_substrings_once(char* expression, 61 | int cflags, int mflags, 62 | char* string); 63 | 64 | 65 | 66 | #ifdef __cplusplus 67 | } 68 | #endif 69 | 70 | #endif 71 | -------------------------------------------------------------------------------- /dfsch/lib/process.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - Scheme-like Lisp dialect 3 | * Sub-process handling 4 | * Copyright (C) 2009 Ales Hakl 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | * 20 | */ 21 | 22 | #ifndef H__dfsch__process__ 23 | #define H__dfsch__process__ 24 | 25 | #include 26 | #include 27 | 28 | #ifdef __cplusplus 29 | extern "C" { 30 | #endif 31 | 32 | extern dfsch_type_t dfsch_process_port_type; 33 | #define DFSCH_PROCESS_PORT_TYPE (&dfsch_process_port_type) 34 | extern dfsch_port_type_t dfsch_process_output_port_type; 35 | #define DFSCH_PROCESS_OUTPUT_PORT_TYPE (&dfsch_process_output_port_type) 36 | extern dfsch_port_type_t dfsch_process_input_port_type; 37 | #define DFSCH_PROCESS_INPUT_PORT_TYPE (&dfsch_process_input_port_type) 38 | 39 | dfsch_object_t* dfsch_process_spawn_with_input_port(char* cmd_line); 40 | dfsch_object_t* dfsch_process_spawn_with_output_port(char* cmd_line); 41 | 42 | dfsch_object_t* dfsch_process_close_port(dfsch_object_t* port); 43 | 44 | dfsch_object_t* dfsch_module_process_register(dfsch_object_t *ctx); 45 | 46 | 47 | #ifdef __cplusplus 48 | } 49 | #endif 50 | 51 | #endif 52 | -------------------------------------------------------------------------------- /dfsch/lib/random.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch__lib__random__ 2 | #define H__dfsch__lib__random__ 3 | 4 | #include 5 | 6 | #include 7 | #include 8 | 9 | typedef struct int dfsch_random_generator_bytes_t(dfsch_object_t* rg, 10 | size_t size, 11 | uint8_t* get); 12 | 13 | typedef struct dfsch_random_generator_type_t { 14 | dfsch_type_t parent; 15 | 16 | dfsch_random_generator_bytes_t bytes; 17 | }; 18 | 19 | dfsch_object_t* dfsch_current_random_generator(); 20 | 21 | long dfsch_random_long(dfsch_object_t* rg); 22 | double dfsch_random_double(dfsch_object_t* rg); 23 | void dfsch_random_bytes(dfsch_object_t* rg, size_t size, uint8_t bytes); 24 | long dfsch_random_below(dfsch_object_t* rg, long max); 25 | 26 | #endif 27 | -------------------------------------------------------------------------------- /dfsch/lib/shtml.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch__shtml__ 2 | #define H__dfsch__shtml__ 3 | 4 | #include 5 | 6 | typedef enum { 7 | ELEM_VOID, 8 | ELEM_CDATA, 9 | ELEM_RCDATA, 10 | ELEM_PCDATA 11 | } dfsch_shtml_element_type_t; 12 | 13 | dfsch_shtml_element_type_t dfsch_shtml_get_element_type(char* name); 14 | 15 | typedef struct dfsch_shtml_emitter_params_t { 16 | int pretty_print; 17 | char* prepend_string; 18 | } dfsch_shtml_emitter_params_t; 19 | 20 | dfsch_shtml_emitter_params_t* dfsch_shtml_emitter_params(dfsch_object_t* args); 21 | 22 | 23 | char* dfsch_shtml_emit_cstr(dfsch_object_t* infoset, 24 | dfsch_shtml_emitter_params_t* params); 25 | void dfsch_shtml_emit_port(dfsch_object_t* infoset, dfsch_object_t* port, 26 | dfsch_shtml_emitter_params_t* params); 27 | void dfsch_shtml_emit_file(dfsch_object_t* infoset, char* filename, 28 | dfsch_shtml_emitter_params_t* params); 29 | 30 | #endif 31 | -------------------------------------------------------------------------------- /dfsch/lib/socket-port.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch__socket_port__ 2 | #define H__dfsch__socket_port__ 3 | 4 | #include 5 | #include 6 | 7 | extern dfsch_port_type_t dfsch_socket_port_type; 8 | #define DFSCH_SOCKET_PORT_TYPE (&dfsch_socket_port_type) 9 | extern dfsch_type_t dfsch_socket_port_error_type; 10 | #define DFSCH_SOCKET_PORT_ERROR_TYPE (&dfsch_socket_port_error_type) 11 | 12 | dfsch_object_t* dfsch_socket_port_tcp_connect(char* hostname, 13 | char* service); 14 | dfsch_object_t* dfsch_socket_port_unix_connect(char* path); 15 | 16 | void dfsch_socket_port_close(dfsch_object_t* spo); 17 | 18 | extern dfsch_type_t dfsch_server_socket_type; 19 | #define DFSCH_SERVER_SOCKET_TYPE (&dfsch_server_socket_type) 20 | 21 | dfsch_object_t* dfsch_server_socket_tcp_bind(char* hostname, 22 | char* service); 23 | dfsch_object_t* dfsch_server_socket_unix_bind(char* path); 24 | void dfsch_server_socket_close(dfsch_object_t* sso); 25 | 26 | dfsch_object_t* dfsch_server_socket_accept(dfsch_object_t* server_socket); 27 | 28 | typedef void (*dfsch_server_socket_accept_loop_cb_t)(void* baton, 29 | dfsch_object_t* port); 30 | void dfsch_server_socket_run_accept_loop(dfsch_object_t* server_socket, 31 | dfsch_server_socket_accept_loop_cb_t cb, 32 | void* baton); 33 | 34 | #endif 35 | -------------------------------------------------------------------------------- /dfsch/lib/sxml.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch__sxml__ 2 | #define H__dfsch__sxml__ 3 | 4 | #include 5 | 6 | typedef struct dfsch_sxml_parser_params_t { 7 | int namespaces; 8 | char* encoding; 9 | int collapse_whitespace; 10 | int fragment; 11 | } dfsch_sxml_parser_params_t; 12 | 13 | dfsch_sxml_parser_params_t* dfsch_sxml_parser_params(dfsch_object_t* args); 14 | 15 | dfsch_object_t* dfsch_sxml_parse_file(char* filename, 16 | dfsch_sxml_parser_params_t* params); 17 | dfsch_object_t* dfsch_sxml_parse_port(dfsch_object_t* port, 18 | dfsch_sxml_parser_params_t* params); 19 | dfsch_object_t* dfsch_sxml_parse_buf(char* buf, size_t len, 20 | dfsch_sxml_parser_params_t* params); 21 | dfsch_object_t* dfsch_sxml_parse_strbuf(dfsch_strbuf_t* b, 22 | dfsch_sxml_parser_params_t* params); 23 | dfsch_object_t* dfsch_sxml_parse_cstr(char* s, 24 | dfsch_sxml_parser_params_t* params); 25 | 26 | typedef struct dfsch_sxml_emitter_params_t { 27 | int pretty_print; 28 | int xml_decl; 29 | char* dtd_public; 30 | char* dtd_system; 31 | char* prepend_string; 32 | } dfsch_sxml_emitter_params_t; 33 | 34 | dfsch_sxml_emitter_params_t* dfsch_sxml_emitter_params(dfsch_object_t* args); 35 | 36 | 37 | char* dfsch_sxml_emit_cstr(dfsch_object_t* infoset, 38 | dfsch_sxml_emitter_params_t* params); 39 | void dfsch_sxml_emit_port(dfsch_object_t* infoset, dfsch_object_t* port, 40 | dfsch_sxml_emitter_params_t* params); 41 | void dfsch_sxml_emit_file(dfsch_object_t* infoset, char* filename, 42 | dfsch_sxml_emitter_params_t* params); 43 | 44 | #endif 45 | -------------------------------------------------------------------------------- /dfsch/lib/threads.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - dfox's quick and dirty scheme implementation 3 | * Multithreading API 4 | * Copyright (C) 2005-2008 Ales Hakl 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | * 20 | */ 21 | 22 | #ifndef H__dfsch__threads__ 23 | #define H__dfsch__threads__ 24 | 25 | #include 26 | #ifdef __cplusplus 27 | extern "C" { 28 | #endif 29 | 30 | extern dfsch_object_t* dfsch_thread_create(dfsch_object_t* function, 31 | dfsch_object_t* arguments); 32 | extern dfsch_object_t* dfsch_thread_join(dfsch_object_t* thread); 33 | extern void dfsch_thread_detach(dfsch_object_t* thread); 34 | extern dfsch_object_t* dfsch_thread_self(); 35 | 36 | extern dfsch_object_t* dfsch_mutex_create(); 37 | extern void dfsch_mutex_lock(dfsch_object_t* mutex); 38 | extern int dfsch_mutex_trylock(dfsch_object_t* mutex); 39 | extern void dfsch_mutex_unlock(dfsch_object_t* mutex); 40 | 41 | extern dfsch_object_t* dfsch_condition_create(); 42 | extern void dfsch_condition_wait(dfsch_object_t* condition, 43 | dfsch_object_t* mutex); 44 | extern void dfsch_condition_signal(dfsch_object_t* condition); 45 | extern void dfsch_condition_broadcast(dfsch_object_t* condition); 46 | 47 | extern dfsch_object_t* dfsch_channel_create(size_t buffer); 48 | extern dfsch_object_t* dfsch_channel_read(dfsch_object_t* channel); 49 | extern void dfsch_channel_write(dfsch_object_t* channel, 50 | dfsch_object_t* object); 51 | 52 | extern dfsch_object_t* dfsch_module_threads_register(dfsch_object_t *ctx); 53 | 54 | #ifdef __cplusplus 55 | } 56 | #endif 57 | 58 | #endif 59 | -------------------------------------------------------------------------------- /dfsch/lib/tk-gui.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch_lib__tk_gui__ 2 | #define H__dfsch_lib__tk_gui__ 3 | 4 | #include 5 | #include 6 | #include 7 | 8 | extern dfsch_type_t dfsch_tcl_interpreter_type; 9 | #define DFSCH_TCL_INTERPRETER_TYPE \ 10 | (&dfsch_tcl_interpreter_type) 11 | extern dfsch_type_t dfsch_tcl_command_wrapper_type; 12 | #define DFSCH_TCL_COMMAND_WRAPPER_TYPE \ 13 | (&dfsch_tcl_command_wrapper_type) 14 | 15 | Tcl_Interp* dfsch_tcl_interpreter(dfsch_object_t* obj); 16 | dfsch_object_t* dfsch_tcl_make_interpreter(Tcl_Interp* interp); 17 | dfsch_object_t* dfsch_tcl_create_interpreter(); 18 | void dfsch_tcl_destroy_interpreter(dfsch_object_t* obj); 19 | 20 | dfsch_object_t* dfsch_tcl_wrap_command(char* name, dfsch_object_t* interp); 21 | void dfsch_tcl_create_command(Tcl_Interp* interp, 22 | char* name, 23 | dfsch_object_t* proc); 24 | void dfsch_tcl_error(Tcl_Interp* interp); 25 | char* dfsch_tcl_eval(Tcl_Interp* interp, char* string); 26 | char* dfsch_tcl_quote(char* str); 27 | char* dfsch_tcl_quote_list(dfsch_object_t* list); 28 | 29 | void dfsch_tcl_event_loop(); 30 | 31 | dfsch_object_t* dfsch_tcl_split_list(char* list); 32 | 33 | #define DFSCH_TCL_INTERPRETER_ARG(al, name) \ 34 | DFSCH_GENERIC_ARG(al, name, Tcl_Interp*, dfsch_tcl_interpreter) 35 | #define DFSCH_TCL_INTERPRETER_ARG_OPT(al, name, default) \ 36 | DFSCH_GENERIC_ARG_OPT(al, name, default, \ 37 | Tcl_Interp*, dfsch_tcl_interpreter) 38 | 39 | #endif 40 | -------------------------------------------------------------------------------- /dfsch/lib/tokyo-cabinet.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch_ext__tokyocabinet__ 2 | #define H__dfsch_ext__tokyocabinet__ 3 | 4 | #include 5 | #include 6 | #include 7 | #include 8 | 9 | extern dfsch_type_t dfsch_tokyo_cabinet_db_type; 10 | #define DFSCH_TOKYO_CABINET_DB_TYPE (&dfsch_tokyo_cabinet_db_type) 11 | 12 | dfsch_object_t* dfsch_tokyo_cabinet_db_open(char* name); 13 | void dfsch_tokyo_cabinet_db_close(dfsch_object_t*db); 14 | dfsch_object_t* dfsch_tokyo_cabinet_prefix_search(dfsch_object_t* dbo, 15 | char* buf, size_t len, 16 | int limit); 17 | void dfsch_tokyo_cabinet_begin_transaction(dfsch_object_t* dbo); 18 | void dfsch_tokyo_cabinet_commit_transaction(dfsch_object_t* dbo); 19 | void dfsch_tokyo_cabinet_abort_transaction(dfsch_object_t* dbo); 20 | 21 | void dfscgh_tokyo_cabinet_db_sync(dfsch_object_t* dbo); 22 | 23 | extern dfsch_type_t dfsch_tokyo_cabinet_table_type; 24 | #define DFSCH_TOKYO_CABINET_TABLE_TYPE (&dfsch_tokyo_cabinet_table_type) 25 | 26 | dfsch_object_t* dfsch_tokyo_cabinet_table_open(char* name); 27 | void dfsch_tokyo_cabinet_table_close(dfsch_object_t*db); 28 | dfsch_object_t* dfsch_tokyo_cabinet_table_prefix_search(dfsch_object_t* dbo, 29 | char* buf, size_t len, 30 | int limit); 31 | void dfsch_tokyo_cabinet_table_begin_transaction(dfsch_object_t* dbo); 32 | void dfsch_tokyo_cabinet_table_commit_transaction(dfsch_object_t* dbo); 33 | void dfsch_tokyo_cabinet_table_abort_transaction(dfsch_object_t* dbo); 34 | 35 | void dfscgh_tokyo_cabinet_table_sync(dfsch_object_t* dbo); 36 | 37 | dfsch_object_t* dfsch_tokyo_cabinet_list_2_object(TCLIST* list); 38 | TCMAP* dfsch_tokyo_cabinet_object_2_map(dfsch_object_t* obj); 39 | dfsch_object_t* dfsch_tokyo_cabinet_map_2_object(TCMAP* map); 40 | 41 | void dfsch_tokyo_cabinet_table_set_index(dfsch_object_t* dbo, 42 | char* name, 43 | int type); 44 | int dfsch_tokyo_cabinet_parse_index_type(dfsch_object_t* args); 45 | 46 | 47 | extern dfsch_type_t dfsch_tokyo_cabinet_query_type; 48 | #define DFSCH_TOKYO_CABINET_QUERY_TYPE (&dfsch_tokyo_cabinet_query_type) 49 | 50 | dfsch_object_t* dfsch_tokyo_cabinet_make_query(dfsch_object_t* dbo); 51 | 52 | void dfsch_tokyo_cabinet_add_query_condition(dfsch_object_t* qo, 53 | char* col_name, 54 | dfsch_object_t* args); 55 | void dfsch_tokyo_cabinet_set_query_order(dfsch_object_t* qo, 56 | char* colname, 57 | int type); 58 | int dfsch_tokyo_cabinet_parse_order_type(dfsch_object_t* type); 59 | void dfsch_tokyo_cabinet_set_query_limit(dfsch_object_t* qo, 60 | int count, 61 | int skip); 62 | 63 | dfsch_object_t* dfsch_tokyo_cabinet_query_search(dfsch_object_t* qo); 64 | dfsch_object_t* dfsch_tokyo_cabinet_query_get_records(dfsch_object_t* qo); 65 | 66 | #endif 67 | -------------------------------------------------------------------------------- /dfsch/lib/tokyo-tyrant.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch_ext__tokyotyrant__ 2 | #define H__dfsch_ext__tokyotyrant__ 3 | 4 | #include 5 | #include 6 | #include 7 | 8 | extern dfsch_type_t dfsch_tokyo_tyrant_db_type; 9 | #define DFSCH_TOKYO_TYRANT_DB_TYPE (&dfsch_tokyo_tyrant_db_type) 10 | 11 | extern dfsch_type_t dfsch_tokyo_tyrant_table_type; 12 | #define DFSCH_TOKYO_TYRANT_TABLE_TYPE (&dfsch_tokyo_tyrant_table_type) 13 | 14 | extern dfsch_type_t dfsch_tokyo_tyrant_query_type; 15 | #define DFSCH_TOKYO_TYRANT_QUERY_TYPE (&dfsch_tokyo_tyrant_query_type) 16 | 17 | dfsch_object_t* dfsch_tokyo_tyrant_db_open(char* name); 18 | void dfsch_tokyo_tyrant_db_close(dfsch_object_t*db); 19 | dfsch_object_t* dfsch_tokyo_tyrant_prefix_search(dfsch_object_t* dbo, 20 | char* buf, size_t len, 21 | int limit); 22 | void dfsch_tokyo_tyrant_begin_transaction(dfsch_object_t* dbo); 23 | void dfsch_tokyo_tyrant_commit_transaction(dfsch_object_t* dbo); 24 | void dfsch_tokyo_tyrant_abort_transaction(dfsch_object_t* dbo); 25 | 26 | 27 | #endif 28 | -------------------------------------------------------------------------------- /dfsch/lib/unix.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - dfox's quick and dirty scheme implementation 3 | * Unix operating system interface 4 | * Copyright (C) 2005-2008 Ales Hakl 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | * 20 | */ 21 | 22 | #ifndef H__dfsch__unix__ 23 | #define H__dfsch__unix__ 24 | 25 | #include 26 | 27 | #ifdef __cplusplus 28 | extern "C" { 29 | #endif 30 | 31 | extern dfsch_object_t* dfsch_module_unix_register(dfsch_object_t* ctx); 32 | 33 | 34 | extern dfsch_object_t* dfsch_unix_opendir(char* name); 35 | extern void dfsch_unix_closedir(dfsch_object_t* dir_obj); 36 | extern char* dfsch_unix_readdir(dfsch_object_t* dir_obj); 37 | 38 | extern dfsch_object_t* dfsch_unix_make_stat_struct(); 39 | extern struct stat* dfsch_unix_get_stat(dfsch_object_t* stat); 40 | 41 | #ifdef __cplusplus 42 | } 43 | #endif 44 | 45 | #endif 46 | -------------------------------------------------------------------------------- /dfsch/lib/xml.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch_lib__xml__ 2 | #define H__dfsch_lib__xml__ 3 | 4 | #include 5 | #include 6 | 7 | dfsch_object_t* dfsch_xml_make_parser(char* encoding, int ns); 8 | 9 | void dfsch_xml_destroy_parser(dfsch_object_t* parser); 10 | 11 | XML_Parser dfsch_xml_parser_ref(dfsch_object_t* parser); 12 | 13 | void dfsch_xml_set_start_element_proc(dfsch_object_t* parser, 14 | dfsch_object_t* proc); 15 | void dfsch_xml_set_end_element_proc(dfsch_object_t* parser, 16 | dfsch_object_t* proc); 17 | void dfsch_xml_set_character_data_proc(dfsch_object_t* parser, 18 | dfsch_object_t* proc); 19 | void dfsch_xml_set_processing_instruction_proc(dfsch_object_t* parser, 20 | dfsch_object_t* proc); 21 | void dfsch_xml_set_comment_proc(dfsch_object_t* parser, 22 | dfsch_object_t* proc); 23 | 24 | void dfsch_xml_parse_buf(dfsch_object_t* parser, 25 | char* buf, 26 | size_t len, 27 | int eof); 28 | void dfsch_xml_parse_strbuf(dfsch_object_t* parser, 29 | dfsch_strbuf_t* buf, 30 | int eof); 31 | void dfsch_xml_parse_cstr(dfsch_object_t* parser, 32 | char* str, 33 | int eof); 34 | void dfsch_xml_parse_eof(dfsch_object_t* parser); 35 | 36 | void dfsch_xml_parse_file(dfsch_object_t* parsr, 37 | char* filename, 38 | int eof); 39 | void dfsch_xml_parse_port(dfsch_object_t* parser, 40 | dfsch_object_t* port, 41 | int eof); 42 | 43 | 44 | extern dfsch_type_t dfsch_xml_parser_type; 45 | #define DFSCH_XML_PARSER_TYPE (&dfsch_xml_parser_type) 46 | 47 | void dfsch_xml_signal_error(XML_Parser parser); 48 | 49 | 50 | #endif 51 | -------------------------------------------------------------------------------- /dfsch/lib/zlib.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - Scheme-like Lisp dialect 3 | * Sub-process handling 4 | * Copyright (C) 2009 Ales Hakl 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | * 20 | */ 21 | 22 | #ifndef H__dfsch__zlib__ 23 | #define H__dfsch__zlib__ 24 | 25 | #include 26 | #include 27 | 28 | #ifdef __cplusplus 29 | extern "C" { 30 | #endif 31 | 32 | extern dfsch_type_t dfsch_gzip_port_type; 33 | #define DFSCH_GZIP_PORT_TYPE (&dfsch_gzip_port_type) 34 | extern dfsch_port_type_t dfsch_process_gzip_port_type; 35 | #define DFSCH_GZIP_OUTPUT_PORT_TYPE (&dfsch_gzip_output_port_type) 36 | extern dfsch_port_type_t dfsch_process_gzip_port_type; 37 | #define DFSCH_GZIP_INPUT_PORT_TYPE (&dfsch_gzip_input_port_type) 38 | 39 | dfsch_object_t* dfsch_gzip_open_for_input(char* filename); 40 | dfsch_object_t* dfsch_gzip_open_for_output(char* filename); 41 | dfsch_object_t* dfsch_gzip_open_for_append(char* filename); 42 | 43 | void dfsch_gzip_close_port(dfsch_object_t* port); 44 | 45 | #ifdef __cplusplus 46 | } 47 | #endif 48 | 49 | #endif 50 | -------------------------------------------------------------------------------- /dfsch/mkhash.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch__mchash__ 2 | #define H__dfsch__mchash__ 3 | 4 | #include 5 | #include 6 | 7 | #define DFSCH_MKHASH_TYPE ((dfsch_type_t*)&dfsch_mkhash_type) 8 | extern dfsch_type_t dfsch_mkhash_type; 9 | 10 | typedef struct dfsch_mkhash_t dfsch_mkhash_t; 11 | 12 | dfsch_mkhash_t* dfsch_make_mkhash(size_t num_keys, 13 | int eqp); 14 | int dfsch_mkhash_ref(dfsch_mkhash_t* hash, 15 | dfsch_object_t** keys, 16 | dfsch_object_t** result); 17 | void dfsch_mkhash_set(dfsch_mkhash_t* hash, 18 | dfsch_object_t** keys, 19 | dfsch_object_t* value); 20 | void dfsch_mkhash_unset(dfsch_mkhash_t* hash, 21 | dfsch_object_t** keys); 22 | dfsch_object_t* dfsch_mkhash_2_alist(dfsch_mkhash_t* hash); 23 | 24 | #endif 25 | -------------------------------------------------------------------------------- /dfsch/object.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - dfox's quick and dirty scheme implementation 3 | * Object system 4 | * Copyright (C) 2005-2010 Ales Hakl 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Lesser General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2.1 of the License, or (at your option) any later version. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19 | * 20 | */ 21 | 22 | #ifndef H__dfsch__object__ 23 | #define H__dfsch__object__ 24 | 25 | #include 26 | #include 27 | 28 | #ifdef __cplusplus 29 | extern "C" { 30 | #endif 31 | 32 | typedef struct dfsch_metaclass_t dfsch_metaclass_t; 33 | 34 | typedef dfsch_object_t* (*dfsch_alloc_instance_t)(dfsch_object_t* klass); 35 | typedef dfsch_object_t* (*dfsch_make_class_t)(dfsch_metaclass_t* mc, 36 | dfsch_object_t* super, 37 | char* name, 38 | dfsch_object_t* slots, 39 | dfsch_object_t* options, 40 | dfsch_object_t* roles); 41 | 42 | struct dfsch_metaclass_t { 43 | dfsch_type_t type; 44 | dfsch_alloc_instance_t allocate_instance; 45 | dfsch_make_class_t make_class; 46 | }; 47 | 48 | extern dfsch_type_t dfsch_metaclass_type; 49 | #define DFSCH_METACLASS_TYPE (&dfsch_metaclass_type) 50 | 51 | extern dfsch_metaclass_t dfsch_standard_class_type; 52 | #define DFSCH_STANDARD_CLASS_TYPE (&dfsch_standard_class_type) 53 | 54 | typedef struct dfsch_standard_class_t { 55 | dfsch_type_t standard_type; 56 | dfsch_object_t* write_instance; 57 | dfsch_object_t* initfuncs; 58 | dfsch_object_t* initargs; 59 | } dfsch_standard_class_t; 60 | 61 | 62 | dfsch_object_t* dfsch_make_class(dfsch_object_t* superclass, 63 | dfsch_object_t* metaclass, 64 | char* name, 65 | dfsch_object_t* slots, 66 | dfsch_object_t* options, 67 | dfsch_object_t* roles); 68 | dfsch_object_t* dfsch_make_instance(dfsch_object_t* klass, 69 | dfsch_object_t* args); 70 | 71 | void dfsch_make_class_slots(dfsch_slot_type_t* default_slot_type, 72 | dfsch_type_t* klass, 73 | dfsch_object_t* defs); 74 | void dfsch_standard_class_prepare_slots(dfsch_standard_class_t* klass); 75 | 76 | extern dfsch_type_specializer_type_t dfsch_role_type; 77 | #define DFSCH_ROLE_TYPE (&dfsch_role_type) 78 | 79 | dfsch_object_t* dfsch_make_role(char* name, 80 | dfsch_object_t* superroles, 81 | dfsch_object_t* slots, 82 | dfsch_object_t* options); 83 | int dfsch_role_inherited_p(dfsch_object_t* sub, 84 | dfsch_object_t* super); 85 | 86 | #ifdef __cplusplus 87 | } 88 | #endif 89 | 90 | #endif 91 | -------------------------------------------------------------------------------- /dfsch/parse.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - dfox's quick and dirty scheme implementation 3 | * Event driven parser 4 | * Copyright (C) 2005-2010 Ales Hakl 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Lesser General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2.1 of the License, or (at your option) any later version. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19 | * 20 | */ 21 | 22 | /** \file dfsch/parse.h 23 | * 24 | * Stream based S-expression parser. 25 | */ 26 | 27 | #ifndef H__dfsch__parse__ 28 | #define H__dfsch__parse__ 29 | 30 | #include 31 | #include 32 | 33 | #ifdef __cplusplus 34 | extern "C" { 35 | #endif 36 | 37 | 38 | #define DFSCH_PARSER_NOERROR 0 39 | #define DFSCH_PARSER_UNEXPECTED_CLOSE 1 40 | #define DFSCH_PARSER_UNEXPECTED_DOT 2 41 | #define DFSCH_PARSER_UNEXPECTED_OBJECT 3 42 | #define DFSCH_PARSER_CAR_EXPECTED 4 43 | #define DFSCH_PARSER_LIST_EXPECTED 5 44 | #define DFSCH_PARSER_INVALID_ESCAPE 6 45 | #define DFSCH_PARSER_INVALID_NUMBER 7 46 | #define DFSCH_PARSER_UNREADABLE 8 47 | #define DFSCH_PARSER_NULL 254 48 | #define DFSCH_PARSER_STOPPED 255 49 | 50 | extern dfsch_type_t dfsch_parse_error_type; 51 | #define DFSCH_PARSE_ERROR_TYPE (&dfsch_parse_error_type) 52 | 53 | 54 | typedef struct dfsch_parser_ctx_t dfsch_parser_ctx_t; 55 | typedef int (*dfsch_parser_callback_t)(dfsch_object_t* obj, void* baton); 56 | 57 | 58 | /** 59 | * Creates new parser instance 60 | */ 61 | extern dfsch_parser_ctx_t* dfsch_parser_create(); 62 | 63 | /** 64 | * Sets callback for complete objects parsed. 65 | */ 66 | extern void dfsch_parser_callback(dfsch_parser_ctx_t *ctx, 67 | dfsch_parser_callback_t callback, 68 | void *baton); 69 | 70 | /** 71 | * Feed some data into parser. 72 | */ 73 | extern int dfsch_parser_feed(dfsch_parser_ctx_t *ctx, char* data); 74 | extern int dfsch_parser_feed_line(dfsch_parser_ctx_t* ctx, char* data); 75 | 76 | /** 77 | * Get nesting level (i.e. some value proportional to depth of parser 78 | * stack) 79 | */ 80 | extern int dfsch_parser_get_level(dfsch_parser_ctx_t *ctx); 81 | 82 | /** 83 | * Return true if parser is in default state. 84 | */ 85 | extern int dfsch_parser_top_level(dfsch_parser_ctx_t *ctx); 86 | 87 | /** 88 | * Destroy current parser context and start from scratch (useful for 89 | * C-c in interactive applications) 90 | */ 91 | extern void dfsch_parser_reset(dfsch_parser_ctx_t *ctx); 92 | 93 | /** 94 | * Read one object from port. 95 | */ 96 | extern dfsch_object_t* dfsch_parser_read_from_port(dfsch_object_t* port); 97 | 98 | extern void dfsch_parser_eval_env(dfsch_parser_ctx_t *ctx, 99 | dfsch_object_t* env); 100 | 101 | extern void dfsch_parser_set_source(dfsch_parser_ctx_t* ctx, 102 | dfsch_object_t* source); 103 | #ifdef __cplusplus 104 | } 105 | #endif 106 | 107 | 108 | #endif 109 | -------------------------------------------------------------------------------- /dfsch/random.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch__random__ 2 | #define H__dfsch__random__ 3 | 4 | #include 5 | 6 | typedef void (*dfsch_random_get_bytes_t)(dfsch_object_t* state, 7 | uint8_t* buf, size_t len); 8 | 9 | typedef struct dfsch_random_state_type_t { 10 | dfsch_type_t type; 11 | dfsch_random_get_bytes_t get_bytes; 12 | int deterministic; 13 | } dfsch_random_state_type_t; 14 | 15 | extern dfsch_type_t dfsch_random_state_type; 16 | #define DFSCH_RANDOM_STATE_TYPE (&dfsch_random_state_type) 17 | extern dfsch_type_t dfsch_random_state_type_type; 18 | #define DFSCH_RANDOM_STATE_TYPE_TYPE (&dfsch_random_state_type_type) 19 | extern dfsch_random_state_type_t dfsch_default_random_state_type; 20 | #define DFSCH_DEFAULT_RANDOM_STATE_TYPE (&dfsch_default_random_state_type) 21 | extern dfsch_random_state_type_t dfsch_file_random_state_type; 22 | #define DFSCH_FILE_RANDOM_STATE_TYPE (&dfsch_file_random_state_type) 23 | extern dfsch_random_state_type_t dfsch_lcg_random_state_type; 24 | #define DFSCH_LCG_RANDOM_STATE_TYPE (&dfsch_lcg_random_state_type) 25 | 26 | dfsch_object_t* dfsch_get_random_state(); 27 | void dfsch_set_random_state(dfsch_object_t* state); 28 | 29 | void dfsch_random_get_bytes(dfsch_object_t* state, uint8_t* buf, size_t len); 30 | int64_t dfsch_random_get_integer(dfsch_object_t* state, int64_t max); 31 | double dfsch_random_get_double(dfsch_object_t* state); 32 | dfsch_object_t* dfsch_random_get_number(dfsch_object_t* state, 33 | dfsch_object_t* max); 34 | dfsch_object_t* dfsch_random_get_bignum(dfsch_object_t* state, 35 | size_t len); 36 | 37 | dfsch_object_t* dfsch_make_default_random_state(uint8_t* seed, size_t len); 38 | dfsch_object_t* dfsch_make_file_random_state(char* filename); 39 | 40 | void dfsch_get_random_id(char buf[18]); 41 | void dfsch_get_random_scoped_id(char buf[20], char scope[16]); 42 | int dfsch_check_scoped_id(char id[20], char scope[16]); 43 | 44 | 45 | #endif 46 | -------------------------------------------------------------------------------- /dfsch/sha256.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch__sha256__ 2 | #define H__dfsch__sha256__ 3 | 4 | #include 5 | #include 6 | #include 7 | 8 | typedef struct dfsch_sha256_context_t{ 9 | dfsch_type_t* type; 10 | uint64_t length; 11 | uint32_t state[8], curlen; 12 | unsigned char buf[64]; 13 | } dfsch_sha256_context_t; 14 | 15 | void dfsch_sha256_setup(dfsch_sha256_context_t* md); 16 | 17 | void dfsch_sha256_process(dfsch_sha256_context_t* md, 18 | const unsigned char *in, 19 | unsigned long inlen); 20 | void dfsch_sha256_result(dfsch_sha256_context_t * md, unsigned char *out); 21 | 22 | 23 | #endif 24 | -------------------------------------------------------------------------------- /dfsch/strhash.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch__strhash__ 2 | #define H__dfsch__strhash__ 3 | 4 | #include 5 | 6 | typedef struct dfsch_strhash_t dfsch_strhash_t; 7 | typedef struct dfsch_strhash__entry_t dfsch_strhash__entry_t; 8 | 9 | struct dfsch_strhash_t { 10 | dfsch_strhash__entry_t** vector; 11 | size_t mask; 12 | size_t count; 13 | }; 14 | 15 | struct dfsch_strhash__entry_t { 16 | size_t hash; 17 | char* name; 18 | char* value; 19 | dfsch_strhash__entry_t* next; 20 | }; 21 | 22 | void dfsch_strhash_init(dfsch_strhash_t* h); 23 | void dfsch_strhash_set(dfsch_strhash_t* sh, 24 | char* key, void* value); 25 | void* dfsch_strhash_ref(dfsch_strhash_t* sh, 26 | char* key); 27 | 28 | void dfsch_strhash_init_sa(dfsch_strhash_t* h); 29 | void dfsch_strhash_set_sa(dfsch_strhash_t* sh, 30 | char* key, void* value); 31 | 32 | 33 | #endif 34 | -------------------------------------------------------------------------------- /dfsch/weak.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - dfox's quick and dirty scheme implementation 3 | * Weak references 4 | * Copyright (C) 2005-2010 Ales Hakl 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Lesser General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2.1 of the License, or (at your option) any later version. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19 | * 20 | */ 21 | 22 | 23 | #ifndef H__dfsch__weak__ 24 | #define H__dfsch__weak__ 25 | 26 | #include 27 | #include 28 | 29 | #ifdef __cplusplus 30 | extern "C" { 31 | #endif 32 | 33 | extern dfsch_object_t* dfsch_make_weak_reference(dfsch_object_t* refered); 34 | 35 | extern int dfsch_weak_reference_live_p(dfsch_object_t* reference); 36 | extern dfsch_object_t* dfsch_weak_reference_dereference(dfsch_object_t* reference); 37 | 38 | extern dfsch_object_t* dfsch_make_weak_vector(size_t length, 39 | dfsch_object_t* fill); 40 | extern size_t dfsch_weak_vector_length(dfsch_object_t *vector); 41 | extern dfsch_object_t** dfsch_weak_vector_as_array(dfsch_object_t *vector, 42 | size_t *length); 43 | extern dfsch_object_t* dfsch_weak_vector_from_array(dfsch_object_t **array, 44 | size_t length); 45 | extern dfsch_object_t* dfsch_weak_vector_ref(dfsch_object_t *vector, 46 | size_t k); 47 | extern dfsch_object_t* dfsch_weak_vector_set(dfsch_object_t* vector, 48 | size_t k, 49 | dfsch_object_t* obj); 50 | 51 | extern dfsch_type_t dfsch_weak_reference_type; 52 | #define DFSCH_WEAK_REFERENCE_TYPE (&dfsch_weak_reference_type) 53 | extern dfsch_type_t dfsch_weak_vector_type; 54 | #define DFSCH_WEAK_VECTOR_TYPE (&dfsch_weak_vector_type) 55 | extern dfsch_type_t dfsch_weak_key_hash_type; 56 | #define DFSCH_WEAK_KEY_HASH_TYPE ((dfsch_type_t*)&dfsch_weak_key_hash_type) 57 | 58 | #ifdef __cplusplus 59 | } 60 | #endif 61 | 62 | #endif 63 | -------------------------------------------------------------------------------- /dfsch/writer.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch__writer__ 2 | #define H__dfsch__writer__ 3 | 4 | #include 5 | #include 6 | 7 | #ifdef __cplusplus 8 | extern "C" { 9 | #endif 10 | 11 | 12 | #define DFSCH_WRITE_CIRCULAR -1 13 | #define DFSCH_PRINT 0 14 | #define DFSCH_WRITE 1 15 | #define DFSCH_STRICT_WRITE 2 16 | 17 | dfsch_writer_state_t* dfsch_make_writer_state(int max_depth, 18 | int readability, 19 | dfsch_output_proc_t proc, 20 | void* baton); 21 | void dfsch_invalidate_writer_state(dfsch_writer_state_t* state); 22 | int dfsch_writer_state_print_p(dfsch_writer_state_t* state); 23 | int dfsch_writer_state_strict_write_p(dfsch_writer_state_t* state); 24 | int dfsch_writer_state_pprint_p(dfsch_writer_state_t* state); 25 | int dfsch_writer_state_cmark_p(dfsch_writer_state_t* state); 26 | 27 | int dfsch_writer_get_readability(dfsch_writer_state_t* state); 28 | void dfsch_writer_set_readability(dfsch_writer_state_t* state, 29 | int readability); 30 | 31 | 32 | void dfsch_write_object(dfsch_writer_state_t* state, 33 | dfsch_object_t* object); 34 | void dfsch_write_string(dfsch_writer_state_t* state, 35 | char* str); 36 | void dfsch_write_strbuf(dfsch_writer_state_t* state, 37 | char* str, size_t len); 38 | void dfsch_write_unreadable(dfsch_writer_state_t* state, 39 | dfsch_object_t* obj, 40 | char* format, ...); 41 | void dfsch_write_unreadable_with_slots(dfsch_writer_state_t* state, 42 | dfsch_object_t* obj); 43 | void dfsch_write_unreadable_start(dfsch_writer_state_t* state, 44 | dfsch_object_t* obj); 45 | void dfsch_write_unreadable_end(dfsch_writer_state_t* state); 46 | void dfsch_write_pprint_newline(dfsch_writer_state_t* state); 47 | void dfsch_write_pprint_indent(dfsch_writer_state_t* state); 48 | void dfsch_write_pprint_begin(dfsch_writer_state_t* state); 49 | void dfsch_write_pprint_end(dfsch_writer_state_t* state); 50 | 51 | 52 | void dfsch_write_unreadable_with_slots_method(dfsch_object_t* obj, 53 | dfsch_writer_state_t* state); 54 | 55 | void dfsch_put_object(FILE* f, dfsch_object_t* obj, 56 | int max_depth, int mode); 57 | 58 | #ifdef __cplusplus 59 | } 60 | #endif 61 | #endif 62 | -------------------------------------------------------------------------------- /doc/dfsch-repl.1: -------------------------------------------------------------------------------- 1 | .\" Process this file with 2 | .\" groff -man -Tascii foo.1 3 | .\" 4 | .TH DFSCH-REPL 1 "" "" "User Manuals" 5 | .SH NAME 6 | dfsch-repl \- scheme interpreter 7 | .SH SYNOPSIS 8 | .B dfsch-repl [-i] [-e 9 | .I expression 10 | .B ] [-E 11 | .I expression 12 | .B ] [-l 13 | .I scheme-file 14 | .B ] [-O 15 | .I filename 16 | .B ] [ 17 | .I filename 18 | .B [ 19 | .I arguments 20 | .B ... ]] 21 | .SH DESCRIPTION 22 | .B dfsch 23 | is small embeddable scheme interpreter. 24 | .B dfsch-repl 25 | is standalone command interpreter of scheme subset used by 26 | .BR dfsch . 27 | .SH OPTIONS 28 | .IP "-e expression" 29 | Execute given expression. That is, evaluate it and forget result. 30 | .IP "-E expression" 31 | Evaluate given expression. That is, evaluate it and print result to 32 | .BR stdout . 33 | .IP -i 34 | Force entry into 35 | .B "interactive mode" 36 | even after executing code from non-interactive sources. 37 | .IP "-l scheme-file" 38 | Load given code into top-level environment. 39 | .IP "-O filename" 40 | Log all sucessfuly evaluated expressions into given file. 41 | .SH BUGS 42 | Many. 43 | .SH AUTHOR 44 | Ales Hakl 45 | .SH "SEE ALSO" 46 | .BR dfsch (3) 47 | -------------------------------------------------------------------------------- /doc/example-module/AUTHORS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/adh/dfsch/0b54da0f392485754d587e3f678219ad07991733/doc/example-module/AUTHORS -------------------------------------------------------------------------------- /doc/example-module/ChangeLog: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/adh/dfsch/0b54da0f392485754d587e3f678219ad07991733/doc/example-module/ChangeLog -------------------------------------------------------------------------------- /doc/example-module/Makefile.am: -------------------------------------------------------------------------------- 1 | dfschlibexec_LTLIBRARIES = example.la libdfsch-example.la 2 | 3 | nobase_include_headers = dfsch-ext/example.h 4 | 5 | libdfsch_example_la_SOURCES = src/example.c dfsch-ext/example.h 6 | libdfsch_example_la_LDFLAGS = -version-info 1:0:0 -no-undefined 7 | libdfsch_example_la_LIBADD = -ldfsch 8 | 9 | example_la_SOURCES = src/example_mod.c 10 | example_la_LIBADD = -ldfsch libdfsch-example.la 11 | example_la_LDFLAGS = -module -no-undefined -------------------------------------------------------------------------------- /doc/example-module/NEWS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/adh/dfsch/0b54da0f392485754d587e3f678219ad07991733/doc/example-module/NEWS -------------------------------------------------------------------------------- /doc/example-module/README: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/adh/dfsch/0b54da0f392485754d587e3f678219ad07991733/doc/example-module/README -------------------------------------------------------------------------------- /doc/example-module/bootstrap.sh: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | autoheader \ 3 | && aclocal-1.9 \ 4 | && libtoolize \ 5 | && automake-1.9 --add-missing \ 6 | && autoconf 7 | -------------------------------------------------------------------------------- /doc/example-module/configure.ac: -------------------------------------------------------------------------------- 1 | 2 | dnl AM_CONFIG_HEADER(src/config.h) - keep it simple 3 | 4 | dnl package name and version number 5 | 6 | PACKAGE=dfsch-example 7 | VERSION=0.1 8 | AC_INIT(dfsch-example, 0.1) 9 | AC_CONFIG_SRCDIR(src/example.c) 10 | AC_CONFIG_HEADERS(config.h) 11 | AM_INIT_AUTOMAKE 12 | dnl AC_CONFIG_AUX_DIR(config) 13 | dnl checks for programs 14 | 15 | dnl AC_PROG_INTLTOOL - We dont want i18n 16 | 17 | AC_PROG_CC 18 | AC_PROG_LIBTOOL 19 | AC_PROG_CPP 20 | AC_PROG_AWK 21 | AC_PROG_INSTALL 22 | AC_PROG_LN_S 23 | AC_PROG_MAKE_SET 24 | AC_PROG_RANLIB 25 | 26 | # Checks for typedefs, structures, and compiler characteristics. 27 | AC_HEADER_STDBOOL 28 | AC_C_CONST 29 | dnl AC_C_INLINE 30 | AC_HEADER_STDC 31 | AC_CHECK_HEADERS([fcntl.h stdlib.h string.h strings.h unistd.h],, [not_posix="1"]) 32 | AC_FUNC_MALLOC 33 | AC_CHECK_FUNCS([memmove memset strcasecmp strchr strerror strpbrk],, [not_posix="1"]) 34 | 35 | if test x$not_posix == x1; then 36 | AC_MSG_RESULT() 37 | AC_MSG_RESULT(****************************************************************) 38 | AC_MSG_RESULT(Your system lacks some of standard C features) 39 | AC_MSG_RESULT(****************************************************************) 40 | AC_MSG_RESULT() 41 | AC_MSG_ERROR(Seems like you are going to make a new port...) 42 | fi 43 | 44 | AC_CHECK_HEADERS(gc/gc.h, [have_gc="1"], [have_gc="0"]) 45 | AC_CHECK_LIB(gc, GC_malloc,, [have_gc="0"], [-ldl -lpthread]) 46 | 47 | if test x$have_gc != x1; then 48 | AC_MSG_RESULT() 49 | AC_MSG_RESULT(****************************************************************) 50 | AC_MSG_RESULT(Boehm Garbage Collector (gc) not found!) 51 | AC_MSG_RESULT() 52 | AC_MSG_RESULT(See http://www.hpl.hp.com/personal/Hans_Boehm/gc/index.html) 53 | AC_MSG_RESULT(****************************************************************) 54 | AC_MSG_RESULT() 55 | AC_MSG_ERROR(Cannot compile without gc!) 56 | fi 57 | 58 | AC_ARG_WITH([dfsch], 59 | AC_HELP_STRING([--with-dfsch=PATH], [Path to dfsch installation]), 60 | CPPFLAGS="$CPPFLAGS -I${withval}/include -I${withval}" 61 | LDFLAGS="$LDFLAGS -L${withval}/lib -L${withval}") 62 | 63 | AC_CHECK_HEADERS(dfsch/dfsch.h, [have_dfsch="1"], [have_dfsch="0"]) 64 | AC_CHECK_LIB(dfsch, dfsch_cons,, [have_dfsch="0"]) 65 | 66 | if test x$have_dfsch != x1; then 67 | AC_MSG_RESULT() 68 | AC_MSG_RESULT(****************************************************************) 69 | AC_MSG_RESULT(dfsch not found!) 70 | AC_MSG_RESULT(****************************************************************) 71 | AC_MSG_RESULT() 72 | AC_MSG_ERROR(There is little point in dfsch extension without dfsch.) 73 | fi 74 | 75 | CFLAGS="$CFLAGS -D_REENTRANT -DGC_THREADS -D_POSIX_C_SOURCE=200112L" 76 | 77 | AC_SYS_LARGEFILE 78 | 79 | dfschlibexecdir="$libdir/dfsch/" 80 | AC_SUBST(dfschlibexecdir) 81 | 82 | dnl automake stuff 83 | AM_MAINTAINER_MODE 84 | 85 | dnl create makefiles 86 | AC_OUTPUT(Makefile) -------------------------------------------------------------------------------- /doc/example-module/dfsch-ext/example.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch_ext__example__ 2 | #define H__dfsch_ext__example__ 3 | 4 | #include 5 | 6 | /* Write prototypes for functionality exported by example.c here */ 7 | 8 | #endif 9 | -------------------------------------------------------------------------------- /doc/example-module/src/example.c: -------------------------------------------------------------------------------- 1 | #include "dfsch-ext/example.h" 2 | 3 | /* Write common code useful for C modules here, when your module is 4 | only thin wrapper you can probably omit this file and 5 | libdfsch-example.so library */ 6 | -------------------------------------------------------------------------------- /doc/example-module/src/example_mod.c: -------------------------------------------------------------------------------- 1 | #include "dfsch-ext/example.h" 2 | #include 3 | 4 | /* Write dfsch interface code here */ 5 | 6 | void dfsch_module_example_register(dfsch_object_t* env){ 7 | dfsch_provide(env, "example"); 8 | } 9 | -------------------------------------------------------------------------------- /doc/indent.el: -------------------------------------------------------------------------------- 1 | ;; this file should be probably automatically generated by reflection 2 | 3 | (put 'with-gensyms 'scheme-indent-function 1) 4 | (put 'handler-case 'scheme-indent-function 1) 5 | (put 'handler-bind 'scheme-indent-function 1) 6 | (put 'restart-case 'scheme-indent-function 1) 7 | (put 'restart-bind 'scheme-indent-function 1) 8 | (put 'with-gensyms 'scheme-indent-function 1) 9 | (put 'multiple-value-bind 'scheme-indent-function 2) 10 | 11 | (put 'catch 'scheme-indent-function 1) 12 | (put 'loop 'scheme-indent-function 0) 13 | 14 | (put 'when 'scheme-indent-function 1) 15 | (put 'unless 'scheme-indent-function 1) -------------------------------------------------------------------------------- /doc/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | dfsch documentation 4 | 5 | 6 |

dfsch documentation

7 |
    8 |
  • Default environment contents (for end users) 9 |
    • 23 |
  • C API
    • 24 | 25 | 26 | -------------------------------------------------------------------------------- /doc/notes.md: -------------------------------------------------------------------------------- 1 | # zip 2 | 3 | For example: 4 | 5 | ]=> (zip '(a b c) '(1 2 3)) 6 | ((a 1) (b 2) (c 3)) 7 | ]=> (zip #(foo bar baz quux) (make-number-sequence )) 8 | ((foo 0) (bar 1) (baz 2) (quux 3)) 9 | 10 | 11 | -------------------------------------------------------------------------------- /ext/fastlz/LICENSE: -------------------------------------------------------------------------------- 1 | FastLZ - lightning-fast lossless compression library 2 | 3 | Copyright (C) 2007 Ariya Hidayat (ariya@kde.org) 4 | Copyright (C) 2006 Ariya Hidayat (ariya@kde.org) 5 | Copyright (C) 2005 Ariya Hidayat (ariya@kde.org) 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the "Software"), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | 25 | -------------------------------------------------------------------------------- /ext/fastlz/README.TXT: -------------------------------------------------------------------------------- 1 | FastLZ - lightning-fast lossless compression library 2 | 3 | Author: Ariya Hidayat 4 | Official website: http://www.fastlz.org 5 | 6 | FastLZ is distributed using the MIT license, see file LICENSE 7 | for details. 8 | 9 | FastLZ consists of two files: fastlz.h and fastlz.c. Just add these 10 | files to your project in order to use FastLZ. For information on 11 | compression and decompression routines, see fastlz.h. 12 | 13 | A simple file compressor called 6pack is included as an example 14 | on how to use FastLZ. The corresponding decompressor is 6unpack. 15 | 16 | To compile using GCC: 17 | 18 | gcc -o 6pack 6pack.c fastlz.c 19 | gcc -o 6unpack 6unpack.c fastlz.c 20 | 21 | To compile using MinGW: 22 | 23 | mingw32-gcc -o 6pack 6pack.c fastlz.c 24 | mingw32-gcc -o 6unpack 6unpack.c fastlz.c 25 | 26 | To compile using Microsoft Visual C++: 27 | 28 | cl 6pack.c fastlz.c 29 | cl 6unpack.c fastlz.c 30 | 31 | To compile using Borland C++: 32 | 33 | bcc32 6pack.c fastlz.c 34 | bcc32 6unpack.c fastlz.c 35 | 36 | To compile using OpenWatcom C/C++: 37 | 38 | cl386 6pack.c fastlz.c 39 | cl386 6unpack.c fastlz.c 40 | 41 | To compile using Intel C++ compiler for Windows: 42 | 43 | icl 6pack.c fastlz.c 44 | icl 6unpack.c fastlz.c 45 | 46 | To compile using Intel C++ compiler for Linux: 47 | 48 | icc -o 6pack 6pack.c fastlz.c 49 | icc -o 6unpack 6unpack.c fastlz.c 50 | 51 | To compile 6pack using LCC-Win32: 52 | 53 | lc 6pack.c fastlz.c 54 | lc 6unpack.c fastlz.c 55 | 56 | To compile 6pack using Pelles C: 57 | 58 | pocc 6pack.c 59 | pocc 6unpack.c 60 | pocc fastlz.c 61 | polink 6pack.obj fastlz.obj 62 | polink 6unpack.obj fastlz.obj 63 | 64 | For speed optimization, always use proper compile flags for optimization options. 65 | Typical compiler flags are given below: 66 | 67 | * GCC (pre 4.2): -march=pentium -O3 -fomit-frame-pointer -mtune=pentium 68 | * GCC 4.2 or later: -march=pentium -O3 -fomit-frame-pointer -mtune=generic 69 | * Digital Mars C/C++: -o+all -5 70 | * Intel C++ (Windows): /O3 /Qipo 71 | * Intel C++ (Linux): -O2 -march=pentium -mtune=pentium 72 | * Borland C++: -O2 -5 73 | * LCC-Win32: -O 74 | * Pelles C: /O2 75 | 76 | -------------------------------------------------------------------------------- /ext/fastlz/fastlz.h: -------------------------------------------------------------------------------- 1 | /* 2 | FastLZ - lightning-fast lossless compression library 3 | 4 | Copyright (C) 2007 Ariya Hidayat (ariya@kde.org) 5 | Copyright (C) 2006 Ariya Hidayat (ariya@kde.org) 6 | Copyright (C) 2005 Ariya Hidayat (ariya@kde.org) 7 | 8 | Permission is hereby granted, free of charge, to any person obtaining a copy 9 | of this software and associated documentation files (the "Software"), to deal 10 | in the Software without restriction, including without limitation the rights 11 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | copies of the Software, and to permit persons to whom the Software is 13 | furnished to do so, subject to the following conditions: 14 | 15 | The above copyright notice and this permission notice shall be included in 16 | all copies or substantial portions of the Software. 17 | 18 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 24 | THE SOFTWARE. 25 | */ 26 | 27 | #ifndef FASTLZ_H 28 | #define FASTLZ_H 29 | 30 | #define FASTLZ_VERSION 0x000100 31 | 32 | #define FASTLZ_VERSION_MAJOR 0 33 | #define FASTLZ_VERSION_MINOR 0 34 | #define FASTLZ_VERSION_REVISION 0 35 | 36 | #define FASTLZ_VERSION_STRING "0.1.0" 37 | 38 | #if defined (__cplusplus) 39 | extern "C" { 40 | #endif 41 | 42 | /** 43 | Compress a block of data in the input buffer and returns the size of 44 | compressed block. The size of input buffer is specified by length. The 45 | minimum input buffer size is 16. 46 | 47 | The output buffer must be at least 5% larger than the input buffer 48 | and can not be smaller than 66 bytes. 49 | 50 | If the input is not compressible, the return value might be larger than 51 | length (input buffer size). 52 | 53 | The input buffer and the output buffer can not overlap. 54 | */ 55 | 56 | int dfsch__fastlz_compress(const void* input, int length, void* output); 57 | 58 | /** 59 | Decompress a block of compressed data and returns the size of the 60 | decompressed block. If error occurs, e.g. the compressed data is 61 | corrupted or the output buffer is not large enough, then 0 (zero) 62 | will be returned instead. 63 | 64 | The input buffer and the output buffer can not overlap. 65 | 66 | Decompression is memory safe and guaranteed not to write the output buffer 67 | more than what is specified in maxout. 68 | */ 69 | 70 | int dfsch__fastlz_decompress(const void* input, int length, 71 | void* output, int maxout); 72 | 73 | /** 74 | Compress a block of data in the input buffer and returns the size of 75 | compressed block. The size of input buffer is specified by length. The 76 | minimum input buffer size is 16. 77 | 78 | The output buffer must be at least 5% larger than the input buffer 79 | and can not be smaller than 66 bytes. 80 | 81 | If the input is not compressible, the return value might be larger than 82 | length (input buffer size). 83 | 84 | The input buffer and the output buffer can not overlap. 85 | 86 | Compression level can be specified in parameter level. At the moment, 87 | only level 1 and level 2 are supported. 88 | Level 1 is the fastest compression and generally useful for short data. 89 | Level 2 is slightly slower but it gives better compression ratio. 90 | 91 | Note that the compressed data, regardless of the level, can always be 92 | decompressed using the function fastlz_decompress above. 93 | */ 94 | 95 | int dfsch__fastlz_compress_level(int level, const void* input, 96 | int length, void* output); 97 | 98 | #if defined (__cplusplus) 99 | } 100 | #endif 101 | 102 | #endif /* FASTLZ_H */ 103 | -------------------------------------------------------------------------------- /ext/upskirt/BSDmakefile: -------------------------------------------------------------------------------- 1 | # Makefile 2 | 3 | # Copyright (c) 2009, Natacha Porté 4 | # 5 | # Permission to use, copy, modify, and distribute this software for any 6 | # purpose with or without fee is hereby granted, provided that the above 7 | # copyright notice and this permission notice appear in all copies. 8 | # 9 | # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | 17 | DEPDIR=depends 18 | ALLDEPS=$(DEPDIR)/all 19 | CFLAGS=-c -g -O3 -Wall -Werror -fPIC 20 | LDFLAGS=-g -O3 -Wall -Werror 21 | CC=gcc 22 | 23 | all: libupskirt.so lace kilt 24 | 25 | .PHONY: all clean 26 | 27 | 28 | # libraries 29 | 30 | libupskirt.so: libupskirt.so.2 31 | ln -s $(.ALLSRC) $(.TARGET) 32 | 33 | libupskirt.so.2: markdown.o array.o buffer.o renderers.o 34 | $(CC) $(LDFLAGS) -shared -Wl,-soname=$(.TARGET) \ 35 | $(.ALLSRC) -o $(.TARGET) 36 | 37 | 38 | # executables 39 | 40 | lace: lace.o libupskirt.so 41 | $(CC) $(LDFLAGS) $(.ALLSRC) -o $(.TARGET) 42 | 43 | kilt: kilt.o libupskirt.so 44 | $(CC) $(LDFLAGS) $(.ALLSRC) -o $(.TARGET) 45 | 46 | 47 | # Housekeeping 48 | 49 | benchmark: benchmark.o libupskirt.so 50 | $(CC) $(LDFLAGS) $(.ALLSRC) -o $(.TARGET) 51 | 52 | clean: 53 | rm -f *.o 54 | rm -f libupskirt.so libupskirt.so.* lace kilt benchmark 55 | rm -rf $(DEPDIR) 56 | 57 | 58 | # dependencies 59 | 60 | .sinclude "$(ALLDEPS)" 61 | 62 | 63 | # generic object compilations 64 | 65 | .c.o: 66 | @mkdir -p $(DEPDIR) 67 | @touch $(ALLDEPS) 68 | @$(CC) -MM $(.IMPSRC) > $(DEPDIR)/$(.PREFIX).d 69 | @grep -q "$(.PREFIX).d" $(ALLDEPS) \ 70 | || echo ".include \"$(.PREFIX).d\"" >> $(ALLDEPS) 71 | $(CC) $(CFLAGS) -o $(.TARGET) $(.IMPSRC) 72 | 73 | .m.o: 74 | @mkdir -p $(DEPDIR) 75 | @touch $(ALLDEPS) 76 | @$(CC) -MM $(.IMPSRC) > depends/$(.PREFIX).d 77 | @grep -q "$(.PREFIX).d" $(ALLDEPS) \ 78 | || echo ".include \"$(.PREFIX).d\"" >> $(ALLDEPS) 79 | $(CC) $(CFLAGS) -o $(.TARGET) $(.IMPSRC) 80 | -------------------------------------------------------------------------------- /ext/upskirt/GNUmakefile: -------------------------------------------------------------------------------- 1 | # Makefile 2 | 3 | # Copyright (c) 2009, Natacha Porté 4 | # 5 | # Permission to use, copy, modify, and distribute this software for any 6 | # purpose with or without fee is hereby granted, provided that the above 7 | # copyright notice and this permission notice appear in all copies. 8 | # 9 | # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | 17 | DEPDIR=depends 18 | CFLAGS=-c -g -O3 -Wall -Werror 19 | LDFLAGS=-g -O3 -Wall -Werror 20 | CC=gcc 21 | 22 | all: libupskirt.so lace kilt 23 | 24 | .PHONY: all clean 25 | 26 | 27 | # libraries 28 | 29 | libupskirt.so: libupskirt.so.2 30 | ln -s $^ $@ 31 | 32 | libupskirt.so.2: markdown.o array.o buffer.o renderers.o 33 | $(CC) $(LDFLAGS) -shared -Wl,-soname=$@ $^ -o $@ 34 | 35 | 36 | # executables 37 | 38 | lace: lace.o libupskirt.so 39 | $(CC) $(LDFLAGS) $^ -o $@ 40 | 41 | kilt: kilt.o libupskirt.so 42 | $(CC) $(LDFLAGS) $^ -o $@ 43 | 44 | 45 | # housekeeping 46 | 47 | benchmark: benchmark.o libupskirt.so 48 | $(CC) $(LDFLAGS) $^ -o $@ 49 | 50 | clean: 51 | rm -f *.o 52 | rm -f libupskirt.so libupskirt.so.* lace kilt benchmark 53 | rm -rf $(DEPDIR) 54 | 55 | 56 | # dependencies 57 | 58 | include $(wildcard $(DEPDIR)/*.d) 59 | 60 | 61 | # generic object compilations 62 | 63 | %.o: %.c 64 | @mkdir -p $(DEPDIR) 65 | @$(CC) -MM $< > $(DEPDIR)/$*.d 66 | $(CC) $(CFLAGS) -o $@ $< 67 | 68 | %.o: %.m 69 | @mkdir -p $(DEPDIR) 70 | @$(CC) -MM $< > depends/$*.d 71 | $(CC) $(CFLAGS) -o $@ $< 72 | -------------------------------------------------------------------------------- /ext/upskirt/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009, Natacha Porté 2 | 3 | Permission to use, copy, modify, and distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /ext/upskirt/benchmark.c: -------------------------------------------------------------------------------- 1 | /* benchmark.c - main function for markdown module benchmarking */ 2 | 3 | /* 4 | * Copyright (c) 2009, Natacha Porté 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | */ 18 | 19 | #include "markdown.h" 20 | #include "renderers.h" 21 | 22 | #include 23 | #include 24 | #include 25 | #include 26 | 27 | #define READ_UNIT 1024 28 | #define OUTPUT_UNIT 64 29 | 30 | 31 | /* buffer statistics, to track some memleaks */ 32 | extern long buffer_stat_nb; 33 | extern size_t buffer_stat_alloc_bytes; 34 | 35 | 36 | 37 | /* markdown_file • performs markdown transformation on FILE* */ 38 | static void 39 | benchmark(FILE *in, int nb) { 40 | struct buf *ib, *ob; 41 | size_t ret, i, n; 42 | if (!in) return; 43 | n = (nb <= 1) ? 1 : nb; 44 | 45 | /* reading everything */ 46 | ib = bufnew(READ_UNIT); 47 | bufgrow(ib, READ_UNIT); 48 | while ((ret = fread(ib->data + ib->size, 1, 49 | ib->asize - ib->size, in)) > 0) { 50 | ib->size += ret; 51 | bufgrow(ib, ib->size + READ_UNIT); } 52 | 53 | /* performing markdown parsing */ 54 | for (i = 0; i < n; i += 1) { 55 | ob = bufnew(OUTPUT_UNIT); 56 | ob->size = 0; 57 | markdown(ob, ib, &mkd_xhtml); 58 | bufrelease(ob); } 59 | 60 | /* cleanup */ 61 | bufrelease(ib); } 62 | 63 | 64 | 65 | /* main • main function, interfacing STDIO with the parser */ 66 | int 67 | main(int argc, char **argv) { 68 | int nb = 1, i, j, f, files = 0; 69 | FILE *in = 0; 70 | 71 | /* looking for a count number */ 72 | if (argc > 1) { 73 | for (i = 1; i < argc; i += 1) 74 | if (argv[i][0] == '-' && argv[i][1] == '-') 75 | nb = atoi(argv[i] + 2); 76 | else files += 1; 77 | if (nb < 1) { 78 | fprintf(stderr, "Usage: %s [--] " 79 | "[file] [file] ...\n", argv[0]); 80 | return 2; } } 81 | 82 | /* if no file is given, using stdin as the only file */ 83 | if (files <= 0) { 84 | in = stdin; 85 | files = 1; } 86 | 87 | /* performing the markdown */ 88 | f = 0; 89 | for (j = 0; j < files; j += 1) { 90 | if (in != stdin) { 91 | f += 1; 92 | while (f < argc 93 | && argv[f][0] == '-' && argv[f][1] == '-') 94 | f += 1; 95 | if (f >= argc) break; 96 | in = fopen(argv[f], "r"); 97 | if (!in) { 98 | fprintf(stderr, "Unable to open \"%s\": %s\n", 99 | argv[f], strerror(errno)); 100 | continue; } } 101 | benchmark(in, nb); 102 | if (in != stdin) fclose(in); } 103 | 104 | /* memory checks */ 105 | if (buffer_stat_nb) 106 | fprintf(stderr, "Warning: %ld buffers still active\n", 107 | buffer_stat_nb); 108 | if (buffer_stat_alloc_bytes) 109 | fprintf(stderr, "Warning: %zu bytes still allocated\n", 110 | buffer_stat_alloc_bytes); 111 | return 0; } 112 | 113 | /* vim: set filetype=c: */ 114 | -------------------------------------------------------------------------------- /ext/upskirt/expanded_markdown.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Copyright (c) 2009, Natacha Porté 4 | # 5 | # Permission to use, copy, modify, and distribute this software for any 6 | # purpose with or without fee is hereby granted, provided that the above 7 | # copyright notice and this permission notice appear in all copies. 8 | # 9 | # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | 17 | # This script is used for markdown validation: 18 | # The original Markdown.pl expand tabs into spaces, which is something 19 | # I don't want to do, and it cannot be easily fixed in the renderer, 20 | # so has to be preprocessed. expand(1) is used for that preprocessing, 21 | # feeding tab-free data into my markdown. 22 | 23 | expand -t 4 "$@" | $(dirname $0)/lace --markdown --xhtml 24 | -------------------------------------------------------------------------------- /ext/upskirt/renderers.h: -------------------------------------------------------------------------------- 1 | /* renderers.h - example markdown renderers */ 2 | 3 | /* 4 | * Copyright (c) 2009, Natacha Porté 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | */ 18 | 19 | #ifndef MARKDOWN_RENDERERS_H 20 | #define MARKDOWN_RENDERERS_H 21 | 22 | #include "markdown.h" 23 | 24 | 25 | /***************************** 26 | * EXPORTED HELPER FUNCTIONS * 27 | *****************************/ 28 | 29 | /* lus_attr_escape • copy the buffer entity-escaping '<', '>', '&' and '"' */ 30 | void 31 | lus_attr_escape(struct buf *ob, char *src, size_t size); 32 | 33 | /* lus_body_escape • copy the buffer entity-escaping '<', '>' and '&' */ 34 | void 35 | lus_body_escape(struct buf *ob, char *src, size_t size); 36 | 37 | 38 | 39 | /*********************** 40 | * RENDERER STRUCTURES * 41 | ***********************/ 42 | 43 | /* original markdown renderers */ 44 | extern const struct mkd_renderer mkd_html; /* HTML 4 renderer */ 45 | extern const struct mkd_renderer mkd_xhtml; /* XHTML 1.0 renderer */ 46 | 47 | /* renderers with some discount extensions */ 48 | extern const struct mkd_renderer discount_html; 49 | extern const struct mkd_renderer discount_xhtml; 50 | 51 | /* renderers with Natasha's own extensions */ 52 | extern const struct mkd_renderer nat_html; 53 | extern const struct mkd_renderer nat_xhtml; 54 | 55 | #endif /* ndef MARKDOWN_RENDERERS_H */ 56 | -------------------------------------------------------------------------------- /gen-doc.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | scm/docgen.scm doc/toplevel 4 | for mod in \ 5 | cmdopts collections console extref gcollect \ 6 | inet process regex sxml threads xml; do 7 | scm/docgen.scm --default-all --module $mod doc/$mod 8 | done 9 | doxygen Doxyfile 10 | 11 | -------------------------------------------------------------------------------- /gen-git-rev.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | if git rev-parse --verify HEAD >/dev/null 2>&1; then 4 | REV=`git rev-parse --verify HEAD` 5 | echo '#define DFSCH_GIT_REV "'$REV'"' 6 | fi -------------------------------------------------------------------------------- /gen-module-docs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | mkdir documentation/modules/ 2>/dev/null 4 | 5 | cat > documentation/modules/index.html < 7 | dfsch standard modules documentation 8 | EOF 9 | 10 | if [ -f "$DOCGEN_HEAD_FILE" ]; then 11 | cat "$DOCGEN_HEAD_FILE" >> documentation/modules/index.html 12 | fi 13 | 14 | cat >> documentation/modules/index.html < 16 | 17 |

    dfsch standard modules documentation

    18 |
      19 | EOF 20 | 21 | for i in $2; do 22 | cmdpart=''; 23 | if [ -x $1/doc/module/${i}.md ]; then 24 | cmdpart="--chapters $1/doc/module/$i.md"; 25 | fi; 26 | ./dfsch-run -L ./.libs -L $1/lib-scm \ 27 | $1/tools/docgen.scm --module $i --package-exported $i \ 28 | documentation/modules/${i} #>/dev/null 2>/dev/null 29 | 30 | if [ $? -eq 0 ]; then 31 | echo ${i}... OK 32 | echo "
    • ${i}
      • " \ 33 | >> documentation/modules/index.html 34 | else 35 | echo ${i}... Error 36 | fi 37 | done 38 | 39 | cat >> documentation/modules/index.html < 41 | 42 | 43 | EOF -------------------------------------------------------------------------------- /git-make-stamp.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | if git rev-parse --verify HEAD >/dev/null 2>&1; then 4 | git describe > "$1" 5 | fi 6 | -------------------------------------------------------------------------------- /lib-scm/markdown-tools.scm: -------------------------------------------------------------------------------- 1 | ;;; dfsch - Scheme-like Lisp dialect 2 | ;;; Helper functions for markdown handling 3 | ;;; Copyright (c) 2011 Ales Hakl 4 | ;;; 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining 6 | ;;; a copy of this software and associated documentation files (the 7 | ;;; "Software"), to deal in the Software without restriction, including 8 | ;;; without limitation the rights to use, copy, modify, merge, publish, 9 | ;;; distribute, sublicense, and/or sell copies of the Software, and to 10 | ;;; permit persons to whom the Software is furnished to do so, subject to 11 | ;;; the following conditions: 12 | ;;; 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | ;;; 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 20 | ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 21 | ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 22 | ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | (provide :markdown-tools) 25 | (require :markdown) 26 | 27 | (define-package :markdown-tools 28 | :uses '(:dfsch :markdown) 29 | :exports '(:split-file 30 | :get-title 31 | :get-file-title 32 | :make-outlining-header-renderer)) 33 | (use-package :markdown-tools) 34 | 35 | (define (split-file port) 36 | (letrec ((cur (list () "")) 37 | (res (list cur))) 38 | (for-each (lambda (line) 39 | (if (string-starts-with? line "# ") 40 | (let ((name (string-trim " \t\n\r#" (substring line 1)))) 41 | (set! cur (list name "")) 42 | (nconc res (list cur))) 43 | (set-car! (cdr cur) 44 | (string-append (cadr cur) 45 | line)))) 46 | (make-port-line-iterator port)) 47 | res)) 48 | 49 | (define (get-title port) 50 | (catch 'done 51 | (for-each (lambda (line) 52 | (when (string-starts-with? line "# ") 53 | (throw 'done 54 | (string-trim " \t\n\r#" (substring line 1))))) 55 | (make-port-line-iterator port)))) 56 | 57 | (define (get-file-title filename) 58 | (with-open-file f (filename "r") 59 | (get-title f))) 60 | -------------------------------------------------------------------------------- /lib-scm/os-utils.scm: -------------------------------------------------------------------------------- 1 | (provide :os-utils) 2 | (require :os) 3 | 4 | (define-package :os-utils 5 | :uses '(:dfsch :os) 6 | :exports '(:directory? 7 | :ensure-directory 8 | :directory->list)) 9 | (in-package :os-utils) 10 | 11 | (define (directory? path) 12 | (let ((stat (os:stat path))) 13 | (if (null? stat) 14 | () 15 | (stat :isdir)))) 16 | 17 | (define (ensure-directory path) 18 | (unless (directory? path) 19 | (os:mkdir path 0755))) 20 | 21 | (define (directory->list directory &key full-paths? filter) 22 | (let ((dd (os:opendir directory))) 23 | (let next ((list ())) 24 | (let ((dirent (os:readdir dd))) 25 | (if (null? dirent) 26 | list 27 | (if (and filter (not (filter dirent))) 28 | (next list) 29 | (next (cons (if full-paths? 30 | (string-append directory "/" dirent) 31 | dirent) 32 | list)))))))) 33 | -------------------------------------------------------------------------------- /lib-scm/simple-tests.scm: -------------------------------------------------------------------------------- 1 | (provide :simple-tests) 2 | (require :cmdopts) 3 | (require :os) 4 | (define-package :simple-tests :uses '(:dfsch :cmdopts)) 5 | (in-package :simple-tests) 6 | 7 | (define tests-passed 0) 8 | (define tests-failed 0) 9 | 10 | (define one-test-fail ()) 11 | 12 | (define (print . args) 13 | (for-each (lambda (i) (display i)) args) 14 | (newline)) 15 | 16 | (when (defined? *posix-argv*) 17 | (let ((parser (make-parser))) 18 | (add-option parser 19 | (lambda (p v) 20 | (set! one-test-fail #t) 21 | (print "Running in strict mode")) 22 | :long-option "one-test-fail") 23 | (parse-list parser (cdr *posix-argv*)))) 24 | 25 | 26 | (define (exit-func fail-status) 27 | (print) 28 | (print "***** RESULTS: *****") 29 | (print " Tests passed: " tests-passed) 30 | (if (> tests-failed 0) 31 | (print "\033[0;31m Tests failed: " tests-failed "\033[0;39m") 32 | (print " Tests failed: " tests-failed)) 33 | (print " ===========================") 34 | (print " Tests total: " (+ tests-passed tests-failed)) 35 | (if (= tests-failed 0) 36 | (os:exit 0) 37 | (os:exit fail-status))) 38 | 39 | 40 | (define (%test-pass id) 41 | (print " Test passed: \033[0;32m" id "\033[0;39m") 42 | (set! tests-passed (+ tests-passed 1))) 43 | (define (%test-fail id fmt &rest args) 44 | (print "\033[0;31m!!\033[0;39m Test failed: \033[0;31m" id 45 | "\033[0;39m " 46 | (apply format fmt args)) 47 | (set! tests-failed (+ tests-failed 1)) 48 | (when one-test-fail 49 | (print "*** Test failed -- ABORTING ***") 50 | (exit-func))) 51 | 52 | (define (test id exp val) 53 | (if (equal? exp val) 54 | (%test-pass id) 55 | (%test-fail id "was: ~s should be: ~s" 56 | exp val))) 57 | 58 | (define-macro (test-error id &body body) 59 | `(if (cdr (detect-errors ,@body)) 60 | (%test-pass ,id) 61 | (%test-fail ,id "Should signal error"))) 62 | 63 | 64 | (define (group-generator indent separator name statements) 65 | (define tmp-passed (gensym)) 66 | (define tmp-failed (gensym)) 67 | `(begin 68 | (print ',indent ',separator " " ',name " " ',separator) 69 | (let ((,tmp-passed tests-passed) 70 | (,tmp-failed tests-failed)) 71 | ,@statements 72 | (let ((passed (- tests-passed ,tmp-passed)) 73 | (failed (- tests-failed ,tmp-failed))) 74 | (print ',indent ',separator " [passed: " passed " failed: " failed 75 | " out of " (+ passed failed) "] " ',separator))))) 76 | 77 | (define-macro (group name . statements) 78 | (group-generator "" "=====" name statements)) 79 | 80 | (define-macro (sub-group name . statements) 81 | (group-generator " " "----" name statements)) 82 | 83 | (define-macro (ignore . code) 84 | ()) 85 | -------------------------------------------------------------------------------- /lib-scm/sql.scm: -------------------------------------------------------------------------------- 1 | ;;; dfsch - Scheme-like Lisp dialect 2 | ;;; SQL database interface 3 | ;;; Copyright (c) 2010 Ales Hakl 4 | ;;; 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining 6 | ;;; a copy of this software and associated documentation files (the 7 | ;;; "Software"), to deal in the Software without restriction, including 8 | ;;; without limitation the rights to use, copy, modify, merge, publish, 9 | ;;; distribute, sublicense, and/or sell copies of the Software, and to 10 | ;;; permit persons to whom the Software is furnished to do so, subject to 11 | ;;; the following conditions: 12 | ;;; 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | ;;; 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 20 | ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 21 | ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 22 | ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | (provide :sql) 25 | (require :sql-support) 26 | (define-package :sql 27 | :uses '(:dfsch :sql-support) 28 | :exports '(:close-database! 29 | :exec-string! 30 | :query-string 31 | :close-result! 32 | :column-names 33 | :column-types 34 | :exec! 35 | :query 36 | :begin-transaction! 37 | :commit-transaction! 38 | :rollback-transaction! 39 | :with-transaction, 40 | :escape-string)) 41 | (in-package :sql) 42 | 43 | ;;; Fallback implementation (for sqlite3) 44 | (define-method (column-types res) 45 | (map type-of 46 | (iter-this res))) 47 | 48 | (define-generic-function convert-sql-value) 49 | 50 | (define (build-query string values &optional db) 51 | (construct-string string values 52 | :convert-all (lambda (val) 53 | (convert-sql-value val db)) 54 | :escape-character #\:)) 55 | 56 | (define-method (exec! db statement &rest args) 57 | (exec-string! db (build-query statement args db))) 58 | 59 | (define-method (query db statement &rest args) 60 | (query-string db (build-query statement args db))) 61 | 62 | 63 | (define-method (escape-string db string) 64 | (sql-support:escape-string string)) 65 | 66 | (define-method (convert-sql-value (value ) db) 67 | (sql:escape-string db value)) 68 | (define-method (convert-sql-value (value ) db) 69 | (number->string value)) 70 | (define-method (convert-sql-value (value <>) db) 71 | (string-append 72 | "(" 73 | (string-join (map convert-sql-value value) ", ") 74 | ")")) 75 | 76 | (define-method (begin-transaction! db) 77 | (exec-string! db "BEGIN")) 78 | (define-method (commit-transaction! db) 79 | (exec-string! db "COMMIT")) 80 | (define-method (rollback-transaction! db) 81 | (exec-string! db "ROLLBACK")) 82 | 83 | (define-macro (with-transaction database &body body) 84 | (with-gensyms (db commited?) 85 | `(let ((,db ,database) (,commited? ())) 86 | (unwind-protect 87 | (begin 88 | (begin-transaction! ,db) 89 | ,@body 90 | (commit-transaction! ,db) 91 | (set! ,commited? #t)) 92 | (unless ,commited? 93 | (rollback-transaction! ,db)))))) -------------------------------------------------------------------------------- /lib-scm/stream-functions.scm: -------------------------------------------------------------------------------- 1 | ;;; dfsch - Scheme-like Lisp dialect 2 | ;;; Stream manipulation functions 3 | ;;; Copyright (c) 2009 Ales Hakl 4 | ;;; 5 | ;;; Permission is hereby granted, free of charge, to any person obtaining 6 | ;;; a copy of this software and associated documentation files (the 7 | ;;; "Software"), to deal in the Software without restriction, including 8 | ;;; without limitation the rights to use, copy, modify, merge, publish, 9 | ;;; distribute, sublicense, and/or sell copies of the Software, and to 10 | ;;; permit persons to whom the Software is furnished to do so, subject to 11 | ;;; the following conditions: 12 | ;;; 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | ;;; 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 20 | ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 21 | ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 22 | ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | (in-package :dfsch%internal) 25 | (provide :stream-functions) 26 | 27 | (define (dfsch:stream-filter fn stream) 28 | (if stream 29 | (let ((element (stream-car stream))) 30 | (if (fn element) 31 | (stream-cons element 32 | (dfsch:stream-filter fn (stream-cdr stream))) 33 | (dfsch:stream-filter fn (stream-cdr stream)))) 34 | ())) 35 | 36 | (define (dfsch:stream-while fn stream) 37 | (if stream 38 | (let ((element (stream-car stream))) 39 | (if (fn element) 40 | (stream-cons element 41 | (dfsch:stream-while fn (stream-cdr stream))) 42 | ())) 43 | ())) 44 | 45 | (define (dfsch:stream-reduce fn stream) 46 | (if stream 47 | (let loop ((i (stream-cdr stream)) (val (stream-car stream))) 48 | (if i 49 | (loop (stream-cdr i) (fn val (stream-car i))) 50 | val)) 51 | ())) -------------------------------------------------------------------------------- /lib/cdebug_mod.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | dfsch_object_t* dfsch_module_cdebug_register(dfsch_object_t* env){ 5 | dfsch_package_t* cdebug_pkg = dfsch_make_package("cdebug", 6 | "Console debugger"); 7 | dfsch_defcanon_pkgcstr(env, cdebug_pkg, "debugger-procedure", dfsch_cdebug_get_procedure()); 8 | } 9 | -------------------------------------------------------------------------------- /lib/cinspect_mod.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | dfsch_object_t* dfsch_module_cinspect_register(dfsch_object_t* env){ 5 | dfsch_package_t* cinspect_pkg = dfsch_make_package("cinspect", 6 | "Console inspector"); 7 | dfsch_defcanon_pkgcstr(env, cinspect_pkg, "debugger-procedure", dfsch_cinspect_get_procedure()); 8 | } 9 | -------------------------------------------------------------------------------- /lib/collections_mod.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | DFSCH_DEFINE_PRIMITIVE(make_priority_queue, 0){ 4 | dfsch_object_t* lt; 5 | DFSCH_OBJECT_ARG(args, lt); 6 | DFSCH_ARG_END(args); 7 | return dfsch_collections_make_priority_queue(lt); 8 | } 9 | DFSCH_DEFINE_PRIMITIVE(priority_queue_empty_p, 0){ 10 | dfsch_object_t* queue; 11 | DFSCH_OBJECT_ARG(args, queue); 12 | DFSCH_ARG_END(args); 13 | return dfsch_bool(dfsch_collections_priority_queue_empty_p(queue)); 14 | } 15 | DFSCH_DEFINE_PRIMITIVE(priority_queue_pop, 0){ 16 | dfsch_object_t* queue; 17 | DFSCH_OBJECT_ARG(args, queue); 18 | DFSCH_ARG_END(args); 19 | return dfsch_collections_priority_queue_pop(queue); 20 | } 21 | DFSCH_DEFINE_PRIMITIVE(priority_queue_push, 0){ 22 | dfsch_object_t* queue; 23 | dfsch_object_t* object; 24 | DFSCH_OBJECT_ARG(args, queue); 25 | DFSCH_OBJECT_ARG(args, object); 26 | DFSCH_ARG_END(args); 27 | dfsch_collections_priority_queue_push(queue, object); 28 | return NULL; 29 | } 30 | 31 | DFSCH_DEFINE_PRIMITIVE(make_bitvector, NULL){ 32 | long length; 33 | DFSCH_LONG_ARG(args, length); 34 | DFSCH_ARG_END(args); 35 | 36 | return dfsch_collections_make_bitvector(length); 37 | } 38 | DFSCH_DEFINE_PRIMITIVE(bitvector, NULL){ 39 | return dfsch_collections_list_2_bitvector(args); 40 | } 41 | 42 | DFSCH_DEFINE_PRIMITIVE(bitvector_increment, 43 | "Return next bitvector value in numeric ordering"){ 44 | dfsch_object_t* bv; 45 | DFSCH_OBJECT_ARG(args, bv); 46 | return dfsch_collections_bitvector_increment(bv); 47 | } 48 | 49 | void dfsch_module_collections_register(dfsch_object_t* env){ 50 | dfsch_package_t* collections = dfsch_make_package("collections", 51 | "Advanced collections"); 52 | dfsch_provide(env, "collections"); 53 | 54 | dfsch_defcanon_pkgcstr(env, collections, "", 55 | DFSCH_COLLECTIONS_PRIORITY_QUEUE_TYPE); 56 | dfsch_defcanon_pkgcstr(env, collections, "make-priority-queue", 57 | DFSCH_PRIMITIVE_REF(make_priority_queue)); 58 | dfsch_defcanon_pkgcstr(env, collections, "priority-queue-push!", 59 | DFSCH_PRIMITIVE_REF(priority_queue_push)); 60 | dfsch_defcanon_pkgcstr(env, collections, "priority-queue-pop!", 61 | DFSCH_PRIMITIVE_REF(priority_queue_pop)); 62 | dfsch_defcanon_pkgcstr(env, collections, "priority-queue-empty?", 63 | DFSCH_PRIMITIVE_REF(priority_queue_empty_p)); 64 | 65 | dfsch_defcanon_pkgcstr(env, collections, "", 66 | DFSCH_COLLECTIONS_BITVECTOR_TYPE); 67 | dfsch_defcanon_pkgcstr(env, collections, "make-bitvector", 68 | DFSCH_PRIMITIVE_REF(make_bitvector)); 69 | dfsch_defcanon_pkgcstr(env, collections, "bitvector", 70 | DFSCH_PRIMITIVE_REF(bitvector)); 71 | 72 | dfsch_defcanon_pkgcstr(env, collections, "bitvector-increment", 73 | DFSCH_PRIMITIVE_REF(bitvector_increment)); 74 | 75 | } 76 | -------------------------------------------------------------------------------- /lib/console_mod.c: -------------------------------------------------------------------------------- 1 | #include "dfsch/lib/console.h" 2 | #include 3 | #include 4 | 5 | DFSCH_DEFINE_PRIMITIVE(read_line, 0){ 6 | char* prompt; 7 | DFSCH_STRING_ARG_OPT(args, prompt, "> "); 8 | DFSCH_ARG_END(args); 9 | 10 | return dfsch_make_string_cstr(dfsch_console_read_line(prompt)); 11 | } 12 | DFSCH_DEFINE_PRIMITIVE(read_object, 0){ 13 | char* prompt; 14 | DFSCH_STRING_ARG_OPT(args, prompt, "> "); 15 | DFSCH_ARG_END(args); 16 | 17 | return dfsch_console_read_object(prompt); 18 | } 19 | 20 | dfsch_object_t* dfsch_module_console_register(dfsch_object_t* env){ 21 | dfsch_package_t* console = dfsch_make_package("console", 22 | "Console UI support"); 23 | dfsch_provide(env, "console"); 24 | 25 | dfsch_defcanon_pkgcstr(env, console, "read-line", 26 | DFSCH_PRIMITIVE_REF(read_line)); 27 | dfsch_defcanon_pkgcstr(env, console, "read-object", 28 | DFSCH_PRIMITIVE_REF(read_object)); 29 | return env; 30 | } 31 | -------------------------------------------------------------------------------- /lib/crypto/fe25519.h: -------------------------------------------------------------------------------- 1 | #ifndef FE25519_H 2 | #define FE25519_H 3 | 4 | #define fe25519 dfsch_crypto_sign_edwards25519sha512batch_fe25519 5 | #define fe25519_unpack dfsch_crypto_sign_edwards25519sha512batch_fe25519_unpack 6 | #define fe25519_pack dfsch_crypto_sign_edwards25519sha512batch_fe25519_pack 7 | #define fe25519_cmov dfsch_crypto_sign_edwards25519sha512batch_fe25519_cmov 8 | #define fe25519_setone dfsch_crypto_sign_edwards25519sha512batch_fe25519_setone 9 | #define fe25519_setzero dfsch_crypto_sign_edwards25519sha512batch_fe25519_setzero 10 | #define fe25519_neg dfsch_crypto_sign_edwards25519sha512batch_fe25519_neg 11 | #define fe25519_getparity dfsch_crypto_sign_edwards25519sha512batch_fe25519_getparity 12 | #define fe25519_add dfsch_crypto_sign_edwards25519sha512batch_fe25519_add 13 | #define fe25519_sub dfsch_crypto_sign_edwards25519sha512batch_fe25519_sub 14 | #define fe25519_mul dfsch_crypto_sign_edwards25519sha512batch_fe25519_mul 15 | #define fe25519_square dfsch_crypto_sign_edwards25519sha512batch_fe25519_square 16 | #define fe25519_pow dfsch_crypto_sign_edwards25519sha512batch_fe25519_pow 17 | #define fe25519_sqrt_vartime dfsch_crypto_sign_edwards25519sha512batch_fe25519_sqrt_vartime 18 | #define fe25519_invert dfsch_crypto_sign_edwards25519sha512batch_fe25519_invert 19 | 20 | #include 21 | 22 | typedef struct { 23 | uint32_t v[32]; 24 | } fe25519; 25 | 26 | void fe25519_unpack(fe25519 *r, const unsigned char x[32]); 27 | 28 | void fe25519_pack(unsigned char r[32], const fe25519 *x); 29 | 30 | void fe25519_cmov(fe25519 *r, const fe25519 *x, unsigned char b); 31 | 32 | void fe25519_setone(fe25519 *r); 33 | 34 | void fe25519_setzero(fe25519 *r); 35 | 36 | void fe25519_neg(fe25519 *r, const fe25519 *x); 37 | 38 | unsigned char fe25519_getparity(const fe25519 *x); 39 | 40 | void fe25519_add(fe25519 *r, const fe25519 *x, const fe25519 *y); 41 | 42 | void fe25519_sub(fe25519 *r, const fe25519 *x, const fe25519 *y); 43 | 44 | void fe25519_mul(fe25519 *r, const fe25519 *x, const fe25519 *y); 45 | 46 | void fe25519_square(fe25519 *r, const fe25519 *x); 47 | 48 | void fe25519_pow(fe25519 *r, const fe25519 *x, const unsigned char *e); 49 | 50 | int fe25519_sqrt_vartime(fe25519 *r, const fe25519 *x, unsigned char parity); 51 | 52 | void fe25519_invert(fe25519 *r, const fe25519 *x); 53 | 54 | #endif 55 | -------------------------------------------------------------------------------- /lib/crypto/ge25519.h: -------------------------------------------------------------------------------- 1 | #ifndef GE25519_H 2 | #define GE25519_H 3 | 4 | #include "fe25519.h" 5 | #include "sc25519.h" 6 | 7 | #define ge25519 dfsch_crypto_sign_edwards25519sha512batch_ge25519 8 | #define ge25519_unpack_vartime dfsch_crypto_sign_edwards25519sha512batch_ge25519_unpack_vartime 9 | #define ge25519_pack dfsch_crypto_sign_edwards25519sha512batch_ge25519_pack 10 | #define ge25519_add dfsch_crypto_sign_edwards25519sha512batch_ge25519_add 11 | #define ge25519_double dfsch_crypto_sign_edwards25519sha512batch_ge25519_double 12 | #define ge25519_scalarmult dfsch_crypto_sign_edwards25519sha512batch_ge25519_scalarmult 13 | #define ge25519_scalarmult_base dfsch_crypto_sign_edwards25519sha512batch_ge25519_scalarmult_base 14 | 15 | typedef struct { 16 | fe25519 x; 17 | fe25519 y; 18 | fe25519 z; 19 | fe25519 t; 20 | } ge25519; 21 | 22 | int ge25519_unpack_vartime(ge25519 *r, const unsigned char p[32]); 23 | 24 | void ge25519_pack(unsigned char r[32], const ge25519 *p); 25 | 26 | void ge25519_add(ge25519 *r, const ge25519 *p, const ge25519 *q); 27 | 28 | void ge25519_double(ge25519 *r, const ge25519 *p); 29 | 30 | void ge25519_scalarmult(ge25519 *r, const ge25519 *p, const sc25519 *s); 31 | 32 | void ge25519_scalarmult_base(ge25519 *r, const sc25519 *s); 33 | 34 | #endif 35 | -------------------------------------------------------------------------------- /lib/crypto/hmac.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | typedef struct hmac_t { 4 | dfsch_crypto_hash_t parent; 5 | dfsch_crypto_hash_t* hash; 6 | } hmac_t; 7 | 8 | 9 | dfsch_type_t dfsch_crypto_hmac_type = { 10 | .type = DFSCH_META_TYPE, 11 | .superclass = DFSCH_CRYPTO_HASH_TYPE, 12 | .name = "crypto:hmac-type", 13 | .size = sizeof(hmac_t) 14 | }; 15 | 16 | typedef struct hmac_context_t { 17 | hmac_t* hmac; 18 | } hmac_context_t; 19 | 20 | static void hmac_setup(hmac_context_t* ctx, uint8_t* key, size_t keylen){ 21 | int i; 22 | 23 | if (keylen > ctx->hmac->hash->block_len){ 24 | dfsch_error("HMAC key too long", NULL); 25 | } 26 | 27 | ctx->hmac->hash->setup(ctx, NULL, 0); 28 | memset(((uint8_t*)ctx) + ctx->hmac->hash->type.size, 0, 29 | ctx->hmac->hash->block_len); 30 | memcpy(((uint8_t*)ctx) + ctx->hmac->hash->type.size, key, keylen); 31 | 32 | for (i = 0; i < ctx->hmac->hash->block_len; i++){ 33 | (((uint8_t*)ctx) + ctx->hmac->hash->type.size)[i] ^= 0x36; 34 | } 35 | 36 | ctx->hmac->hash->process(ctx, 37 | ((uint8_t*)ctx) + ctx->hmac->hash->type.size, 38 | ctx->hmac->hash->block_len); 39 | } 40 | 41 | static void hmac_result(hmac_context_t* ctx, uint8_t* res){ 42 | uint8_t buf[ctx->hmac->hash->result_len]; 43 | dfsch_crypto_hash_context_t* oc; 44 | int i; 45 | 46 | for (i = 0; i < ctx->hmac->hash->block_len; i++){ 47 | (((uint8_t*)ctx) + ctx->hmac->hash->type.size)[i] ^= (0x36 ^ 0x5c); 48 | } 49 | 50 | ctx->hmac->hash->result(ctx, buf); 51 | 52 | oc = dfsch_crypto_hash_setup(ctx->hmac->hash, NULL, 0); 53 | oc->algo->process(oc, 54 | ((uint8_t*)ctx) + ctx->hmac->hash->type.size, 55 | ctx->hmac->hash->block_len); 56 | oc->algo->process(oc, buf, ctx->hmac->hash->result_len); 57 | oc->algo->result(oc, res); 58 | } 59 | 60 | dfsch_crypto_hash_t* dfsch_crypto_make_hmac(dfsch_crypto_hash_t* hash){ 61 | hmac_t* hmac = dfsch_make_object(DFSCH_CRYPTO_HMAC_TYPE); 62 | 63 | hmac->hash = hash; 64 | 65 | hmac->parent.type.name = dfsch_saprintf("hmac-%s", hash->type.name); 66 | hmac->parent.type.size = hash->type.size + hash->block_len; 67 | 68 | hmac->parent.name = dfsch_saprintf("HMAC-%s", hash->name); 69 | hmac->parent.block_len = hash->block_len; 70 | hmac->parent.result_len = hash->result_len; 71 | 72 | hmac->parent.setup = hmac_setup; 73 | hmac->parent.process = hash->process; 74 | hmac->parent.result = hmac_result; 75 | return hmac; 76 | } 77 | -------------------------------------------------------------------------------- /lib/crypto/internal.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch_crypto___internal__ 2 | #define H__dfsch_crypto___internal__ 3 | 4 | 5 | typedef struct sha512_context_t { 6 | dfsch_crypto_hash_t* algo; 7 | uint64_t length, state[8]; 8 | unsigned long curlen; 9 | unsigned char buf[128]; 10 | } sha512_context_t; 11 | 12 | void dfsch_sha512_setup(sha512_context_t * md, 13 | uint8_t* key, size_t keylen); 14 | void dfsch_sha512_process(sha512_context_t * md, 15 | const unsigned char* in, 16 | unsigned long inlen); 17 | void dfsch_sha512_result(sha512_context_t * md, unsigned char *out); 18 | 19 | 20 | #endif 21 | -------------------------------------------------------------------------------- /lib/crypto/rc4.c: -------------------------------------------------------------------------------- 1 | #include "dfsch/lib/crypto.h" 2 | 3 | typedef struct rc4_context_t { 4 | dfsch_stream_cipher_t* cipher; 5 | uint8_t i; 6 | uint8_t j; 7 | uint8_t s[256]; 8 | } rc4_context_t; 9 | 10 | static void rc4_encrypt_bytes(rc4_context_t* ctx, 11 | uint8_t *keystream, 12 | size_t keystreamlen){ 13 | uint8_t t; 14 | 15 | while (keystreamlen){ 16 | ctx->i = (ctx->i + 1) & 0xff; 17 | ctx->j = (ctx->j + ctx->s[ctx->i]) & 0xff; 18 | t = ctx->s[ctx->j]; 19 | ctx->s[ctx->j] = ctx->s[ctx->i]; 20 | ctx->s[ctx->i] = t; 21 | *keystream ^= ctx->s[(ctx->s[ctx->i] + ctx->s[ctx->j]) & 0xff]; 22 | keystream++; 23 | keystreamlen--; 24 | } 25 | } 26 | 27 | static void rc4_setup(rc4_context_t* ctx, 28 | uint8_t* key, 29 | size_t key_len, 30 | uint8_t *nonce, 31 | size_t nonce_len){ 32 | int i; 33 | int j; 34 | uint8_t t; 35 | 36 | if (key_len < 1 || key_len > 256){ 37 | dfsch_error("Key length for RC4 must be between 1 and 256", NULL); 38 | } 39 | if (nonce_len != 0){ 40 | dfsch_error("RC4 does not support nonces", NULL); 41 | } 42 | 43 | for (i = 0; i < 256; i++){ 44 | ctx->s[i] = i; 45 | } 46 | 47 | j = 0; 48 | 49 | for (i = 0; i < 256; i++){ 50 | j = (j + ctx->s[i] + key[i % key_len]) & 0xff; 51 | t = ctx->s[j]; 52 | ctx->s[j] = ctx->s[i]; 53 | ctx->s[i] = t; 54 | } 55 | 56 | ctx->j = 0; 57 | ctx->i = 0; 58 | } 59 | 60 | dfsch_stream_cipher_t dfsch_crypto_rc4_cipher = { 61 | .type = { 62 | .type = DFSCH_STREAM_CIPHER_TYPE, 63 | .size = sizeof(rc4_context_t), 64 | .name = "crypto:rc4" 65 | }, 66 | .name = "RC4", 67 | 68 | .setup = rc4_setup, 69 | .encrypt_bytes = rc4_encrypt_bytes, 70 | }; 71 | 72 | static void rc4_setup_drop768(rc4_context_t* ctx, 73 | uint8_t* key, 74 | size_t key_len, 75 | uint8_t *nonce, 76 | size_t nonce_len){ 77 | int i; 78 | uint8_t buf[128]; 79 | rc4_setup(ctx, key, key_len, nonce, nonce_len); 80 | 81 | for (i = 0; i < 6; i++){ 82 | rc4_encrypt_bytes(ctx, buf, 128); 83 | } 84 | } 85 | 86 | static void rc4_setup_drop3072(rc4_context_t* ctx, 87 | uint8_t* key, 88 | size_t key_len, 89 | uint8_t *nonce, 90 | size_t nonce_len){ 91 | int i; 92 | uint8_t buf[128]; 93 | rc4_setup(ctx, key, key_len, nonce, nonce_len); 94 | 95 | for (i = 0; i < 24; i++){ 96 | rc4_encrypt_bytes(ctx, buf, 128); 97 | } 98 | } 99 | 100 | dfsch_stream_cipher_t dfsch_crypto_rc4_drop768_cipher = { 101 | .type = { 102 | .type = DFSCH_STREAM_CIPHER_TYPE, 103 | .size = sizeof(rc4_context_t), 104 | .name = "crypto:rc4-drop768" 105 | }, 106 | .name = "RC4", 107 | 108 | .setup = rc4_setup_drop768, 109 | .encrypt_bytes = rc4_encrypt_bytes, 110 | }; 111 | 112 | dfsch_stream_cipher_t dfsch_crypto_rc4_drop3072_cipher = { 113 | .type = { 114 | .type = DFSCH_STREAM_CIPHER_TYPE, 115 | .size = sizeof(rc4_context_t), 116 | .name = "crypto:rc4-drop3072" 117 | }, 118 | .name = "RC4", 119 | 120 | .setup = rc4_setup_drop3072, 121 | .encrypt_bytes = rc4_encrypt_bytes, 122 | }; 123 | -------------------------------------------------------------------------------- /lib/crypto/sc25519.c: -------------------------------------------------------------------------------- 1 | #include "sc25519.h" 2 | 3 | /*Arithmetic modulo the group order n = 2^252 + 27742317777372353535851937790883648493 = 7237005577332262213973186563042994240857116359379907606001950938285454250989 */ 4 | 5 | static const uint32_t m[32] = {0xED, 0xD3, 0xF5, 0x5C, 0x1A, 0x63, 0x12, 0x58, 0xD6, 0x9C, 0xF7, 0xA2, 0xDE, 0xF9, 0xDE, 0x14, 6 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x10}; 7 | 8 | static const uint32_t mu[33] = {0x1B, 0x13, 0x2C, 0x0A, 0xA3, 0xE5, 0x9C, 0xED, 0xA7, 0x29, 0x63, 0x08, 0x5D, 0x21, 0x06, 0x21, 9 | 0xEB, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0x0F}; 10 | 11 | /* Reduce coefficients of r before calling reduce_add_sub */ 12 | static void reduce_add_sub(sc25519 *r) 13 | { 14 | int i, b, pb=0, nb; 15 | unsigned char t[32]; 16 | 17 | for(i=0;i<32;i++) 18 | { 19 | b = (r->v[i]v[i]-pb-m[i]+b*256; 21 | pb = b; 22 | } 23 | nb = 1-b; 24 | for(i=0;i<32;i++) 25 | r->v[i] = r->v[i]*b + t[i]*nb; 26 | } 27 | 28 | /* Reduce coefficients of x before calling barrett_reduce */ 29 | static void barrett_reduce(sc25519 *r, const uint32_t x[64]) 30 | { 31 | /* See HAC, Alg. 14.42 */ 32 | int i,j; 33 | uint32_t q2[66] = {0}; 34 | uint32_t *q3 = q2 + 33; 35 | uint32_t r1[33]; 36 | uint32_t r2[33] = {0}; 37 | uint32_t carry; 38 | int b, pb=0; 39 | 40 | for(i=0;i<33;i++) 41 | for(j=0;j<33;j++) 42 | if(i+j >= 31) q2[i+j] += mu[i]*x[j+31]; 43 | carry = q2[31] >> 8; 44 | q2[32] += carry; 45 | carry = q2[32] >> 8; 46 | q2[33] += carry; 47 | 48 | for(i=0;i<33;i++)r1[i] = x[i]; 49 | for(i=0;i<32;i++) 50 | for(j=0;j<33;j++) 51 | if(i+j < 33) r2[i+j] += m[i]*q3[j]; 52 | 53 | for(i=0;i<32;i++) 54 | { 55 | carry = r2[i] >> 8; 56 | r2[i+1] += carry; 57 | r2[i] &= 0xff; 58 | } 59 | 60 | for(i=0;i<32;i++) 61 | { 62 | b = (r1[i]v[i] = r1[i]-pb-r2[i]+b*256; 64 | pb = b; 65 | } 66 | 67 | /* XXX: Can it really happen that r<0?, See HAC, Alg 14.42, Step 3 68 | * If so: Handle it here! 69 | */ 70 | 71 | reduce_add_sub(r); 72 | reduce_add_sub(r); 73 | } 74 | 75 | /* 76 | static int iszero(const sc25519 *x) 77 | { 78 | // Implement 79 | return 0; 80 | } 81 | */ 82 | 83 | void sc25519_from32bytes(sc25519 *r, const unsigned char x[32]) 84 | { 85 | int i; 86 | uint32_t t[64] = {0}; 87 | for(i=0;i<32;i++) t[i] = x[i]; 88 | barrett_reduce(r, t); 89 | } 90 | 91 | void sc25519_from64bytes(sc25519 *r, const unsigned char x[64]) 92 | { 93 | int i; 94 | uint32_t t[64] = {0}; 95 | for(i=0;i<64;i++) t[i] = x[i]; 96 | barrett_reduce(r, t); 97 | } 98 | 99 | /* XXX: What we actually want for crypto_group is probably just something like 100 | * void sc25519_frombytes(sc25519 *r, const unsigned char *x, size_t xlen) 101 | */ 102 | 103 | void sc25519_to32bytes(unsigned char r[32], const sc25519 *x) 104 | { 105 | int i; 106 | for(i=0;i<32;i++) r[i] = x->v[i]; 107 | } 108 | 109 | void sc25519_add(sc25519 *r, const sc25519 *x, const sc25519 *y) 110 | { 111 | int i, carry; 112 | for(i=0;i<32;i++) r->v[i] = x->v[i] + y->v[i]; 113 | for(i=0;i<31;i++) 114 | { 115 | carry = r->v[i] >> 8; 116 | r->v[i+1] += carry; 117 | r->v[i] &= 0xff; 118 | } 119 | reduce_add_sub(r); 120 | } 121 | 122 | void sc25519_mul(sc25519 *r, const sc25519 *x, const sc25519 *y) 123 | { 124 | int i,j,carry; 125 | uint32_t t[64]; 126 | for(i=0;i<64;i++)t[i] = 0; 127 | 128 | for(i=0;i<32;i++) 129 | for(j=0;j<32;j++) 130 | t[i+j] += x->v[i] * y->v[j]; 131 | 132 | /* Reduce coefficients */ 133 | for(i=0;i<63;i++) 134 | { 135 | carry = t[i] >> 8; 136 | t[i+1] += carry; 137 | t[i] &= 0xff; 138 | } 139 | 140 | barrett_reduce(r, t); 141 | } 142 | 143 | void sc25519_square(sc25519 *r, const sc25519 *x) 144 | { 145 | sc25519_mul(r, x, x); 146 | } 147 | -------------------------------------------------------------------------------- /lib/crypto/sc25519.h: -------------------------------------------------------------------------------- 1 | #ifndef SC25519_H 2 | #define SC25519_H 3 | 4 | #define sc25519 dfsch_crypto_sign_edwards25519sha512batch_sc25519 5 | #define sc25519_from32bytes dfsch_crypto_sign_edwards25519sha512batch_sc25519_from32bytes 6 | #define sc25519_from64bytes dfsch_crypto_sign_edwards25519sha512batch_sc25519_from64bytes 7 | #define sc25519_to32bytes dfsch_crypto_sign_edwards25519sha512batch_sc25519_to32bytes 8 | #define sc25519_pack dfsch_crypto_sign_edwards25519sha512batch_sc25519_pack 9 | #define sc25519_getparity dfsch_crypto_sign_edwards25519sha512batch_sc25519_getparity 10 | #define sc25519_setone dfsch_crypto_sign_edwards25519sha512batch_sc25519_setone 11 | #define sc25519_setzero dfsch_crypto_sign_edwards25519sha512batch_sc25519_setzero 12 | #define sc25519_neg dfsch_crypto_sign_edwards25519sha512batch_sc25519_neg 13 | #define sc25519_add dfsch_crypto_sign_edwards25519sha512batch_sc25519_add 14 | #define sc25519_sub dfsch_crypto_sign_edwards25519sha512batch_sc25519_sub 15 | #define sc25519_mul dfsch_crypto_sign_edwards25519sha512batch_sc25519_mul 16 | #define sc25519_square dfsch_crypto_sign_edwards25519sha512batch_sc25519_square 17 | #define sc25519_invert dfsch_crypto_sign_edwards25519sha512batch_sc25519_invert 18 | 19 | #include 20 | 21 | typedef struct { 22 | uint32_t v[32]; 23 | } sc25519; 24 | 25 | void sc25519_from32bytes(sc25519 *r, const unsigned char x[32]); 26 | 27 | void sc25519_from64bytes(sc25519 *r, const unsigned char x[64]); 28 | 29 | void sc25519_to32bytes(unsigned char r[32], const sc25519 *x); 30 | 31 | void sc25519_pack(unsigned char r[32], const sc25519 *x); 32 | 33 | unsigned char sc25519_getparity(const sc25519 *x); 34 | 35 | void sc25519_setone(sc25519 *r); 36 | 37 | void sc25519_setzero(sc25519 *r); 38 | 39 | void sc25519_neg(sc25519 *r, const sc25519 *x); 40 | 41 | void sc25519_add(sc25519 *r, const sc25519 *x, const sc25519 *y); 42 | 43 | void sc25519_sub(sc25519 *r, const sc25519 *x, const sc25519 *y); 44 | 45 | void sc25519_mul(sc25519 *r, const sc25519 *x, const sc25519 *y); 46 | 47 | void sc25519_square(sc25519 *r, const sc25519 *x); 48 | 49 | void sc25519_invert(sc25519 *r, const sc25519 *x); 50 | 51 | #endif 52 | -------------------------------------------------------------------------------- /lib/crypto/sha256-desc.c: -------------------------------------------------------------------------------- 1 | #include "dfsch/lib/crypto.h" 2 | #include 3 | 4 | void sha256_setup(dfsch_sha256_context_t * md, 5 | uint8_t* key, size_t keylen) 6 | { 7 | if (keylen != 0){ 8 | dfsch_error("SHA-512 is not keyed", NULL); 9 | } 10 | dfsch_sha256_setup(md); 11 | } 12 | 13 | dfsch_crypto_hash_t dfsch_crypto_sha256 = { 14 | .type = { 15 | .type = DFSCH_CRYPTO_HASH_TYPE, 16 | .name = "sha-256", 17 | .size = sizeof(dfsch_sha256_context_t), 18 | }, 19 | 20 | .name = "SHA-256", 21 | 22 | .block_len = 64, 23 | .result_len = 32, 24 | 25 | .setup = sha256_setup, 26 | .process = dfsch_sha256_process, 27 | .result = dfsch_sha256_result 28 | }; 29 | -------------------------------------------------------------------------------- /lib/crypto/xtea.c: -------------------------------------------------------------------------------- 1 | /* LibTomCrypt, modular cryptographic library -- Tom St Denis 2 | * 3 | * LibTomCrypt is a library that provides various cryptographic 4 | * algorithms in a highly modular and flexible manner. 5 | * 6 | * The library is free for all purposes without any express 7 | * guarantee it works. 8 | * 9 | * Tom St Denis, tomstdenis@gmail.com, http://libtom.org 10 | */ 11 | 12 | /** 13 | @file xtea.c 14 | Implementation of LTC_XTEA, Tom St Denis 15 | */ 16 | #include 17 | #include "macros.h" 18 | 19 | typedef struct xtea_key_t { 20 | dfsch_block_cipher_t* cipher; 21 | unsigned long A[32], B[32]; 22 | } xtea_key_t; 23 | 24 | static void xtea_setup(xtea_key_t* ctx, const unsigned char *key, int keylen) 25 | { 26 | unsigned long x, sum, K[4]; 27 | 28 | /* check arguments */ 29 | if (keylen != 16) { 30 | dfsch_error("Invalid key length", DFSCH_MAKE_FIXNUM(keylen)); 31 | } 32 | 33 | /* load key */ 34 | LOAD32L(K[0], key+0); 35 | LOAD32L(K[1], key+4); 36 | LOAD32L(K[2], key+8); 37 | LOAD32L(K[3], key+12); 38 | 39 | for (x = sum = 0; x < 32; x++) { 40 | ctx->A[x] = (sum + K[sum&3]) & 0xFFFFFFFFUL; 41 | sum = (sum + 0x9E3779B9UL) & 0xFFFFFFFFUL; 42 | ctx->B[x] = (sum + K[(sum>>11)&3]) & 0xFFFFFFFFUL; 43 | } 44 | } 45 | 46 | /** 47 | Encrypts a block of text with LTC_XTEA 48 | @param pt The input plaintext (8 bytes) 49 | @param ct The output ciphertext (8 bytes) 50 | @param skey The key as scheduled 51 | @return CRYPT_OK if successful 52 | */ 53 | static void xtea_encrypt(xtea_key_t* key, 54 | const unsigned char *pt, unsigned char *ct) 55 | { 56 | unsigned long y, z; 57 | int r; 58 | 59 | LOAD32L(y, &pt[0]); 60 | LOAD32L(z, &pt[4]); 61 | for (r = 0; r < 32; r += 4) { 62 | y = (y + ((((z<<4)^(z>>5)) + z) ^ key->A[r])) & 0xFFFFFFFFUL; 63 | z = (z + ((((y<<4)^(y>>5)) + y) ^ key->B[r])) & 0xFFFFFFFFUL; 64 | 65 | y = (y + ((((z<<4)^(z>>5)) + z) ^ key->A[r+1])) & 0xFFFFFFFFUL; 66 | z = (z + ((((y<<4)^(y>>5)) + y) ^ key->B[r+1])) & 0xFFFFFFFFUL; 67 | 68 | y = (y + ((((z<<4)^(z>>5)) + z) ^ key->A[r+2])) & 0xFFFFFFFFUL; 69 | z = (z + ((((y<<4)^(y>>5)) + y) ^ key->B[r+2])) & 0xFFFFFFFFUL; 70 | 71 | y = (y + ((((z<<4)^(z>>5)) + z) ^ key->A[r+3])) & 0xFFFFFFFFUL; 72 | z = (z + ((((y<<4)^(y>>5)) + y) ^ key->B[r+3])) & 0xFFFFFFFFUL; 73 | } 74 | STORE32L(y, &ct[0]); 75 | STORE32L(z, &ct[4]); 76 | } 77 | 78 | /** 79 | Decrypts a block of text with LTC_XTEA 80 | @param ct The input ciphertext (8 bytes) 81 | @param pt The output plaintext (8 bytes) 82 | @param skey The key as scheduled 83 | @return CRYPT_OK if successful 84 | */ 85 | static void xtea_decrypt(xtea_key_t* key, 86 | const unsigned char *ct, unsigned char *pt) 87 | { 88 | unsigned long y, z; 89 | int r; 90 | 91 | LOAD32L(y, &ct[0]); 92 | LOAD32L(z, &ct[4]); 93 | for (r = 31; r >= 0; r -= 4) { 94 | z = (z - ((((y<<4)^(y>>5)) + y) ^ key->B[r])) & 0xFFFFFFFFUL; 95 | y = (y - ((((z<<4)^(z>>5)) + z) ^ key->A[r])) & 0xFFFFFFFFUL; 96 | 97 | z = (z - ((((y<<4)^(y>>5)) + y) ^ key->B[r-1])) & 0xFFFFFFFFUL; 98 | y = (y - ((((z<<4)^(z>>5)) + z) ^ key->A[r-1])) & 0xFFFFFFFFUL; 99 | 100 | z = (z - ((((y<<4)^(y>>5)) + y) ^ key->B[r-2])) & 0xFFFFFFFFUL; 101 | y = (y - ((((z<<4)^(z>>5)) + z) ^ key->A[r-2])) & 0xFFFFFFFFUL; 102 | 103 | z = (z - ((((y<<4)^(y>>5)) + y) ^ key->B[r-3])) & 0xFFFFFFFFUL; 104 | y = (y - ((((z<<4)^(z>>5)) + z) ^ key->A[r-3])) & 0xFFFFFFFFUL; 105 | } 106 | STORE32L(y, &pt[0]); 107 | STORE32L(z, &pt[4]); 108 | } 109 | 110 | dfsch_block_cipher_t dfsch_crypto_xtea_cipher = { 111 | .type = { 112 | .type = DFSCH_BLOCK_CIPHER_TYPE, 113 | .name = "crypto:xtea", 114 | .size = sizeof(xtea_key_t) 115 | }, 116 | 117 | .name = "XTEA", 118 | 119 | .block_size = 8, 120 | 121 | .encrypt = xtea_encrypt, 122 | .decrypt = xtea_decrypt, 123 | .setup = xtea_setup 124 | }; 125 | 126 | -------------------------------------------------------------------------------- /lib/csv_mod.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | DFSCH_DEFINE_PRIMITIVE(read_line, 4 | "Read one line of CSV data into vector"){ 5 | dfsch_csv_params_t* params; 6 | dfsch_object_t* port; 7 | DFSCH_OBJECT_ARG(args, port); 8 | params = dfsch_csv_params(args); 9 | 10 | return dfsch_csv_read_line(port, params); 11 | } 12 | 13 | DFSCH_DEFINE_PRIMITIVE(read_port, 14 | "Read CSV file from port into list of vectors"){ 15 | dfsch_csv_params_t* params; 16 | dfsch_object_t* port; 17 | DFSCH_OBJECT_ARG(args, port); 18 | params = dfsch_csv_params(args); 19 | 20 | return dfsch_csv_read_file(port, params); 21 | } 22 | 23 | DFSCH_DEFINE_PRIMITIVE(read_file, 24 | "Read CSV file into list of vectors"){ 25 | dfsch_csv_params_t* params; 26 | char* filename; 27 | DFSCH_STRING_ARG(args, filename); 28 | params = dfsch_csv_params(args); 29 | 30 | return dfsch_csv_read_file(dfsch_open_file_port(filename, "r"), params); 31 | } 32 | 33 | void dfsch_module_csv_register(dfsch_object_t* env){ 34 | dfsch_package_t* csv = dfsch_make_package("csv", 35 | "CSV parser"); 36 | dfsch_provide(env, "csv"); 37 | 38 | dfsch_defcanon_pkgcstr(env, csv, "read-line", 39 | DFSCH_PRIMITIVE_REF(read_line)); 40 | dfsch_defcanon_pkgcstr(env, csv, "read-port", 41 | DFSCH_PRIMITIVE_REF(read_port)); 42 | dfsch_defcanon_pkgcstr(env, csv, "read-file", 43 | DFSCH_PRIMITIVE_REF(read_file)); 44 | } 45 | -------------------------------------------------------------------------------- /lib/curl_mod.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | DFSCH_DEFINE_PRIMITIVE(fetch, "Fetch contents of URL"){ 6 | char* url; 7 | CURL* handle = curl_easy_init(); 8 | dfsch_curl_options_context_t* ctx = dfsch_curl_make_options_context(); 9 | dfsch_strbuf_t* ret; 10 | DFSCH_UNWIND { 11 | DFSCH_STRING_ARG(args, url); 12 | 13 | curl_easy_setopt(handle, CURLOPT_URL, url); 14 | 15 | while (dfsch_pair_p(args)){ 16 | dfsch_object_t* name; 17 | dfsch_object_t* value; 18 | DFSCH_OBJECT_ARG(args, name); 19 | DFSCH_OBJECT_ARG(args, value); 20 | dfsch_curl_setopt(handle, name, value, ctx); 21 | } 22 | 23 | ret = dfsch_curl_perform(handle); 24 | } DFSCH_PROTECT { 25 | dfsch_curl_cleanup(handle, ctx); 26 | } DFSCH_PROTECT_END; 27 | 28 | return dfsch_make_byte_vector_nocopy(ret->ptr, ret->len); 29 | } 30 | 31 | void dfsch_module_curl_register(dfsch_object_t* env){ 32 | dfsch_package_t* curl = dfsch_make_package("curl", 33 | "CURL URL handling library"); 34 | 35 | dfsch_provide(env, "curl"); 36 | curl_global_init(CURL_GLOBAL_ALL); 37 | 38 | dfsch_defcanon_pkgcstr(env, curl, "fetch", DFSCH_PRIMITIVE_REF(fetch)); 39 | } 40 | -------------------------------------------------------------------------------- /lib/extref_mod.c: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - dfox's quick and dirty scheme implementation 3 | * External object references 4 | * Copyright (C) 2005-2008 Ales Hakl 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | * 20 | */ 21 | 22 | #include "dfsch/lib/extref.h" 23 | #include 24 | #include 25 | #include 26 | #include 27 | #include 28 | #include 29 | #include 30 | #include 31 | 32 | 33 | DFSCH_DEFINE_PRIMITIVE(extref_make, 0){ 34 | dfsch_object_t* object; 35 | time_t timeout; 36 | int mode = DFSCH_EXTREF_FROMNOW; 37 | 38 | DFSCH_OBJECT_ARG(args, object); 39 | DFSCH_LONG_ARG_OPT(args, timeout, 600); 40 | DFSCH_FLAG_PARSER_BEGIN_ONE_OPT(args, mode); 41 | DFSCH_FLAG_VALUE("fromnow", DFSCH_EXTREF_FROMNOW, mode); 42 | DFSCH_FLAG_VALUE("refresh", DFSCH_EXTREF_REFRESH, mode); 43 | DFSCH_FLAG_VALUE("onceonly", DFSCH_EXTREF_ONCEONLY, mode); 44 | DFSCH_FLAG_PARSER_END(args); 45 | DFSCH_ARG_END(args); 46 | 47 | return dfsch_make_string_cstr(dfsch_extref_create(object, timeout, mode)); 48 | } 49 | 50 | DFSCH_DEFINE_PRIMITIVE(extref_ref, 0){ 51 | char* handle; 52 | 53 | DFSCH_STRING_ARG(args, handle); 54 | DFSCH_ARG_END(args); 55 | 56 | return dfsch_extref_ref(handle); 57 | } 58 | 59 | dfsch_object_t* dfsch_module_extref_register(dfsch_object_t* env){ 60 | dfsch_package_t* extref = dfsch_make_package("extref", 61 | "Externalized reference support"); 62 | dfsch_provide(env, "extref"); 63 | 64 | dfsch_defcanon_pkgcstr(env, extref, "make-extref", 65 | DFSCH_PRIMITIVE_REF(extref_make)); 66 | dfsch_defcanon_pkgcstr(env, extref, "ref-extref", 67 | DFSCH_PRIMITIVE_REF(extref_ref)); 68 | return env; 69 | } 70 | -------------------------------------------------------------------------------- /lib/fastlz_mod.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "ext/fastlz/fastlz.h" 3 | 4 | DFSCH_DEFINE_PRIMITIVE(compress, 5 | "Compress string using FastLZ."){ 6 | dfsch_strbuf_t* str; 7 | char* res; 8 | size_t rlen; 9 | 10 | DFSCH_BUFFER_ARG(args, str); 11 | DFSCH_ARG_END(args); 12 | 13 | rlen = str->len + (str->len / 19); 14 | res = GC_MALLOC_ATOMIC(rlen); 15 | rlen = dfsch__fastlz_compress(str->ptr, str->len, res); 16 | if (rlen == 0){ 17 | dfsch_error("Internal error", NULL); 18 | } 19 | 20 | return dfsch_make_string_buf(res, rlen); 21 | } 22 | 23 | DFSCH_DEFINE_PRIMITIVE(uncompress, 24 | "Uncompress result of fastlz:compress."){ 25 | dfsch_strbuf_t* str; 26 | char* res; 27 | size_t rlen; 28 | int zres; 29 | 30 | DFSCH_BUFFER_ARG(args, str); 31 | DFSCH_ARG_END(args); 32 | 33 | rlen = str->len; 34 | 35 | do { 36 | rlen *= 4; 37 | res = GC_MALLOC_ATOMIC(rlen); 38 | zres = dfsch__fastlz_decompress(str->ptr, str->len, res, rlen); 39 | } while (zres == 0); 40 | 41 | return dfsch_make_string_buf(res, zres); 42 | } 43 | 44 | void dfsch_module_fastlz_register(dfsch_object_t* env){ 45 | dfsch_package_t* flz = 46 | dfsch_make_package("fastlz", 47 | "FastLZ compression and decompression"); 48 | dfsch_provide(env, "fastlz"); 49 | 50 | dfsch_defcanon_pkgcstr(env, flz, "compress", 51 | DFSCH_PRIMITIVE_REF(compress)); 52 | dfsch_defcanon_pkgcstr(env, flz, "uncompress", 53 | DFSCH_PRIMITIVE_REF(uncompress)); 54 | } 55 | -------------------------------------------------------------------------------- /lib/ffi_mod.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | DFSCH_DEFINE_PRIMITIVE(load_library, "Load shared library for use with FFI"){ 5 | char* filename; 6 | DFSCH_STRING_ARG(args, filename); 7 | DFSCH_ARG_END(args); 8 | 9 | return dfsch_ffi_load_library(filename); 10 | } 11 | 12 | DFSCH_DEFINE_PRIMITIVE(call, "Call function from shared library"){ 13 | dfsch_object_t* lib; 14 | char* fun_name; 15 | 16 | DFSCH_OBJECT_ARG(args, lib); 17 | DFSCH_STRING_ARG(args, fun_name); 18 | return dfsch_ffi_call(lib, fun_name, args); 19 | } 20 | 21 | DFSCH_DEFINE_PRIMITIVE(make_function, "Wrap function from shared library"){ 22 | dfsch_object_t* lib; 23 | char* fun_name; 24 | dfsch_object_t* return_type; 25 | 26 | DFSCH_OBJECT_ARG(args, lib); 27 | DFSCH_STRING_ARG(args, fun_name); 28 | DFSCH_OBJECT_ARG(args, return_type); 29 | return dfsch_ffi_make_function(lib, fun_name, return_type, args); 30 | } 31 | 32 | void dfsch_module_ffi_register(dfsch_object_t* env){ 33 | dfsch_package_t* ffi = dfsch_make_package("ffi", 34 | "Foreign function interface"); 35 | dfsch_provide(env, "ffi"); 36 | 37 | dfsch_defcanon_pkgcstr(env, ffi, "", 38 | DFSCH_FFI_LIBRARY_TYPE); 39 | dfsch_defcanon_pkgcstr(env, ffi, "", 40 | DFSCH_FFI_POINTER_TYPE); 41 | dfsch_defcanon_pkgcstr(env, ffi, "", 42 | DFSCH_FFI_FUNCTION_TYPE); 43 | 44 | dfsch_defcanon_pkgcstr(env, ffi, "load-library", 45 | DFSCH_PRIMITIVE_REF(load_library)); 46 | dfsch_defcanon_pkgcstr(env, ffi, "call", 47 | DFSCH_PRIMITIVE_REF(call)); 48 | dfsch_defcanon_pkgcstr(env, ffi, "make-function", 49 | DFSCH_PRIMITIVE_REF(make_function)); 50 | dfsch_defconst_pkgcstr(env, ffi, "*null*", 51 | dfsch_ffi_wrap_pointer(NULL)); 52 | } 53 | -------------------------------------------------------------------------------- /lib/gcollect.c: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - dfox's quick and dirty scheme implementation 3 | * Garbage collector state 4 | * Copyright (C) 2005-2008 Ales Hakl 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | * 20 | */ 21 | 22 | #include "dfsch/lib/gcollect.h" 23 | #include 24 | #include 25 | 26 | 27 | DFSCH_DEFINE_PRIMITIVE(gcollect, 0){ 28 | DFSCH_ARG_END(args); 29 | 30 | GC_gcollect(); 31 | 32 | return NULL; 33 | } 34 | 35 | DFSCH_DEFINE_PRIMITIVE(heap_size, 0){ 36 | DFSCH_ARG_END(args); 37 | 38 | return dfsch_make_number_from_long(GC_get_heap_size()); 39 | } 40 | 41 | DFSCH_DEFINE_PRIMITIVE(free_bytes, 0){ 42 | DFSCH_ARG_END(args); 43 | 44 | return dfsch_make_number_from_long(GC_get_free_bytes()); 45 | } 46 | 47 | DFSCH_DEFINE_PRIMITIVE(bytes_since_gc, 0){ 48 | DFSCH_ARG_END(args); 49 | 50 | return dfsch_make_number_from_long(GC_get_bytes_since_gc()); 51 | } 52 | 53 | DFSCH_DEFINE_PRIMITIVE(total_bytes, 0){ 54 | DFSCH_ARG_END(args); 55 | 56 | return dfsch_make_number_from_long(GC_get_total_bytes()); 57 | } 58 | 59 | 60 | DFSCH_DEFINE_PRIMITIVE(count, 0){ 61 | DFSCH_ARG_END(args); 62 | 63 | return dfsch_make_number_from_long(GC_gc_no); 64 | } 65 | 66 | DFSCH_DEFINE_PRIMITIVE(enable, 0){ 67 | DFSCH_ARG_END(args); 68 | GC_enable(); 69 | return NULL; 70 | } 71 | DFSCH_DEFINE_PRIMITIVE(disable, 0){ 72 | DFSCH_ARG_END(args); 73 | GC_disable(); 74 | return NULL; 75 | } 76 | 77 | dfsch_object_t* dfsch_module_gcollect_register(dfsch_object_t* env){ 78 | dfsch_provide(env, "gcollect"); 79 | 80 | dfsch_defcanon_cstr(env, "gc-collect!", 81 | DFSCH_PRIMITIVE_REF(gcollect)); 82 | dfsch_defcanon_cstr(env, "gc-heap-size", 83 | DFSCH_PRIMITIVE_REF(heap_size)); 84 | dfsch_defcanon_cstr(env, "gc-free-bytes", 85 | DFSCH_PRIMITIVE_REF(free_bytes)); 86 | dfsch_defcanon_cstr(env, "gc-bytes-since-gc", 87 | DFSCH_PRIMITIVE_REF(bytes_since_gc)); 88 | dfsch_defcanon_cstr(env, "gc-total-bytes", 89 | DFSCH_PRIMITIVE_REF(total_bytes)); 90 | dfsch_defcanon_cstr(env, "gc-count", 91 | DFSCH_PRIMITIVE_REF(count)); 92 | dfsch_defcanon_cstr(env, "gc-enable!", 93 | DFSCH_PRIMITIVE_REF(enable)); 94 | dfsch_defcanon_cstr(env, "gc-disable!", 95 | DFSCH_PRIMITIVE_REF(disable)); 96 | 97 | return NULL; 98 | } 99 | -------------------------------------------------------------------------------- /lib/gd.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | typedef struct gd_image_t { 4 | dfsch_type_t* type; 5 | gdImagePtr img; 6 | } gd_image_t; 7 | 8 | typedef struct gd_font_t { 9 | dfsch_type_t* type; 10 | gdFontPtr font; 11 | } gd_font_t; 12 | 13 | dfsch_type_t dfsch_gd_image_type = { 14 | .type = DFSCH_STANDARD_TYPE, 15 | .name = "gd:image", 16 | .size = sizeof(gd_image_t), 17 | }; 18 | 19 | dfsch_type_t dfsch_gd_font_type = { 20 | .type = DFSCH_STANDARD_TYPE, 21 | .name = "gd:font", 22 | .size = sizeof(gd_font_t), 23 | }; 24 | 25 | 26 | gdImagePtr dfsch_gd_image(dfsch_object_t* obj){ 27 | gd_image_t* i = DFSCH_ASSERT_TYPE(obj, DFSCH_GD_IMAGE_TYPE); 28 | return i->img; 29 | } 30 | 31 | static image_finalizer(gd_image_t* img, void* discard){ 32 | if (img->type == DFSCH_GD_IMAGE_TYPE){ 33 | gdImageDestroy(img->img); 34 | } 35 | } 36 | 37 | dfsch_object_t* dfsch_gd_cons_image(gdImagePtr img){ 38 | gd_image_t* i = dfsch_make_object(DFSCH_GD_IMAGE_TYPE); 39 | if (!img){ 40 | dfsch_error("Error creating GD image", NULL); 41 | } 42 | i->img = img; 43 | GC_REGISTER_FINALIZER(i, (GC_finalization_proc)image_finalizer, 44 | NULL, NULL, NULL); 45 | 46 | return i; 47 | } 48 | void dfsch_gd_destroy_image(dfsch_object_t* img){ 49 | gd_image_t* i = DFSCH_ASSERT_TYPE(img, DFSCH_GD_IMAGE_TYPE); 50 | gdImageDestroy(i->img); 51 | dfsch_invalidate_object(i); 52 | } 53 | 54 | gdFontPtr dfsch_gd_font(dfsch_object_t* obj){ 55 | gd_font_t* f = DFSCH_ASSERT_TYPE(obj, DFSCH_GD_FONT_TYPE); 56 | return f->font; 57 | } 58 | dfsch_object_t* dfsch_gd_cons_font(gdFontPtr font){ 59 | gd_font_t* f = dfsch_make_object(DFSCH_GD_FONT_TYPE); 60 | f->font = font; 61 | return f; 62 | } 63 | -------------------------------------------------------------------------------- /lib/json_mod.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | DFSCH_DEFINE_PRIMITIVE(parse_string, 5 | "Parse JSON object from string object"){ 6 | char* string; 7 | dfsch_object_t* multiple_objects; 8 | 9 | DFSCH_STRING_ARG(args, string); 10 | DFSCH_OBJECT_ARG_OPT(args, multiple_objects, NULL); 11 | DFSCH_ARG_END(args); 12 | 13 | return dfsch_json_parse_cstr(string, multiple_objects); 14 | } 15 | 16 | DFSCH_DEFINE_PRIMITIVE(parse_file, 17 | "Parse JSON object from file"){ 18 | char* file_name; 19 | dfsch_object_t* multiple_objects; 20 | 21 | DFSCH_STRING_ARG(args, file_name); 22 | DFSCH_OBJECT_ARG_OPT(args, multiple_objects, NULL); 23 | DFSCH_ARG_END(args); 24 | 25 | return dfsch_json_parse_file(file_name, multiple_objects); 26 | } 27 | DFSCH_DEFINE_PRIMITIVE(parse_port, 28 | "Parse JSON object from port"){ 29 | dfsch_object_t* port; 30 | dfsch_object_t* multiple_objects; 31 | 32 | DFSCH_OBJECT_ARG(args, port); 33 | DFSCH_OBJECT_ARG_OPT(args, multiple_objects, NULL); 34 | DFSCH_ARG_END(args); 35 | 36 | return dfsch_json_parse_port(port, multiple_objects); 37 | } 38 | 39 | DFSCH_DEFINE_PRIMITIVE(emit_string, 40 | "Serialize object into JSON string"){ 41 | dfsch_object_t* object; 42 | 43 | DFSCH_OBJECT_ARG(args, object); 44 | DFSCH_ARG_END(args); 45 | 46 | return dfsch_make_string_cstr(dfsch_json_emit_cstr(object)); 47 | } 48 | DFSCH_DEFINE_PRIMITIVE(emit_file, 49 | "Serialize object into new file"){ 50 | dfsch_object_t* object; 51 | char* filename; 52 | 53 | DFSCH_OBJECT_ARG(args, object); 54 | DFSCH_STRING_ARG(args, filename); 55 | DFSCH_ARG_END(args); 56 | 57 | dfsch_json_emit_file(object, filename); 58 | return NULL; 59 | } 60 | DFSCH_DEFINE_PRIMITIVE(emit_port, 61 | "Serialize object into port"){ 62 | dfsch_object_t* object; 63 | dfsch_object_t* port; 64 | 65 | DFSCH_OBJECT_ARG(args, object); 66 | DFSCH_OBJECT_ARG(args, port); 67 | DFSCH_ARG_END(args); 68 | 69 | dfsch_json_emit_port(object, port); 70 | return NULL; 71 | } 72 | 73 | 74 | void dfsch_module_json_register(dfsch_object_t* env){ 75 | dfsch_package_t* json_pkg = dfsch_make_package("json", 76 | "JSON input and output"); 77 | dfsch_provide(env, "json"); 78 | dfsch_defcanon_pkgcstr(env, json_pkg, "", DFSCH_JSON_PARSER_TYPE); 79 | 80 | dfsch_defcanon_pkgcstr(env, json_pkg, "parse-string", 81 | DFSCH_PRIMITIVE_REF(parse_string)); 82 | dfsch_defcanon_pkgcstr(env, json_pkg, "parse-file", 83 | DFSCH_PRIMITIVE_REF(parse_file)); 84 | dfsch_defcanon_pkgcstr(env, json_pkg, "parse-port", 85 | DFSCH_PRIMITIVE_REF(parse_port)); 86 | 87 | dfsch_defcanon_pkgcstr(env, json_pkg, "emit-string", 88 | DFSCH_PRIMITIVE_REF(emit_string)); 89 | 90 | } 91 | -------------------------------------------------------------------------------- /lib/minizip.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "ext/minizip/unzip.h" 3 | 4 | typedef struct minizip_t { 5 | dfsch_type_t* type; 6 | unzFile file; 7 | pthread_mutex_t* mutex; 8 | } minizip_t; 9 | 10 | static dfsch_object_t* mz_ref(minizip_t* mz, dfsch_object_t* name_obj){ 11 | char* name = dfsch_string_to_cstr(name_obj); 12 | int ret; 13 | unz_file_info64 info; 14 | dfsch_object_t* contents; 15 | char* buf; 16 | 17 | pthread_mutex_lock(mz->mutex); 18 | ret = unzLocateFile(mz->file, name, 1); /* Always case sensitive */ 19 | if (ret == UNZ_END_OF_LIST_OF_FILE){ 20 | pthread_mutex_unlock(mz->mutex); 21 | return DFSCH_INVALID_OBJECT; 22 | } 23 | 24 | unzGetCurrentFileInfo64(mz->file, &info, NULL, 0, NULL, 0, NULL, 0); 25 | 26 | if (unzOpenCurrentFile(mz->file) != UNZ_OK){ 27 | pthread_mutex_unlock(mz->mutex); 28 | dfsch_error("Error reading from archive", mz); 29 | } 30 | 31 | 32 | contents = dfsch_alloc_byte_vector(&buf, info.uncompressed_size); 33 | ret = unzReadCurrentFile(mz->file, buf, info.uncompressed_size); 34 | if (ret != info.uncompressed_size){ 35 | unzCloseCurrentFile(mz->file); 36 | pthread_mutex_unlock(mz->mutex); 37 | dfsch_error("Error reading from archive", mz); 38 | } 39 | 40 | ret = unzCloseCurrentFile(mz->file); 41 | pthread_mutex_unlock(mz->mutex); 42 | if (ret == UNZ_CRCERROR){ 43 | dfsch_error("CRC error", mz); 44 | } else if (ret != UNZ_OK){ 45 | dfsch_error("Error reading from archive", mz); 46 | } 47 | 48 | return contents; 49 | } 50 | 51 | static dfsch_object_t* mz_get_keys(minizip_t* mz){ 52 | dfsch_object_t* list = NULL; 53 | unz_file_info64 info; 54 | char* buf; 55 | int ret; 56 | 57 | pthread_mutex_lock(mz->mutex); 58 | if (unzGoToFirstFile(mz->file) != UNZ_OK){ 59 | pthread_mutex_unlock(mz->mutex); 60 | dfsch_error("Error reading from archive", mz); 61 | } 62 | 63 | do { 64 | unzGetCurrentFileInfo(mz->file, &info, NULL, 0, NULL, 0, NULL, 0); 65 | buf = GC_MALLOC_ATOMIC(info.size_filename + 1); 66 | unzGetCurrentFileInfo(mz->file, &info, buf, info.size_filename + 1, 67 | NULL, 0, NULL, 0); 68 | 69 | list = dfsch_cons(dfsch_make_string_cstr(buf), list); 70 | 71 | ret = unzGoToNextFile(mz->file); 72 | } while (ret == UNZ_OK); 73 | pthread_mutex_unlock(mz->mutex); 74 | 75 | if (ret != UNZ_END_OF_LIST_OF_FILE){ 76 | dfsch_error("Error reading from archive", mz); 77 | } 78 | 79 | return list; 80 | } 81 | 82 | static dfsch_mapping_methods_t mz_map = { 83 | .ref = mz_ref, 84 | .get_keys_iterator = mz_get_keys, 85 | }; 86 | 87 | dfsch_type_t dfsch_minizip_type = { 88 | .type = DFSCH_STANDARD_TYPE, 89 | .name = "minizip", 90 | .size = sizeof(minizip_t), 91 | .documentation = "ZIP file as a mapping", 92 | .mapping = &mz_map 93 | }; 94 | 95 | static void mz_finalizer(minizip_t* mz, void* discard){ 96 | unzClose(mz->file); 97 | } 98 | 99 | dfsch_object_t* dfsch_minizip_open(char* filename){ 100 | minizip_t* mz = dfsch_make_object(DFSCH_MINIZIP_TYPE); 101 | 102 | mz->file = unzOpen64(filename); 103 | 104 | if (!mz->file){ 105 | dfsch_error("Cannot open zip file", dfsch_make_string_cstr(filename)); 106 | } 107 | 108 | GC_register_finalizer(mz, (GC_finalization_proc)mz_finalizer, NULL, 109 | NULL, NULL); 110 | mz->mutex = dfsch_create_finalized_mutex(); 111 | 112 | return (dfsch_object_t*)mz; 113 | } 114 | -------------------------------------------------------------------------------- /lib/minizip_mod.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | DFSCH_DEFINE_PRIMITIVE(open, "Open zip file for reading" 5 | DFSCH_DOC_SYNOPSIS("(filename)")){ 6 | char* filename; 7 | DFSCH_STRING_ARG(args, filename); 8 | DFSCH_ARG_END(args); 9 | 10 | return dfsch_minizip_open(filename); 11 | } 12 | 13 | void dfsch_module_minizip_register(dfsch_object_t* env){ 14 | dfsch_package_t* minizip = dfsch_make_package("minizip", 15 | "Simple ZIP file handling"); 16 | dfsch_provide(env, "minizip"); 17 | dfsch_defcanon_pkgcstr(env, minizip, "", DFSCH_MINIZIP_TYPE); 18 | dfsch_defcanon_pkgcstr(env, minizip, "open", 19 | DFSCH_PRIMITIVE_REF(open)); 20 | } 21 | -------------------------------------------------------------------------------- /lib/process_mod.c: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - Scheme-like Lisp dialect 3 | * Sub-process handling 4 | * Copyright (C) 2009 Ales Hakl 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | * 20 | */ 21 | 22 | #include "dfsch/lib/process.h" 23 | #include 24 | #include 25 | 26 | DFSCH_DEFINE_PRIMITIVE(spawn, NULL){ 27 | char* cmd_line; 28 | int r; 29 | DFSCH_STRING_ARG(args, cmd_line); 30 | DFSCH_ARG_END(args); 31 | 32 | r = system(cmd_line); 33 | 34 | if (r == -1){ 35 | dfsch_error("Cannot spawn process", 36 | dfsch_make_string_cstr(strerror(errno))); 37 | } 38 | return DFSCH_MAKE_FIXNUM(r); 39 | } 40 | 41 | DFSCH_DEFINE_PRIMITIVE(spawn_with_input_port, NULL){ 42 | char* cmd_line; 43 | DFSCH_STRING_ARG(args, cmd_line); 44 | DFSCH_ARG_END(args); 45 | return dfsch_process_spawn_with_input_port(cmd_line); 46 | } 47 | DFSCH_DEFINE_PRIMITIVE(spawn_with_output_port, NULL){ 48 | char* cmd_line; 49 | DFSCH_STRING_ARG(args, cmd_line); 50 | DFSCH_ARG_END(args); 51 | return dfsch_process_spawn_with_output_port(cmd_line); 52 | } 53 | 54 | DFSCH_DEFINE_PRIMITIVE(close_port, NULL){ 55 | dfsch_object_t* port; 56 | DFSCH_OBJECT_ARG(args, port); 57 | DFSCH_ARG_END(args); 58 | 59 | return dfsch_process_close_port(port); 60 | } 61 | 62 | 63 | dfsch_object_t* dfsch_module_process_register(dfsch_object_t *ctx){ 64 | dfsch_defcanon_cstr(ctx, "", 65 | DFSCH_PROCESS_PORT_TYPE); 66 | dfsch_defcanon_cstr(ctx, "", 67 | DFSCH_PROCESS_INPUT_PORT_TYPE); 68 | dfsch_defcanon_cstr(ctx, "", 69 | DFSCH_PROCESS_OUTPUT_PORT_TYPE); 70 | 71 | dfsch_defcanon_cstr(ctx, "spawn-process!", 72 | DFSCH_PRIMITIVE_REF(spawn)); 73 | dfsch_defcanon_cstr(ctx, "spawn-process-with-input-port!", 74 | DFSCH_PRIMITIVE_REF(spawn_with_input_port)); 75 | dfsch_defcanon_cstr(ctx, "spawn-process-with-output-port!", 76 | DFSCH_PRIMITIVE_REF(spawn_with_output_port)); 77 | dfsch_defcanon_cstr(ctx, "close-process-port!", 78 | DFSCH_PRIMITIVE_REF(close_port)); 79 | } 80 | -------------------------------------------------------------------------------- /lib/random.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/adh/dfsch/0b54da0f392485754d587e3f678219ad07991733/lib/random.c -------------------------------------------------------------------------------- /lib/shtml_mod.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | DFSCH_DEFINE_PRIMITIVE(emit_string, 0){ 5 | dfsch_object_t* params; 6 | dfsch_object_t* infoset; 7 | dfsch_shtml_emitter_params_t* p; 8 | DFSCH_OBJECT_ARG(args, infoset); 9 | DFSCH_ARG_REST(args, params); 10 | p = dfsch_shtml_emitter_params(params); 11 | 12 | return dfsch_make_string_cstr(dfsch_shtml_emit_cstr(infoset, p)); 13 | } 14 | DFSCH_DEFINE_PRIMITIVE(emit_file, 0){ 15 | dfsch_object_t* params; 16 | dfsch_object_t* infoset; 17 | char* filename; 18 | dfsch_shtml_emitter_params_t* p; 19 | DFSCH_OBJECT_ARG(args, infoset); 20 | DFSCH_STRING_ARG(args, filename); 21 | DFSCH_ARG_REST(args, params); 22 | p = dfsch_shtml_emitter_params(params); 23 | 24 | dfsch_shtml_emit_file(infoset, filename, p); 25 | return NULL; 26 | } 27 | DFSCH_DEFINE_PRIMITIVE(emit_port, 0){ 28 | dfsch_object_t* params; 29 | dfsch_object_t* infoset; 30 | dfsch_object_t* port; 31 | dfsch_shtml_emitter_params_t* p; 32 | DFSCH_OBJECT_ARG(args, infoset); 33 | DFSCH_OBJECT_ARG(args, port); 34 | DFSCH_ARG_REST(args, params); 35 | p = dfsch_shtml_emitter_params(params); 36 | 37 | dfsch_shtml_emit_port(infoset, port, p); 38 | return NULL; 39 | } 40 | 41 | void dfsch_module_shtml_register(dfsch_object_t* env){ 42 | dfsch_package_t* xml_pkg = dfsch_make_package("shtml", 43 | "HTML5 output support"); 44 | dfsch_provide(env, "shtml"); 45 | dfsch_defcanon_pkgcstr(env, xml_pkg, "emit-string", 46 | DFSCH_PRIMITIVE_REF(emit_string)); 47 | dfsch_defcanon_pkgcstr(env, xml_pkg, "emit-file", 48 | DFSCH_PRIMITIVE_REF(emit_file)); 49 | dfsch_defcanon_pkgcstr(env, xml_pkg, "emit-port", 50 | DFSCH_PRIMITIVE_REF(emit_port)); 51 | } 52 | -------------------------------------------------------------------------------- /lib/socket-port_mod.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | DFSCH_DEFINE_PRIMITIVE(tcp_connect, NULL){ 4 | char* hostname; 5 | char* service; 6 | 7 | DFSCH_STRING_ARG(args, hostname); 8 | DFSCH_STRING_ARG(args, service); 9 | DFSCH_ARG_END(args); 10 | 11 | return dfsch_socket_port_tcp_connect(hostname, service); 12 | } 13 | 14 | DFSCH_DEFINE_PRIMITIVE(tcp_bind, NULL){ 15 | char* hostname; 16 | char* service; 17 | 18 | DFSCH_STRING_ARG(args, hostname); 19 | DFSCH_STRING_ARG(args, service); 20 | DFSCH_ARG_END(args); 21 | 22 | return dfsch_server_socket_tcp_bind(hostname, service); 23 | } 24 | 25 | DFSCH_DEFINE_PRIMITIVE(unix_connect, NULL){ 26 | char* path; 27 | 28 | DFSCH_STRING_ARG(args, path); 29 | DFSCH_ARG_END(args); 30 | 31 | return dfsch_socket_port_unix_connect(path); 32 | } 33 | 34 | DFSCH_DEFINE_PRIMITIVE(unix_bind, NULL){ 35 | char* path; 36 | 37 | DFSCH_STRING_ARG(args, path); 38 | DFSCH_ARG_END(args); 39 | 40 | return dfsch_server_socket_unix_bind(path); 41 | } 42 | 43 | DFSCH_DEFINE_PRIMITIVE(server_socket_accept, NULL){ 44 | dfsch_object_t* server_socket; 45 | DFSCH_OBJECT_ARG(args, server_socket); 46 | DFSCH_ARG_END(args); 47 | 48 | return dfsch_server_socket_accept(server_socket); 49 | } 50 | 51 | DFSCH_DEFINE_PRIMITIVE(socket_port_close, NULL){ 52 | dfsch_object_t* socket_port; 53 | DFSCH_OBJECT_ARG(args, socket_port); 54 | DFSCH_ARG_END(args); 55 | 56 | dfsch_socket_port_close(socket_port); 57 | return NULL; 58 | } 59 | DFSCH_DEFINE_PRIMITIVE(server_socket_close, NULL){ 60 | dfsch_object_t* server_socket; 61 | DFSCH_OBJECT_ARG(args, server_socket); 62 | DFSCH_ARG_END(args); 63 | 64 | dfsch_server_socket_close(server_socket); 65 | return NULL; 66 | } 67 | 68 | static void apply_one(dfsch_object_t* proc, dfsch_object_t* arg){ 69 | dfsch_apply(proc, dfsch_cons(arg, NULL)); 70 | } 71 | 72 | DFSCH_DEFINE_PRIMITIVE(server_socket_run_accept_loop, NULL){ 73 | dfsch_object_t* server_socket; 74 | dfsch_object_t* client_proc; 75 | DFSCH_OBJECT_ARG(args, server_socket); 76 | DFSCH_OBJECT_ARG(args, client_proc); 77 | DFSCH_ARG_END(args); 78 | 79 | dfsch_server_socket_run_accept_loop(server_socket, apply_one, client_proc); 80 | return NULL; 81 | } 82 | 83 | 84 | void dfsch_module_socket_port_register(dfsch_object_t* env){ 85 | dfsch_provide(env, "socket-port"); 86 | 87 | dfsch_defcanon_cstr(env, "", DFSCH_SOCKET_PORT_TYPE); 88 | dfsch_defcanon_cstr(env, "", DFSCH_SERVER_SOCKET_TYPE); 89 | dfsch_defcanon_cstr(env, "tcp-connect", DFSCH_PRIMITIVE_REF(tcp_connect)); 90 | dfsch_defcanon_cstr(env, "tcp-bind", DFSCH_PRIMITIVE_REF(tcp_bind)); 91 | 92 | dfsch_defcanon_cstr(env, "unix-connect", DFSCH_PRIMITIVE_REF(unix_connect)); 93 | dfsch_defcanon_cstr(env, "unix-bind", DFSCH_PRIMITIVE_REF(unix_bind)); 94 | 95 | dfsch_defcanon_cstr(env, "server-socket-accept", 96 | DFSCH_PRIMITIVE_REF(server_socket_accept)); 97 | dfsch_defcanon_cstr(env, "server-socket-close!", 98 | DFSCH_PRIMITIVE_REF(server_socket_close)); 99 | dfsch_defcanon_cstr(env, "socket-port-close!", 100 | DFSCH_PRIMITIVE_REF(socket_port_close)); 101 | 102 | dfsch_defcanon_cstr(env, "server-socket-run-accept-loop", 103 | DFSCH_PRIMITIVE_REF(server_socket_run_accept_loop)); 104 | } 105 | -------------------------------------------------------------------------------- /lib/sql/sql-support.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | DFSCH_DEFINE_PRIMITIVE(escape_string, 5 | "Escape SQL string literal"){ 6 | dfsch_strbuf_t* string; 7 | size_t res_len = 0; 8 | dfsch_object_t* res; 9 | char* obuf; 10 | size_t i; 11 | DFSCH_BUFFER_ARG(args, string); 12 | DFSCH_ARG_END(args); 13 | 14 | for (i = 0; i < string->len; i++){ 15 | if (string->ptr[i] == '\''){ 16 | res_len += 2; 17 | } else { 18 | res_len++; 19 | } 20 | } 21 | 22 | res = dfsch_make_string_for_write(res_len + 2, &obuf); 23 | *obuf = '\''; 24 | obuf++; 25 | for (i = 0; i < string->len; i++){ 26 | *obuf = string->ptr[i]; 27 | obuf++; 28 | if (string->ptr[i] == '\''){ 29 | *obuf = string->ptr[i]; 30 | obuf++; 31 | } 32 | } 33 | *obuf = '\''; 34 | obuf++; 35 | *obuf = '\0'; 36 | return res; 37 | } 38 | 39 | void dfsch_module_sql_support_register(dfsch_object_t* env){ 40 | dfsch_package_t* sql_support = dfsch_make_package("sql-support", 41 | "Native code for SQL " 42 | "support"); 43 | dfsch_provide(env, "sql-support"); 44 | dfsch_defcanon_pkgcstr(env, sql_support, "escape-string", 45 | DFSCH_PRIMITIVE_REF(escape_string)); 46 | } 47 | -------------------------------------------------------------------------------- /lib/sxml_mod.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | DFSCH_DEFINE_PRIMITIVE(parse_string, 0){ 5 | dfsch_strbuf_t* string; 6 | dfsch_object_t* params; 7 | DFSCH_BUFFER_ARG(args, string); 8 | DFSCH_ARG_REST(args, params); 9 | 10 | return dfsch_sxml_parse_strbuf(string, 11 | dfsch_sxml_parser_params(params)); 12 | } 13 | DFSCH_DEFINE_PRIMITIVE(parse_file, 0){ 14 | char* filename; 15 | dfsch_object_t* params; 16 | DFSCH_STRING_ARG(args, filename); 17 | DFSCH_ARG_REST(args, params); 18 | 19 | return dfsch_sxml_parse_file(filename, 20 | dfsch_sxml_parser_params(params)); 21 | } 22 | DFSCH_DEFINE_PRIMITIVE(parse_port, 0){ 23 | dfsch_object_t* port; 24 | dfsch_object_t* params; 25 | DFSCH_OBJECT_ARG(args, port); 26 | DFSCH_ARG_REST(args, params); 27 | 28 | return dfsch_sxml_parse_port(port, 29 | dfsch_sxml_parser_params(params)); 30 | } 31 | 32 | 33 | DFSCH_DEFINE_PRIMITIVE(emit_string, 0){ 34 | dfsch_object_t* params; 35 | dfsch_object_t* infoset; 36 | dfsch_sxml_emitter_params_t* p; 37 | DFSCH_OBJECT_ARG(args, infoset); 38 | DFSCH_ARG_REST(args, params); 39 | p = dfsch_sxml_emitter_params(params); 40 | 41 | return dfsch_make_string_cstr(dfsch_sxml_emit_cstr(infoset, p)); 42 | } 43 | DFSCH_DEFINE_PRIMITIVE(emit_file, 0){ 44 | dfsch_object_t* params; 45 | dfsch_object_t* infoset; 46 | char* filename; 47 | dfsch_sxml_emitter_params_t* p; 48 | DFSCH_OBJECT_ARG(args, infoset); 49 | DFSCH_STRING_ARG(args, filename); 50 | DFSCH_ARG_REST(args, params); 51 | p = dfsch_sxml_emitter_params(params); 52 | 53 | dfsch_sxml_emit_file(infoset, filename, p); 54 | return NULL; 55 | } 56 | DFSCH_DEFINE_PRIMITIVE(emit_port, 0){ 57 | dfsch_object_t* params; 58 | dfsch_object_t* infoset; 59 | dfsch_object_t* port; 60 | dfsch_sxml_emitter_params_t* p; 61 | DFSCH_OBJECT_ARG(args, infoset); 62 | DFSCH_OBJECT_ARG(args, port); 63 | DFSCH_ARG_REST(args, params); 64 | p = dfsch_sxml_emitter_params(params); 65 | 66 | dfsch_sxml_emit_port(infoset, port, p); 67 | return NULL; 68 | } 69 | 70 | void dfsch_module_sxml_register(dfsch_object_t* env){ 71 | dfsch_package_t* xml_pkg = dfsch_make_package("xml", 72 | "XML support"); 73 | dfsch_provide(env, "sxml"); 74 | dfsch_defcanon_pkgcstr(env, xml_pkg, "sxml-parse-string", 75 | DFSCH_PRIMITIVE_REF(parse_string)); 76 | dfsch_defcanon_pkgcstr(env, xml_pkg, "sxml-parse-file", 77 | DFSCH_PRIMITIVE_REF(parse_file)); 78 | dfsch_defcanon_pkgcstr(env, xml_pkg, "sxml-parse-port", 79 | DFSCH_PRIMITIVE_REF(parse_port)); 80 | dfsch_defcanon_pkgcstr(env, xml_pkg, "sxml-emit-string", 81 | DFSCH_PRIMITIVE_REF(emit_string)); 82 | dfsch_defcanon_pkgcstr(env, xml_pkg, "sxml-emit-file", 83 | DFSCH_PRIMITIVE_REF(emit_file)); 84 | dfsch_defcanon_pkgcstr(env, xml_pkg, "sxml-emit-port", 85 | DFSCH_PRIMITIVE_REF(emit_port)); 86 | } 87 | -------------------------------------------------------------------------------- /lib/zlib_mod.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "zlib.h" 3 | 4 | DFSCH_DEFINE_PRIMITIVE(compress, 5 | "Compress string using DEFLATE."){ 6 | dfsch_strbuf_t* str; 7 | char* res; 8 | size_t rlen; 9 | 10 | DFSCH_BUFFER_ARG(args, str); 11 | DFSCH_ARG_END(args); 12 | 13 | rlen = compressBound(str->len); 14 | res = GC_MALLOC_ATOMIC(rlen); 15 | if (compress(res, &rlen, str->ptr, str->len) != Z_OK){ 16 | dfsch_error("Internal error", NULL); 17 | } 18 | 19 | return dfsch_make_string_buf(res, rlen); 20 | } 21 | 22 | DFSCH_DEFINE_PRIMITIVE(uncompress, 23 | "Uncompress result of zlib:compress."){ 24 | dfsch_strbuf_t* str; 25 | char* res; 26 | size_t rlen; 27 | int zres; 28 | 29 | DFSCH_BUFFER_ARG(args, str); 30 | DFSCH_ARG_END(args); 31 | 32 | rlen = str->len; 33 | 34 | do { 35 | rlen *= 4; 36 | res = GC_MALLOC_ATOMIC(rlen); 37 | zres = uncompress(res, &rlen, str->ptr, str->len); 38 | if (zres == Z_DATA_ERROR){ 39 | dfsch_error("Internal error", NULL); 40 | } 41 | } while (zres != Z_OK); 42 | 43 | return dfsch_make_string_buf(res, rlen); 44 | } 45 | 46 | DFSCH_DEFINE_PRIMITIVE(gzip_open_for_input, 47 | "Open gzip compressed file for reading"){ 48 | char* filename; 49 | DFSCH_STRING_ARG(args, filename); 50 | DFSCH_ARG_END(args); 51 | 52 | return dfsch_gzip_open_for_input(filename); 53 | } 54 | DFSCH_DEFINE_PRIMITIVE(gzip_open_for_output, 55 | "Open gzip compressed file for writing"){ 56 | char* filename; 57 | DFSCH_STRING_ARG(args, filename); 58 | DFSCH_ARG_END(args); 59 | 60 | return dfsch_gzip_open_for_output(filename); 61 | } 62 | DFSCH_DEFINE_PRIMITIVE(gzip_open_for_append, 63 | "Open gzip compressed file for appending"){ 64 | char* filename; 65 | DFSCH_STRING_ARG(args, filename); 66 | DFSCH_ARG_END(args); 67 | 68 | return dfsch_gzip_open_for_append(filename); 69 | } 70 | 71 | void dfsch_module_zlib_register(dfsch_object_t* env){ 72 | dfsch_package_t* zlib = dfsch_make_package("zlib", 73 | "Zlib and gzip support"); 74 | dfsch_provide(env, "zlib"); 75 | 76 | dfsch_defcanon_pkgcstr(env, zlib, "compress", 77 | DFSCH_PRIMITIVE_REF(compress)); 78 | dfsch_defcanon_pkgcstr(env, zlib, "uncompress", 79 | DFSCH_PRIMITIVE_REF(uncompress)); 80 | 81 | dfsch_defcanon_pkgcstr(env, zlib, "gzip-open-for-input", 82 | DFSCH_PRIMITIVE_REF(gzip_open_for_input)); 83 | dfsch_defcanon_pkgcstr(env, zlib, "gzip-open-for-output", 84 | DFSCH_PRIMITIVE_REF(gzip_open_for_output)); 85 | dfsch_defcanon_pkgcstr(env, zlib, "gzip-open-for-append", 86 | DFSCH_PRIMITIVE_REF(gzip_open_for_append)); 87 | } 88 | -------------------------------------------------------------------------------- /make-version-h.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | if [ -f "$1" ]; then 4 | REV=`cat "$1"` 5 | else 6 | REV=snapshot 7 | if git rev-parse --verify HEAD >/dev/null 2>&1; then 8 | REV=`git describe` 9 | fi 10 | fi 11 | 12 | echo "#define BUILD_ID \"$REV\"" > version.h 13 | -------------------------------------------------------------------------------- /src/native_cxr.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "util.h" 3 | #include "internal.h" 4 | 5 | static char *cxr_table[][2] = { 6 | {"caar", "aa"}, 7 | {"cadr", "da"}, 8 | {"cdar", "ad"}, 9 | {"cddr", "dd"}, 10 | 11 | {"caaar", "aaa"}, 12 | {"caadr", "daa"}, 13 | {"cadar", "ada"}, 14 | {"caddr", "dda"}, 15 | {"cdaar", "aad"}, 16 | {"cdadr", "dad"}, 17 | {"cddar", "add"}, 18 | {"cdddr", "ddd"}, 19 | 20 | {"caaaar", "aaaa"}, 21 | {"caaadr", "daaa"}, 22 | {"caadar", "adaa"}, 23 | {"caaddr", "ddaa"}, 24 | {"cadaar", "aada"}, 25 | {"cadadr", "dada"}, 26 | {"caddar", "adda"}, 27 | {"cadddr", "ddda"}, 28 | {"cdaaar", "aaad"}, 29 | {"cdaadr", "daad"}, 30 | {"cdadar", "adad"}, 31 | {"cdaddr", "ddad"}, 32 | {"cddaar", "aadd"}, 33 | {"cddadr", "dadd"}, 34 | {"cdddar", "addd"}, 35 | {"cddddr", "dddd"}, 36 | 37 | }; 38 | 39 | DFSCH_PRIMITIVE_HEAD(cxr){ 40 | dfsch_object_t* pair; 41 | char* action = (char*) baton; 42 | 43 | DFSCH_OBJECT_ARG(args, pair); 44 | DFSCH_ARG_END(args); 45 | 46 | while(*action){ 47 | if ((*action) == 'a'){ 48 | pair = dfsch_car(pair); 49 | } else { 50 | pair = dfsch_cdr(pair); 51 | } 52 | action++; 53 | } 54 | 55 | return pair; 56 | } 57 | 58 | static char* build_doc(char* name){ 59 | str_list_t* sl = sl_create(); 60 | name++; 61 | sl_append(sl, "Return "); 62 | 63 | while (*name){ 64 | switch (*name){ 65 | case 'a': 66 | sl_append(sl, "car of "); 67 | break; 68 | case 'd': 69 | sl_append(sl, "cdr of "); 70 | break; 71 | } 72 | name++; 73 | } 74 | sl_append(sl, "argument"); 75 | 76 | return sl_value(sl); 77 | } 78 | 79 | void dfsch__native_cxr_register(dfsch_object_t *ctx){ 80 | int i; 81 | 82 | for (i=0; i < (sizeof(cxr_table)/sizeof(cxr_table[0])); i++){ 83 | dfsch_defcanon_cstr(ctx, cxr_table[i][0], 84 | DFSCH_PRIMITIVE_REF_MAKE(cxr, cxr_table[i][1], 85 | build_doc(cxr_table[i][0]))); 86 | 87 | } 88 | 89 | } 90 | -------------------------------------------------------------------------------- /src/types.h: -------------------------------------------------------------------------------- 1 | #ifndef H__dfsch__types__2__ 2 | #define H__dfsch__types__2__ 3 | 4 | #include 5 | #include 6 | #include 7 | 8 | typedef dfsch_object_t object_t; 9 | 10 | typedef dfsch__symbol_t symbol_t; 11 | 12 | typedef dfsch_primitive_t primitive_t; 13 | 14 | #define LL_FLAG_ALLOW_OTHER_KEYS 1 15 | #define LL_FLAG_REST_IS_BODY 2 16 | 17 | typedef struct lambda_list_t { 18 | dfsch_type_t* type; 19 | uint16_t flags; 20 | uint16_t positional_count; 21 | uint16_t keyword_count; 22 | uint16_t optional_count; 23 | dfsch_object_t* rest; 24 | dfsch_object_t* all; 25 | dfsch_object_t** defaults; 26 | dfsch_object_t** supplied_p; 27 | dfsch_object_t** keywords; 28 | dfsch_object_t* aux_list; 29 | dfsch_object_t* arg_list[]; 30 | } lambda_list_t; 31 | 32 | 33 | typedef struct vector_t { 34 | dfsch_type_t* type; 35 | size_t length; 36 | object_t* data[]; 37 | } vector_t; 38 | 39 | typedef dfsch_macro_t macro_t; 40 | 41 | //#define ENV_CONSTANT_FLAG 1 42 | 43 | typedef struct environment_t environment_t; 44 | 45 | #define EFRAME_RETAIN 1 46 | #define EFRAME_SERIAL_MASK 0x7ff0000 47 | #define EFRAME_SERIAL_INCR 0x0010000 48 | 49 | struct environment_t { 50 | dfsch_type_t* type; 51 | environment_t* parent; 52 | dfsch__thread_info_t* owner; 53 | dfsch_eqhash_t values; 54 | dfsch_hash_t* decls; 55 | dfsch_object_t* context; 56 | int flags; 57 | }; 58 | 59 | typedef struct closure_t{ 60 | dfsch_type_t* type; 61 | lambda_list_t* args; 62 | object_t* code; 63 | environment_t* env; 64 | object_t* name; 65 | object_t* orig_code; 66 | dfsch_object_t* orig_args; 67 | object_t* documentation; 68 | int compiled; 69 | int call_count; 70 | } closure_t; 71 | 72 | struct dfsch__stack_frame_t { 73 | dfsch_object_t* procedure; 74 | dfsch_object_t* arguments; 75 | int tail_recursive; 76 | 77 | dfsch_object_t* code; 78 | dfsch_object_t* env; 79 | dfsch_object_t* expr; 80 | 81 | dfsch__stack_frame_t* next; 82 | }; 83 | 84 | 85 | #endif 86 | -------------------------------------------------------------------------------- /src/util.h: -------------------------------------------------------------------------------- 1 | /* 2 | * dfsch - dfox's quick and dirty scheme implementation 3 | * Utility functions 4 | * Copyright (C) 2005-2014 Ales Hakl 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Lesser General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2.1 of the License, or (at your option) any later version. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19 | * 20 | */ 21 | 22 | #ifndef H__dfsch___util__ 23 | #define H__dfsch___util__ 24 | 25 | #include "dfsch/util.h" 26 | 27 | #define SL_BUF_LEN 512 28 | 29 | typedef struct str_li_t str_li_t; 30 | typedef dfsch_str_list_t str_list_t; 31 | struct dfsch_str_list_t { 32 | str_li_t* head; 33 | str_li_t* tail; 34 | size_t len; 35 | 36 | size_t buf_used; 37 | char buf[SL_BUF_LEN]; 38 | }; 39 | struct str_li_t { 40 | char* str; 41 | size_t len; 42 | str_li_t* next; 43 | }; 44 | 45 | #define ASCII_tolower(c) ((c)<='Z'&&(c)>='A'?(c)+('a'-'A'):(c)) 46 | 47 | #define sl_create dfsch_sl_create 48 | #define sl_append dfsch_sl_append 49 | #define sl_printf dfsch_sl_printf 50 | #define sl_nappend dfsch_sl_nappend 51 | #define sl_value dfsch_sl_value 52 | #define sl_value_strbuf dfsch_sl_value_strbuf 53 | #define stracat dfsch_stracat 54 | #define strancat dfsch_strancat 55 | #define stracpy dfsch_stracpy 56 | #define strancpy dfsch_strancpy 57 | #define straquote dfsch_straquote 58 | #define ascii_strcasecmp dfsch_ascii_strcasecmp 59 | 60 | #define create_finalized_mutex dfsch_create_finalized_mutex 61 | #define create_finalized_cvar dfsch_create_finalized_cvar 62 | #define create_finalized_rwlock dfsch_create_finalized_rwlock 63 | 64 | #define vsaprintf dfsch_vsaprintf 65 | #define saprintf dfsch_saprintf 66 | 67 | #endif 68 | -------------------------------------------------------------------------------- /src/version.c: -------------------------------------------------------------------------------- 1 | #include "config.h" 2 | #include "version.h" 3 | 4 | char* dfsch_get_build_id(){ 5 | return BUILD_ID; 6 | } 7 | char* dfsch_get_version(){ 8 | return PACKAGE_VERSION; 9 | } 10 | -------------------------------------------------------------------------------- /tests/c-api-test.c: -------------------------------------------------------------------------------- 1 | #include "tests/test-macros.h" 2 | #include 3 | 4 | int main(int argc, char**argv){ 5 | TEST_INIT(argc, argv); 6 | 7 | 8 | TEST_EXIT(1); 9 | } 10 | 11 | -------------------------------------------------------------------------------- /tests/compiler-tests.scm: -------------------------------------------------------------------------------- 1 | (define-evaluation-test let-shadowing (:language :compiler) 2 | ((let ((exp :local)) 3 | exp) ===> :local)) 4 | 5 | (define-evaluation-test letrec-shadowing (:language :compiler) 6 | ((letrec ((exp :local)) 7 | exp) ===> :local)) 8 | 9 | (define-evaluation-test named-let-shadowing (:language :compiler) 10 | ((let ((my-var :outer)) 11 | (let my-var () 12 | (procedure? my-var))) ===> #t) 13 | ((let pi () 14 | (procedure? pi)) ===> #t)) 15 | 16 | (define-evaluation-test argument-shadowing (:language :compiler) 17 | (((lambda (exp) exp) :local) ===> :local) 18 | (((lambda (&aux (exp :local)) exp)) ===> :local)) 19 | 20 | (define-evaluation-test local-shadowing (:language :compiler) 21 | ((begin 22 | (define exp :local) 23 | exp) ===> :local)) 24 | 25 | (define-evaluation-test destructuring-bind-shadowing (:language :compiler) 26 | ((destructuring-bind (exp) '(:local) 27 | exp) ===> :local)) 28 | 29 | (define-test declare (:language :compiler) 30 | (define foo 1) 31 | (declare foo :type ) 32 | (assert-true #t)) 33 | -------------------------------------------------------------------------------- /tests/fix-regression-tests.scm: -------------------------------------------------------------------------------- 1 | (define-evaluation-test gensym-write-segfault (:regression) 2 | ((let ((str (object->string (gensym)))) 3 | #t) 4 | ===> #t)) 5 | 6 | (define-evaluation-test negative-divide (:regression) 7 | ((/ -1 2) ===> -1/2)) 8 | 9 | (define-evaluation-test fracnum-absolute-value (:regression) 10 | ((abs -1/2) ===> 1/2)) 11 | 12 | (define-test gensym-print (:language :numbers) 13 | (let ((l1 (string->object (object->string (let ((x (gensym))) 14 | (list x x))))) 15 | (l2 (string->object (object->string (let ((x (unintern 'mnau))) 16 | (list x x)))))) 17 | (assert-equal (car l1) (cadr l1)) 18 | (assert-equal (car l2) (cadr l2)))) 19 | -------------------------------------------------------------------------------- /tests/json-parser-test.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | static int callback(dfsch_object_t* obj, void* baton){ 4 | printf("%s\n", dfsch_object_2_string(obj, 100, 1)); 5 | } 6 | 7 | int main(){ 8 | dfsch_json_parser_t* jp = dfsch_make_json_parser(); 9 | char buf[1024]; 10 | 11 | dfsch_json_parser_set_callback(jp, callback, NULL); 12 | 13 | while (!feof(stdin)){ 14 | if (!fgets(buf, 1024, stdin)){ 15 | break; 16 | } 17 | dfsch_json_parser_feed(jp, buf); 18 | } 19 | } 20 | -------------------------------------------------------------------------------- /tests/library-tests.scm: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | BUILD_DIR="`pwd`" 4 | 5 | cd $srcdir/tests 6 | 7 | 8 | $BUILD_DIR/dfsch-repl -L $BUILD_DIR/.libs -L $srcdir/lib-scm interp-test.scm 9 | 10 | -------------------------------------------------------------------------------- /tests/main.scm: -------------------------------------------------------------------------------- 1 | (require :dfsch-unit) 2 | (use-package :dfsch-unit) 3 | 4 | (define-macro (define-evaluation-test name categories &rest exprs) 5 | `(let () 6 | (define-test ,name ,categories 7 | ,@(map (lambda (e) 8 | (if (and (pair? e) (cdr e) (eq? (cadr e) '===>)) 9 | (begin 10 | (when (not (cddr e)) 11 | (error "Expected result missing" :clause e)) 12 | (when (cdddr e) 13 | (error "Too many expressions in clause" :clause e)) 14 | `(assert-equal ,(car e) ',(caddr e))) 15 | e)) 16 | exprs)))) 17 | 18 | (require :language-tests) 19 | (require :r5rs-tests) 20 | (require :fix-regression-tests) 21 | (require :compiler-tests) 22 | 23 | (test-toplevel) -------------------------------------------------------------------------------- /tests/platform-test.c: -------------------------------------------------------------------------------- 1 | #include "tests/test-macros.h" 2 | #include 3 | #include 4 | 5 | int test_alignment(){ 6 | int i; 7 | for (i = 8; i < 2048; i++){ 8 | if (((size_t)GC_MALLOC(i)) & 0x7){ 9 | return 0; 10 | } 11 | } 12 | return 1; 13 | } 14 | 15 | int main(int argc, char**argv){ 16 | TEST_INIT(argc, argv); 17 | TEST("allocation-alignment", test_alignment()); 18 | TEST_EXIT(77); 19 | } 20 | -------------------------------------------------------------------------------- /tests/scm-test-interp.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | BUILD_DIR="`pwd`" 4 | 5 | cd $srcdir/tests 6 | 7 | 8 | $BUILD_DIR/dfsch-repl -X-compile_on_apply \ 9 | -L $BUILD_DIR/.libs -L ../lib-scm -L . main.scm 10 | 11 | -------------------------------------------------------------------------------- /tests/scm-test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | BUILD_DIR="`pwd`" 4 | 5 | cd $srcdir/tests 6 | 7 | 8 | $BUILD_DIR/dfsch-repl -L $BUILD_DIR/.libs -L ../lib-scm -L . main.scm 9 | 10 | -------------------------------------------------------------------------------- /tests/test-macros.h: -------------------------------------------------------------------------------- 1 | #ifndef H__adh__test_macros__ 2 | #define H__adh__test_macros__ 3 | 4 | #include 5 | #include 6 | 7 | #include 8 | 9 | static int test__fail_fast = 0; 10 | 11 | #define TEST_INIT(argc, argv) \ 12 | int test__pass = 0; \ 13 | int test__fail = 0; \ 14 | test__init_impl((argc), (argv)) 15 | 16 | #define TEST(name, cond) \ 17 | if ((cond)){ \ 18 | test__pass++; \ 19 | printf(" Test passed: \033[0;32m%s\033[0;39m\n", name); \ 20 | } else { \ 21 | test__fail++; \ 22 | printf("\033[0;31m!!\033[0;39m Test failed: "\ 23 | "\033[0;31m%s\033[0;39m (%s)\n", name, #cond); \ 24 | if (test__fail_fast) { \ 25 | exit(1); \ 26 | } \ 27 | } \ 28 | 29 | #define TEST_EXIT(fail_status) \ 30 | printf("***** RESULTS: ******\n"); \ 31 | printf(" Tests passed: %d\n", test__pass); \ 32 | printf(" Tests failed: %d\n", test__fail); \ 33 | printf("===========================\n"); \ 34 | printf(" Tests total: %d\n", test__pass + test__fail); \ 35 | if (test__fail != 0){ \ 36 | exit(fail_status); \ 37 | } else { \ 38 | exit(0); \ 39 | } 40 | 41 | 42 | static void test__init_impl(int argc, char** argv){ 43 | dfsch_cmdopts_t* parser = dfsch_cmdopts_make_parser(0); 44 | dfsch_cmdopts_add_flag_set(parser, 0, "one-test-fail", 1, &test__fail_fast); 45 | dfsch_cmdopts_parse_argv(parser, argv+1, argc-1); 46 | } 47 | 48 | 49 | #endif 50 | -------------------------------------------------------------------------------- /tools/benchmarks/deriv.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env dfsch-repl 2 | 3 | (require 'gcollect) 4 | 5 | (define (print . args) 6 | (for-each (lambda (i) (display i)) args) 7 | (newline)) 8 | 9 | (define-macro (measure-time name . body) 10 | (let ((start-run (gensym)) (start-real (gensym)) (start-bytes (gensym))) 11 | `(let ((,start-real (get-internal-real-time)) 12 | (,start-run (get-internal-run-time)) 13 | (,start-bytes (gc-total-bytes))) 14 | (print ">>> " ',name) 15 | ,@body 16 | (print "<<< " ',name 17 | " real: " (* 1.0 (/ (- (get-internal-real-time) 18 | ,start-real) 19 | internal-time-units-per-second)) 20 | " run: " (* 1.0 (/ (- (get-internal-run-time) 21 | ,start-run) 22 | internal-time-units-per-second)) 23 | " cons'd: " (- (gc-total-bytes) 24 | ,start-bytes))))) 25 | 26 | (define-macro (without-gc &rest thunk) 27 | `(begin 28 | (gc-disable!) 29 | (unwind-protect 30 | (begin 31 | ,@thunk) 32 | (gc-enable!) 33 | (gc-collect!)))) 34 | 35 | (define (deriv a) 36 | (cond ((not (pair? a)) 37 | (if (eq? a 'x) 1 0)) 38 | ((eq? (car a) '+) 39 | (cons '+ 40 | (map deriv (cdr a)))) 41 | ((eq? (car a) '-) 42 | (cons '- 43 | (map deriv (cdr a)))) 44 | ((eq? (car a) '*) 45 | (list '* 46 | a 47 | (cons '+ 48 | (map (lambda (a) (list '/ (deriv a) a)) (cdr a))))) 49 | ((eq? (car a) '/) 50 | (list '- 51 | (list '/ 52 | (deriv (cadr a)) 53 | (caddr a)) 54 | (list '/ 55 | (cadr a) 56 | (list '* 57 | (caddr a) 58 | (caddr a) 59 | (deriv (caddr a)))))) 60 | (else 61 | (error #f "No derivation method available")))) 62 | 63 | (define-constant *deriv-map* 64 | (make-identity-hash)) 65 | 66 | (map-set! *deriv-map* '+ 67 | (lambda (a) 68 | (cons '+ 69 | (map deriv (cdr a))))) 70 | 71 | (map-set! *deriv-map* '- 72 | (lambda (a) 73 | (cons '- 74 | (map deriv (cdr a))))) 75 | 76 | (map-set! *deriv-map* '* 77 | (lambda (a) 78 | (list '* 79 | a 80 | (cons '+ 81 | (map (lambda (a) (list '/ (deriv a) a)) (cdr a)))))) 82 | 83 | (map-set! *deriv-map* '/ 84 | (lambda (a) 85 | (list '- 86 | (list '/ 87 | (deriv (cadr a)) 88 | (caddr a)) 89 | (list '/ 90 | (cadr a) 91 | (list '* 92 | (caddr a) 93 | (caddr a) 94 | (deriv (caddr a))))))) 95 | 96 | 97 | (define (dderiv a) 98 | (if (not (pair? a)) 99 | (if (eq? a 'x) 1 0) 100 | ((map-ref *deriv-map* (car a)) a))) 101 | 102 | 103 | (define (nth-deriv expr n) 104 | (let ((tmp expr)) 105 | (for-each (lambda (x) 106 | (set! tmp (deriv tmp))) 107 | (make-number-sequence :to n)) 108 | tmp)) 109 | (define (nth-dderiv expr n) 110 | (let ((tmp expr)) 111 | (for-each (lambda (x) 112 | (set! tmp (dderiv tmp))) 113 | (make-number-sequence :to n)) 114 | tmp)) 115 | 116 | (define-constant inputs 117 | '(1 118 | x 119 | (+ x x) 120 | (- 4 x) 121 | (* 3 x) 122 | (/ 1 x) 123 | (* x x) 124 | (+ (* x y) (/ x y)))) 125 | 126 | (measure-time "deriv" (for-each (lambda (expr) (nth-deriv expr 6)) inputs)) 127 | (measure-time "dderiv" (for-each (lambda (expr) (nth-dderiv expr 6)) inputs)) 128 | 129 | 130 | 131 | 132 | -------------------------------------------------------------------------------- /tools/benchmarks/let-tak.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env dfsch-repl 2 | 3 | (require 'gcollect) 4 | (use-package :dfsch%internal) 5 | 6 | (define (print . args) 7 | (for-each (lambda (i) (display i)) args) 8 | (newline)) 9 | 10 | (define (tak x0 y0 z0) 11 | (let ((x x0) (y y0) (z z0)) 12 | (if (not (< y x)) 13 | z 14 | (tak (tak (- x 1) y z) 15 | (tak (- y 1) z x) 16 | (tak (- z 1) x y))))) 17 | 18 | (define (%tak x0 y0 z0) 19 | (%let ((x x0) (y y0) (z z0)) 20 | (if (not (< y x)) 21 | z 22 | (%tak (%tak (- x 1) y z) 23 | (%tak (- y 1) z x) 24 | (%tak (- z 1) x y))))) 25 | 26 | (define-macro (measure-time name . body) 27 | (let ((start-run (gensym)) (start-real (gensym)) (start-bytes (gensym))) 28 | `(let ((,start-real (get-internal-real-time)) 29 | (,start-run (get-internal-run-time)) 30 | (,start-bytes (gc-total-bytes))) 31 | (print ">>> " ',name) 32 | ,@body 33 | (print "<<< " ',name 34 | " real: " (* 1.0 (/ (- (get-internal-real-time) 35 | ,start-real) 36 | internal-time-units-per-second)) 37 | " run: " (* 1.0 (/ (- (get-internal-run-time) 38 | ,start-run) 39 | internal-time-units-per-second)) 40 | " cons'd: " (- (gc-total-bytes) 41 | ,start-bytes))))) 42 | 43 | 44 | (measure-time "let-tak" (tak 24 16 8)) 45 | (measure-time "%let-tak" (%tak 24 16 8)) -------------------------------------------------------------------------------- /tools/benchmarks/manyadds.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env dfsch-repl 2 | 3 | (require 'gcollect) 4 | 5 | (define (print . args) 6 | (for-each (lambda (i) (display i)) args) 7 | (newline)) 8 | 9 | (define-macro (measure-time name . body) 10 | (let ((start-run (gensym)) (start-real (gensym)) (start-bytes (gensym))) 11 | `(let ((,start-real (get-internal-real-time)) 12 | (,start-run (get-internal-run-time)) 13 | (,start-bytes (gc-total-bytes))) 14 | (print ">>> " ',name) 15 | ,@body 16 | (print "<<< " ',name 17 | " real: " (* 1.0 (/ (- (get-internal-real-time) 18 | ,start-real) 19 | internal-time-units-per-second)) 20 | " run: " (* 1.0 (/ (- (get-internal-run-time) 21 | ,start-run) 22 | internal-time-units-per-second)) 23 | " cons'd: " (- (gc-total-bytes) 24 | ,start-bytes))))) 25 | 26 | (define-macro (without-gc &rest thunk) 27 | `(begin 28 | (gc-disable!) 29 | (unwind-protect 30 | (begin 31 | ,@thunk) 32 | (gc-enable!) 33 | (gc-collect!)))) 34 | 35 | (define (many-add-fix-fun) 36 | (for-each (lambda (x) (+ x x)) (make-number-sequence :to 10000000))) 37 | 38 | (define (reduce-fix-fun) 39 | (for-each (lambda (x) (+ x x)) (make-number-sequence :to 10000000))) 40 | 41 | (measure-time "many-add-fix" (for-each (lambda (x) (+ x x)) (make-number-sequence :to 10000000))) 42 | (measure-time "many-add-fix-fun" (many-add-fix-fun)) 43 | (measure-time "many-add-flo" (for-each (lambda (x) (+ x pi)) (make-number-sequence :to 10000000))) 44 | 45 | (measure-time "reduce-fix" (reduce + (make-number-sequence :to 10000000))) 46 | (measure-time "reduce-fix-fun" (many-add-fix-fun)) 47 | (measure-time "reduce-flo" (reduce + (make-number-sequence :to 10000000))) 48 | -------------------------------------------------------------------------------- /tools/benchmarks/parallel.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env dfsch-repl 2 | 3 | (require :gcollect) 4 | (require :threads) 5 | (use-package :threads) 6 | 7 | (define (tak x y z) 8 | (if (not (< y x)) 9 | z 10 | (tak (tak (- x 1) y z) 11 | (tak (- y 1) z x) 12 | (tak (- z 1) x y)))) 13 | 14 | (define (tak-inline x y z) 15 | (define (tak-impl x y z) 16 | (#.if (#.not (#.< y x)) 17 | z 18 | (tak-impl (tak-impl (#.- x 1) y z) 19 | (tak-impl (#.- y 1) z x) 20 | (tak-impl (#.- z 1) x y)))) 21 | (tak-impl x y z)) 22 | 23 | 24 | 25 | (define (print . args) 26 | (for-each (lambda (i) (display i)) args) 27 | (newline)) 28 | (define-macro (measure-time name . body) 29 | (let ((start-run (gensym)) (start-real (gensym)) (start-bytes (gensym))) 30 | `(let ((,start-real (get-internal-real-time)) 31 | (,start-run (get-internal-run-time)) 32 | (,start-bytes (gc-total-bytes))) 33 | (print ">>> " ',name) 34 | ,@body 35 | (print "<<< " ',name 36 | " real: " (* 1.0 (/ (- (get-internal-real-time) 37 | ,start-real) 38 | internal-time-units-per-second)) 39 | " run: " (* 1.0 (/ (- (get-internal-run-time) 40 | ,start-run) 41 | internal-time-units-per-second)) 42 | " cons'd: " (- (gc-total-bytes) 43 | ,start-bytes))))) 44 | 45 | (define (run-threads n proc) 46 | (if (> n 0) 47 | (cons 48 | (thread-create proc) 49 | (run-threads (- n 1) proc)) 50 | ())) 51 | 52 | (define (join-threads tl) 53 | (if (null? tl) 54 | () 55 | (begin 56 | (thread-join (car tl)) 57 | (join-threads (cdr tl))))) 58 | 59 | (define (tak-thread) 60 | (tak 24 16 8)) 61 | (define (tak-inline-thread) 62 | (tak-inline 24 16 8)) 63 | 64 | (set-current-output-port! *standard-output-port*) 65 | 66 | (measure-time tak-0 (tak-thread)) 67 | (measure-time tak-inline-0 (tak-inline-thread)) 68 | (measure-time tak-1 (join-threads (run-threads 1 tak-thread))) 69 | (measure-time tak-inline-1 (join-threads (run-threads 1 tak-inline-thread))) 70 | (measure-time tak-2 (join-threads (run-threads 2 tak-thread))) 71 | (measure-time tak-inline-2 (join-threads (run-threads 2 tak-inline-thread))) 72 | (measure-time tak-3 (join-threads (run-threads 3 tak-thread))) 73 | (measure-time tak-inline-3 (join-threads (run-threads 3 tak-inline-thread))) 74 | (measure-time tak-4 (join-threads (run-threads 4 tak-thread))) 75 | (measure-time tak-inline-4 (join-threads (run-threads 4 tak-inline-thread))) 76 | (measure-time tak-5 (join-threads (run-threads 5 tak-thread))) 77 | (measure-time tak-inline-5 (join-threads (run-threads 5 tak-inline-thread))) 78 | (measure-time tak-6 (join-threads (run-threads 6 tak-thread))) 79 | (measure-time tak-inline-6 (join-threads (run-threads 6 tak-inline-thread))) 80 | (measure-time tak-7 (join-threads (run-threads 7 tak-thread))) 81 | (measure-time tak-inline-7 (join-threads (run-threads 7 tak-inline-thread))) 82 | (measure-time tak-8 (join-threads (run-threads 8 tak-thread))) 83 | (measure-time tak-inline-8 (join-threads (run-threads 8 tak-inline-thread))) 84 | 85 | -------------------------------------------------------------------------------- /tools/benchmarks/tak.scm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env dfsch-repl 2 | 3 | (require 'gcollect) 4 | 5 | (define (print . args) 6 | (for-each (lambda (i) (display i)) args) 7 | (newline)) 8 | 9 | (define (tak x y z) 10 | (if (not (< y x)) 11 | z 12 | (tak (tak (- x 1) y z) 13 | (tak (- y 1) z x) 14 | (tak (- z 1) x y)))) 15 | 16 | (define (tak-inline x y z) 17 | (#.if (#.not (#.< y x)) 18 | z 19 | (tak-inline (tak-inline (#.- x 1) y z) 20 | (tak-inline (#.- y 1) z x) 21 | (tak-inline (#.- z 1) x y)))) 22 | 23 | 24 | (define-macro (measure-time name . body) 25 | (let ((start-run (gensym)) (start-real (gensym)) (start-bytes (gensym))) 26 | `(let ((,start-real (get-internal-real-time)) 27 | (,start-run (get-internal-run-time)) 28 | (,start-bytes (gc-total-bytes))) 29 | (print ">>> " ',name) 30 | ,@body 31 | (print "<<< " ',name 32 | " real: " (* 1.0 (/ (- (get-internal-real-time) 33 | ,start-real) 34 | internal-time-units-per-second)) 35 | " run: " (* 1.0 (/ (- (get-internal-run-time) 36 | ,start-run) 37 | internal-time-units-per-second)) 38 | " cons'd: " (- (gc-total-bytes) 39 | ,start-bytes))))) 40 | 41 | (define-macro (without-gc &rest thunk) 42 | `(begin 43 | (gc-disable!) 44 | (unwind-protect 45 | (begin 46 | ,@thunk) 47 | (gc-enable!) 48 | (gc-collect!)))) 49 | 50 | 51 | (measure-time "tak" (tak 24 16 8)) 52 | (measure-time "takfp" (tak 24.0 16.0 8.0)) 53 | (measure-time "tak-inline" (tak-inline 24 16 8)) 54 | (without-gc 55 | (measure-time "nogc-tak" (tak 24 16 8))) 56 | (without-gc 57 | (measure-time "nogc-takfp" (tak 24.0 16.0 8.0))) 58 | (without-gc 59 | (measure-time "nogc-tak-inline" (tak-inline 24 16 8))) --------------------------------------------------------------------------------