~ chicken-core (chicken-5) 2097ada70c88406411f4a76bc9590e2fc79a7f6e
commit 2097ada70c88406411f4a76bc9590e2fc79a7f6e
Author: Felix <bunny351@gmail.com>
AuthorDate: Sun Nov 8 00:50:31 2009 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Nov 23 17:56:08 2009 +0100
removed obsolete files; removed elisp files; minor cleaning up
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/README b/README
index 00cb58d8..78a30889 100644
--- a/README
+++ b/README
@@ -325,53 +325,14 @@
6. Emacs support:
- An emacs mode is provided in the file `hen.el'. To use it,
- copy it somewhere into a location you normally use for emacs
- extensions. If you want to add a specific location permanently
- to the list of paths emacs should search for extensions, add
- the following line to your `.emacs' file:
-
- (setq load-path
- (cons
- "<directory-where-your-emacs-lisp-files-live>"
- load-path))
-
- Add
-
- (require 'hen)
-
- To make "hen-mode" available, and enter it by issuing the
- command M-x hen-mode.
-
- A copy of Alex Shinn's highly useful tab-completion code is
- also included in `scheme-complete.el'. Install it like `hen.el'
- and add this code to your `.emacs':
-
- (autoload 'scheme-smart-complete "scheme-complete" nil t)
- (eval-after-load 'scheme
- '(progn (define-key scheme-mode-map "\e\t" 'scheme-smart-complete)))
-
- Or:
-
- (eval-after-load 'scheme
- '(progn (define-key scheme-mode-map "\t" 'scheme-complete-or-indent)))
-
- If you use eldoc-mode (included in Emacs), you can also get live
- scheme documentation with:
-
- (add-hook 'scheme-mode-hook
- (lambda ()
- (setq eldoc-info-function 'scheme-get-current-symbol-info)
- (eldoc-mode)))
-
- Replace "'scheme" in the elisp expressions above with "'hen", if
- you want to add tab-completion to CHICKEN's own emacs mode.
+ See http://chicken.wiki.br/emacs for tips and links to emacs
+ extensions for Scheme and CHICKEN programming.
7. Compatibility notes
CHICKEN 4 uses a completely reimplemented hygienic macro and
- module system, which has considerably more felixbility and power,
+ module system, which has considerably more flexibility and power,
but will require rewriting macros in code that previously was
used with CHICKEN 3. Notably, `define-macro' is not available
anymore. See the manual on how to translate such macros to
diff --git a/c-platform.scm b/c-platform.scm
index 2ba21720..6823a363 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -87,7 +87,7 @@
profile inline keep-shadowed-macros ignore-repository
fixnum-arithmetic disable-interrupts optimize-leaf-routines
lambda-lift compile-syntax tag-pointers accumulate-profile
- disable-stack-overflow-checks disable-c-syntax-checks unsafe-libraries raw
+ disable-stack-overflow-checks unsafe-libraries raw
emit-external-prototypes-first release local inline-global
analyze-only dynamic scrutinize no-argc-checks no-procedure-checks
no-bound-checks no-procedure-checks-for-usual-bindings no-compiler-syntax
diff --git a/chicken-primitive-object-inlines.scm b/chicken-primitive-object-inlines.scm
deleted file mode 100644
index b47e768b..00000000
--- a/chicken-primitive-object-inlines.scm
+++ /dev/null
@@ -1,1093 +0,0 @@
-;;;; chicken-primitive-object-nlines.scm
-;;;; Kon Lovett, Jan '09
-;;;; (Was chicken-sys-macros.scm)
-
-; ***** SHOULD RENAME SAFE ROUTINES AS '*foo', KEEPING '%foo' FOR UNSAFE *****
-
-; Usage
-;
-; (include "chicken-primitive-object-inlines")
-
-;; Notes
-;;
-;; Provides inlines for primitive procedures. Use of these procedures
-;; by non-core is highly suspect. Many of these routines are unsafe.
-;;
-;; In fact, any use is suspect ;-)
-;;
-;; A ##core#Inline is just what it says - literal inclusion in the compiled C
-;; code of the C macro/function and the arguments taken literally, i.e. as the
-;; C_word value.
-;;
-;; These are much faster than a lambda, but very dangerous since the arguments and
-;; the return value are not converted. The C code must perform any such conversions.
-;;
-;; ##core#inline cannot be used with a runtime C function which is coded in the
-;; CPS style.
-;;
-;; A ##core#primitive creates a lambda for a C function which is coded in the
-;; CPS style.
-;;
-;; These have a stereotypical argument list which begins the 3 arguments C_word
-;; c, C_word closure, and C_word k. Any actual arguments follow.
-;;
-;; c - number of arguments, not including 'c', but including 'closure' & 'k'
-;; closure - caller
-;; k - continuation
-
-;;; Unsafe Type Predicates
-
-;; Fixnum
-
-(define-inline (%fixnum-type? x) (##core#inline "C_fixnump" x))
-
-;; Character
-
-(define-inline (%char-type? x) (##core#inline "C_charp" x))
-
-;; Boolean
-
-(define-inline (%boolean-type? x) (##core#inline "C_booleanp" x))
-
-;; EOF
-
-(define-inline (%eof-object-type? x) (##core#inline "C_eofp" x))
-
-;; Null (the end-of-list value)
-
-(define-inline (%eol-object-type? x) (##core#inline "C_i_nullp" x))
-
-;; Undefined (void)
-
-(define-inline (%undefined-type? x) (##core#inline "C_undefinedp" x))
-
-;; Unbound (the unbound value, not 'is a symbol unbound')
-
-(define-inline (%unbound-type? x) (##core#inline "C_unboundvaluep" x))
-
-;; Byteblock
-
-(define-inline (%byteblock-type? x) (##core#inline "C_byteblockp" x))
-
-;; Bytevector
-
-(define-inline (%bytevector-type? x) (##core#inline "C_bytevectorp" x))
-
-;; String
-
-(define-inline (%string-type? x) (##core#inline "C_stringp" x))
-
-;; Flonum
-
-(define-inline (%flonum-type? x) (##core#inline "C_flonump" x))
-
-;; Lambda-info
-
-(define-inline (%lambda-info-type? x) (##core#inline "C_lambdainfop" x))
-
-;; Vector
-
-(define-inline (%vector-type? x) (##core#inline "C_vectorp" x))
-
-;; Pair
-
-(define-inline (%pair-type? x) (##core#inline "C_pairp" x))
-
-;; Bucket
-
-; A bucket is used by the runtime for the symbol-table. The bucket type is not
-; "seen" by Scheme code.
-
-;; Structure
-
-(define-inline (%structure-type? x) (##core#inline "C_structurep" x))
-
-;; Symbol
-
-(define-inline (%symbol-type? x) (##core#inline "C_symbolp" x))
-
-;; Closure
-
-(define-inline (%closure-type? x) (##core#inline "C_closurep" x))
-
-;; Port
-
-(define-inline (%port-type? x) (##core#inline "C_portp" x))
-
-;; Any-pointer
-
-(define-inline (%any-pointer-type? x) (##core#inline "C_anypointerp" x))
-
-;; Simple-pointer
-
-(define-inline (%simple-pointer-type? x) (##core#inline "C_pointerp" x))
-
-;; Tagged-Pointer
-
-(define-inline (%tagged-pointer-type? x) (##core#inline "C_taggedpointerp" x))
-
-;; Swig-Pointer
-
-(define-inline (%swig-pointer-type? x) (##core#inline "C_swigpointerp" x))
-
-;; Locative
-
-(define-inline (%locative-type? x) (##core#inline "C_locativep" x))
-
-;;; Safe Type Predicates
-
-;; Immediate
-
-(define-inline (%immediate? x) (##core#inline "C_immp" x))
-
-;; Fixnum
-
-(define-inline (%fixnum? x) (and (%immediate? x) (%fixnum-type? x)))
-
-;; Character
-
-(define-inline (%char? x) (and (%immediate? x) (%char-type? x)))
-
-;; Boolean
-
-(define-inline (%boolean? x) (and (%immediate? x) (%boolean-type? x)))
-
-(define-inline (%true-value? x) (and (%boolean? x) (##core#inline "C_and" x #t)))
-(define-inline (%false-value? x) (not (%true-value? x)))
-
-;; EOF
-
-(define-inline (%eof-object? x) (and (%immediate? x) (%eof-object-type? x)))
-
-;; Null (the end-of-list value)
-
-(define-inline (%eol-object? x) (and (%immediate? x) (%eol-object-type? x)))
-
-;; Undefined (void)
-
-(define-inline (%undefined-value? x) (and (%immediate? x) (%undefined-type? x)))
-
-(define-inline (%undefined-value) (##core#undefined))
-
-;; Unbound (the unbound value, not 'is a symbol unbound')
-
-(define-inline (%unbound-value? x) (and (%immediate? x) (%unbound-type? x)))
-
-;; Block (anything not immediate)
-
-(define-inline (%block? x) (##core#inline "C_blockp" x))
-
-;; Special
-
-(define-inline (%special? x) (##core#inline "C_specialp" x))
-
-;; Byteblock
-
-(define-inline (%byteblock? x) (and (%block? x) (%byteblock-type? x)))
-
-;; Bytevector
-
-(define-inline (%bytevector? x) (and (%block? x) (%bytevector-type? x)))
-
-;; String
-
-(define-inline (%string? x) (and (%block? x) (%string-type? x)))
-
-;; Flonum
-
-(define-inline (%flonum? x) (and (%block? x) (%flonum-type? x)))
-
-;; Lambda-info
-
-(define-inline (%lambda-info? x) (and (%block? x) (%lambda-info-type? x)))
-
-;; Wordblock (special block)
-
-(define-inline (%wordblock? x) (and (%block? x) (%special? x)))
-
-;; Vector
-
-(define-inline (%vector? x) (and (%block? x) (%vector-type? x)))
-
-;; Pair
-
-(define-inline (%pair? x) (and (%block? x) (%pair-type? x)))
-
-;; Bucket
-
-; A bucket is used by the runtime for the symbol-table. The bucket type is not
-; "seen" by Scheme code.
-
-;; Structure
-
-(define-inline (%structure? x) (and (%block? x) (%structure-type? x)))
-
-;; Symbol
-
-(define-inline (%symbol? x) (and (%block? x) (%symbol-type? x)))
-
-;; Closure
-
-(define-inline (%closure? x) (and (%block? x) (%closure-type? x)))
-
-;; Port
-
-(define-inline (%port? x) (and (%block? x) (%port-type? x)))
-
-;; Any-pointer
-
-(define-inline (%pointer? x) (and (%block? x) (%any-pointer-type? x)))
-
-;; Simple-pointer
-
-(define-inline (%simple-pointer? x) (and (%block? x) (%simple-pointer-type? x)))
-
-;; Tagged-Pointer
-
-(define-inline (%tagged-pointer? x) (and (%block? x) (%tagged-pointer-type? x)))
-
-;; Swig-Pointer
-
-(define-inline (%swig-pointer? x) (and (%block? x) (%swig-pointer-type? x)))
-
-;; Locative
-
-(define-inline (%locative? x) (and (%block? x) (%locative-type? x)))
-
-;; Forwarded (block object moved to new address, forwarding pointer)
-
-(define-inline (%forwarded? x) (##core#inline "C_forwardedp" x))
-
-;;; Operations
-
-;Safe
-
-(define-inline (%eq? x y) (##core#inline "C_eqp" x y))
-
-;; Fixnum
-
-;Safe
-
-(define-inline (%fxrandom x) (##core#inline "C_random_fixnum" x))
-
-;Unsafe
-
-(define-inline (%fx= x y) (%eq? x y))
-(define-inline (%fx> x y) (##core#inline "C_fixnum_greaterp" x y))
-(define-inline (%fx< x y) (##core#inline "C_fixnum_lessp" x y))
-(define-inline (%fx>= x y) (##core#inline "C_fixnum_greater_or_equal_p" x y))
-(define-inline (%fx<= x y) (##core#inline "C_fixnum_less_or_equal_p" x y))
-
-(define-inline (%fxclosed-right? l x h) (and (fx%< l x) (%fx<= x h)))
-(define-inline (%fxclosed? l x h) (and (%fx<= l x) (%fx<= x h)))
-(define-inline (%fxclosed-left? l x h) (and (%fx<= l x) (%fx< x h)))
-
-(define-inline (%fxzero? fx) (%fx= 0 fx))
-(define-inline (%fxpositive? fx) (%fx< 0 fx))
-(define-inline (%fxnegative? fx) (%fx< fx 0))
-(define-inline (%fxcardinal? fx) (%fx<= 0 fx))
-(define-inline (%fxodd? fx) (%fx= 1 (%fxand fx 1)))
-(define-inline (%fxeven? fx) (%fx= 0 (%fxand fx 1)))
-
-(define-inline (%fxmin x y) (if (%fx< x y) x y))
-(define-inline (%fxmax x y) (if (%fx< x y) y x))
-
-(define-inline (%fx+ x y) (##core#inline "C_fixnum_plus" x y))
-(define-inline (%fx- x y) (##core#inline "C_fixnum_difference" x y))
-(define-inline (%fx* x y) (##core#inline "C_fixnum_times" x y))
-(define-inline (%fx/ x y) (##core#inline "C_fixnum_divide" x y))
-(define-inline (%fxmod x y) (##core#inline "C_fixnum_modulo" x y))
-
-(define-inline (%fxadd1 fx) (##core#inline "C_fixnum_increase" fx))
-(define-inline (%fxsub1 fx) (##core#inline "C_fixnum_decrease" fx))
-
-(define-inline (%fxshl x y) (##core#inline "C_fixnum_shift_left" x y))
-(define-inline (%fxshr x y) (##core#inline "C_fixnum_shift_right" x y))
-
-(define-inline (%fxneg x) (##core#inline "C_fixnum_negate" x))
-(define-inline (%fxabs fx) (if (%fxnegative? fx) (%fxneg fx) fx))
-
-(define-inline (%fxand x y) (##core#inline "C_fixnum_and" x y))
-(define-inline (%fxior x y) (##core#inline "C_fixnum_or" x y))
-(define-inline (%fxxor x y) (##core#inline "C_fixnum_xor" x y))
-(define-inline (%fxnot x) (##core#inline "C_fixnum_not" x))
-
-;; Block
-
-(define-inline (%peek-signed-integer b i) ((##core#primitive "C_peek_signed_integer") b i))
-(define-inline (%peek-unsigned-integer b i) ((##core#primitive "C_peek_unsigned_integer") b i))
-(define-inline (%poke-integer b i n) (##core#inline "C_poke_integer" b i n))
-
-;Safe
-
-(define-inline (%block-address b) (##core#inline_allocate ("C_block_address" 4) b))
-
-;; Size of object in units of sub-object.
-
-; (%block-allocate size byteblock? fill aligned-8-byte-boundry?)
-;
-; byteblock? #t - size is # of bytes, fill is-a character -> "string"
-; byteblock? #f - size is # of words, fill is-a any -> "vector"
-
-(define-inline (%block-allocate n bb? f a?) ((##core#primitive "C_allocate_vector") n bb? f a?))
-
-;Unsafe
-
-; Byteblock -> # of bytes
-; Wordblock -> # of words.
-
-(define-inline (%block-size b) (##core#inline "C_block_size" b))
-
-;;
-
-;; Byteblock
-
-;Safe
-
-(define-inline (%make-byteblock n f a?) (%block-allocate n #t f a?))
-
-;Unsafe
-
-(define-inline (%byteblock-length bb) (%block-size bb))
-
-(define-inline (%byteblock-ref bb i) (##core#inline "C_subbyte" bb i))
-
-(define-inline (%byteblock-set! bb i v) (##core#inline "C_setsubbyte" bb i v))
-
-;; Generic-byteblock
-
-;Safe
-
-; generic-byteblock isa bytevector, string, flonum, or lambda-info
-(define-inline (%generic-byteblock? x)
- (or (%bytevector? x) (%string? x) (%flonum? x) (%lambda-info? x)) )
-
-;; Bytevector (byteblock)
-
-;Safe
-
-(define-inline (%make-bytevector sz)
- (let ((bv (%make-byteblock sz #f #t)))
- (##core#inline "C_string_to_bytevector" bv)
- bv ) )
-
-(define-inline (%string->bytevector s)
- (let* ((n (%byteblock-length s) #;(%string-size s))
- (bv (%make-bytevector sz)) )
- (##core#inline "C_copy_memory" bv s n)
- bv ) )
-
-;Unsafe
-
-(define-inline (%bytevector-length bv) (%byteblock-length bv))
-
-(define-inline (%bytevector=? bv1 bv2)
- (let ((n (%bytevector-length bv1)))
- (and (%fx= n (%bytevector-length bv2))
- (%fx= 0 (##core#inline "C_string_compare" bv1 bv2 n)) ) ) )
-
-(define-inline (%bytevector-ref bv i) (%byteblock-ref bv i))
-
-(define-inline (%bytevector-set! bv i x) (%byteblock-set! bv i x))
-
-;; Blob (isa bytevector w/o accessors)
-
-(define-inline (%make-blob sz) (%make-bytevector sz))
-
-(define-inline (%string->blob s) (%string->bytevector s))
-
-(define-inline (%blob? x) (%bytevector? x))
-
-(define-inline (%blob-size b) (%bytevector-length b))
-
-(define-inline (%blob=? b1 b2) (%bytevector=? b1 b2))
-
-;; String (byteblock)
-
-;Safe
-
-(define-inline (%make-string size fill) (%make-byteblock size fill #f))
-
-;Unsafe
-
-(define-inline (%bytevector->string bv)
- (let* ((n (%bytevector-length bv))
- (s (%make-string n #\space)) )
- (##core#inline "C_copy_memory" s bv n)
- s ) )
-
-(define-inline (%blob->string bv) (%bytevector->string bv))
-
-(define-inline (%lambda-info->string li)
- (let* ((sz (%byteblock-length li) #;(%lambda-info-length li))
- (s (%make-string sz #\space)) )
- (##core#inline "C_copy_memory" s li sz)
- s ) )
-
-(define-inline (%string-size s) (%byteblock-length s))
-(define-inline (%string-length s) (%byteblock-length s))
-
-(define-inline (%string-ref s i) (##core#inline "C_subchar" s i))
-
-(define-inline (%string-set! s i c) (##core#inline "C_setsubchar" s i c))
-
-(define-inline (%string-compare/length s1 s2 l) (##core#inline "C_string_compare" s1 s2 l))
-
-(define-inline (%string-compare s1 s2)
- (let* ((l1 (%string-length s1))
- (l2 (%string-length s2))
- (d (%fx- l1 l2))
- (r (%string-compare/length s1 s2 (if (%fxpositive? d) l2 l1))) )
- (if (%fxzero? r) d
- r ) ) )
-
-(define-inline (%string=? s1 s2) (%fxzero? (%string-compare s1 s2)))
-(define-inline (%string<? s1 s2) (%fxnegative? (%string-compare s1 s2)))
-(define-inline (%string>? s1 s2) (%fxpositive? (%string-compare s1 s2)))
-(define-inline (%string<=? s1 s2) (%fx<= 0 (%string-compare s1 s2)))
-(define-inline (%string>=? s1 s2) (%fx>= 0 (%string-compare s1 s2)))
-
-(define-inline (%string-ci-compare/length s1 s2 l) (##core#inline "C_string_compare_case_insensitive" s1 s2 l))
-
-(define-inline (%string-ci-compare s1 s2)
- (let* ((l1 (%string-length s1))
- (l2 (%string-length s2))
- (d (%fx- l1 l2))
- (r (%string-ci-compare/length s1 s2 (if (%fxpositive? d) l2 l1))) )
- (if (%fxzero? r) d
- r ) ) )
-
-(define-inline (%string-ci=? s1 s2) (%fxzero? (%string-ci-compare s1 s2)))
-(define-inline (%string-ci<? s1 s2) (%fxnegative? (%string-ci-compare s1 s2)))
-(define-inline (%string-ci>? s1 s2) (%fxpositive? (%string-ci-compare s1 s2)))
-(define-inline (%string-ci<=? s1 s2) (%fx<= 0 (%string-ci-compare s1 s2)))
-(define-inline (%string-ci>=? s1 s2) (%fx>= 0 (%string-ci-compare s1 s2)))
-
-;; Flonum (byteblock)
-
-;Unsafe
-
-(define-inline (%fp= x y) (##core#inline "C_flonum_equalp" x y))
-(define-inline (%fp< x y) (##core#inline "C_flonum_lessp" x y))
-(define-inline (%fp<= x y) (##core#inline "C_flonum_less_or_equal_p" x y))
-(define-inline (%fp> x y) (##core#inline "C_flonum_greaterp" x y))
-(define-inline (%fp>= x y) (##core#inline "C_flonum_greater_or_equal_p" x y))
-
-(define-inline (%fpmax x y) (##core#inline "C_i_flonum_max" x y))
-(define-inline (%fpmin x y) (##core#inline "C_i_flonum_min" x y))
-
-(define-inline (%finite? x) (##core#inline "C_i_finitep" x))
-
-(define-inline (%fp- x y) (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y))
-(define-inline (%fp* x y) (##core#inline_allocate ("C_a_i_flonum_times" 4) x y))
-(define-inline (%fp/ x y) (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y))
-(define-inline (%fp+ x y) (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y))
-
-(define-inline (%fpfraction x) ((##core#primitive "C_flonum_fraction") x))
-
-(define-inline (%fpnegate x) (##core#inline_allocate ("C_a_i_flonum_negate" 4) x))
-
-(define-inline (%fpfloor x) ((##core#primitive "C_flonum_floor") x))
-(define-inline (%fpceiling x) ((##core#primitive "C_flonum_ceiling") x))
-(define-inline (%fpround x) ((##core#primitive "C_flonum_round") x))
-(define-inline (%fptruncate x) ((##core#primitive "C_flonum_truncate") x))
-
-;Safe
-
-(define-inline (%exact->inexact x) ((##core#primitive "C_exact_to_inexact") x))
-
-; Actually 'number' operations
-(define-inline (%fpabs x) (##core#inline_allocate ("C_a_i_abs" 4) x))
-(define-inline (%fpacos x) (##core#inline_allocate ("C_a_i_acos" 4) x))
-(define-inline (%fpasin x) (##core#inline_allocate ("C_a_i_asin" 4) x))
-(define-inline (%fpatan x) (##core#inline_allocate ("C_a_i_atan" 4) x))
-(define-inline (%fpatan2 x y) (##core#inline_allocate ("C_a_i_atan2" 4) x y))
-(define-inline (%fpcos x) (##core#inline_allocate ("C_a_i_cos" 4) x))
-(define-inline (%fpexp x) (##core#inline_allocate ("C_a_i_exp" 4) x))
-(define-inline (%fplog x) (##core#inline_allocate ("C_a_i_log" 4) x))
-(define-inline (%fpsin x) (##core#inline_allocate ("C_a_i_sin" 4) x))
-(define-inline (%fpsqrt x) (##core#inline_allocate ("C_a_i_sqrt" 4) x))
-(define-inline (%fptan x) (##core#inline_allocate ("C_a_i_tan" 4) x))
-
-;; Lambda-info (byteblock)
-
-;Unsafe
-
-(define-inline (%string->lambda-info s)
- (let* ((n (%string-size s))
- (li (%make-string n)) )
- (##core#inline "C_copy_memory" li s n)
- (##core#inline "C_string_to_lambdainfo" li)
- li ) )
-
-(define-inline (%lambda-info-length li) (%byteblock-length s))
-
-;; Wordblock
-
-;Safe
-
-(define-inline (%make-wordblock n f a?) (%block-allocate n #f f a?))
-
-;Unsafe
-
-(define-inline (%wordblock-length wb) (%block-size wb))
-
-(define-inline (%wordblock-ref wb i) (##core#inline "C_slot" wb i))
-
-(define-inline (%wordblock-set!/mutate wb i v) (##core#inline "C_i_setslot" wb i v))
-(define-inline (%wordblock-set!/immediate wb i v) (##core#inline "C_i_set_i_slot" wb i v))
-(define-inline (%wordblock-set! wb i v)
- (if (%immediate? v) (%wordblock-set!/immediate wb i v)
- (%wordblock-set!/mutate wb i v) ) )
-
-;; Generic-vector (wordblock)
-
-; generic-vector isa vector, pair, structure, symbol, or keyword
-(define-inline (%generic-vector? x) (and (%block? x) (not (or (%special? x) (%byteblock? x)))))
-
-;; Vector (wordblock)
-
-;Safe
-
-(define-inline (%make-vector size fill) (%make-wordblock size fill #f))
-
-;Unsafe
-
-(define-inline (%vector-length v) (%wordblock-length v))
-
-(define-inline (%vector-ref v i) (%wordblock-ref v i))
-
-(define-inline (%vector-set!/mutate v i x) (%wordblock-set!/mutate v i x))
-(define-inline (%vector-set!/immediate v i x) (%wordblock-set!/immediate v i x))
-(define-inline (%vector-set! v i x) (%wordblock-set! v i x))
-
-;; Pair (wordblock)
-
-;Safe
-
-(define-inline (%null? x) (%eol-object? x))
-
-(define-inline (%list? x) (or (%null? x) (%pair? x)))
-
-(define-inline (%cons x y) (##core#inline_allocate ("C_a_i_cons" 3) x y) )
-
-(define-inline (%length ls) (##core#inline "C_i_length" ls))
-
-;Unsafe
-
-(define-inline (%car pr) (%wordblock-ref pr 0))
-
-(define-inline (%set-car!/mutate pr x) (%wordblock-set!/mutate pr 0 x))
-(define-inline (%set-car!/immediate pr x) (%wordblock-set!/immediate pr 0 x))
-(define-inline (%set-car! pr x) (%wordblock-set! pr 0 x))
-
-(define-inline (%cdr pr) (%wordblock-ref pr 1))
-
-(define-inline (%set-cdr!/mutate pr x) (%wordblock-set!/mutate pr 1 x))
-(define-inline (%set-cdr!/immediate pr x) (%wordblock-set!/immediate pr 1 x))
-(define-inline (%set-cdr! pr x) (%wordblock-set! pr 1 x))
-
-(define-inline (%caar pr) (%car (%car pr)))
-(define-inline (%cadr pr) (%car (%cdr pr)))
-(define-inline (%cdar pr) (%cdr (%car pr)))
-(define-inline (%cddr pr) (%cdr (%cdr pr)))
-
-(define-inline (%caaar pr) (%car (%caar pr)))
-(define-inline (%caadr pr) (%car (%cadr pr)))
-(define-inline (%cadar pr) (%car (%cdar pr)))
-(define-inline (%caddr pr) (%car (%cddr pr)))
-(define-inline (%cdaar pr) (%cdr (%caar pr)))
-(define-inline (%cdadr pr) (%cdr (%cadr pr)))
-(define-inline (%cddar pr) (%cdr (%cdar pr)))
-(define-inline (%cdddr pr) (%cdr (%cddr pr)))
-
-;Safe
-
-(define-inline (%memq x ls) (##core#inline "C_i_memq" x ls))
-(define-inline (%memv x ls) (##core#inline "C_i_memv" x ls))
-(define-inline (%member x ls) (##core#inline "C_i_member" x ls))
-
-(define-inline (%assq x ls) (##core#inline "C_i_assq" x ls))
-(define-inline (%assv x ls) (##core#inline "C_i_assv" x ls))
-(define-inline (%assoc x ls) (##core#inline "C_i_assoc" x ls))
-
-;Unsafe
-
-(define-inline (%list-ref ls0 i0)
- ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
- (let loop ((ls ls0) (i i0))
- (cond ((%null? ls) '() )
- ((%fx= 0 i) (%car ls) )
- (else (loop (%cdr ls) (%fx- i 1)) ) ) ) )
-
-(define-inline (%list-pair-ref ls0 i0)
- ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
- (let loop ((ls ls0) (i i0))
- (cond ((%null? ls) '() )
- ((%fx= 0 i) ls )
- (else (loop (%cdr ls) (%fx- i 1)) ) ) ) )
-
-(define-inline (%last-pair ls0)
- ;(assert (and (proper-list? ls0) (pair? ls0)))
- (do ((ls ls0 (%cdr ls)))
- ((%null? (%cdr ls)) ls)) )
-
-(define-inline (%list-copy ls0)
- ;(assert (proper-list? ls0))
- (let copy-rest ((ls ls0))
- (if (%null? ls) '()
- (%cons (%car ls) (copy-rest (%cdr ls))) ) ) )
-
-(define-inline (%append! . lss)
- ;(assert (and (proper-list? lss) (for-each (cut proper-list? <>) lss)))
- (let ((lss (let position-at-first-pair ((lss lss))
- (cond ((%null? lss) '() )
- ((%null? (%car lss)) (position-at-first-pair (%cdr lss)) )
- (else lss ) ) ) ) )
- (if (%null? lss) '()
- (let ((ls0 (%car lss)))
- ;(assert (pair? ls0))
- (let append!-rest ((lss (%cdr lss)) (pls ls0))
- (if (%null? lss) ls0
- (let ((ls (%car lss)))
- (cond ((%null? ls)
- (append!-rest (%cdr lss) pls) )
- (else
- (%set-cdr!/mutate (%last-pair pls) ls)
- (append!-rest (%cdr lss) ls) ) ) ) ) ) ) ) ) )
-
-(define-inline (%delq! x ls0)
- ;(assert (proper-list? ls0))
- (let find-elm ((ls ls0) (ppr #f))
- (cond ((%null? ls)
- ls0 )
- ((%eq? x (%car ls))
- (cond (ppr
- (%set-cdr! ppr (%cdr ls))
- ls0 )
- (else
- (%cdr ls) ) ) )
- (else
- (find-elm (%cdr ls) ls) ) ) ) )
-
-(define-inline (%list-fold/1 func init ls0)
- ;(assert (and (proper-list? ls0) (procedure? func)))
- (let loop ((ls ls0) (acc init))
- (if (%null? ls) acc
- (loop (%cdr ls) (func (%car ls) acc)) ) ) )
-
-(define-inline (%list-map/1 func ls0)
- ;(assert (and (proper-list? ls0) (procedure? func)))
- (let loop ((ls ls0))
- (if (%null? ls) '()
- (%cons (func (%car ls)) (loop (%cdr ls))) ) ) )
-
-(define-inline (%list-for-each/1 proc ls0)
- ;(assert (and (proper-list? ls0) (procedure? proc)))
- (let loop ((ls ls0))
- (unless (%null? ls)
- (proc (%car ls))
- (loop (%cdr ls)) ) ) )
-
-(define-inline (%list/1 obj) (%cons obj '()))
-
-(define-inline (%list . objs)
- (let loop ((objs objs))
- (if (%null? objs) '()
- (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
-
-(define-inline (%make-list n e)
- (let loop ((n n) (ls '()))
- (if (%fxzero? n) ls
- (loop (%fxsub1 n) (%cons e ls)) ) ) )
-
-(define-inline (%list-take ls0 n)
- (let loop ((ls ls0) (n n))
- (if (%fxzero? n) '()
- (%cons (%car ls) (loop (%cdr ls) (%fxsub1 n))) ) ) )
-
-(define-inline (%list-drop ls0 n)
- (let loop ((ls ls0) (n n))
- (if (%fxzero? n) ls
- (loop (%cdr ls) (%fxsub1 n)) ) ) )
-
-(define-inline (%list-any/1 pred? ls)
- (let loop ((ls ls))
- (and (not (%null? ls))
- (or (pred? (%car ls))
- (loop (%cdr ls)) ) ) ) )
-
-(define-inline (%list-every/1 pred? ls)
- (let loop ((ls ls))
- (or (%null? ls)
- (and (pred? (%car ls))
- (loop (%cdr ls))) ) ) )
-
-(define-inline (%list-length ls0)
- (let loop ((ls ls0) (n 0))
- (if (%null? ls) n
- (loop (%cdr ls) (%fxadd1 n)) ) ) )
-
-(define-inline (%list-find pred? ls)
- (let loop ((ls ls))
- (and (not (%null? ls))
- (or (let ((elm (%car ls))) (and (pred? elm) elm))
- (loop (%cdr ls)) ) ) ) )
-
-(define-inline (%alist-ref key al #!optional (test eqv?) def)
- (let loop ((al al))
- (cond ((%null? al) def )
- ((test key (%caar al)) (%cdar al) )
- (else (loop (%cdr al)) ) ) ) )
-
-(define-inline (%alist-update! key val al0 #!optional (test eqv?))
- (let loop ((al al0))
- (cond ((%null? al) (%cons (%cons key val) al0) )
- ((test key (%caar al)) (%set-cdr! (%car al) val) al0 )
- (else (loop (%cdr al)) ) ) ) )
-
-(define-inline (%alist-delete! key al0 #!optional (test equal?))
- (let loop ((al al0) (prv #f))
- (cond ((%null? al) al0)
- ((test key (%caar al)) (if prv (begin (%set-cdr! prv (%cdr al)) al0) (%cdr al)) )
- (else (loop (%cdr al) al) ) ) ) )
-
-;; Structure (wordblock)
-
-(define-inline (%make-structure t . s) (apply (##core#primitive "C_make_structure") t s))
-
-(define-inline (%structure-instance? x s) (##core#inline "C_i_structurep" x s))
-
-(define-inline (%structure-length r) (%wordblock-length r))
-
-(define-inline (%structure-tag r) (%wordblock-ref r 0))
-
-(define-inline (%structure-ref r i) (%wordblock-ref r i))
-
-(define-inline (%structure-set!/mutate r i x) (%wordblock-set!/mutate r i x))
-(define-inline (%structure-set!/immediate r i x) (%wordblock-set!/immediate r i x))
-(define-inline (%structure-set! r i x) (%wordblock-set! r i x))
-
-;; Port (wordblock)
-
-; Port layout:
-;
-; 0 FP (special - FILE *)
-; 1 input/output (bool)
-; 2 class (vector, see Port-class)
-; 3 name (string)
-; 4 row (fixnum)
-; 5 col (fixnum)
-; 6 EOF (bool)
-; 7 type (symbol)
-; 8 closed (bool)
-; 9 data
-; 10-15 reserved, port class specific
-
-(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
-(define-inline (%port-input-mode? port) (%wordblock-ref port 1))
-(define-inline (%port-class port) (%wordblock-ref port 2))
-(define-inline (%port-name port) (%wordblock-ref port 3))
-(define-inline (%port-row port) (%wordblock-ref port 4))
-(define-inline (%port-column port) (%wordblock-ref port 5))
-(define-inline (%port-eof? port) (%wordblock-ref port 6))
-(define-inline (%port-type port) (%wordblock-ref port 7))
-(define-inline (%port-closed? port) (%wordblock-ref port 8))
-(define-inline (%port-data port) (%wordblock-ref port 9))
-
-(define-inline (%input-port? x) (and (%port? x) (%port-input-mode? x)))
-(define-inline (%output-port? x) (and (%port? x) (not (%port-input-mode? x))))
-
-(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))
-(define-inline (%port-input-mode-set! port f) (%wordblock-set!/immediate port 1 f))
-(define-inline (%port-class-set! port v) (%wordblock-set!/mutate port 2 v))
-(define-inline (%port-name-set! port s) (%wordblock-set!/mutate port 3 s))
-(define-inline (%port-row-set! port n) (%wordblock-set!/immediate port 4 n))
-(define-inline (%port-column-set! port n) (%wordblock-set!/immediate port 5 n))
-(define-inline (%port-eof-set! port f) (%wordblock-set!/immediate port 6 f))
-(define-inline (%port-type-set! port s) (%wordblock-set!/mutate port 7 s))
-(define-inline (%port-closed-set! port f) (%wordblock-set!/immediate port 8 f))
-(define-inline (%port-data-set! port x) (%wordblock-set!/mutate port 9 x))
-
-(define-inline (%make-port i/o class name type)
- ; port is 16 slots + a block-header word
- (let ((port (##core#inline_allocate ("C_a_i_port" 17))))
- (%port-input-mode-set! port i/o)
- (%port-class-set! port class)
- (%port-name-set! port name)
- (%port-row-set! port 1)
- (%port-column-set! port 0)
- (%port-type-set! port type)
- port ) )
-
-; Port-class layout
-;
-; 0 (read-char PORT) -> CHAR | EOF
-; 1 (peek-char PORT) -> CHAR | EOF
-; 2 (write-char PORT CHAR)
-; 3 (write-string PORT STRING)
-; 4 (close PORT)
-; 5 (flush-output PORT)
-; 6 (char-ready? PORT) -> BOOL
-; 7 (read-string! PORT COUNT STRING START) -> COUNT'
-; 8 (read-line PORT LIMIT) -> STRING | EOF
-
-(define-inline (%make-port-class rc pc wc ws cl fl cr rs rl)
- (let ((class (%make-vector 9 #f)))
- (%vector-set! class 0 rc)
- (%vector-set! class 1 pc)
- (%vector-set! class 2 wc)
- (%vector-set! class 3 ws)
- (%vector-set! class 4 cl)
- (%vector-set! class 5 fl)
- (%vector-set! class 6 cr)
- (%vector-set! class 7 rs)
- (%vector-set! class 8 rl)
- class ) )
-
-(define-inline (%port-class-read-char-ref c) (%vector-ref c 0))
-(define-inline (%port-class-peek-char-ref c) (%vector-ref c 1))
-(define-inline (%port-class-write-char-ref c) (%vector-ref c 2))
-(define-inline (%port-class-write-string-ref c) (%vector-ref c 3))
-(define-inline (%port-class-close-ref c) (%vector-ref c 4))
-(define-inline (%port-class-flush-output-ref c) (%vector-ref c 5))
-(define-inline (%port-class-char-ready-ref c) (%vector-ref c 6))
-(define-inline (%port-class-read-string-ref c) (%vector-ref c 7))
-(define-inline (%port-class-read-line-ref c) (%vector-ref c 8))
-
-(define-inline (%port-class-read-char c p) ((%port-class-read-char-ref c) p) )
-(define-inline (%port-class-peek-char c p) ((%port-class-peek-char-ref c) p))
-(define-inline (%port-class-write-char c p c) ((%port-class-write-char-ref c) p c))
-(define-inline (%port-class-write-string c p s) ((%port-class-write-string-ref c) p s))
-(define-inline (%port-class-close c p) ((%port-class-close-ref c) p))
-(define-inline (%port-class-flush-output c p) ((%port-class-flush-output-ref c) p))
-(define-inline (%port-class-char-ready? c p) ((%port-class-char-ready-ref c) p))
-(define-inline (%port-class-read-string! c p n d s) ((%port-class-read-string-ref c) p n d s))
-(define-inline (%port-class-read-line c p l) ((%port-class-read-line-ref c) p l))
-
-(define-inline (%port-read-char p) ((%port-class-read-char-ref (%port-class p)) p) )
-(define-inline (%port-peek-char p) ((%port-class-peek-char-ref (%port-class p)) p))
-(define-inline (%port-write-char p c) ((%port-class-write-char-ref (%port-class p)) p c))
-(define-inline (%port-write-string p s) ((%port-class-write-string-ref (%port-class p)) p s))
-(define-inline (%port-close p) ((%port-class-close-ref (%port-class p)) p))
-(define-inline (%port-flush-output p) ((%port-class-flush-output-ref (%port-class p)) p))
-(define-inline (%port-char-ready? p) ((%port-class-char-ready-ref (%port-class p)) p))
-(define-inline (%port-read-string! p n d s) ((%port-class-read-string-ref (%port-class p)) p n d s))
-(define-inline (%port-read-line p l) ((%port-class-read-line-ref (%port-class p)) p l))
-
-;; Closure (wordblock)
-
-;Unsafe
-
-(define-inline (%make-closure! n)
- (let ((v (%make-vector n)))
- (##core#inline "C_vector_to_closure" v)
- v ) )
-
-(define-inline (%procedure? x) (%closure? x))
-
-(define-inline (%vector->closure! v a)
- (##core#inline "C_vector_to_closure" v)
- (##core#inline "C_update_pointer" a v) )
-
-(define-inline (%closure-length c) (%wordblock-length? c))
-
-(define-inline (%closure-ref c i) (%wordblock-ref c i))
-
-(define-inline (%closure-set! c i v) (%wordblock-set! c i v))
-
-(define-inline (%closure-copy tc fc l)
- (do ((i 1 (%fxadd1 i)))
- ((%fx>= i l))
- (%closure-set! tc i (%closure-ref fc i)) ) )
-
-(define-inline (%closure-decoration c test)
- (let find-decor ((i (%fxsub1 (%closure-length c))))
- (and (%fxpositive? i)
- (let ((x (%closure-ref c i)))
- (if (test x) x
- (find-decor (%fxsub1 i)) ) ) ) ) )
-
-(define-inline (%closure-decorate! c test dcor)
- (let ((l (%closure-length c)))
- (let find-decor ((i (%fxsub l)))
- (cond ((%fxzero? i)
- (let ((nc (%make-closure (%fxadd1 l))))
- (%closure-copy nc c l)
- (##core#inline "C_copy_pointer" c nc)
- (dcor nc i) ) )
- (else
- (let ((x (%closure-ref c i)))
- (if (test x) (dcor c i)
- (find-decor (%fxsub i)) ) ) ) ) ) ) )
-
-(define-inline (%closure-lambda-info c)
- (%closure-decoration c (lambda (x) (%lambda-info? x))) )
-
-;; Symbol (wordblock)
-
-;Unsafe
-
-(define-inline (%symbol-binding s) (%wordblock-ref s 0))
-(define-inline (%symbol-string s) (%wordblock-ref s 1))
-(define-inline (%symbol-bucket s) (%wordblock-ref s 2))
-
-(define-constant NAMESPACE-MAX-ID-LEN 31)
-
-(define-inline (%qualified-symbol? s)
- (let ((str (%symbol-string s)))
- (and (%fxpositive? (%string-size str))
- (%fx<= (%byteblock-ref str 0) NAMESPACE-MAX-ID-LEN) ) ) )
-
-;Safe
-
-(define-inline (%string->symbol-interned s) ((##core#primitive "C_string_to_symbol") s))
-
-(define-inline (%symbol-interned? x) (##core#inline "C_lookup_symbol" x))
-
-(define-inline (%symbol-bound? s) (##core#inline "C_boundp" s))
-
-;; Keyword (wordblock)
-
-(define-inline (%keyword? x) (and (%symbol? x) (%fxzero? (%byteblock-ref (%symbol-string x) 0))))
-
-;; Pointer (wordblock)
-
-; simple-pointer, tagged-pointer, swig-pointer, locative
-(define-inline (%generic-pointer? x) (or (%pointer? x) (%locative? x)))
-
-; simple-pointer, tagged-pointer, swig-pointer, locative, closure, port, symbol, keyword
-(define-inline (%pointer-like? x) (%wordblock? x))
-
-; These operate on pointer-like objects
-
-(define-inline (%pointer-null? ptr) (##core#inline "C_null_pointerp" ptr))
-
-(define-inline (%pointer-ref ptr) (%wordblock-ref ptr 0))
-(define-inline (%pointer-set! ptr y) (%wordblock-set!/mutate ptr 0 y))
-
-(define-inline (%peek-byte ptr i) (##core#inline "C_peek_byte" ptr i))
-
-(define-inline (%pointer->address ptr)
- ; Pack pointer address value into Chicken words; '4' is platform dependent!
- (##core#inline_allocate ("C_block_address" 4) (%generic-pointer-ref ptr)) )
-
-;; Simple-pointer (wordblock)
-
-(define-inline (%make-simple-pointer) ((##core#primitive "C_make_pointer")))
-
-(define-inline (%make-pointer-null)
- (let ((ptr (%make-simple-pointer)))
- (##core#inline "C_update_pointer" 0 ptr)
- ptr ) )
-
-(define-inline (%address->pointer a)
- (let ((ptr (%make-simple-pointer)))
- (##core#inline "C_update_pointer" a ptr)
- ptr ) )
-
-(define-inline (%make-block-pointer b)
- (let ((ptr (%make-simple-pointer)))
- (##core#inline "C_pointer_to_block" ptr b)
- ptr ) )
-
-;; Tagged-pointer (wordblock)
-
-(define-inline (%make-tagged-pointer t) ((##core#primitive "C_make_tagged_pointer") t))
-
-;; Swig-pointer (wordblock)
-
-;; Locative (wordblock)
-
-(define-inline (%make-locative typ obj idx weak?)
- (##core#inline_allocate ("C_a_i_make_locative" 5) typ obj idx weak?))
-
-; Locative layout:
-;
-; 0 Object-address + byte-offset (address)
-; 1 Byte-offset (fixnum)
-; 2 Type (fixnum)
-; 0 vector or pair (C_SLOT_LOCATIVE)
-; 1 string (C_CHAR_LOCATIVE)
-; 2 u8vector (C_U8_LOCATIVE)
-; 3 s8vector or bytevector (C_U8_LOCATIVE)
-; 4 u16vector (C_U16_LOCATIVE)
-; 5 s16vector (C_S16_LOCATIVE)
-; 6 u32vector (C_U32_LOCATIVE)
-; 7 s32vector (C_S32_LOCATIVE)
-; 8 f32vector (C_F32_LOCATIVE)
-; 9 f64vector (C_F64_LOCATIVE)
-; 3 Object or #f, if weak (C_word)
-
-(define-inline (%locative-address lv) (%pointer->address lv))
-
-(define-inline (%locative-offset lv) (%wordblock-ref lv 1))
-(define-inline (%locative-type lv) (%wordblock-ref lv 2))
-(define-inline (%locative-weak? lv) (not (%wordblock-ref lv 3)))
-(define-inline (%locative-object lv) (%wordblock-ref lv 3))
-
-;; Numbers
-
-;Safe
-
-(define-inline (%number? x) (or (%fixnum? x) (%flonum? x)))
-(define-inline (%integer? x) (##core#inline "C_i_integerp" x))
-(define-inline (%exact? x) (##core#inline "C_i_exactp" x))
-(define-inline (%inexact? x) (##core#inline "C_i_inexactp" x))
-
-(define-inline (%= x y) (##core#inline "C_i_eqvp" x y))
-(define-inline (%< x y) (##core#inline "C_i_lessp" x y))
-(define-inline (%<= x y) (##core#inline "C_i_less_or_equalp" x y))
-(define-inline (%> x y) (##core#inline "C_i_greaterp" x y))
-(define-inline (%>= x y) (##core#inline "C_i_greater_or_equalp" x y))
-
-(define-inline (%zero? n) (##core#inline "C_i_zerop" n))
-(define-inline (%positive? n) (##core#inline "C_i_positivep" n))
-(define-inline (%negative? n) (##core#inline "C_i_negativep" n))
-(define-inline (%cardinal? fx) (%<= 0 fx))
-
-(define-inline (%odd? n) (##core#inline "C_i_oddp" n))
-(define-inline (%even? n) (##core#inline "C_i_evenp" n))
-
-(define-inline (%+ x y) ((##core#primitive "C_plus") x y))
-(define-inline (%- x y) ((##core#primitive "C_minus") x y))
-(define-inline (%* x y) ((##core#primitive "C_times") x y))
-(define-inline (%/ x y) ((##core#primitive "C_divide") x y))
-
-(define-inline (%add1 x) (%+ x 1))
-(define-inline (%sub1 x) (%- x 1))
-
-(define-inline (%quotient x y) ((##core#primitive "C_quotient") x y))
-(define-inline (%remainder x y) (let ((quo (%quotient x y))) (%- x (%* quo y))))
-
-(define-inline (%expt x y) ((##core#primitive "C_expt") x y))
-(define-inline (%abs x) (##core#inline_allocate ("C_a_i_abs" 4) x))
-(define-inline (%acos x) (##core#inline_allocate ("C_a_i_acos" 4) x))
-(define-inline (%asin x) (##core#inline_allocate ("C_a_i_asin" 4) x))
-(define-inline (%atan x) (##core#inline_allocate ("C_a_i_atan" 4) x))
-(define-inline (%atan2 x y) (##core#inline_allocate ("C_a_i_atan2" 4) x y))
-(define-inline (%cos x) (##core#inline_allocate ("C_a_i_cos" 4) x))
-(define-inline (%exp x) (##core#inline_allocate ("C_a_i_exp" 4) x))
-(define-inline (%log x) (##core#inline_allocate ("C_a_i_log" 4) x))
-(define-inline (%sin x) (##core#inline_allocate ("C_a_i_sin" 4) x))
-(define-inline (%sqrt x) (##core#inline_allocate ("C_a_i_sqrt" 4) x))
-(define-inline (%tan x) (##core#inline_allocate ("C_a_i_tan" 4) x))
-
-(define-inline (%bitwise-and x y) (##core#inline_allocate ("C_a_i_bitwise_and" 4) x y))
-(define-inline (%bitwise-xor x y) (##core#inline_allocate ("C_a_i_bitwise_xor" 4) x y))
-(define-inline (%bitwise-ior x y) (##core#inline_allocate ("C_a_i_bitwise_ior" 4) x y))
-(define-inline (%bitwise-not x) (##core#inline_allocate ("C_a_i_bitwise_not" 4) x))
-
-(define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d))
-
-(define-inline (%bit-set? n i) (##core#inline "C_i_bit_setp" n i))
-
-(define-inline (%randomize n) (##core#inline "C_randomize" n))
-
-;;; Operations
-
-;Safe
-
-(define-inline (%->boolean obj) (and obj #t))
-
-(define-inline (%make-unique-object #!optional id) (if id (%make-vector 1 id) '#()))
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 34fe44b0..dfecdb9b 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -443,7 +443,7 @@
(when (or (not (pair? val)) (not (c %lambda (car val))))
(syntax-error
'define-inline "invalid substitution form - must be lambda"
- name) )
+ name val) )
(list name val) ) ) ] )
`(##core#define-inline ,@(quotify-proc (cdr form) 'define-inline)))) ) ) )
diff --git a/chicken-thread-object-inlines.scm b/chicken-thread-object-inlines.scm
deleted file mode 100644
index c4213ac6..00000000
--- a/chicken-thread-object-inlines.scm
+++ /dev/null
@@ -1,297 +0,0 @@
-;;;; chicken-thread-object-primitive-inlines.scm
-;;;; Kon Lovett, Jan '09
-
-; Usage
-;
-; (include "chicken-primitive-object-inlines")
-; (include "chicken-thread-object-inlines")
-
-;; Notes
-;
-; Provides inlines & macros for thread objects. Use of these procedures
-; by non-core & non-core-extensions is highly suspect. Many of these routines
-; are unsafe.
-;
-; In fact, any use is suspect ;-)
-
-
-;;; Mutex object helpers:
-
-;; Mutex layout:
-;
-; 0 Tag - 'mutex
-; 1 Name (object)
-; 2 Thread (thread or #f)
-; 3 Waiting threads (FIFO list)
-; 4 Abandoned? (boolean)
-; 5 Locked? (boolean)
-; 6 Specific (object)
-
-(define-inline (%mutex? x)
- (%structure-instance? x 'mutex) )
-
-(define-inline (%mutex-name mx)
- (%structure-ref mx 1) )
-
-(define-inline (%mutex-thread mx)
- (%structure-ref mx 2) )
-
-(define-inline (%mutex-thread-set! mx th)
- (%structure-set!/mutate mx 2 th) )
-
-(define-inline (%mutex-thread-clear! mx)
- (%structure-set!/immediate mx 2 #f) )
-
-(define-inline (%mutex-waiters mx)
- (%structure-ref mx 3) )
-
-(define-inline (%mutex-waiters-set! mx wt)
- (%structure-set!/mutate mx 3 wt) )
-
-(define-inline (%mutex-waiters-empty? mx)
- (%null? (%mutex-waiters mx)) )
-
-(define-inline (%mutex-waiters-empty! mx)
- (%structure-set!/immediate mx 3 '()) )
-
-(define-inline (%mutex-waiters-add! mx th)
- (%mutex-waiters-set! mx (%append! (%mutex-waiters mx) (%cons th '()))) )
-
-(define-inline (%mutex-waiters-delete! mx th)
- (%mutex-waiters-set! mx (%delq! th (%mutex-waiters mx))) )
-
-(define-inline (%mutex-waiters-pop! mx)
- (let* ([wt (%mutex-waiters mx)]
- [top (%car wt)])
- (%mutex-waiters-set! mx (%cdr wt))
- top ) )
-
-(define-inline (%mutex-abandoned? mx)
- (%structure-ref mx 4) )
-
-(define-inline (%mutex-abandoned-set! mx f)
- (%structure-set!/immediate mx 4 f) )
-
-(define-inline (%mutex-locked? mx)
- (%structure-ref mx 5) )
-
-(define-inline (%mutex-locked-set! mx f)
- (%structure-set!/immediate mx 5 f) )
-
-(define-inline (%mutex-specific mx)
- (%structure-ref mx 6) )
-
-(define-inline (%mutex-specific-set! mx x)
- (%structure-set!/mutate mx 6 x) )
-
-
-;;; Thread object helpers:
-
-;; Thread layout:
-;
-; 0 Tag - 'thread
-; 1 Thunk (procedure)
-; 2 Results (list-of object)
-; 3 State (symbol)
-; 4 Block-timeout (fixnum or #f)
-; 5 State buffer (vector)
-; 0 Dynamic winds (list)
-; 1 Standard input (port)
-; 2 Standard output (port)
-; 3 Standard error (port)
-; 4 Exception handler (procedure)
-; 5 Parameters (vector)
-; 6 Name (object)
-; 7 Reason (condition of #f)
-; 8 Mutexes (list-of mutex)
-; 9 Quantum (fixnum)
-; 10 Specific (object)
-; 11 Block object (thread or (pair-of fd io-mode))
-; 12 Recipients (list-of thread)
-; 13 Unblocked by timeout? (boolean)
-
-(define-inline (%thread? x)
- (%structure-instance? x 'thread) )
-
-(define-inline (%thread-thunk th)
- (%structure-ref th 1) )
-
-(define-inline (%thread-thunk-set! th tk)
- (%structure-set!/mutate th 1 tk) )
-
-(define-inline (%thread-results th)
- (%structure-ref th 2) )
-
-(define-inline (%thread-results-set! th rs)
- (%structure-set!/mutate th 2 rs) )
-
-(define-inline (%thread-state th)
- (%structure-ref th 3) )
-
-(define-inline (%thread-state-set! th st)
- (%structure-set!/mutate th 3 st) )
-
-(define-inline (%thread-block-timeout th)
- (%structure-ref th 4) )
-
-(define-inline (%thread-block-timeout-set! th to)
- (%structure-set!/immediate th 4 to) )
-
-(define-inline (%thread-block-timeout-clear! th)
- (%thread-block-timeout-set! th #f) )
-
-(define-inline (%thread-state-buffer th)
- (%structure-ref th 5) )
-
-(define-inline (%thread-state-buffer-set! th v)
- (%structure-set!/mutate th 5 v) )
-
-(define-inline (%thread-name th)
- (%structure-ref th 6) )
-
-(define-inline (%thread-reason th)
- (%structure-ref th 7) )
-
-(define-inline (%thread-reason-set! th cd)
- (%structure-set!/mutate th 7 cd) )
-
-(define-inline (%thread-mutexes th)
- (%structure-ref th 8) )
-
-(define-inline (%thread-mutexes-set! th wt)
- (%structure-set!/mutate th 8 wx) )
-
-(define-inline (%thread-mutexes-empty? th)
- (%null? (%thread-mutexes th)) )
-
-(define-inline (%thread-mutexes-empty! th)
- (%structure-set!/immediate th 8 '()) )
-
-(define-inline (%thread-mutexes-add! th mx)
- (%thread-mutexes-set! th (%cons mx (%thread-mutexes th))) )
-
-(define-inline (%thread-mutexes-delete! th mx)
- (%thread-mutexes-set! th (%delq! mx (%thread-mutexes th))) )
-
-(define-inline (%thread-quantum th)
- (%structure-ref th 9) )
-
-(define-inline (%thread-quantum-set! th qt)
- (%structure-set!/immediate th 9 qt) )
-
-(define-inline (%thread-specific th)
- (%structure-ref th 10) )
-
-(define-inline (%thread-specific-set! th x)
- (%structure-set!/mutate th 10 x) )
-
-(define-inline (%thread-block-object th)
- (%structure-ref th 11) )
-
-(define-inline (%thread-block-object-set! th x)
- (%structure-set!/mutate th 11 x) )
-
-(define-inline (%thread-block-object-clear! th)
- (%structure-set!/immediate th 11 #f) )
-
-(define-inline (%thread-recipients th)
- (%structure-ref th 12) )
-
-(define-inline (%thread-recipients-set! th x)
- (%structure-set!/mutate th 12 x) )
-
-(define-inline (%thread-recipients-empty? th)
- (%null? (%condition-variable-waiters th)) )
-
-(define-inline (%thread-recipients-empty! th)
- (%structure-set!/immediate th 12 '()) )
-
-(define-inline (%thread-recipients-add! th rth)
- (%thread-recipients-set! t (%cons rth (%thread-recipients t))) )
-
-(define-inline (%thread-recipients-process! th tk)
- (let ([rs (%thread-recipients t)])
- (unless (%null? rs) (for-each tk rs) ) )
- (%thread-recipients-empty! t) )
-
-(define-inline (%thread-unblocked-by-timeout? th)
- (%structure-ref th 13) )
-
-(define-inline (%thread-unblocked-by-timeout-set! th f)
- (%structure-set!/immediate th 13 f) )
-
-(define-inline (%thread-blocked-for-timeout? th)
- (and (%thread-block-timeout th)
- (not (%thread-block-object th))) )
-
-(define-inline (%thread-blocked? th)
- (%eq? 'blocked (%thread-state th)) )
-
-(define-inline (%thread-created? th)
- (%eq? 'created (%thread-state th)) )
-
-(define-inline (%thread-ready? th)
- (%eq? 'ready (%thread-state th)) )
-
-(define-inline (%thread-sleeping? th)
- (%eq? 'sleeping (%thread-state th)) )
-
-(define-inline (%thread-suspended? th)
- (%eq? 'suspended (%thread-state th)) )
-
-(define-inline (%thread-terminated? th)
- (%eq? 'terminated (%thread-state th)) )
-
-(define-inline (%thread-dead? th)
- (%eq? 'dead (%thread-state th)) )
-
-;; Synonyms
-
-(define-inline (%current-thread)
- ##sys#current-thread )
-
-
-;;; Condition-variable object:
-
-;; Condition-variable layout:
-;
-; 0 Tag - 'condition-variable
-; 1 Name (object)
-; 2 Waiting threads (FIFO list)
-; 3 Specific (object)
-
-(define-inline (%condition-variable? x)
- (%structure-instance? x 'condition-variable) )
-
-(define-inline (%condition-variable-name cv)
- (%structure-ref cv 1) )
-
-(define-inline (%condition-variable-waiters cv)
- (%structure-ref cv 2) )
-
-(define-inline (%condition-variable-waiters-set! cv x)
- (%structure-set!/mutate cv 2 x) )
-
-(define-inline (%condition-variable-waiters-empty? cv)
- (%null? (%condition-variable-waiters cv)) )
-
-(define-inline (%condition-variable-waiters-empty! cv)
- (%structure-set!/immediate cv 2 '()) )
-
-(define-inline (%condition-variable-waiters-add! cv th)
- (%condition-variable-waiters-set! cv (%append! (%condition-variable-waiters cv) (%cons th '()))) )
-
-(define-inline (%condition-variable-waiters-delete! cv th)
- (%condition-variable-waiters-set! cv (%delq! th (%condition-variable-waiters cv))) )
-
-(define-inline (%condition-variable-waiters-pop! mx)
- (let* ([wt (%condition-variable-waiters mx)]
- [top (%car wt)])
- (%condition-variable-waiters-set! mx (%cdr wt))
- top ) )
-
-(define-inline (%condition-variable-specific cv)
- (%structure-ref cv 3) )
-
-(define-inline (%condition-variable-specific-set! cv x)
- (%structure-set!/mutate cv 3 x) )
diff --git a/csc.scm b/csc.scm
index b625af8e..eafad0a3 100644
--- a/csc.scm
+++ b/csc.scm
@@ -442,7 +442,6 @@ Usage: csc FILENAME | OPTION ...
-debug MODES display debugging output for the given modes
-compiler PATHNAME use other compiler than default `chicken'
- -disable-c-syntax-checks disable syntax checks of C code fragments
-raw do not generate implicit init- and exit code
-emit-external-prototypes-first
emit prototypes for callbacks before foreign
diff --git a/distribution/manifest b/distribution/manifest
index ca3d97c4..35278aca 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -221,7 +221,6 @@ rules.make
defaults.make
private-namespace.scm
compiler-namespace.scm
-scripts/scheme
scripts/tools.scm
scripts/test-dist.sh
scripts/wiki2html.scm
diff --git a/hen.el b/hen.el
deleted file mode 100644
index 00b3ec90..00000000
--- a/hen.el
+++ /dev/null
@@ -1,567 +0,0 @@
-;;; HEN.EL --- mode for editing chicken code
-
-;; Copyright (C) 2004 Linh Dang
-
-;; Author: Linh Dang <linhd@>
-;; Maintainer: Linh Dang <linhd@>
-;; Created: 19 Apr 2004
-;; Version: 1
-;; Keywords:
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 1, or (at your option)
-;; any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; A copy of the GNU General Public License can be obtained from this
-;; program's author (send electronic mail to <linhd@>) or from the
-;; Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
-;; USA.
-
-;; LCD Archive Entry:
-;; hen|Linh Dang|<linhd@>
-;; | mode for editing chicken code
-;; |$Date: 2004/11/22 22:36:11 $|$Revision: 1.13 $|~/packages/hen.el
-
-;;; Commentary:
-;; Hen is a mode derived from scheme-mode and is specialized for
-;; editing chicken scheme.
-;; This mode assumes:
-;; - the user has chicken.info install
-;; - the csi executable can be launch as "csi"
-
-;;
-;; Changes by Micky Latowicki:
-;;
-;; * Added implementation of with-temp-message, which is missing from xemacs 21.4.
-;; * Added trivial display-mouse-p, which is similarly missing.
-;; * fixed font-lock problems.
-;; * removed most calls to accept-process-output, which made
-;; hen unacceptably slow.
-;; * removed (apparently) redundant call to hen-proc-wait-prompt in
-;; hen-proc-send
-;; * updated prompt regexp pattern to include the running number.
-;; * start csi with -quiet
-;; * fixed completions, made them more like emacs lisp behaviour.
-;; Note: completions were fixed at the cost of feeding csi the commands
-;; (require 'srfi-1) and (require 'regex) before matching strings are
-;; searched for. This was done because the completions-searching code
-;; relies on these libraries. A true fix would be to statically link these
-;; libraries into csi, because the way it works now the user cannot choose
-;; to keep srfi-1 and regex out of her csi environment.
-
-;; Changes by felix:
-;;
-;; * removed hen-describe-symbol
-;; * various cleaning up
-;; * still pretty bad...
-
-;; Changes by Adhi Hargo:
-;;
-;; * automatically raise *csi* buffer on any relevant operations, and
-;; made it a read-only buffer.
-;; * changes definition-at-point evaluation command.
-;; * s-exp evaluation no longer shown in minibuffer.
-;; * added : + Hen-mode customization group.
-;; + Buffer evaluation command.
-;; + csi process-terminating command, partly so I can erase
-;; previous definitions and start anew.
-;; + close-parens-at-point command, from SLIME.
-;; + modification-check before compilation.
-
-;;; Code:
-
-(defconst hen-version (substring "$Revision: 1.13 $" 11 -2)
- "$Id: hen.el,v 1.13 2004/11/22 22:36:11 flw Exp $
-
-Report bugs to: Felix Winkelmann <bunny351@gmail.com>")
-
-(require 'scheme)
-(require 'compile)
-
-;;; GROUP DECLARATION ================================================
-
-(defgroup hen nil
- "Major mode for editing Scheme programs using Chicken."
- :version "21.3"
- :group 'scheme
- :prefix "hen-")
-(defgroup hen-font-face nil
- "Various font face configurations."
- :group 'hen)
-
-(defun hen-version ()
- "Outputs Hen's current version to the minibuffer."
- (interactive)
- (message "Hen %s" hen-version))
-
-;;; USER-CONFIGURABLE COMMANDS =======================================
-
-(defcustom hen-csc-program "csc"
- "*Chicken compiler executable's filename."
- :group 'hen
- :type 'string)
-(defcustom hen-csi-program "csi"
- "*Chicken interpreter executable's filename."
- :group 'hen
- :type 'string)
-(defcustom hen-build-exec-arg ""
- "*Compiler-argument when building an executable file."
- :group 'hen
- :type 'string)
-(defcustom hen-build-obj-arg ""
- "*Compiler-argument when building an object file."
- :group 'hen
- :type 'string)
-(defcustom hen-eval-init-arg ""
- "*Additional interpreter argument."
- :group 'hen
- :type 'string)
-
-(defcustom hen-autosave-buffer-before-compile nil
- "*Save modified file automatically before compilation.
-The default behavior is to ask the user whether to save or not."
- :group 'hen
- :type 'boolean)
-
-(defcustom hen-load-hook nil
- "Hook run after entering Hen mode."
- :group 'hen
- :type 'hook)
-
-
-;; with-temp-message pasted from a mailing list. It's not available in my xemacs 21.4
-(unless (functionp 'with-temp-message)
- (defmacro with-temp-message (message &rest body)
- "Display MESSAGE temporarily while BODY is evaluated.
-The original message is restored to the echo area after BODY has finished.
-The value returned is the value of the last form in BODY."
- (let ((current-message (make-symbol "current-message"))
- (temp-message (make-symbol "with-temp-message")))
- `(let ((,temp-message ,message)
- (,current-message))
- (unwind-protect
- (progn
- (when ,temp-message
- (setq ,current-message (current-message))
- (message "%s" ,temp-message))
- ,@body)
- (and ,temp-message ,current-message
- (message "%s" ,current-message)))))))
-
-;; display-mouse-p not available in xemacs 21.4, so here's a quick fix, sort of.
-(unless (functionp 'display-mouse-p)
- (defun display-mouse-p (&optional display) t))
-
-(defconst hen-syntax-table
- (let ((tab (copy-syntax-table scheme-mode-syntax-table)))
- (modify-syntax-entry ?# "_ " tab)
- (modify-syntax-entry ?: "_ " tab)
- (modify-syntax-entry ?\[ "(] " tab)
- (modify-syntax-entry ?\] ")[ " tab)
-
- tab))
-
-(defconst hen-font-lock-keywords-1
- (eval-when-compile
- (list
- ;; Declarations
- (list (concat "\\(?:(\\|\\[\\)"
- "\\(" (regexp-opt
- '("define"
- "define-class"
- "define-external"
- "define-constant"
- "define-datatype"
- "define-foreign-type"
- "define-foreign-variable"
- "define-foreign-record"
- "define-generic"
- "define-inline"
- "define-macro"
- "define-method"
- "define-reader-ctor"
- "define-record"
- "defstruct"
- "define-record-printer"
- "define-record-type"
- "define-compiler-macro"
- "define-syntax"
- "define-for-syntax"
- "define-values") 1) "\\)"
- "\\s-+(?\\(\\(\\sw\\|\\s_\\)+\\)")
-
- '(1 font-lock-keyword-face t t)
- '(2 font-lock-function-name-face t t))))
- "Basic font-locking for Hen mode.")
-
-(defconst hen-font-lock-keywords-2
- (append hen-font-lock-keywords-1
- (eval-when-compile
- (list
- ;;
- ;; Control structures.
- (cons
- (concat
- "\\<" (regexp-opt
- '("begin" "begin0" "else"
- "else"
- "foreign-lambda*" "foreign-safe-lambda*" "foreign-primitive"
- "foreign-declare" "foreign-parse" "foreign-parse/declare"
- "foreign-lambda" "foreign-safe-lambda" "foreign-code"
- "match" "match-lambda" "match-lambda*" "match-define" "match-let" "match-let*"
-
- "case" "case-lambda" "cond" "cond-expand" "condition-case" "select"
- "handle-exceptions"
- "cut" "cute" "time" "regex-case"
-
- "do" "else" "if" "lambda" "when" "while" "if*" "unless"
-
- "let-location" "location" "rec"
- "let" "let*" "let-syntax" "letrec" "letrec-syntax" "set!-values"
- "and-let*" "let-optionals" "let-optionals*" "optional"
- "fluid-let" "let-values" "let*-values" "letrec-values"
- "parameterize"
- "module" "import-only" "import" "import*"
-
- "and" "or" "delay" "receive"
-
- "assert" "ignore-errors" "ensure" "eval-when"
-
- "loop" "sc-macro-transformer"
-
- "declare" "include" "require-extension" "require" "require-for-syntax" "use" "quasiquote"
-
- "syntax" "with-syntax" "syntax-case" "identifier-syntax" "syntax-rules") t)
- "\\>") 'font-lock-keyword-face)
- '("\\<set!" . font-lock-keyword-face)
- ;;
- ;; `:' keywords as builtins.
- '("#?\\<:\\sw+\\>" . font-lock-builtin-face)
- '("\\<\\sw+:\\>" . font-lock-builtin-face)
- '(",@?\\|`" . font-lock-builtin-face)
- '("\\(##\\sw+#\\)" (1 font-lock-builtin-face t nil))
- '("#\\\\?\\sw+" (0 font-lock-constant-face nil t))
-;? '("(\\(declare\\|require\\(-extension\\)?\\)" . font-lock-keyword-face)
- )))
- "Gaudy expressions to highlight in Hen mode.")
-
-(defconst hen-font-lock-keywords hen-font-lock-keywords-2)
-
-(mapc (lambda (cell)
- (put (car cell) 'scheme-indent-function (cdr cell)))
- '((begin0 . 0)
-
- (when . 1) (while . 1) (unless . 1)
- (and-let* . 1) (fluid-let . 1)
-
- (call-with-input-pipe . 1)
- (call-with-ouput-pipe . 1)
- (call-with-input-string . 1)
- (call-with-input-string . 1)
-
- (call-with-values . 1)
-
- (with-input-from-pipe . 1)
- (with-ouput-to-pipe . 0)
- (with-input-from-string . 1)
- (with-output-to-string . 0)
-
- (if* . 2)))
-
-(defun hen-identifier-at-point ()
- "Return the identifier close to the cursor."
- (save-excursion
- (save-match-data
- (let ((beg (line-beginning-position))
- (end (line-end-position))
- (pos (point)))
- (cond ((progn (goto-char pos)
- (skip-chars-forward " \t" end)
- (skip-syntax-backward "w_" beg)
- (memq (char-syntax (following-char)) '(?w ?_)))
- (buffer-substring-no-properties (point) (progn (forward-sexp 1) (point))))
- ((progn (goto-char pos)
- (skip-chars-backward " \t" beg)
- (skip-syntax-forward "w_" end)
- (memq (char-syntax (preceding-char)) '(?w ?_)))
- (buffer-substring-no-properties (point) (progn (forward-sexp -1) (point))))
- (t nil))))))
-
-(defun hen-build (cmd args)
- (when (and (buffer-modified-p)
- (or hen-autosave-buffer-before-compile
- (progn (beep)
- (y-or-n-p "File modified. Save it? "))))
- (save-buffer))
- (compile-internal (mapconcat 'identity (cons cmd args) " ")
- "No more errors" "csc" nil
- `(("Error:.+in line \\([0-9]+\\):" 0 1 nil ,(buffer-file-name)))
- (lambda (ignored) "*csc*")))
-
-(defun hen-build-extension ()
- (interactive)
- (let* ((file-name (file-name-nondirectory
- (buffer-file-name))))
- (hen-build hen-csc-program (list "-s" file-name hen-build-obj-arg))))
-
-(defun hen-build-program ()
- (interactive)
- (let* ((file-name (file-name-nondirectory
- (buffer-file-name))))
- (hen-build hen-csc-program (list file-name hen-build-exec-arg))))
-
-(define-derived-mode hen-mode scheme-mode "Hen"
- "Mode for editing chicken Scheme code.
-\\[hen-csi-eval-last-sexp] evaluates the sexp at/preceding point in csi.
-\\[hen-csi-eval-region] evaluates the region in csi.
-\\[hen-csi-eval-buffer] evaluates current buffer in csi.
-\\[hen-csi-eval-definition] evaluates the toplevel definition at point in csi.
-\\[hen-csi-send] reads a sexp from the user and evaluates it csi.
-\\[hen-csi-proc-delete] terminates csi subprocess.
-\\[hen-close-parens-at-point] closes parentheses for top-level sexp at point.
-\\[hen-build-extension] compiles the current file as a shared object
-\\[hen-build-program] compiles the current file as a program
-"
-
- (set-syntax-table hen-syntax-table)
- (setq local-abbrev-table scheme-mode-abbrev-table)
-
- (define-key hen-mode-map (kbd "C-c C-e") 'hen-csi-eval-last-sexp)
- (define-key hen-mode-map (kbd "C-c C-r") 'hen-csi-eval-region)
- (define-key hen-mode-map (kbd "C-c C-b") 'hen-csi-eval-buffer)
- (define-key hen-mode-map (kbd "C-c C-d") 'hen-csi-eval-definition)
- (define-key hen-mode-map (kbd "C-c C-l") 'hen-build-unit)
- (define-key hen-mode-map (kbd "C-c C-x") 'hen-csi-send)
- (define-key hen-mode-map (kbd "C-c C-q") 'hen-csi-proc-delete)
- (define-key hen-mode-map (kbd "C-c C-l") 'hen-build-extension)
- (define-key hen-mode-map (kbd "C-c C-c") 'hen-build-program)
- (define-key hen-mode-map (kbd "C-c C-]") 'hen-close-parens-at-point)
-
- (define-key hen-mode-map [menu-bar scheme run-scheme] nil)
- (define-key hen-mode-map [menu-bar shared build-prog] '("Compile File" hen-build-program))
- (define-key hen-mode-map [menu-bar shared send-to-csi] '("Evaluate" . hen-csi-send))
- (define-key hen-mode-map [menu-bar scheme build-as-extension]
- '("Compile File as Extension" . hen-build-extension))
- (define-key hen-mode-map [menu-bar scheme eval-buffer] '("Eval Buffer" . hen-csi-eval-buffer))
- (define-key hen-mode-map [menu-bar scheme eval-region] '("Eval Region" . hen-csi-eval-region))
- (define-key hen-mode-map [menu-bar scheme eval-last-sexp]
- '("Eval Last S-Expression" . hen-csi-eval-last-sexp))
-
- (setq font-lock-defaults
- '((hen-font-lock-keywords
- hen-font-lock-keywords-1 hen-font-lock-keywords-2)
- nil t
- ((?+ . "w") (?- . "w") (?* . "w") (?/ . "w")
- (?. . "w") (?< . "w") (?> . "w") (?= . "w")
- (?? . "w") (?$ . "w") (?% . "w") (?_ . "w")
- (?& . "w") (?~ . "w") (?^ . "w") (?: . "w"))
- beginning-of-defun
- (font-lock-mark-block-function . mark-defun)))
- (make-local-variable 'paragraph-start)
- (setq paragraph-start (concat page-delimiter "\\|$" ))
-
- (make-local-variable 'paragraph-separate)
- (setq paragraph-separate paragraph-start)
-
- (make-local-variable 'paragraph-ignore-fill-prefix)
- (setq paragraph-ignore-fill-prefix t)
-
- (make-local-variable 'adaptive-fill-mode)
- (setq adaptive-fill-mode nil)
-
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments t)
-
- (make-local-variable 'outline-regexp)
- (setq outline-regexp ";;;;* \\|(")
-
- (make-local-variable 'comment-start)
- (setq comment-start ";")
-
- (make-local-variable 'comment-column)
- (setq comment-column 40)
-
- (make-local-variable 'comment-add)
- (setf comment-add 1)
- )
-
-;;stolen from cxref
-(defun hen-looking-backward-at (regexp)
- "Return t if text before point matches regular expression REGEXP.
-This function modifies the match data that `match-beginning',
-`match-end' and `match-data' access; save and restore the match
-data if you want to preserve them."
- (save-excursion
- (let ((here (point)))
- (if (re-search-backward regexp (point-min) t)
- (if (re-search-forward regexp here t)
- (= (point) here))))))
-
-(defun hen-proc-wait-prompt (proc prompt-re &optional timeout msg)
- "Wait for the prompt of interactive process PROC. PROMPT-RE must be
-a regexp matching the prompt. TIMEOUT is the amount of time to wait in
-secs before giving up. MSG is the message to display while waiting."
- (setq timeout (if (numberp timeout) (* timeout 2) 60))
- (unless (stringp msg)
- (setq msg (concat "wait for " hen-csi-proc-name "'s prompt")))
- (goto-char (process-mark proc))
- (if (hen-looking-backward-at prompt-re)
- t
- (while (and (> timeout 0) (not (hen-looking-backward-at prompt-re)))
- (with-temp-message (setq msg (concat msg "."))
- (accept-process-output proc 0 timeout))
- (setq timeout (1- timeout))
- (goto-char (process-mark proc)))
- (with-temp-message (concat msg (if (> timeout 0)
- " got it!" " timeout!"))
- (sit-for 0 100))
- (> timeout 0))
- )
-
-(defun hen-proc-send (question proc prompt-re &optional timeout msg)
- "Send the string QUESTION to interactive process proc. PROMPT-RE is
-the regexp matching PROC's prompt. TIMEOUT is the amount of time to
-wait in secs before giving up. MSG is the message to display while
-waiting."
- (setq timeout (if (numberp timeout) (* timeout 2) 60))
- (save-excursion
- (set-buffer (process-buffer proc))
- (widen)
- (save-match-data
- (goto-char (process-mark proc))
- (if (hen-looking-backward-at prompt-re)
- (let ((start (match-end 0)))
- (narrow-to-region start (point-max))
- (process-send-string proc (concat question "\n"))
- (hen-proc-wait-prompt proc prompt-re timeout msg)
- (narrow-to-region start (match-beginning 0))
- (current-buffer))))))
-
-(defconst hen-csi-prompt-pattern "#;[0-9]*> ")
-(defconst hen-csi-proc-name "csi")
-(defconst hen-csi-buffer-name "*csi*")
-
-(defun hen-csi-buffer-create ()
- "Creates a new buffer for csi, make it read-only."
- (let ((buffer (get-buffer-create hen-csi-buffer-name)))
- (with-current-buffer buffer
- (make-local-variable 'buffer-read-only)
- (setf buffer-read-only t))
- buffer))
-
-(defun hen-csi-buffer-erase ()
- "Erases csi buffer's content, used mainly when its process was being
-reset."
- (let ((buffer (get-buffer hen-csi-buffer-name)))
- (unless (null buffer) (with-current-buffer buffer
- (setf buffer-read-only '())
- (erase-buffer)
- (setf buffer-read-only t)))))
-
-(defun hen-csi-buffer ()
- (let ((buffer (or (get-buffer hen-csi-buffer-name) ;check if exists
- (hen-csi-buffer-create)))) ;... or create one
- (display-buffer buffer)
- buffer))
-
-(defun hen-csi-proc ()
- (let ((proc (get-process hen-csi-proc-name)))
- (if (and (processp proc)
- (eq (process-status proc) 'run))
- proc
- (setq proc
- (eval `(start-process hen-csi-proc-name (hen-csi-buffer)
- hen-csi-program
- "-no-init" "-quiet" "-:c" "-R" "srfi-1" "-R" "regex" "-R" "utils"
- ,@(split-string hen-eval-init-arg))))
- (with-current-buffer (hen-csi-buffer)
- (hen-proc-wait-prompt proc hen-csi-prompt-pattern)
- proc))))
-
-(defun hen-csi-proc-delete ()
- (interactive)
- (let ((proc (get-process hen-csi-proc-name)))
- (when (and (processp proc)
- (eq (process-status proc) 'run))
- (delete-process proc))
- (hen-csi-buffer-erase)
- ()))
-
-(defun hen-csi-send (sexp)
- "Evaluate SEXP in CSI"
- (interactive
- (let ((sexp (read-string "Evaluate S-expression: "))
- (send-sexp-p nil))
- (unwind-protect
- (progn
- (let ((obarray (make-vector 11 0)))
- (read sexp)
- (setq send-sexp-p t)))
- (unless send-sexp-p
- (setq send-sexp-p
- (y-or-n-p (format "`%s' is not a valid sexp! evaluate anyway? " sexp)))))
- (list (if send-sexp-p sexp nil))))
- (when (stringp sexp)
- (let* ((proc (hen-csi-proc))
- (buf (hen-proc-send (concat sexp "\n") proc hen-csi-prompt-pattern))
- result len)
- (unless (buffer-live-p buf)
- (error "Internal hen-mode failure"))
-
- (save-excursion
- (with-current-buffer buf
- (setq result (buffer-string))
- (setq len (length result))
- (if (and (> len 0)
- (eq (aref result (1- len)) ?\n))
- (setq result (substring result 0 -1)))
- result)))))
-
-(defun hen-csi-eval-buffer ()
- "Evaluate the current buffer in CSI"
- (interactive)
- (hen-csi-send (buffer-string)))
-
-(defun hen-csi-eval-region (beg end)
- "Evaluate the current region in CSI."
- (interactive "r")
- (hen-csi-send (buffer-substring beg end)))
-
-(defun hen-csi-eval-last-sexp ()
- "Evaluate the s-expression at point in CSI"
- (interactive)
- (hen-csi-eval-region (save-excursion (backward-sexp) (point))
- (point)))
-
-(defun hen-csi-eval-definition ()
- "Evaluate the enclosing top-level form in CSI."
- (interactive)
- (hen-csi-eval-region (save-excursion
- (end-of-defun) (beginning-of-defun)
- (point))
- (save-excursion
- (end-of-defun) (point))))
-
-;; from SLIME
-(defun hen-close-parens-at-point ()
- "Close parenthesis at point to complete the top-level-form. Simply
-inserts ')' characters at point until `beginning-of-defun' and
-`end-of-defun' execute without errors, or internal variable
-`close-parens-limit' is exceeded."
- (interactive)
- (let ((close-parens-limit 16))
- (loop for i from 1 to close-parens-limit
- until (save-excursion
- (beginning-of-defun)
- (ignore-errors (end-of-defun) t))
- do (insert ")"))))
-
-(provide 'hen)
-(run-hooks 'hen-load-hook)
-;;; HEN.EL ends here
diff --git a/manual/Unit files b/manual/Unit files
index f4cc74be..8657159a 100644
--- a/manual/Unit files
+++ b/manual/Unit files
@@ -119,7 +119,7 @@ Returns 3 values: the {{base-origin}}, {{base-directory}}, and the
{{DIRECTORY}} is a {{string}}.
-* On WIndows {{(decompose-directory "c:foo/bar")}} => {{"c:" #f ("foo" "bar")}}
+* On Windows {{(decompose-directory "c:foo/bar")}} => {{"c:" #f ("foo" "bar")}}
=== Temporary files
diff --git a/cconv-sample.c b/misc/cconv-sample.c
similarity index 83%
rename from cconv-sample.c
rename to misc/cconv-sample.c
index 56325686..f169b700 100644
--- a/cconv-sample.c
+++ b/misc/cconv-sample.c
@@ -1,4 +1,4 @@
-/* cconv-sample.c */
+/* cconv-sample.c - code to disassemble if you want to figure out calling conventions */
#include "chicken.h"
diff --git a/misc/inline.scm b/misc/inline.scm
deleted file mode 100644
index 524fe624..00000000
--- a/misc/inline.scm
+++ /dev/null
@@ -1,418 +0,0 @@
-;;; this assumes that :
-;;; a) nothing has been evaluated yet
-;;; b) basic syntactical correctness has been assured (so a list l starting
-;;; with 'define-inline will have the procedure-name as (caadr l) and
-;;; arity for all procedure calls is correct)
-;;; c) alpha substitution has occurred so all named symbols are guaranteed
-;;; unique across all procedures
-;;; d) optional, keyword, and rest arguments are not allowed for inline
-;;; procedures (although it should be possible to add them)
-
-;; beginning of the pass
-;; takes the ordered quoted list of all top-level statements
-;; ends by calling either
-;; inline-pass:final with the input list (if no inline procedures exist) and
-;; null, or
-;; inline-pass:graph-inline with two lists, the inline procedures (with some
-;; metadata) and all non-inline-procedure statements.
-(define (inline-pass:start qlst)
- (let find-inline ((q qlst) ; quoted top-level statements
- (i 0) ; index of inline procedure for later steps
- (l '()) ; inline procedures
- (r '())) ; non-inline statements
- (cond ((null? q)
- (if (= 0 i)
- (inline-pass:final (reverse r) '())
- (inline-pass:graph-inline i (reverse l) (reverse r))))
- ((and (list? (car q)) (eq? 'define-inline (caar q)))
- (find-inline
- (cdr q)
- (+ 1 i)
- (cons (cons (caadar q)
- (vector i 0 (cddar q) (cdadar q)))
- l)
- r))
- (else
- (find-inline (cdr q) i l (cons (car q) r))))))
-
-
-;; walks through a list
-;; takes a list, an index vector, and the metadata inline list from above
-;; ends by returning the (possibly modified) vector
-(define (inline-pass:walk l v ilst)
- (let walk ((l l)
- (t 0))
- (cond ((null? l)
- v)
- ((list? (car l))
- (cond ((null? (car l))
- (walk (cdr l) t))
- ((eq? 'quote (caar l))
- (or (= 0 t)
- (walk (cdar l) 3))
- (walk (cdr l) t))
- ((eq? 'quasiquote (caar l))
- (walk (cdar l) 2)
- (walk (cdr l) t))
- ((or (eq? 'unquote (caar l))
- (eq? 'unquote-splicing (caar l)))
- (walk (cdar l) 1)
- (walk (cdr l) t))
- (else
- (walk (car l) t)
- (walk (cdr l) t))))
- ((pair? (car l))
- (walk (unfold not-pair? car cdr (car l) list) t)
- (walk (cdr l) t))
- ((vector? (car l))
- (walk (vector->list (car l)) t)
- (walk (cdr l) t))
- ((not (symbol? (car l)))
- (walk (cdr l) t))
- ((> t 1)
- (walk (cdr l) t))
- ((alist-ref (car l) ilst) =>
- (lambda (d)
- (vector-set! v (vector-ref d 0) #t)
- (walk (cdr l) t)))
- (else
- (walk (cdr l) t)))))
-
-
-;; builds a graph of calls to inline procedures from inline procedures
-;; takes the inline-list-length, inline metadata list, and other statements
-;; ends by calling inline-pass:simplify1 with the graph and input args
-(define (inline-pass:graph-inline i ilst rlst)
- (inline-pass:simplify1
- (map
- (lambda (iv)
- (cons (car iv)
- (inline-pass:walk
- (vector-ref (cdr iv) 3)
- (make-vector i #f)
- ilst)))
- ilst)
- i ilst rlst))
-
-
-;; simplifies direct self-call, no further inline, and only-self cases
-;; takes the graph, inline list length, inline metadata list, and statements
-;; ends by calling either:
-;; inline-pass:simplify2 with the further inline, no-further-but-self inline,
-;; graph, inline length, all inline, and other statements, or
-;; inline-pass:final with the statements and inlines
-(define (inline-pass:simplify1 g i ilst rlst)
- (for-each
- (lambda (x)
- (and (vector-ref (cdr x) (car x))
- (vector-set! (cdr (list-ref ilst (car x))) 1 1)))
- g)
- (let simple ((h g) ; graph
- (l ilst) ; inline metadata
- (r '()) ; no further inlines (except possibly self)
- (s '())) ; further inlining
- (cond ((null? h)
- (if (null? s)
- (inline-pass:final rlst r)
- (inline-pass:simplify2 s r g i ilst rlst)))
- ((every (lambda (x i) (or (= i (caar h)) (not x)))
- (vector->list (cdar h)) (iota i))
- (simple (cdr h) (cdr l) (cons (car l) r) s))
- (else
- (simple (cdr h) (cdr l) r (cons (car l) s))))))
-
-;; substitutes in inlined procedures
-;; takes the procedure in which to do the substitution (as a list) and the
-;; list of inlined procedures with metadata
-;; ends with the new procedure-as-list
-;; note: there are four distinct cases -
-;; 1) inline procedure in application position, no self call :
-;; becomes a (begin ...) with the arguments set locally
-;; 2) inline procedure in application position, with self call :
-;; becomes a (let <name> (vars ...) ...)
-;; 3) inline procedure not in application position, no self call :
-;; becomes a (lambda (arglist) ...)
-;; 4) inline procedure not in application position, with self call :
-;; becomes a (lambda (arglist) (let <name> (vars ...) ...) with new
-;; symbols generated for arglist
-(define (inline-pass:subst1 l ilst)
- (let walk ((l l)
- (t 0))
- (cond ((null? l)
- l)
- ((vector? l)
- (list->vector (walk (vector->list l) t)))
- ((symbol? l)
- (cond ((> t 1)
- l)
- ((alist-ref l ilst) =>
- (lambda (d)
- (if (= 1 (vector-ref d 1))
- (let* ((a (map
- (lambda (x) (gensym 'ia))
- (vector-ref d 2)))
- (m (map
- (lambda (a x) (list a x))
- (vector-ref d 2) a)))
- `(lambda ,a (let ,l ,m
- ,@(vector-ref d 3))))
- `(lambda ,(vector-ref d 2)
- ,@(vector-ref d 3)))))
- (else
- l)))
- ((not (pair? l))
- l)
- ((list? (car l))
- (cond ((null? (car l))
- (cons (car l) (walk (cdr l) t)))
- ((not (symbol? (caar l)))
- (cons (walk (car l) t) (walk (cdr l) t)))
- ((eq? 'quote (caar l))
- (if (= t 0)
- (cons (car l) (walk (cdr l) t))
- (cons `(quote ,(walk (cadr l) 3))
- (walk (cdr l) t))))
- ((eq? 'quasiquote (caar l))
- (cons `(quasiquote ,(walk (cadr l) 2))
- (walk (cdr l) t)))
- ((or (eq? 'unquote (caar l))
- (eq? 'unquote-splicing (caar l)))
- (cons `(,(caar l) ,(walk (cadr l) 1))
- (walk (cdr l) t)))
- ((> t 1)
- (cons (walk (car l) t) (walk (cdr l) t)))
- ((alist-ref (caar l) ilst) =>
- (lambda (d)
- (cons
- (if (= 1 (vector-ref d 1))
- (let ((m (map
- (lambda (a x) (list a x))
- (vector-ref d 2)
- (walk (cdar l) t))))
- `(let ,(caar l) ,m
- ,@(vector-ref d 3)))
- `(begin
- ,@(map
- (lambda (a x)
- `(set-local! ,a ,x))
- (vector-ref d 2)
- (walk (cdar l) t))
- ,@(vector-ref d 3)))
- (walk (cdr l) t))))
- (else
- (cons (walk (car l) t) (walk (cdr l) t)))))
- ((pair? (car l))
- (cons (cons (walk (caar l) t) (walk (cdar l) t))
- (walk (cdr l) t)))
- ((vector? (car l))
- (cons (list->vector (walk (vector->list (car l)) t))
- (walk (cdr l) t)))
- ((not (symbol? (car l)))
- (cons (car l) (walk (cdr l) t)))
- ((> t 1)
- (cons (car l) (walk (cdr l) t)))
- ((alist-ref (car l) ilst) =>
- (lambda (d)
- (cons
- (if (= 1 (vector-ref d 1))
- (let* ((a (map
- (lambda (x) (gensym 'ia))
- (vector-ref d 2)))
- (m (map
- (lambda (a x) (list a x))
- (vector-ref d 2) a)))
- `(lambda ,a (let ,(car l) ,m
- ,@(vector-ref d 3))))
- `(lambda ,(vector-ref d 2) ,@(vector-ref d 3)))
- (walk (cdr l) t))))
- (else
- (cons (car l) (walk (cdr l) t))))))
-
-
-;; substitutes in inlined procedures with further processing
-;; takes the procedure in which to do the substitution (as a list), the
-;; list of inlined procedures with metadata, and a list of procedures to
-;; not treat as inline
-;; ends with the new procedure-as-list
-;; note: there are four distinct cases -
-;; 1) inline procedure in application position, no self call :
-;; becomes a (begin ...) with the arguments set locally
-;; 2) inline procedure in application position, with self call :
-;; becomes a (let <name> (vars ...) ...)
-;; 3) inline procedure not in application position, no self call :
-;; becomes a (lambda (arglist) ...)
-;; 4) inline procedure not in application position, with self call :
-;; becomes a (lambda (arglist) (let <name> (vars ...) ...) with new
-;; symbols generated for arglist
-(define (inline-pass:subst2 l ilst nof)
- (let walk ((l l)
- (n nof)
- (t 0))
- (cond ((null? l)
- l)
- ((vector? l)
- (list->vector (walk (vector->list l) t n)))
- ((symbol? l)
- (cond ((> t 1)
- l)
- ((memq l n) =>
- (lambda (m)
- (let ((d (alist-ref l ilst)))
- (if (= 1 (vector-ref d 1))
- l
- (begin
- (vector-set! d 1 1)
- (if (= 1 (length m))
- l
- (walk l t (cdr m))))))))
- ((alist-ref l ilst) =>
- (lambda (d)
- (if (= 1 (vector-ref d 1))
- (let* ((a (map
- (lambda (x) (gensym 'ia))
- (vector-ref d 2)))
- (m (map
- (lambda (a x) (list a x))
- (vector-ref d 2) a)))
- `(lambda ,a (let ,l ,m
- ,@(walk (vector-ref d 3) t
- (cons l n)))))
- `(lambda ,(vector-ref d 2)
- ,@(walk (vector-ref d 3) t
- (cons l n))))))
- (else
- l)))
- ((not (pair? l))
- l)
- ((list? (car l))
- (cond ((null? (car l))
- (cons (car l) (walk (cdr l) t n)))
- ((not (symbol? (caar l)))
- (cons (walk (car l) t n) (walk (cdr l) t n)))
- ((eq? 'quote (caar l))
- (if (= t 0)
- (cons (car l) (walk (cdr l) t n))
- (cons `(quote ,(walk (cadr l) 3 n))
- (walk (cdr l) t n))))
- ((eq? 'quasiquote (caar l))
- (cons `(quasiquote ,(walk (cadr l) 2 n))
- (walk (cdr l) t n)))
- ((or (eq? 'unquote (caar l))
- (eq? 'unquote-splicing (caar l)))
- (cons `(,(caar l) ,(walk (cadr l) 1 n))
- (walk (cdr l) t n)))
- ((> t 1)
- (cons (walk (car l) t n) (walk (cdr l) t n)))
- ((memq (caar l) n) =>
- (lambda (m)
- (let ((d (alist-ref (caar l) ilst)))
- (if (= 1 (vector-ref d 1))
- (cons (cons (caar l)
- (walk (cdar l) t n))
- (walk (cdr l) t n))
- (begin
- (vector-set! d 1 1)
- (if (= 1 (length m))
- (cons (cons (caar l)
- (walk (cdar l) t n))
- (walk (cdr l) t n))
- (walk l t
- (cdr m))))))))
- ((alist-ref (caar l) ilst) =>
- (lambda (d)
- (cons
- (if (= 1 (vector-ref d 1))
- (let ((m (map
- (lambda (a x) (list a x))
- (vector-ref d 2)
- (walk (cdar l) t
- (cons (caar l) n)))))
- `(let ,(caar l) ,m
- ,@(walk (vector-ref d 3) t
- (cons (caar l) n))))
- `(begin
- ,@(map
- (lambda (a x)
- `(set-local! ,a ,x))
- (vector-ref d 2)
- (walk (cdar l) t
- (cons (caar l) n)))
- ,@(walk (vector-ref d 3) t
- (cons (caar l) n))))
- (walk (cdr l) t n))))
- (else
- (cons (walk (car l) t n) (walk (cdr l) t n)))))
- ((pair? (car l))
- (cons (cons (walk (caar l) t n) (walk (cdar l) t n))
- (walk (cdr l) t n)))
- ((vector? (car l))
- (cons (list->vector (walk (vector->list (car l)) t n))
- (walk (cdr l) t n)))
- ((not (symbol? (car l)))
- (cons (car l) (walk (cdr l) t n)))
- ((> t 1)
- (cons (car l) (walk (cdr l) t)))
- ((memq (car l) n) =>
- (lambda (m)
- (let ((d (alist-ref (car l) ilst)))
- (if (= 1 (vector-ref d 1))
- (cons (car l) (walk (cdr l) t n))
- (begin
- (vector-set! d 1 1)
- (if (= 1 (length m))
- (cons (car l) (walk (cdr l) t n))
- (walk l t (cdr m))))))))
- ((alist-ref (car l) ilst) =>
- (lambda (d)
- (cons
- (if (= 1 (vector-ref d 1))
- (let* ((a (map
- (lambda (x) (gensym 'ia))
- (vector-ref d 2)))
- (m (map
- (lambda (a x) (list a x))
- (vector-ref d 2) a)))
- `(lambda ,a (let ,l ,m
- ,@(walk (vector-ref d 3) t
- (cons (car l) n)))))
- `(lambda ,(vector-ref d 2)
- ,@(walk (vector-ref d 3) t (cons (car l) n))))
- (walk (cdr l) t n))))
- (else
- (cons (car l) (walk (cdr l) t n))))))
-
-;; finds which inlined procedures are called from non-inlined procedures
-;; performs substitutions for all inline procedures
-;; takes the further inline procedures, no further inline procedures, graph,
-;; inlined procedures list, and statements list
-;; ends by calling inline-pass:final with the statements and inline procedures
-;; ready for substitution
-(define (inline-pass:simplify2 fur nof g ilst rlst)
- (for-each
- (lambda (x)
- (vector-set! (cdr x) 3
- (inline-pass:subst1 (vector-ref (cdr x) 3) nof)))
- fur)
- (let ((v (inline-pass:walk rlst (make-vector i #f) fur)))
- (for-each
- (lambda (x)
- (vector-set! (cdr x) 3
- (inline-pass:subst2 (vector-ref (cdr x) 3) ilst
- (list (car x)))))
- (vector-fold
- (lambda (i r x)
- (if x
- (cons (list-ref ilst i) r)
- r))
- '() v))
- (inline-pass:final rlst ilst)))
-
-
-;; inlines all procedures
-;; takes the list of statements and the list of inline procedures with metadata
-;; returns the list of statements with all procedures inlined
-(define (inline-pass:final rlst ilst)
- (if (null? ilst)
- rlst
- (inline-pass:subst1 rlst ilst)))
-
diff --git a/misc/linux-runner.c b/misc/linux-runner.c
deleted file mode 100644
index 8a3205a7..00000000
--- a/misc/linux-runner.c
+++ /dev/null
@@ -1,212 +0,0 @@
-/*
- * getexename.c
- *
- * written by Nicolai Haehnle <prefect_@gmx.net>
- * I hereby release this trivial piece of code to the public domain.
- *
- * The function getexename() returns the filename of the currently loaded
- * executable.
- *
- * Intended use of this function is to facilitate easier packaging of
- * third-party software for the Linux operating system. The FHS mandates
- * that files that belong to one package are scattered throughout the
- * file system. This works as long as packages are maintained by a
- * package management program. However, it is impossible for application
- * developers to provide packages for every Linux distribution out there.
- * Finding the file locations is also difficult when an application is
- * installed locally by a user inside her own home directory.
- *
- * The simplest and most straight-forward solution to this problem is to
- * put all files belonging to a package into the same directory. The program
- * executable can then reference the necessary data files by using paths
- * relative to the executable location.
- * To give an example:
- *
- * A simple game, consisting of an executable and a number of data files
- * (e.g. images), resides entirely in one directory, with absolute filenames
- * like this:
- * /the/path/foogame
- * /the/path/images/hero.png
- * /the/path/images/badass.png
- * The game executable can use getexename() to find its own location, strip
- * off the last component to get the directory the executable is located in,
- * and append the relative paths "images/hero.png" and "images/badass.png"
- * to reference the data files.
- * The game will be completely position independent. The user is free to
- * move it somewhere else in the filesystem, and it will just work; it will
- * no longer be necessary to change configuration files or even recompile the
- * executable.
- *
- * If you are concerned about executables showing up in a user's PATH, you
- * should somehow arrange for symlinks to be made. For example, if
- * /usr/games/foogame is a symlink to /the/path/foogame, the user can run the
- * game simply by typing "foogame" in the shell (provided that /usr/games is in
- * the user's PATH); since symlinks cannot fool getexename(), the game will
- * still work. (Do note that a hard link will defeat getexename()).
- *
- * Note that while it is possible to reference data files based on the current
- * working directory, this technique only works if the user explicitly sets
- * the CWD to the application's base directory. Therefore, using the executable
- * name as a base is more robust.
- *
- * Also note that while argv[0] can be used as the executable name in many
- * cases as well, it is easily fooled by symlinks and may not contain an
- * absolute filename. argv[0] can also be set to something entirely different
- * from the executable filename by the executing process, either delibaretly
- * or by invoking scripts.
- *
- * Note that this function relies on the layout of the /proc file system, so
- * portability is an issue. While I assume that this part of /proc is fairly
- * stable, I have no documentation whatsoever about potential differences
- * between Linux kernel versions in this area.
- *
- */
-
-#include <stdlib.h>
-#include <stdio.h>
-#include <errno.h>
-
-#include <sys/types.h>
-#include <unistd.h>
-
-#ifndef PROGRAM
-# define PROGRAM "main"
-#endif
-
-
-/*
- * getexename - Get the filename of the currently running executable
- *
- * The getexename() function copies an absolute filename of the currently
- * running executable to the array pointed to by buf, which is of length size.
- *
- * If the filename would require a buffer longer than size elements, NULL is
- * returned, and errno is set to ERANGE; an application should check for this
- * error, and allocate a larger buffer if necessary.
- *
- * Return value:
- * NULL on failure, with errno set accordingly, and buf on success. The
- * contents of the array pointed to by buf is undefined on error.
- *
- * Notes:
- * This function is tested on Linux only. It relies on information supplied by
- * the /proc file system.
- * The returned filename points to the final executable loaded by the execve()
- * system call. In the case of scripts, the filename points to the script
- * handler, not to the script.
- * The filename returned points to the actual exectuable and not a symlink.
- *
- */
-char* getexename(char* buf, size_t size)
-{
- char linkname[64]; /* /proc/<pid>/exe */
- pid_t pid;
- int ret;
-
- /* Get our PID and build the name of the link in /proc */
- pid = getpid();
-
- if (snprintf(linkname, sizeof(linkname), "/proc/%i/exe", pid) < 0)
- {
- /* This should only happen on large word systems. I'm not sure
- what the proper response is here.
- Since it really is an assert-like condition, aborting the
- program seems to be in order. */
- abort();
- }
-
-
- /* Now read the symbolic link */
- ret = readlink(linkname, buf, size);
-
- /* In case of an error, leave the handling up to the caller */
- if (ret == -1)
- return NULL;
-
- /* Report insufficient buffer size */
- if (ret >= size)
- {
- errno = ERANGE;
- return NULL;
- }
-
- /* Ensure proper NUL termination */
- buf[ret] = 0;
-
- return buf;
-}
-
-
-int main(int argc, char *argv[], char *envp[])
-{
- char* buf, buf2[ 256 ], buf3[ 256 ];
- int size;
- static char *env2[ 1024 ];
- char **ep, *cp;
-
- buf = NULL;
- size = 32; /* Set an initial size estimate */
-
- for(;;)
- {
- char* res;
-
- /* Allocate and fill the buffer */
- buf = (char*)malloc(size);
- res = getexename(buf, size);
-
- /* Get out of the loop on success */
- if (res)
- break;
-
- /* Anything but ERANGE indicates a real error */
- if (errno != ERANGE)
- {
- perror("getexename() failed");
- free(buf);
- buf = NULL;
- break;
- }
-
- /* ERANGE means the buffer was too small. Free the current
- buffer and retry with a bigger one. */
- free(buf);
- size *= 2;
- }
-
- /* Exit on failure */
- if (buf == NULL)
- return -1;
-
- cp = strrchr(buf, '/');
-
- if(cp != NULL) *cp = '\0';
-
- ep = env2;
- sprintf(buf2, "LD_LIBRARY_PATH=%s", buf);
- *(ep++) = buf2;
- sprintf(buf3, "CHICKEN_REPOSITORY=%s", buf);
- *(ep++) = buf3;
-
- while(*envp != NULL) {
- char *p2 = strchr(*envp, '=');
-
- if(!strncmp(p2, "CHICKEN_REPOSITORY", strlen("CHICKEN_REPOSITORY")) ||
- !strncmp(p2, "LD_LIBRARY_PATH", strlen("LD_LIBRARY_PATH")))
- ++envp;
- else {
- *ep = *(envp++);
-
- if(*(ep++) == NULL) break;
- }
- }
-
- *ep = NULL;
- strcat(buf, "/");
- strcat(buf, PROGRAM);
-
- if(execve(buf, argv + 1, env2) == -1)
- perror("execve failed");
-
- return 0; /* Indicate success */
-}
diff --git a/misc/mini-runtime/Makefile b/misc/mini-runtime/Makefile
deleted file mode 100644
index c32bc888..00000000
--- a/misc/mini-runtime/Makefile
+++ /dev/null
@@ -1,21 +0,0 @@
-.PHONY: all clean
-
-CC=gcc
-LD=gcc
-CFLAGS=-Os -fomit-frame-pointer -fno-strict-aliasing
-LDFLAGS=-s
-LIBS=-lm
-
-all: mini
-
-mini: lib.o runtime.o
- $(LD) $(LDFLAGS) $^ -o $@ $(LIBS)
-
-runtime.o: ../../runtime.c ../../chicken.h
- $(CC) -c $< -o $@ $(CFLAGS)
-
-lib.o: lib.scm ../../chicken.h
- csc -cx -I../.. $< -o $@ -O2 -d0 -kv -raw -C "$(CFLAGS)"
-
-clean:
- rm -f *.o mini
diff --git a/misc/mini-runtime/lib.scm b/misc/mini-runtime/lib.scm
deleted file mode 100644
index cae0319c..00000000
--- a/misc/mini-runtime/lib.scm
+++ /dev/null
@@ -1,7 +0,0 @@
-;;;; lib.scm
-
-
-(define (##sys#interrupt-hook reason state) #f)
-(define (##sys#error-hook code loc . args) (##core#inline "C_halt" "error"))
-
-(##core#inline "C_halt" "yo!")
diff --git a/rules.make b/rules.make
index 84903182..05b18803 100644
--- a/rules.make
+++ b/rules.make
@@ -1300,33 +1300,11 @@ testclean:
# run tests
-.PHONY: check fullcheck compiler-check
+.PHONY: check
check: $(CHICKEN_SHARED_EXECUTABLE) $(CSI_SHARED_EXECUTABLE) $(CSC_PROGRAM)
cd tests; sh runtests.sh
-# Only for UNIX, yet:
-
-fullcheck: check compiler-check
-
-compiler-check:
- @echo "======================================== packing ..."
- $(MAKE) -f $(SRCDIR)Makefile.$(PLATFORM) dist
- $(REMOVE_COMMAND $(REMOVE_COMMAND_RECURSIVE_OPTIONS) tests$(SEP)chicken-*
- tar -C tests -xzf `ls -t chicken-*.tar.gz | head -1`
- @echo "======================================== building stage 1 ..."
- $(MAKE) -f $(SRCDIR)Makefile.$(PLATFORM) STATICBUILD=1 -C tests$(SEP)chicken-* confclean all
- touch tests$(SEP)chicken-*$(SEP)*.scm
- @echo "======================================== building stage 2 ..."
- $(MAKE) -f $(SRCDIR)Makefile.$(PLATFORM) STATICBUILD=1 -C tests$(SEP)chicken-* confclean all
- cat tests$(SEP)chicken-*$(SEP)*.c >tests$(SEP)stage2.out
- @echo "======================================== building stage 3 ..."
- $(MAKE) -f $(SRCDIR)Makefile.$(PLATFORM) STATICBUILD=1 -C tests$(SEP)chicken-* confclean all
- cat tests$(SEP)chicken-*$(SEP)*.c >tests$(SEP)stage3.out
- diff tests$(SEP)stage2.out tests$(SEP)stage3.out >tests$(SEP)stages.diff
- $(REMOVE_COMMAND) $(REMOVE_COMMAND_RECURSIVE_OPTIONS) tests$(SEP)chicken-*
-
-
# bootstrap from C source tarball
.PHONY: bootstrap bootstrap.tar.gz
@@ -1346,14 +1324,3 @@ $(SRCDIR)bootstrap.tar.gz: distfiles
srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c srfi-69.c posixunix.c posixwin.c regex.c \
scheduler.c profiler.c stub.c expand.c chicken-syntax.c \
$(COMPILER_OBJECTS_1:=.c)
-
-
-# benchmarking
-
-.PHONY: bench
-
-bench:
- @here=`pwd`; \
- cd $(SRCDIR)benchmarks; \
- LD_LIBRARY_PATH=$$here DYLD_LIBRARY_PATH=$$here PATH=$$here:$$PATH \
- $(CSI) -s cscbench.scm $(BENCHMARK_OPTIONS)
diff --git a/scheme-complete.el b/scheme-complete.el
deleted file mode 100644
index 4ed5da76..00000000
--- a/scheme-complete.el
+++ /dev/null
@@ -1,4613 +0,0 @@
-;;; scheme-complete.el -*- Emacs-Lisp -*-
-
-;;; Smart tab completion for Emacs
-
-;;; This code is written by Alex Shinn and placed in the Public
-;;; Domain. All warranties are disclaimed.
-
-;;; This file provides a single function, `scheme-smart-complete',
-;;; which you can use for intelligent, context-sensitive completion
-;;; for any Scheme implementation. To use it just load this file and
-;;; bind that function to a key in your preferred mode:
-;;;
-;;; (autoload 'scheme-smart-complete "scheme-complete" nil t)
-;;; (eval-after-load 'scheme
-;;; '(define-key scheme-mode-map "\e\t" 'scheme-smart-complete))
-;;;
-;;; Alternately, you may want to just bind TAB to the
-;;; `scheme-complete-or-indent' function, which indents at the start
-;;; of a line and otherwise performs the smart completion:
-;;;
-;;; (eval-after-load 'scheme
-;;; '(define-key scheme-mode-map "\t" 'scheme-complete-or-indent))
-;;;
-;;; Note: the completion uses a somewhat less common style than
-;;; typically found in other modes. The first tab will complete the
-;;; longest prefix common to all possible completions. The second
-;;; tab will show a list of those completions. Subsequent tabs will
-;;; scroll that list. You can't use the mouse to select from the
-;;; list - when you see what you want, just type the next one or
-;;; more characters in the symbol you want and hit tab again to
-;;; continue completing it. Any key typed will bury the completion
-;;; list. This ensures you can achieve a completion with the
-;;; minimal number of keystrokes without the completions window
-;;; lingering and taking up space.
-;;;
-;;; If you use eldoc-mode (included in Emacs), you can also get live
-;;; scheme documentation with:
-;;;
-;;; (autoload 'scheme-get-current-symbol-info "scheme-complete" nil t)
-;;; (add-hook 'scheme-mode-hook
-;;; (lambda ()
-;;; (make-local-variable 'eldoc-documentation-function)
-;;; (setq eldoc-documentation-function 'scheme-get-current-symbol-info)
-;;; (eldoc-mode)))
-;;;
-;;; You can enable slightly smarter indentation with
-;;;
-;;; (setq lisp-indent-function 'scheme-smart-indent-function)
-;;;
-;;; which basically ignores the scheme-indent-function property for
-;;; locally overridden symbols (e.g. if you use the (let loop () ...)
-;;; idiom it won't use the special loop indentation inside).
-;;;
-;;; There's a single custom variable, `scheme-default-implementation',
-;;; which you can use to specify your preferred implementation when we
-;;; can't infer it from the source code.
-;;;
-;;; That's all there is to it.
-
-;;; History:
-;;; 0.8.9: 2009/10/28 - allowing indented module/library definitions,
-;;; added various customizations for tab/indent behavior,
-;;; complete jumps to end of current symbol
-;;; 0.8.8: 2009/08/18 - fixing bug in scheme-directory-tree-files
-;; with funny file names
-;;; 0.8.7: 2009/07/18 - foof-loop support, don't complete current var,
-;; updating chicken 4 module information
-;;; 0.8.6: 2009/05/03 - fixing support for chicken 4 w/ unbalanced parens
-;;; 0.8.5: 2009/04/30 - full support for chicken 4, fixed bug in caching
-;;; 0.8.4: 2008/12/26 - numerous small bugfixes (Merry Christmas!)
-;;; 0.8.3: 2008/10/06 - smart indent, inferring types from imported modules,
-;;; optionally caching exports, chicken 4 support
-;;; 0.8.2: 2008/07/04 - both TAB and M-TAB scroll results (thanks Peter Bex),
-;;; better MATCH handling, fixed SRFI-55, other bugfixes
-;;; 0.8.1: 2008/04/17 - great renaming, everthing starts with `scheme-'
-;;; also, don't scan imported modules multiple times
-;;; 0.8: 2008/02/08 - several parsing bugfixes on unclosed parenthesis
-;;; (thanks to Kazushi NODA)
-;;; filename completion works properly on absolute paths
-;;; eldoc works properly on dotted lambdas
-;;; 0.7: 2008/01/18 - handles higher-order types (for apply, map, etc.)
-;;; smarter string completion (hostname, username, etc.)
-;;; smarter type inference, various bugfixes
-;;; 0.6: 2008/01/06 - more bugfixes (merry christmas)
-;;; 0.5: 2008/01/03 - handling internal defines, records, smarter
-;;; parsing
-;;; 0.4: 2007/11/14 - silly bugfix plus better repo env support
-;;; for searching chicken and gauche modules
-;;; 0.3: 2007/11/13 - bugfixes, better inference, smart strings
-;;; 0.2: 2007/10/15 - basic type inference
-;;; 0.1: 2007/09/11 - initial release
-;;;
-;;; What is this talk of 'release'? Klingons do not make software
-;;; 'releases'. Our software 'escapes' leaving a bloody trail of
-;;; designers and quality assurance people in its wake.
-
-(require 'cl)
-
-;; this is just to eliminate some warnings when compiling - this file
-;; should be loaded after 'scheme
-(eval-when (compile)
- (require 'scheme))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; info
-;;
-;; identifier type [doc-string no-type-display?]
-;;
-;; types:
-;;
-;; pair, number, symbol, etc.
-;; (lambda (param-types) [return-type])
-;; (syntax (param-types) [return-type])
-;; (set name values ...)
-;; (flags name values ...)
-;; (list type)
-;; (string expander)
-;; (special type function [outer-function])
-
-(defvar *scheme-r5rs-info*
- '((define (syntax (identifier value) undefined) "define a new variable")
- (set! (syntax (identifier value) undefined) "set the value of a variable")
- (let (syntax (vars body \.\.\.)) "bind new local variables in parallel")
- (let* (syntax (vars body \.\.\.)) "bind new local variables sequentially")
- (letrec (syntax (vars body \.\.\.)) "bind new local variables recursively")
- (lambda (syntax (params body \.\.\.)) "procedure syntax")
- (if (syntax (cond then else)) "conditional evaluation")
- (cond (syntax (clause \.\.\.)) "try each clause until one succeeds")
- (case (syntax (expr clause \.\.\.)) "look for EXPR among literal lists")
- (delay (syntax (expr)) "create a promise to evaluate EXPR")
- (and (syntax (expr \.\.\.)) "evaluate EXPRs while true, return last")
- (or (syntax (expr \.\.\.)) "return the first true EXPR")
- (begin (syntax (expr \.\.\.)) "evaluate each EXPR in turn and return the last")
- (do (syntax (vars finish body \.\.\.)) "simple iterator")
- (quote (syntax (expr)) "represent EXPR literally without evaluating it")
- (quasiquote (syntax (expr)) "quote literals allowing escapes")
- (unquote (syntax (expr)) "escape an expression inside quasiquote")
- (unquote-splicing (syntax (expr)) "escape and splice a list expression inside quasiquote")
- (define-syntax (syntax (identifier body \.\.\.) undefined) "create a macro")
- (let-syntax (syntax (syntaxes body \.\.\.)) "a local macro")
- (letrec-syntax (syntax (syntaxes body \.\.\.)) "a local macro")
- (syntax-rules (syntax (literals clauses \.\.\.) undefined) "simple macro language")
- (eqv? (lambda (obj1 obj2) bool) "returns #t if OBJ1 and OBJ2 are the same object")
- (eq? (lambda (obj1 obj2) bool) "finer grained version of EQV?")
- (equal? (lambda (obj1 obj2) bool) "recursive equivalence")
- (not (lambda (obj) bool) "returns #t iff OBJ is false")
- (boolean? (lambda (obj) bool) "returns #t iff OBJ is #t or #f")
- (number? (lambda (obj) bool) "returns #t iff OBJ is a number")
- (complex? (lambda (obj) bool) "returns #t iff OBJ is a complex number")
- (real? (lambda (obj) bool) "returns #t iff OBJ is a real number")
- (rational? (lambda (obj) bool) "returns #t iff OBJ is a rational number")
- (integer? (lambda (obj) bool) "returns #t iff OBJ is an integer")
- (exact? (lambda (z) bool) "returns #t iff Z is exact")
- (inexact? (lambda (z) bool) "returns #t iff Z is inexact")
- (= (lambda (z1 z2 \.\.\.) bool) "returns #t iff the arguments are all equal")
- (< (lambda (x1 x2 \.\.\.) bool) "returns #t iff the arguments are monotonically increasing")
- (> (lambda (x1 x2 \.\.\.) bool) "returns #t iff the arguments are monotonically decreasing")
- (<= (lambda (x1 x2 \.\.\.) bool) "returns #t iff the arguments are monotonically nondecreasing")
- (>= (lambda (x1 x2 \.\.\.) bool) "returns #t iff the arguments are monotonically nonincreasing")
- (zero? (lambda (z) bool))
- (positive? (lambda (x1) bool))
- (negative? (lambda (x1) bool))
- (odd? (lambda (n) bool))
- (even? (lambda (n) bool))
- (max (lambda (x1 x2 \.\.\.) x3) "returns the maximum of the arguments")
- (min (lambda (x1 x2 \.\.\.) x3) "returns the minimum of the arguments")
- (+ (lambda (z1 \.\.\.) z))
- (* (lambda (z1 \.\.\.) z))
- (- (lambda (z1 \.\.\.) z))
- (/ (lambda (z1 \.\.\.) z))
- (abs (lambda (x1) x2) "returns the absolute value of X")
- (quotient (lambda (n1 n2) n) "integer division")
- (remainder (lambda (n1 n2) n) "same sign as N1")
- (modulo (lambda (n1 n2) n) "same sign as N2")
- (gcd (lambda (n1 \.\.\.) n) "greatest common divisor")
- (lcm (lambda (n2 \.\.\.) n) "least common multiple")
- (numerator (lambda (rational) n))
- (denominator (lambda (rational) n))
- (floor (lambda (x1) n) "largest integer not larger than X")
- (ceiling (lambda (x1) n) "smallest integer not smaller than X")
- (truncate (lambda (x1) n) "drop fractional part")
- (round (lambda (x1) n) "round to even (banker's rounding)")
- (rationalize (lambda (x1 y) n) "rational number differing from X by at most Y")
- (exp (lambda (z) z) "e^Z")
- (log (lambda (z) z) "natural logarithm of Z")
- (sin (lambda (z) z) "sine function")
- (cos (lambda (z) z) "cosine function")
- (tan (lambda (z) z) "tangent function")
- (asin (lambda (z) z) "arcsine function")
- (acos (lambda (z) z) "arccosine function")
- (atan (lambda (z) z) "arctangent function")
- (sqrt (lambda (z) z) "principal square root of Z")
- (expt (lambda (z1 z2) z) "returns Z1 raised to the Z2 power")
- (make-rectangular (lambda (x1 x2) z) "create a complex number")
- (make-polar (lambda (x1 x2) z) "create a complex number")
- (real-part (lambda (z) x1))
- (imag-part (lambda (z) x1))
- (magnitude (lambda (z) x1))
- (angle (lambda (z) x1))
- (exact->inexact (lambda (z) z))
- (inexact->exact (lambda (z) z))
- (number->string (lambda (z :optional radix) str))
- (string->number (lambda (str :optional radix) z))
- (pair? (lambda (obj) bool) "returns #t iff OBJ is a pair")
- (cons (lambda (obj1 obj2) pair) "create a newly allocated pair")
- (car (lambda (pair) obj))
- (cdr (lambda (pair) obj))
- (set-car! (lambda (pair obj) undefined))
- (set-cdr! (lambda (pair obj) undefined))
- (caar (lambda (pair) obj))
- (cadr (lambda (pair) obj))
- (cdar (lambda (pair) obj))
- (cddr (lambda (pair) obj))
- (caaar (lambda (pair) obj))
- (caadr (lambda (pair) obj))
- (cadar (lambda (pair) obj))
- (caddr (lambda (pair) obj))
- (cdaar (lambda (pair) obj))
- (cdadr (lambda (pair) obj))
- (cddar (lambda (pair) obj))
- (cdddr (lambda (pair) obj))
- (caaaar (lambda (pair) obj))
- (caaadr (lambda (pair) obj))
- (caadar (lambda (pair) obj))
- (caaddr (lambda (pair) obj))
- (cadaar (lambda (pair) obj))
- (cadadr (lambda (pair) obj))
- (caddar (lambda (pair) obj))
- (cadddr (lambda (pair) obj))
- (cdaaar (lambda (pair) obj))
- (cdaadr (lambda (pair) obj))
- (cdadar (lambda (pair) obj))
- (cdaddr (lambda (pair) obj))
- (cddaar (lambda (pair) obj))
- (cddadr (lambda (pair) obj))
- (cdddar (lambda (pair) obj))
- (cddddr (lambda (pair) obj))
- (null? (lambda (obj) bool) "returns #t iff OBJ is the empty list")
- (list? (lambda (obj) bool) "returns #t iff OBJ is a proper list")
- (list (lambda (obj \.\.\.) list) "returns a newly allocated list")
- (length (lambda (list) n))
- (append (lambda (list \.\.\.) list) "concatenates the list arguments")
- (reverse (lambda (list) list))
- (list-tail (lambda (list k) list) "returns the Kth cdr of LIST")
- (list-ref (lambda (list k) obj) "returns the Kth element of LIST")
- (memq (lambda (obj list)) "the sublist of LIST whose car is eq? to OBJ")
- (memv (lambda (obj list)) "the sublist of LIST whose car is eqv? to OBJ")
- (member (lambda (obj list)) "the sublist of LIST whose car is equal? to OBJ")
- (assq (lambda (obj list)) "the element of LIST whose car is eq? to OBJ")
- (assv (lambda (obj list)) "the element of LIST whose car is eqv? to OBJ")
- (assoc (lambda (obj list)) "the element of LIST whose car is equal? to OBJ")
- (symbol? (lambda (obj) bool) "returns #t iff OBJ is a symbol")
- (symbol->string (lambda (symbol) str))
- (string->symbol (lambda (str) symbol))
- (char? (lambda (obj) bool) "returns #t iff OBJ is a character")
- (char=? (lambda (ch1 ch2) bool))
- (char<? (lambda (ch1 ch2) bool))
- (char>? (lambda (ch1 ch2) bool))
- (char<=? (lambda (ch1 ch2) bool))
- (char>=? (lambda (ch1 ch2) bool))
- (char-ci=? (lambda (ch1 ch2) bool))
- (char-ci<? (lambda (ch1 ch2) bool))
- (char-ci>? (lambda (ch1 ch2) bool))
- (char-ci<=? (lambda (ch1 ch2) bool))
- (char-ci>=? (lambda (ch1 ch2) bool))
- (char-alphabetic? (lambda (ch) bool))
- (char-numeric? (lambda (ch) bool))
- (char-whitespace? (lambda (ch) bool))
- (char-upper-case? (lambda (ch) bool))
- (char-lower-case? (lambda (ch) bool))
- (char->integer (lambda (ch) int))
- (integer->char (lambda (int) ch))
- (char-upcase (lambda (ch) ch))
- (char-downcase (lambda (ch) ch))
- (string? (lambda (obj) bool) "returns #t iff OBJ is a string")
- (make-string (lambda (k :optional ch) str) "a new string of length k")
- (string (lambda (ch \.\.\.) str) "a new string made of the char arguments")
- (string-length (lambda (str) n) "the number of characters in STR")
- (string-ref (lambda (str i) ch) "the Ith character of STR")
- (string-set! (lambda (str i ch) undefined) "set the Ith character of STR to CH")
- (string=? (lambda (str1 str2) bool))
- (string-ci=? (lambda (str1 str2) bool))
- (string<? (lambda (str1 str2) bool))
- (string>? (lambda (str1 str2) bool))
- (string<=? (lambda (str1 str2) bool))
- (string>=? (lambda (str1 str2) bool))
- (string-ci<? (lambda (str1 str2) bool))
- (string-ci>? (lambda (str1 str2) bool))
- (string-ci<=? (lambda (str1 str2) bool))
- (string-ci>=? (lambda (str1 str2) bool))
- (substring (lambda (str start end) str))
- (string-append (lambda (str \.\.\.) str) "concatenate the string arguments")
- (string->list (lambda (str) list))
- (list->string (lambda (list) str))
- (string-copy (lambda (str) str))
- (string-fill! (lambda (str ch) undefined) "set every char in STR to CH")
- (vector? (lambda (obj) bool) "returns #t iff OBJ is a vector")
- (make-vector (lambda (len :optional fill) vec) "a new vector of K elements")
- (vector (lambda (obj \.\.\.) vec))
- (vector-length (lambda (vec) n) "the number of elements in VEC")
- (vector-ref (lambda (vec i) obj) "the Ith element of VEC")
- (vector-set! (lambda (vec i obj) undefined) "set the Ith element of VEC to OBJ")
- (vector->list (lambda (vec) list))
- (list->vector (lambda (list) vec))
- (vector-fill! (lambda (vec obj) undefined) "set every element in VEC to OBJ")
- (procedure? (lambda (obj) bool) "returns #t iff OBJ is a procedure")
- (apply (lambda ((lambda obj a) obj \.\.\.) a) "procedure application")
- (map (lambda ((lambda (obj1 . obj2) a) list \.\.\.) (list a)) "a new list of PROC applied to every element of LIST")
- (for-each (lambda ((lambda obj a) obj \.\.\.) undefined) "apply PROC to each element of LIST in order")
- (force (lambda (promise) obj) "force the delayed value of PROMISE")
- (call-with-current-continuation (lambda (proc) obj) "goto on steroids")
- (values (lambda (obj \.\.\.)) "send multiple values to the calling continuation")
- (call-with-values (lambda (producer consumer) obj))
- (dynamic-wind (lambda (before-thunk thunk after-thunk) obj))
- (scheme-report-environment (lambda (int) env) "INT should be 5")
- (null-environment (lambda (int) env) "INT should be 5")
- (call-with-input-file (lambda (path proc) input-port))
- (call-with-output-file (lambda (path proc) output-port))
- (input-port? (lambda (obj) bool) "returns #t iff OBJ is an input port")
- (output-port? (lambda (obj) bool) "returns #t iff OBJ is an output port")
- (current-input-port (lambda () input-port) "the default input for read procedures")
- (current-output-port (lambda () output-port) "the default output for write procedures")
- (with-input-from-file (lambda (path thunk) obj))
- (with-output-to-file (lambda (path thunk) obj))
- (open-input-file (lambda (path) input-port))
- (open-output-file (lambda (path) output-port))
- (close-input-port (lambda (input-port)))
- (close-output-port (lambda (output-port)))
- (read (lambda (:optional input-port) obj) "read a datum")
- (read-char (lambda (:optional input-port) ch) "read a single character")
- (peek-char (lambda (:optional input-port) ch))
- (eof-object? (lambda (obj) bool) "returns #t iff OBJ is the end-of-file object")
- (char-ready? (lambda (:optional input-port) bool))
- (write (lambda (object :optional output-port) undefined) "write a datum")
- (display (lambda (object :optional output-port) undefined) "display")
- (newline (lambda (:optional output-port) undefined) "send a linefeed")
- (write-char (lambda (char :optional output-port) undefined) "write a single character")
- (load (lambda (filename) undefined) "evaluate expressions from a file")
- (eval (lambda (expr env)))
- ))
-
-(defvar *scheme-srfi-info*
- [
- ;; SRFI 0
- ("Feature-based conditional expansion construct"
- (cond-expand (syntax (clause \.\.\.))))
-
- ;; SRFI 1
- ("List Library"
- (xcons (lambda (object object) pair))
- (cons* (lambda (object \.\.\.) pair))
- (make-list (lambda (integer :optional object) list))
- (list-tabulate (lambda (integer procedure) list))
- (list-copy (lambda (list) list))
- (circular-list (lambda (object \.\.\.) list))
- (iota (lambda (integer :optional integer integer) list))
- (proper-list? (lambda (object) bool))
- (circular-list? (lambda (object) bool))
- (dotted-list? (lambda (object) bool))
- (not-pair? (lambda (object) bool))
- (null-list? (lambda (object) bool))
- (list= (lambda (procedure list \.\.\.) bool))
- (first (lambda (pair)))
- (second (lambda (pair)))
- (third (lambda (pair)))
- (fourth (lambda (pair)))
- (fifth (lambda (pair)))
- (sixth (lambda (pair)))
- (seventh (lambda (pair)))
- (eighth (lambda (pair)))
- (ninth (lambda (pair)))
- (tenth (lambda (pair)))
- (car+cdr (lambda (pair)))
- (take (lambda (pair integer) list))
- (drop (lambda (pair integer) list))
- (take-right (lambda (pair integer) list))
- (drop-right (lambda (pair integer) list))
- (take! (lambda (pair integer) list))
- (drop-right! (lambda (pair integer) list))
- (split-at (lambda (pair integer) list))
- (split-at! (lambda (pair integer) list))
- (last (lambda (pair) obj))
- (last-pair (lambda (pair) pair))
- (length+ (lambda (object) n))
- (concatenate (lambda (list) list))
- (append! (lambda (list \.\.\.) list))
- (concatenate! (lambda (list) list))
- (reverse! (lambda (list) list))
- (append-reverse (lambda (list list) list))
- (append-reverse! (lambda (list list) list))
- (zip (lambda (list \.\.\.) list))
- (unzip1 (lambda (list) list))
- (unzip2 (lambda (list) list))
- (unzip3 (lambda (list) list))
- (unzip4 (lambda (list) list))
- (unzip5 (lambda (list) list))
- (count (lambda ((lambda (obj1 . obj2)) list \.\.\.) n))
- (fold (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
- (unfold (lambda (procedure procedure procedure object :optional procedure) obj))
- (pair-fold (lambda ((lambda obj a) object list \.\.\.) a))
- (reduce (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
- (fold-right (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
- (unfold-right (lambda (procedure procedure procedure object :optional object) obj))
- (pair-fold-right (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
- (reduce-right (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
- (append-map (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
- (append-map! (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
- (map! (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
- (pair-for-each (lambda ((lambda (obj1 . obj2)) list \.\.\.) undefined))
- (filter-map (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
- (map-in-order (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
- (filter (lambda ((lambda (obj1 . obj2)) list) list))
- (partition (lambda ((lambda (obj) bool) list) list))
- (remove (lambda ((lambda (obj1) bool) list) list))
- (filter! (lambda ((lambda (obj1) bool) list) list))
- (partition! (lambda ((lambda (obj1) bool) list) list))
- (remove! (lambda ((lambda (obj1) bool) list) list))
- (find (lambda ((lambda (obj1) bool) list) obj))
- (find-tail (lambda ((lambda (obj1) bool) list) obj))
- (any (lambda ((lambda (obj1 . obj2) a) list \.\.\.) a))
- (every (lambda ((lambda (obj1 . obj2) a) list \.\.\.) a))
- (list-index (lambda ((lambda (obj1 . obj2)) list \.\.\.) (or bool integer)))
- (take-while (lambda ((lambda (obj)) list) list))
- (drop-while (lambda ((lambda (obj)) list) list))
- (take-while! (lambda ((lambda (obj)) list) list))
- (span (lambda ((lambda (obj)) list) list))
- (break (lambda ((lambda (obj)) list) list))
- (span! (lambda ((lambda (obj)) list) list))
- (break! (lambda ((lambda (obj)) list) list))
- (delete (lambda (object list :optional procedure) list))
- (delete-duplicates (lambda (list :optional procedure) list))
- (delete! (lambda (obj list :optional procedure) list))
- (delete-duplicates! (lambda (list :optional procedure) list))
- (alist-cons (lambda (obj1 obj2 alist) alist))
- (alist-copy (lambda (alist) alist))
- (alist-delete (lambda (obj alist) alist))
- (alist-delete! (lambda (obj alist) alist))
- (lset<= (lambda (procedure list \.\.\.) bool))
- (lset= (lambda (procedure list \.\.\.) bool))
- (lset-adjoin (lambda (procedure list object \.\.\.) list))
- (lset-union (lambda (procedure list \.\.\.) list))
- (lset-union! (lambda (procedure list \.\.\.) list))
- (lset-intersection (lambda (procedure list \.\.\.) list))
- (lset-intersection! (lambda (procedure list \.\.\.) list))
- (lset-difference (lambda (procedure list \.\.\.) list))
- (lset-difference! (lambda (procedure list \.\.\.) list))
- (lset-xor (lambda (procedure list \.\.\.) list))
- (lset-xor! (lambda (procedure list \.\.\.) list))
- (lset-diff+intersection (lambda (procedure list \.\.\.) list))
- (lset-diff+intersection! (lambda (procedure list \.\.\.) list))
-
- )
-
- ;; SRFI 2
- ("AND-LET*: an AND with local bindings, a guarded LET* special form"
- (and-let* (syntax (bindings body \.\.\.))))
-
- ()
-
- ;; SRFI 4
- ("Homogeneous numeric vector datatypes"
-
- (u8vector? (lambda (obj) bool))
- (make-u8vector (lambda (size integer) u8vector))
- (u8vector (lambda (integer \.\.\.) u8vector))
- (u8vector-length (lambda (u8vector) n))
- (u8vector-ref (lambda (u8vector i) int))
- (u8vector-set! (lambda (u8vector i u8value) undefined))
- (u8vector->list (lambda (u8vector) list))
- (list->u8vector (lambda (list) u8vector))
-
- (s8vector? (lambda (obj) bool))
- (make-s8vector (lambda (size integer) s8vector))
- (s8vector (lambda (integer \.\.\.) s8vector))
- (s8vector-length (lambda (s8vector) n))
- (s8vector-ref (lambda (s8vector i) int))
- (s8vector-set! (lambda (s8vector i s8value) undefined))
- (s8vector->list (lambda (s8vector) list))
- (list->s8vector (lambda (list) s8vector))
-
- (u16vector? (lambda (obj) bool))
- (make-u16vector (lambda (size integer) u16vector))
- (u16vector (lambda (integer \.\.\.)))
- (u16vector-length (lambda (u16vector) n))
- (u16vector-ref (lambda (u16vector i) int))
- (u16vector-set! (lambda (u16vector i u16value) undefined))
- (u16vector->list (lambda (u16vector) list))
- (list->u16vector (lambda (list) u16vector))
-
- (s16vector? (lambda (obj) bool))
- (make-s16vector (lambda (size integer) s16vector))
- (s16vector (lambda (integer \.\.\.) s16vector))
- (s16vector-length (lambda (s16vector) n))
- (s16vector-ref (lambda (s16vector i) int))
- (s16vector-set! (lambda (s16vector i s16value) undefined))
- (s16vector->list (lambda (s16vector) list))
- (list->s16vector (lambda (list) s16vector))
-
- (u32vector? (lambda (obj) bool))
- (make-u32vector (lambda (size integer) u32vector))
- (u32vector (lambda (integer \.\.\.) u32vector))
- (u32vector-length (lambda (u32vector) n))
- (u32vector-ref (lambda (u32vector i) int))
- (u32vector-set! (lambda (u32vector i u32value) undefined))
- (u32vector->list (lambda (u32vector) list))
- (list->u32vector (lambda (list) u32vector))
-
- (s32vector? (lambda (obj) bool))
- (make-s32vector (lambda (size integer) s32vector))
- (s32vector (lambda (integer \.\.\.) s32vector))
- (s32vector-length (lambda (s32vector) n))
- (s32vector-ref (lambda (s32vector i) int))
- (s32vector-set! (lambda (s32vector i s32value) undefined))
- (s32vector->list (lambda (s32vector) list))
- (list->s32vector (lambda (list) s32vector))
-
- (u64vector? (lambda (obj) bool))
- (make-u64vector (lambda (size integer) u64vector))
- (u64vector (lambda (integer \.\.\.) u64vector))
- (u64vector-length (lambda (u64vector) n))
- (u64vector-ref (lambda (u64vector i) int))
- (u64vector-set! (lambda (u64vector i u64value) undefined))
- (u64vector->list (lambda (u64vector) list))
- (list->u64vector (lambda (list) u64vector))
-
- (s64vector? (lambda (obj) bool))
- (make-s64vector (lambda (size integer) s64vector))
- (s64vector (lambda (integer \.\.\.) s64vector))
- (s64vector-length (lambda (s64vector) n))
- (s64vector-ref (lambda (s64vector i) int))
- (s64vector-set! (lambda (s64vector i s64value) undefined))
- (s64vector->list (lambda (s64vector) list))
- (list->s64vector (lambda (list) s64vector))
-
- (f32vector? (lambda (obj) bool))
- (make-f32vector (lambda (size integer) f32vector))
- (f32vector (lambda (number \.\.\.) f32vector))
- (f32vector-length (lambda (f32vector) n))
- (f32vector-ref (lambda (f32vector i) int))
- (f32vector-set! (lambda (f32vector i f32value) undefined))
- (f32vector->list (lambda (f32vector) list))
- (list->f32vector (lambda (list) f32vector))
-
- (f64vector? (lambda (obj) bool))
- (make-f64vector (lambda (size integer) f64vector))
- (f64vector (lambda (number \.\.\.) f64vector))
- (f64vector-length (lambda (f64vector) n))
- (f64vector-ref (lambda (f64vector i) int))
- (f64vector-set! (lambda (f64vector i f64value) undefined))
- (f64vector->list (lambda (f64vector) list))
- (list->f64vector (lambda (list) f64vector))
- )
-
- ;; SRFI 5
- ("A compatible let form with signatures and rest arguments"
- (let (syntax (bindings body \.\.\.))))
-
- ;; SRFI 6
- ("Basic String Ports"
- (open-input-string (lambda (str) input-port))
- (open-output-string (lambda () output-port))
- (get-output-string (lambda (output-port) str)))
-
- ;; SRFI 7
- ("Feature-based program configuration language"
- (program (syntax (clause \.\.\.)))
- (feature-cond (syntax (clause))))
-
- ;; SRFI 8
- ("receive: Binding to multiple values"
- (receive (syntax (identifiers producer body \.\.\.))))
-
- ;; SRFI 9
- ("Defining Record Types"
- (define-record-type (syntax (name constructor-name pred-name fields \.\.\.))))
-
- ;; SRFI 10
- ("Sharp-Comma External Form"
- (define-reader-ctor (syntax (name proc) undefined)))
-
- ;; SRFI 11
- ("Syntax for receiving multiple values"
- (let-values (syntax (bindings body \.\.\.)))
- (let-values* (syntax (bindings body \.\.\.))))
-
- ()
-
- ;; SRFI 13
- ("String Library"
- (string-map (lambda (proc str :optional start end) str))
- (string-map! (lambda (proc str :optional start end) undefined))
- (string-fold (lambda (kons knil str :optional start end) obj))
- (string-fold-right (lambda (kons knil str :optional start end) obj))
- (string-unfold (lambda (p f g seed :optional base make-final) str))
- (string-unfold-right (lambda (p f g seed :optional base make-final) str))
- (string-tabulate (lambda (proc len) str))
- (string-for-each (lambda (proc str :optional start end) undefined))
- (string-for-each-index (lambda (proc str :optional start end) undefined))
- (string-every (lambda (pred str :optional start end) obj))
- (string-any (lambda (pred str :optional start end) obj))
- (string-hash (lambda (str :optional bound start end) int))
- (string-hash-ci (lambda (str :optional bound start end) int))
- (string-compare (lambda (string1 string2 lt-proc eq-proc gt-proc :optional start end) obj))
- (string-compare-ci (lambda (string1 string2 lt-proc eq-proc gt-proc :optional start end) obj))
- (string= (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
- (string<> (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
- (string< (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
- (string> (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
- (string<= (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
- (string>= (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
- (string-ci= (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
- (string-ci<> (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
- (string-ci< (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
- (string-ci> (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
- (string-ci<= (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
- (string-ci>= (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
- (string-titlecase (lambda (string :optional start end) str))
- (string-upcase (lambda (string :optional start end) str))
- (string-downcase (lambda (string :optional start end) str))
- (string-titlecase! (lambda (string :optional start end) undefined))
- (string-upcase! (lambda (string :optional start end) undefined))
- (string-downcase! (lambda (string :optional start end) undefined))
- (string-take (lambda (string nchars) str))
- (string-drop (lambda (string nchars) str))
- (string-take-right (lambda (string nchars) str))
- (string-drop-right (lambda (string nchars) str))
- (string-pad (lambda (string k :optional char start end) str))
- (string-pad-right (lambda (string k :optional char start end) str))
- (string-trim (lambda (string :optional char/char-set/pred start end) str))
- (string-trim-right (lambda (string :optional char/char-set/pred start end) str))
- (string-trim-both (lambda (string :optional char/char-set/pred start end) str))
- (string-filter (lambda (char/char-set/pred string :optional start end) str))
- (string-delete (lambda (char/char-set/pred string :optional start end) str))
- (string-index (lambda (string char/char-set/pred :optional start end) (or integer bool)))
- (string-index-right (lambda (string char/char-set/pred :optional end start) (or integer bool)))
- (string-skip (lambda (string char/char-set/pred :optional start end) (or integer bool)))
- (string-skip-right (lambda (string char/char-set/pred :optional end start) (or integer bool)))
- (string-count (lambda (string char/char-set/pred :optional start end) n))
- (string-prefix-length (lambda (string1 string2 :optional start1 end1 start2 end2) n))
- (string-suffix-length (lambda (string1 string2 :optional start1 end1 start2 end2) n))
- (string-prefix-length-ci (lambda (string1 string2 :optional start1 end1 start2 end2) n))
- (string-suffix-length-ci (lambda (string1 string2 :optional start1 end1 start2 end2) n))
- (string-prefix? (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
- (string-suffix? (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
- (string-prefix-ci? (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
- (string-suffix-ci? (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
- (string-contains (lambda (string pattern :optional s-start s-end p-start p-end) obj))
- (string-contains-ci (lambda (string pattern :optional s-start s-end p-start p-end) obj))
- (string-fill! (lambda (string char :optional start end) undefined))
- (string-copy! (lambda (to tstart from :optional fstart fend) undefined))
- (string-copy (lambda (str :optional start end) str))
- (substring/shared (lambda (str start :optional end) str))
- (string-reverse (lambda (str :optional start end) str))
- (string-reverse! (lambda (str :optional start end) undefined))
- (reverse-list->string (lambda (char-list) str))
- (string->list (lambda (str :optional start end) list))
- (string-concatenate (lambda (string-list) str))
- (string-concatenate/shared (lambda (string-list) str))
- (string-append/shared (lambda (str \.\.\.) str))
- (string-concatenate-reverse (lambda (string-list :optional final-string end) str))
- (string-concatenate-reverse/shared (lambda (string-list :optional final-string end) str))
- (xsubstring (lambda (str from :optional to start end) str))
- (string-xcopy! (lambda (target tstart str from :optional to start end) undefined))
- (string-null? (lambda (str) bool))
- (string-join (lambda (string-list :optional delim grammar) str))
- (string-tokenize (lambda (string :optional token-chars start end) str))
- (string-replace (lambda (str1 str2 start1 end1 :optional start2 end2) str))
- (string-kmp-partial-search (lambda (pat rv str i :optional c= p-start s-start s-end) n))
- (make-kmp-restart-vector (lambda (str :optional c= start end) vec))
- (kmp-step (lambda (pat rv c i c= p-start) n))
- )
-
- ;; SRFI 14
- ("Character-Set Library"
- (char-set? (lambda (cset) bool))
- (char-set= (lambda (cset \.\.\.) bool))
- (char-set<= (lambda (cset \.\.\.) bool))
- (char-set-hash (lambda (cset :optional int) int))
- (char-set-cursor (lambda (cset) cursor))
- (char-set-ref (lambda (cset cursor) ch))
- (char-set-cursor-next (lambda (cset cursor) int))
- (end-of-char-set? (lambda (cursor) bool))
- (char-set-fold (lambda (proc obj cset) obj))
- (char-set-unfold (lambda (proc proc proc obj :optional obj) cset))
- (char-set-unfold! (lambda (proc proc proc obj obj) cset))
- (char-set-for-each (lambda (proc cset) undefined))
- (char-set-map (lambda (proc cset) cset))
- (char-set-copy (lambda (cset) cset))
- (char-set (lambda (ch \.\.\.) cset))
- (list->char-set (lambda (list :optional obj) cset))
- (list->char-set! (lambda (list cset) cset))
- (string->char-set (lambda (str :optional cset) cset))
- (string->char-set! (lambda (str cset) cset))
- (ucs-range->char-set (lambda (int int :optional bool cset) cset))
- (ucs-range->char-set! (lambda (int int bool cset) cset))
- (char-set-filter (lambda (proc cset :optional base-cset) cset))
- (char-set-filter! (lambda (proc cset base-cset) cset))
- (->char-set (lambda (obj) cset))
- (char-set-size (lambda (cset) n))
- (char-set-count (lambda (proc cset) n))
- (char-set-contains? (lambda (cset ch) bool))
- (char-set-every (lambda (proc cset) obj))
- (char-set-any (lambda (proc cset) obj))
- (char-set-adjoin (lambda (cset ch \.\.\.) cset))
- (char-set-delete (lambda (cset ch \.\.\.) cset))
- (char-set-adjoin! (lambda (cset ch \.\.\.) cset))
- (char-set-delete! (lambda (cset ch \.\.\.) cset))
- (char-set->list (lambda (cset) list))
- (char-set->string (lambda (cset) str))
- (char-set-complement (lambda (cset) cset))
- (char-set-union (lambda (cset \.\.\.) cset))
- (char-set-intersection (lambda (cset \.\.\.) cset))
- (char-set-xor (lambda (cset \.\.\.) cset))
- (char-set-difference (lambda (cset \.\.\.) cset))
- (char-set-diff+intersection (lambda (cset \.\.\.) cset))
- (char-set-complement! (lambda (cset) cset))
- (char-set-union! (lambda (cset \.\.\.) cset))
- (char-set-intersection! (lambda (cset \.\.\.) cset))
- (char-set-xor! (lambda (cset \.\.\.) cset))
- (char-set-difference! (lambda (cset \.\.\.) cset))
- (char-set-diff+intersection! (lambda (cset \.\.\.) cset))
- (char-set:lower-case char-set)
- (char-set:upper-case char-set)
- (char-set:letter char-set)
- (char-set:digit char-set)
- (char-set:letter+digit char-set)
- (char-set:graphic char-set)
- (char-set:printing char-set)
- (char-set:whitespace char-set)
- (char-set:blank char-set)
- (char-set:iso-control char-set)
- (char-set:punctuation char-set)
- (char-set:symbol char-set)
- (char-set:hex-digit char-set)
- (char-set:ascii char-set)
- (char-set:empty char-set)
- (char-set:full char-set)
- )
-
- ()
-
- ;; SRFI 16
- ("Syntax for procedures of variable arity"
- (case-lambda (syntax (clauses \.\.\.) procedure)))
-
- ;; SRFI 17
- ("Generalized set!"
- (set! (syntax (what value) undefined)))
-
- ;; SRFI 18
- ("Multithreading support"
- (current-thread (lambda () thread))
- (thread? (lambda (obj) bool))
- (make-thread (lambda (thunk :optional name) thread))
- (thread-name (lambda (thread) name))
- (thread-specific (lambda (thread)))
- (thread-specific-set! (lambda (thread obj)))
- (thread-base-priority (lambda (thread)))
- (thread-base-priority-set! (lambda (thread number)))
- (thread-priority-boost (lambda (thread)))
- (thread-priority-boost-set! (lambda (thread number)))
- (thread-quantum (lambda (thread)))
- (thread-quantum-set! (lambda (thread number)))
- (thread-start! (lambda (thread)))
- (thread-yield! (lambda ()))
- (thread-sleep! (lambda (number)))
- (thread-terminate! (lambda (thread)))
- (thread-join! (lambda (thread :optional timeout timeout-val)))
- (mutex? (lambda (obj) bool))
- (make-mutex (lambda (:optional name) mutex))
- (mutex-name (lambda (mutex) name))
- (mutex-specific (lambda (mutex)))
- (mutex-specific-set! (lambda (mutex obj)))
- (mutex-state (lambda (mutex)))
- (mutex-lock! (lambda (mutex :optional timeout thread)))
- (mutex-unlock! (lambda (mutex :optional condition-variable timeout)))
- (condition-variable? (lambda (obj) bool))
- (make-condition-variable (lambda (:optional name) condition-variable))
- (condition-variable-name (lambda (condition-variable) name))
- (condition-variable-specific (lambda (condition-variable)))
- (condition-variable-specific-set! (lambda (condition-variable obj)))
- (condition-variable-signal! (lambda (condition-variable)))
- (condition-variable-broadcast! (lambda (condition-variable)))
- (current-time (lambda () time))
- (time? (lambda (obj) bool))
- (time->seconds (lambda (time) x1))
- (seconds->time (lambda (x1) time))
- (current-exception-handler (lambda () handler))
- (with-exception-handler (lambda (handler thunk)))
- (raise (lambda (obj)))
- (join-timeout-exception? (lambda (obj) bool))
- (abandoned-mutex-exception? (lambda (obj) bool))
- (terminated-thread-exception? (lambda (obj) bool))
- (uncaught-exception? (lambda (obj) bool))
- (uncaught-exception-reason (lambda (exc) obj))
- )
-
- ;; SRFI 19
- ("Time Data Types and Procedures"
- (current-date (lambda (:optional tz-offset)) date)
- (current-julian-day (lambda ()) jdn)
- (current-modified-julian-day (lambda ()) mjdn)
- (current-time (lambda (:optional time-type)) time)
- (time-resolution (lambda (:optional time-type)) nanoseconds)
- (make-time (lambda (type nanosecond second)))
- (time? (lambda (obj)))
- (time-type (lambda (time)))
- (time-nanosecond (lambda (time)))
- (time-second (lambda (time)))
- (set-time-type! (lambda (time)))
- (set-time-nanosecond! (lambda (time)))
- (set-time-second! (lambda (time)))
- (copy-time (lambda (time)))
- (time<=? (lambda (time1 time2)))
- (time<? (lambda (time1 time2)))
- (time=? (lambda (time1 time2)))
- (time>=? (lambda (time1 time2)))
- (time>? (lambda (time1 time2)))
- (time-difference (lambda (time1 time2)))
- (time-difference! (lambda (time1 time2)))
- (add-duration (lambda (time duration)))
- (add-duration! (lambda (time duration)))
- (subtract-duration (lambda (time duration)))
- (subtract-duration! (lambda (time duration)))
- (make-date (lambda (nanosecond second minute hour day month year zone-offset)))
- (date? (lambda (obj)))
- (date-nanosecond (lambda (date)))
- (date-second (lambda (date)))
- (date-minute (lambda (date)))
- (date-hour (lambda (date)))
- (date-day (lambda (date)))
- (date-month (lambda (date)))
- (date-year (lambda (date)))
- (date-zone-offset (lambda (date)))
- (date-year-day (lambda (date)))
- (date-week-day (lambda (date)))
- (date-week-number (lambda (date)))
- (date->julian-day (lambda (date)))
- (date->modified-julian-day (lambda (date)))
- (date->time-monotonic (lambda (date)))
- (date->time-tai (lambda (date)))
- (date->time-utc (lambda (date)))
- (julian-day->date (lambda (date)))
- (julian-day->time-monotonic (lambda (date)))
- (julian-day->time-tai (lambda (date)))
- (julian-day->time-utc (lambda (date)))
- (modified-julian-day->date (lambda (date)))
- (modified-julian-day->time-monotonic (lambda (date)))
- (modified-julian-day->time-tai (lambda (date)))
- (modified-julian-day->time-utc (lambda (date)))
- (time-monotonic->date (lambda (date)))
- (time-monotonic->julian-day (lambda (date)))
- (time-monotonic->modified-julian-day (lambda (date)))
- (time-monotonic->time-monotonic (lambda (date)))
- (time-monotonic->time-tai (lambda (date)))
- (time-monotonic->time-tai! (lambda (date)))
- (time-monotonic->time-utc (lambda (date)))
- (time-monotonic->time-utc! (lambda (date)))
- (time-tai->date (lambda (date)))
- (time-tai->julian-day (lambda (date)))
- (time-tai->modified-julian-day (lambda (date)))
- (time-tai->time-monotonic (lambda (date)))
- (time-tai->time-monotonic! (lambda (date)))
- (time-tai->time-utc (lambda (date)))
- (time-tai->time-utc! (lambda (date)))
- (time-utc->date (lambda (date)))
- (time-utc->julian-day (lambda (date)))
- (time-utc->modified-julian-day (lambda (date)))
- (time-utc->time-monotonic (lambda (date)))
- (time-utc->time-monotonic! (lambda (date)))
- (time-utc->time-tai (lambda (date)))
- (time-utc->time-tai! (lambda (date)))
- (date->string (lambda (date :optional format-string)))
- (string->date (lambda (input-string template-string)))
- )
-
- ()
-
- ;; SRFI 21
- ("Real-time multithreading support"
- srfi-18) ; same as srfi-18
-
- ;; SRFI 22
- ("Running Scheme Scripts on Unix"
- )
-
- ;; SRFI 23
- ("Error reporting mechanism"
- (error (lambda (reason-string arg \.\.\.))))
-
- ()
-
- ;; SRFI 25
- ("Multi-dimensional Array Primitives"
- (array? (lambda (obj)))
- (make-array (lambda (shape :optional init)))
- (shape (lambda (bound \.\.\.)))
- (array (lambda (shape obj \.\.\.)))
- (array-rank (lambda (array)))
- (array-start (lambda (array)))
- (array-end (lambda (array)))
- (array-shape (lambda (array)))
- (array-ref (lambda (array i \.\.\.)))
- (array-set! (lambda (array obj \.\.\.) undefined))
- (share-array (lambda (array shape proc)))
- )
-
- ;; SRFI 26
- ("Notation for Specializing Parameters without Currying"
- (cut (syntax (obj \.\.\.)))
- (cute (lambda (obj \.\.\.))))
-
- ;; SRFI 27
- ("Sources of Random Bits"
- (random-integer (lambda (n)))
- (random-real (lambda ()))
- (default-random-source (lambda ()))
- (make-random-source (lambda ()))
- (random-source? (lambda (obj)))
- (random-source-state-ref (lambda (random-source)))
- (random-source-state-set! (lambda (random-source state)))
- (random-source-randomize! (lambda (random-source)))
- (random-source-pseudo-randomize! (lambda (random-source i j)))
- (random-source-make-integers (lambda (random-source)))
- (random-source-make-reals (lambda (random-source)))
- )
-
- ;; SRFI 28
- ("Basic Format Strings"
- (format (lambda (port-or-boolean format-string arg \.\.\.))))
-
- ;; SRFI 29
- ("Localization"
- (current-language (lambda (:optional symbol)))
- (current-country (lambda (:optional symbol)))
- (current-locale-details (lambda (:optional list)))
- (declare-bundle! (lambda (bundle-name association-list)))
- (store-bundle (lambda (bundle-name)))
- (load-bundle! (lambda (bundle-name)))
- (localized-template (lambda (package-name message-template-name)))
- )
-
- ;; SRFI 30
- ("Nested Multi-line Comments"
- )
-
- ;; SRFI 31
- ("A special form for recursive evaluation"
- (rec (syntax (name body \.\.\.) procedure)))
-
- ()
-
- ()
-
- ;; SRFI 34
- ("Exception Handling for Programs"
- (guard (syntax (clauses \.\.\.)))
- (raise (lambda (obj)))
- )
-
- ;; SRFI 35
- ("Conditions"
- (make-condition-type (lambda (id parent field-name-list)))
- (condition-type? (lambda (obj)))
- (make-condition (lambda (condition-type)))
- (condition? (lambda (obj)))
- (condition-has-type? (lambda (condition condition-type)))
- (condition-ref (lambda (condition field-name)))
- (make-compound-condition (lambda (condition \.\.\.)))
- (extract-condition (lambda (condition condition-type)))
- (define-condition-type (syntax (name parent pred-name fields \.\.\.)))
- (condition (syntax (type-field-binding \.\.\.)))
- )
-
- ;; SRFI 36
- ("I/O Conditions"
- (&error condition)
- (&i/o-error condition)
- (&i/o-port-error condition)
- (&i/o-read-error condition)
- (&i/o-write-error condition)
- (&i/o-closed-error condition)
- (&i/o-filename-error condition)
- (&i/o-malformed-filename-error condition)
- (&i/o-file-protection-error condition)
- (&i/o-file-is-read-only-error condition)
- (&i/o-file-already-exists-error condition)
- (&i/o-no-such-file-error condition)
- )
-
- ;; SRFI 37
- ("args-fold: a program argument processor"
- (args-fold
- (arg-list option-list unrecognized-option-proc operand-proc seed \.\.\.))
- (option-processor (lambda (option name arg seeds \.\.\.)))
- (operand-processor (lambda (operand seeds \.\.\.)))
- (option (lambda (name-list required-arg? optional-arg? option-proc)))
- (option-names (lambda (option)))
- (option-required-arg? (lambda (option)))
- (option-optional-arg? (lambda (option)))
- (option-processor (lambda (option)))
- )
-
- ;; SRFI 38
- ("External Representation for Data With Shared Structure"
- (write-with-shared-structure (lambda (obj :optional port optarg)))
- (read-with-shared-structure (lambda (:optional port)))
- )
-
- ;; SRFI 39
- ("Parameter objects"
- (make-parameter (lambda (init-value :optional converter)))
- (parameterize (syntax (bindings body \.\.\.))))
-
- ;; SRFI 40
- ("A Library of Streams"
- (stream-null stream)
- (stream-cons (syntax (obj stream)))
- (stream? (lambda (obj)))
- (stream-null? (lambda (obj)))
- (stream-pair? (lambda (obj)))
- (stream-car (lambda (stream)))
- (stream-cdr (lambda (stream)))
- (stream-delay (syntax (expr)))
- (stream (lambda (obj \.\.\.)))
- (stream-unfoldn (lambda (generator-proc seed n)))
- (stream-map (lambda (proc stream \.\.\.)))
- (stream-for-each (lambda (proc stream \.\.\.) undefined))
- (stream-filter (lambda (pred stream)))
- )
-
- ()
-
- ;; SRFI 42
- ("Eager Comprehensions"
- (list-ec (syntax))
- (append-ec (syntax))
- (sum-ec (syntax))
- (min-ec (syntax))
- (max-ec (syntax))
- (any?-ec (syntax))
- (every?-ec (syntax))
- (first-ec (syntax))
- (do-ec (syntax))
- (fold-ec (syntax))
- (fold3-ec (syntax))
- (:list (syntax () undefined))
- (:string (syntax () undefined))
- (:vector (syntax () undefined))
- (:integers (syntax () undefined))
- (:range (syntax () undefined))
- (:real-range (syntax () undefined))
- (:char-range (syntax () undefined))
- (:port (syntax () undefined))
- (:do (syntax () undefined))
- (:let (syntax () undefined))
- (:parallel (syntax () undefined))
- (:while (syntax () undefined))
- (:until (syntax () undefined))
- )
-
- ;; SRFI 43
- ("Vector Library"
- (vector-unfold (f length initial-seed \.\.\.))
- (vector-unfold-right (lambda (f length initial-seed \.\.\.)))
- (vector-tabulate (lambda (f size)))
- (vector-copy (lambda (vec :optional start end fill)))
- (vector-reverse-copy (lambda (vec :optional start end)))
- (vector-append (lambda (vec \.\.\.)))
- (vector-concatenate (lambda (vector-list)))
- (vector-empty? (lambda (obj)))
- (vector= (lambda (eq-proc vec \.\.\.)))
- (vector-fold (lambda (kons knil vec \.\.\.)))
- (vector-fold-right (lambda (kons knil vec \.\.\.)))
- (vector-map (lambda (f vec \.\.\.)))
- (vector-map! (lambda (f vec \.\.\.)))
- (vector-for-each (lambda (f vec \.\.\.) undefined))
- (vector-count (lambda (pred vec \.\.\.)))
- (vector-index (lambda (pred vec \.\.\.)))
- (vector-index-right (lambda (pred vec \.\.\.)))
- (vector-skip (lambda (pred vec \.\.\.)))
- (vector-skip-right (lambda (pred vec \.\.\.)))
- (vector-binary-search (lambda (vec value cmp-proc)))
- (vector-any (lambda (pred vec \.\.\.)))
- (vector-every (lambda (pred vec \.\.\.)))
- (vector-swap! (lambda (vec i j) undefined))
- (vector-reverse! (lambda (vec :optional start end) undefined))
- (vector-copy! (lambda (target-vec t-start source-vec :optional start end) undefined))
- (vector-reverse-copy! (lambda (target-vec t-start source-vec :optional start end) undefined))
- (reverse-vector-to-list (lambda (vec :optional start end)))
- (reverse-list-to-vector (lambda (list)))
- )
-
- ;; SRFI 44
- ("Collections"
- )
-
- ;; SRFI 45
- ("Primitives for expressing iterative lazy algorithms"
- (delay (syntax (expr)))
- (lazy (syntax (expr)))
- (force (lambda (promise)))
- (eager (lambda (promise)))
- )
-
- ;; SRFI 46
- ("Basic Syntax-rules Extensions"
- (syntax-rules (syntax () undefined)))
-
- ;; SRFI 47
- ("Array"
- (make-array (lambda (prototype k \.\.\.)))
- (ac64 (lambda (:optional z)))
- (ac32 (lambda (:optional z)))
- (ar64 (lambda (:optional x1)))
- (ar32 (lambda (:optional x1)))
- (as64 (lambda (:optional n)))
- (as32 (lambda (:optional n)))
- (as16 (lambda (:optional n)))
- (as8 (lambda (:optional n)))
- (au64 (lambda (:optional n)))
- (au32 (lambda (:optional n)))
- (au16 (lambda (:optional n)))
- (au8 (lambda (:optional n)))
- (at1 (lambda (:optional bool)))
- (make-shared-array (lambda (array mapper k \.\.\.)))
- (array-rank (lambda (obj)))
- (array-dimensions (lambda (array)))
- (array-in-bounds? (lambda (array k \.\.\.)))
- (array-ref (lambda (array k \.\.\.)))
- (array-set! (lambda (array obj k \.\.\.)))
- )
-
- ;; SRFI 48
- ("Intermediate Format Strings"
- (format (lambda (port-or-boolean format-string arg \.\.\.))))
-
- ;; SRFI 49
- ("Indentation-sensitive syntax"
- )
-
- ()
-
- ;; SRFI 51
- ("Handling rest list"
- (rest-values (lambda (caller rest-list :optional args-number-limit default)))
- (arg-and (syntax))
- (arg-ands (syntax))
- (err-and (syntax))
- (err-ands (syntax))
- (arg-or (syntax))
- (arg-ors (syntax))
- (err-or (syntax))
- (err-ors (syntax))
- )
-
- ()
-
- ()
-
- ;; SRFI 54
- ("Formatting"
- (cat (lambda (obj \.\.\.))))
-
- ;; SRFI 55
- ("require-extension"
- (require-extension (syntax)))
-
- ()
-
- ;; SRFI 57
- ("Records"
- (define-record-type (syntax))
- (define-record-scheme (syntax))
- (record-update (syntax))
- (record-update! (syntax))
- (record-compose (syntax)))
-
- ;; SRFI 58
- ("Array Notation"
- )
-
- ;; SRFI 59
- ("Vicinity"
- (program-vicinity (lambda ()))
- (library-vicinity (lambda ()))
- (implementation-vicinity (lambda ()))
- (user-vicinity (lambda ()))
- (home-vicinity (lambda ()))
- (in-vicinity (lambda (vicinity filename)))
- (sub-vicinity (lambda (vicinity name)))
- (make-vicinity (lambda (dirname)))
- (path-vicinity (lambda (path)))
- (vicinity:suffix? (lambda (ch)))
- )
-
- ;; SRFI 60
- ("Integers as Bits"
- (bitwise-and (lambda (n \.\.\.) int))
- (bitwise-ior (lambda (n \.\.\.) int))
- (bitwise-xor (lambda (n \.\.\.) int))
- (bitwise-not (lambda (n) int))
- (bitwise-if (lambda (mask n m) int))
- (any-bits-set? (lambda (n m) bool))
- (bit-count (lambda (n) int))
- (integer-length (lambda (n) int))
- (first-bit-set (lambda (n) int))
- (bit-set? (lambda (i n) bool))
- (copy-bit (lambda (index n bool) int))
- (bit-field (lambda (n start end) int))
- (copy-bit-field (lambda (to-int from-int start end) int))
- (arithmetic-shift (lambda (n count) int))
- (rotate-bit-field (lambda (n count start end) int))
- (reverse-bit-field (lambda (n start end) int))
- (integer->list (lambda (k :optional len) list))
- (list->integer (lambda (list) int))
- )
-
- ;; SRFI 61
- ("A more general cond clause"
- (cond (syntax)))
-
- ;; SRFI 62
- ("S-expression comments"
- )
-
- ;; SRFI 63
- ("Homogeneous and Heterogeneous Arrays"
- )
-
- ;; SRFI 64
- ("A Scheme API for test suites"
- (test-assert (syntax))
- (test-eqv (syntax))
- (test-equal (syntax))
- (test-eq (syntax))
- (test-approximate (syntax))
- (test-error (syntax))
- (test-read-eval-string (lambda (string)))
- (test-begin (syntax (suite-name :optional count)))
- (test-end (syntax (suite-name)))
- (test-group (syntax (suite-name decl-or-expr \.\.\.)))
- (test-group-with-cleanup (syntax (suite-name decl-or-expr \.\.\.)))
- (test-match-name (lambda (name)))
- (test-match-nth (lambda (n :optional count)))
- (test-match-any (lambda (specifier \.\.\.)))
- (test-match-all (lambda (specifier \.\.\.)))
- (test-skip (syntax (specifier)))
- (test-expect-fail (syntax (specifier)))
- (test-runner? (lambda (obj)))
- (test-runner-current (lambda (:optional runner)))
- (test-runner-get (lambda ()))
- (test-runner-simple (lambda ()))
- (test-runner-null (lambda ()))
- (test-runner-create (lambda ()))
- (test-runner-factory (lambda (:optional factory)))
- (test-apply (syntax (runner specifier \.\.\.)))
- (test-with-runner (syntax (runner decl-or-expr \.\.\.)))
- (test-result-kind (lambda (:optional runner)))
- (test-passed? (lambda (:optional runner)))
- (test-result-ref (lambda (runner prop-name (:optional default))))
- (test-result-set! (lambda (runner prop-name value)))
- (test-result-remove (lambda (runner prop-name)))
- (test-result-clear (lambda (runner)))
- (test-result-alist (lambda (runner)))
- (test-runner-on-test-begin (lambda (runner :optional proc)))
- (test-runner-on-test-begin! (lambda (runner :optional proc)))
- (test-runner-on-test-end (lambda (runner :optional proc)))
- (test-runner-on-test-end! (lambda (runner :optional proc)))
- (test-runner-on-group-begin (lambda (runner :optional proc)))
- (test-runner-on-group-begin! (lambda (runner :optional proc)))
- (test-runner-on-group-end (lambda (runner :optional proc)))
- (test-runner-on-group-end! (lambda (runner :optional proc)))
- (test-runner-on-bad-count (lambda (runner :optional proc)))
- (test-runner-on-bad-count! (lambda (runner :optional proc)))
- (test-runner-on-bad-end-name (lambda (runner :optional proc)))
- (test-runner-on-bad-end-name! (lambda (runner :optional proc)))
- (test-runner-on-final (lambda (runner :optional proc)))
- (test-runner-on-final! (lambda (runner :optional proc)))
- (test-runner-pass-count (lambda (runner)))
- (test-runner-fail-count (lambda (runner)))
- (test-runner-xpass-count (lambda (runner)))
- (test-runner-skip-count (lambda (runner)))
- (test-runner-test-name (lambda (runner)))
- (test-runner-group-path (lambda (runner)))
- (test-runner-group-stack (lambda (runner)))
- (test-runner-aux-value (lambda (runner)))
- (test-runner-aux-value! (lambda (runner)))
- (test-runner-reset (lambda (runner)))
- )
-
- ()
-
- ;; SRFI 66
- ("Octet Vectors"
- (make-u8vector (lambda (len n)))
- (u8vector (lambda (n \.\.\.)))
- (u8vector->list (lambda (u8vector)))
- (list->u8vector (lambda (octet-list)))
- (u8vector-length u8vector)
- (u8vector-ref (lambda (u8vector k)))
- (u8vector-set! (lambda (u8vector k n)))
- (u8vector=? (lambda (u8vector-1 u8vector-2)))
- (u8vector-compare (lambda (u8vector-1 u8vector-2)))
- (u8vector-copy! (lambda (source source-start target target-start n)))
- (u8vector-copy (lambda (u8vector)))
- )
-
- ;; SRFI 67
- ("Compare Procedures"
- )
-
- ()
-
- ;; SRFI 69
- ("Basic hash tables"
- (alist->hash-table (lambda (alist) hash-table))
- (hash (lambda (obj :optional n) int))
- (hash-by-identity (lambda (obj :optional n) int))
- (hash-table->alist (lambda (hash-table) alist))
- (hash-table-copy (lambda (hash-table) hash-table))
- (hash-table-delete! (lambda (hash-table key) undefined))
- (hash-table-equivalence-function (lambda (hash-table) pred))
- (hash-table-exists? (lambda (hash-table key) bool))
- (hash-table-fold (lambda (hash-table f init-value)))
- (hash-table-hash-function (lambda (hash-table) f))
- (hash-table-keys (lambda (hash-table) list))
- (hash-table-merge! (lambda (hash-table1 hash-table2) undefined))
- (hash-table-ref (lambda (hash-table key :optional thunk)))
- (hash-table-ref/default (lambda (hash-table key default)))
- (hash-table-remove! (lambda (hash-table proc) undefined))
- (hash-table-set! (lambda (hash-table key value) undefined))
- (hash-table-size (lambda (hash-table) n))
- (hash-table-update! (lambda (hash-table key proc :optional thunk) undefined))
- (hash-table-update!/default (lambda (hash-table key proc default) undefined))
- (hash-table-values (lambda (hash-table) list))
- (hash-table-walk (lambda (hash-table proc) undefined))
- (hash-table? (lambda (obj) bool))
- (make-hash-table (lambda (:optional eq-fn hash-fn) hash-table))
- (string-ci-hash (lambda (str :optional n) n))
- (string-hash (lambda (str1 :optional n) n))
- )
-
- ;; SRFI 70
- ("Numbers"
- )
-
- ;; SRFI 71
- ("LET-syntax for multiple values"
- )
-
- ;; SRFI 72
- ("Simple hygienic macros"
- )
-
- ()
-
- ;; SRFI 74
- ("Octet-Addressed Binary Blocks"
- )
-
- ])
-
-(defvar *scheme-chicken-modules*
- '((data-structures
- (->string (lambda (obj) str))
- (alist-ref (lambda (alist key :optional eq-fn default)))
- (alist-update! (lambda (key value alist :optional eq-fn) undefined))
- (always? (lambda (obj) bool))
- (any? (lambda (obj) bool))
- (atom? (lambda (obj) bool))
- (binary-search (lambda (vec proc)))
- (butlast (lambda (list) list) "drops the last element of list")
- (chop (lambda (list k) list))
- (complement (lambda (f) f2))
- (compose (lambda (f1 f2 \.\.\.) f))
- (compress (lambda (boolean-list list) list))
- (conc (lambda (obj \.\.\.) str))
- (conjoin (lambda (pred \.\.\.) pred))
- (constantly (lambda (obj \.\.\.) f))
- (disjoin (lambda (pred \.\.\.) pred))
- (each (lambda (proc \.\.\.) proc))
- (flatten (lambda (list1 \.\.\.) list))
- (flip (lambda (proc) proc))
- (identity (lambda (obj)))
- (intersperse (lambda (list obj) list))
- (join (lambda (list-of-lists :optional list) list))
- (left-section (lambda (proc obj \.\.\.) proc))
- (list->queue (lambda (list) queue))
- (list-of? (lambda (pred) (lambda (list) bool)))
- (make-queue (lambda () queue))
- (merge (lambda (list1 list2 less-fn) list))
- (merge! (lambda (list1 list2 less-fn) list))
- (never? (lambda (obj) bool))
- (none? (lambda (obj) bool))
- (noop (lambda (obj \.\.\.) undefined))
- (o (lambda (proc \.\.\.) (lambda (obj))))
- (project (lambda (n) proc))
- (queue->list (lambda (queue) list))
- (queue-add! (lambda (queue obj) undefined))
- (queue-empty? (lambda (queue) bool))
- (queue-first (lambda (queue)))
- (queue-last (lambda (queue)))
- (queue-push-back! (lambda (queue obj) undefined))
- (queue-push-back-list! (lambda (queue list) undefined))
- (queue-remove! (lambda (queue) undefined))
- (queue? (lambda (obj) bool))
- (rassoc (lambda (key list :optional eq-fn)))
- (right-section (lambda (proc obj \.\.\.) proc))
- (shuffle (lambda (list) list))
- (sort (lambda ((or list vector) less-fn) (or list vector)))
- (sort! (lambda ((or list vector) less-fn) (or list vector)))
- (sorted? (lambda ((or list vector) less-fn) bool))
- (string-chomp (lambda (str :optional suffix-str) str))
- (string-chop (lambda (str length) list))
- (string-compare3 (lambda (str1 str2) n))
- (string-compare3-ci (lambda (str1 str2) n))
- (string-intersperse (lambda (list :optional seperator-string) str))
- (string-split (lambda (str :optional delimiter-str keep-empty?) list))
- (string-translate (lambda (str from-str :optional to-str) str))
- (string-translate* (lambda (str list) str))
- (substring-ci=? (lambda (str1 str2 :optional start1 start2 length) str))
- (substring-index (lambda (which-str where-str :optional start) i))
- (substring-index-ci (lambda (which-str where-str :optional start) i))
- (substring=? (lambda (str1 str2 :optional start1 start2 length) bool))
- (tail? (lambda (obj list) bool)))
- (extras
- (alist->hash-table (lambda (alist) hash-table))
- (format (lambda (format-string arg \.\.\.)))
- (fprintf (lambda (port format-string arg \.\.\.)))
- (hash (lambda (obj :optional n) int))
- (hash-by-identity (lambda (obj :optional n) int))
- (hash-table->alist (lambda (hash-table) alist))
- (hash-table-copy (lambda (hash-table) hash-table))
- (hash-table-delete! (lambda (hash-table key) undefined))
- (hash-table-equivalence-function (lambda (hash-table) pred))
- (hash-table-exists? (lambda (hash-table key) bool))
- (hash-table-fold (lambda (hash-table f init-value)))
- (hash-table-hash-function (lambda (hash-table) f))
- (hash-table-keys (lambda (hash-table) list))
- (hash-table-merge! (lambda (hash-table1 hash-table2) undefined))
- (hash-table-ref (lambda (hash-table key :optional thunk)))
- (hash-table-ref/default (lambda (hash-table key default)))
- (hash-table-remove! (lambda (hash-table proc) undefined))
- (hash-table-set! (lambda (hash-table key value) undefined))
- (hash-table-size (lambda (hash-table) n))
- (hash-table-update! (lambda (hash-table key proc :optional thunk) undefined))
- (hash-table-update!/default (lambda (hash-table key proc default) undefined))
- (hash-table-values (lambda (hash-table) list))
- (hash-table-walk (lambda (hash-table proc) undefined))
- (hash-table? (lambda (obj) bool))
- (make-hash-table (lambda (:optional eq-fn hash-fn size) hash-table))
- (pp (lambda (obj :optional output-port) undefined))
- (pretty-print (lambda (obj :optional output-port) undefined))
- (pretty-print-width (lambda (:optional new-width) n))
- (printf (lambda (format-string arg \.\.\.) undefined))
- (random (lambda (n) n))
- (randomize (lambda (:optional x1) undefined))
- (read-file (lambda (:optional file-or-port reader-fn max-count) str))
- (read-line (lambda (:optional port limit) str))
- (read-lines (lambda (:optional port max) list))
- (read-string (lambda (:optional n port) str))
- (read-string! (lambda (n dest :optional port start) n))
- (read-token (lambda (predicate :optional port) str))
- (sprintf (lambda (format-string arg \.\.\.) str))
- (string-hash (lambda (str1 :optional n) n))
- (string-ci-hash (lambda (str :optional n) n))
- (with-error-output-to-port (lambda (output-port thunk)))
- (write-line (lambda (str :optional port) undefined))
- (write-string (lambda (str :optional num port) undefined))
- )
- (files
- (absolute-pathname? (lambda (pathname)))
- (create-temporary-file (lambda (:optional ext-str)))
- (decompose-pathname (lambda (pathname)))
- (delete-file* (lambda (filename)))
- (directory-null? (lambda (pathname) bool))
- (file-copy (lambda (pathname1 pathname2 :optional bool size)))
- (file-move (lambda (pathname1 pathname2 :optional bool size)))
- (make-absolute-pathname (lambda (dir filename :optional ext-str)))
- (make-pathname (lambda (dir filename :optional ext-str) pathname))
- (normalize-pathname (lambda (pathname :optional platform) pathname))
- (pathname-directory (lambda (pathname)))
- (pathname-extension (lambda (pathname)))
- (pathname-file (lambda (pathname)))
- (pathname-replace-directory (lambda (pathname dir)))
- (pathname-replace-extension (lambda (pathname ext-str)))
- (pathname-replace-file (lambda (pathname filename)))
- (pathname-strip-directory (lambda (pathname)))
- (pathname-strip-extension (lambda (pathname)))
- )
- (foreign
- (define-external (syntax (obj type body \.\.\.)))
- (define-location (syntax (name type init)))
- (let-location (syntax bindings body \.\.\.))
- (foreign-code (syntax (str \.\.\.)))
- (foreign-value (syntax (str type)))
- (foreign-declare (syntax (str \.\.\.)))
- (define-foreign-variable (syntax))
- (foreign-lambda (syntax))
- (foreign-lambda* (syntax))
- (foreign-safe-lambda (syntax))
- (foreign-safe-lambda* (syntax))
- (location)
- (foreign-code (syntax))
- )
- (irregex
- (irregex (lambda (obj flags \.\.\.)))
- (string->irregex (lambda (str flags \.\.\.)))
- (sre->irregex (lambda (obj flags \.\.\.)))
- (string->sre (lambda (str)))
- (irregex? (lambda (obj) bool))
- (irregex-match-data? (lambda (obj) bool))
- (irregex-new-matches (lambda (irx)))
- (irregex-reset-matches! (lambda (match-data) undefined))
- (irregex-match-start (lambda (match-data) (or bool integer)))
- (irregex-match-end (lambda (match-data) (or bool integer)))
- (irregex-match-substring (lambda (match-data) (or bool string)))
- (irregex-search (lambda (irx str :optional start end)))
- (irregex-search/matches (lambda (irx str start end match-data)))
- (irregex-match (lambda (irx str :optional start end)))
- (irregex-match-string (lambda (match-data) str))
- (irregex-fold (lambda (irx kons knil str :optional finish start end)))
- (irregex-replace (lambda (irx str replacements \.\.\.) str))
- (irregex-replace/all (lambda (irx str replacements \.\.\.) str))
- (irregex-apply-match (lambda (match-data list) str))
- (irregex-dfa (lambda (irx)))
- (irregex-dfa/search (lambda (irx)))
- (irregex-dfa/extract (lambda (irx)))
- (irregex-nfa (lambda (irx)))
- (irregex-flags (lambda (irx)))
- (irregex-submatches (lambda (irx) n))
- (irregex-lengths (lambda (irx) vector))
- (irregex-names (lambda (irx))))
- (lolevel
- (address->pointer (lambda (n) ptr))
- (align-to-word (lambda (ptr-or-int) ptr))
- (allocate (lambda (size) block))
- (block-ref (lambda (block index) int))
- (block-set! (lambda (block index obj) undefined))
- (byte-vector (lambda (n \.\.\.) byte-vector))
- (byte-vector->list (lambda (byte-vector) list))
- (byte-vector->string (lambda (byte-vector) string))
- (byte-vector-fill! (lambda (byte-vector n) undefined))
- (byte-vector-length (lambda (byte-vector) n))
- (byte-vector-ref (lambda (byte-vector i) int))
- (byte-vector-set! (lambda (byte-vector i n) undefined))
- (byte-vector? (lambda (obj) bool))
- (extend-procedure (lambda (proc x1) proc))
- (extended-procedure? (lambda (proc) bool))
- (free (lambda (pointer) undefined))
- (global-bound? (lambda (sym) bool))
- (global-make-unbound! (lambda (sym) undefined))
- (global-ref (lambda (sym)))
- (global-set! (lambda (sym val) undefined))
- (list->byte-vector (lambda (list) byte-vector))
- (locative->object (lambda (locative) obj))
- (locative-ref (lambda (locative)))
- (locative-set! (lambda (locative val) undefined))
- (locative? (lambda (obj) bool))
- (make-byte-vector (lambda (size :optional init-n) byte-vector))
- (make-locative (lambda (obj :optional index) locative))
- (make-record-instance (lambda (sym arg \.\.\.)))
- (make-static-byte-vector (lambda (size :optional init-n)))
- (make-weak-locative (lambda (obj :optional index) locative))
- (move-memory! (lambda (from to :optional bytes from-offset to-offset) undefined))
- (mutate-procedure (lambda (proc proc) proc))
- (null-pointer (lambda () pointer))
- (null-pointer? (lambda (pointer) bool))
- (number-of-bytes (lambda (block) int))
- (number-of-slots (lambda (block) int))
- (object->pointer (lambda (obj) ptr))
- (object-become! (lambda (alist) undefined))
- (object-copy (lambda (obj)))
- (object-evict (lambda (obj :optional allocator-proc)))
- (object-evict-to-location (lambda (obj ptr :optional limit)))
- (object-evicted? (lambda (obj) bool))
- (object-release (lambda (obj :optional releaser-proc)))
- (object-size (lambda (obj) int))
- (object-unevict (lambda (obj :optional full)))
- (pointer->address (lambda (ptr) n))
- (pointer->object (lambda (ptr)))
- (pointer-f32-ref (lambda (ptr) real))
- (pointer-f32-set! (lambda (ptr x1) undefined))
- (pointer-f64-ref (lambda (ptr) real))
- (pointer-f64-set! (lambda (ptr x1) undefined))
- (pointer-offset (lambda (ptr n) n))
- (pointer-s16-ref (lambda (ptr) int))
- (pointer-s16-set! (lambda (ptr n) undefined))
- (pointer-s32-ref (lambda (ptr) int))
- (pointer-s32-set! (lambda (ptr n) undefined))
- (pointer-s8-ref (lambda (ptr) int))
- (pointer-s8-set! (lambda (ptr n) undefined))
- (pointer-tag (lambda (ptr) tag))
- (pointer-u16-ref (lambda (ptr) int))
- (pointer-u16-set! (lambda (ptr n) undefined))
- (pointer-u32-ref (lambda (ptr) int))
- (pointer-u32-set! (lambda (ptr n) undefined))
- (pointer-u8-ref (lambda (ptr) int))
- (pointer-u8-set! (lambda (ptr n) undefined))
- (pointer=? (lambda (ptr1 ptr2) bool))
- (pointer? (lambda (obj) bool))
- (procedure-data (lambda (proc)))
- (record->vector (lambda (block) vector))
- (record-instance? (lambda (obj) bool))
- (set-invalid-procedure-call-handler! (lambda (proc) undefined))
- (set-procedure-data! (lambda (proc obj) undefined))
- (static-byte-vector->pointer (lambda (byte-vector) pointer))
- (string->byte-vector (lambda (str) byte-vector))
- (tag-pointer (lambda (ptr tag)))
- (tagged-pointer? (lambda (obj tag) bool))
- (unbound-variable-value (lambda (:optional value)))
- )
- (ports
- (call-with-input-string (lambda (string proc)))
- (call-with-output-string (lambda (proc) str))
- (make-input-port (lambda (read-proc ready?-pred close-proc :optional peek-proc) input-port))
- (make-output-port (lambda (write-proc close-proc :optional flush-proc) output-port))
- (port-for-each (lambda (read-fn thunk) undefined))
- (port-map (lambda (read-fn thunk)))
- (port-fold (lambda (proc init port)))
- (make-broadcast-port (lambda (output-port \.\.\.) output-port))
- (make-concatenated-port (lambda (input-port \.\.\.) input-port))
- (with-input-from-port (lambda (input-port thunk)))
- (with-input-from-string (lambda (str thunk)))
- (with-output-to-port (lambda (output-port thunk)))
- (with-output-to-string (lambda (thunk) str))
- (with-error-output-to-port (lambda (output-port thunk))))
- (posix
- (_exit (lambda (:optional n) undefined))
- (call-with-input-pipe (lambda (cmdline-string proc :optional mode)))
- (call-with-output-pipe (lambda (cmdline-string proc :optional mode)))
- (change-directory (lambda (dir)))
- (change-file-mode (lambda (filename mode)))
- (change-file-owner (lambda (filename user-n group-n)))
- (close-input-pipe (lambda (input-port)))
- (close-output-pipe (lambda (output-port)))
- (create-directory (lambda (filename)))
- (create-fifo (lambda (filename :optional mode)))
- (create-pipe (lambda ()))
- (create-session (lambda ()))
- (create-symbolic-link (lambda (old-filename new-filename)))
- (current-directory (lambda (:optional new-dir)))
- (current-effective-group-id (lambda () int))
- (current-effective-user-id (lambda () int))
- (current-environment (lambda ()))
- (current-group-id (lambda ()))
- (current-process-id (lambda ()))
- (current-user-id (lambda ()))
- (delete-directory (lambda (dir)))
- (directory (lambda (:optional dir show-dotfiles?) list))
- (directory? (lambda (filename) bool))
- (duplicate-fileno (lambda (old-n :optional new-n)))
- (errno/acces integer)
- (errno/again integer)
- (errno/badf integer)
- (errno/busy integer)
- (errno/child integer)
- (errno/exist integer)
- (errno/fault integer)
- (errno/intr integer)
- (errno/inval integer)
- (errno/io integer)
- (errno/isdir integer)
- (errno/mfile integer)
- (errno/noent integer)
- (errno/noexec integer)
- (errno/nomem integer)
- (errno/nospc integer)
- (errno/notdir integer)
- (errno/perm integer)
- (errno/pipe integer)
- (errno/rofs integer)
- (errno/spipe integer)
- (errno/srch integer)
- (errno/wouldblock integer)
- (fifo? (lambda (filename) bool))
- (file-access-time (lambda (filename) real))
- (file-change-time (lambda (filename) real))
- (file-close (lambda (fileno)))
- (file-execute-access? (lambda (filename) bool))
- (file-link (lambda (old-filename new-filename)))
- (file-lock (lambda (port :optional start len)))
- (file-lock/blocking (lambda (port :optional start len)))
- (file-mkstemp (lambda (template-filename)))
- (file-modification-time (lambda (filename) real))
- (file-open (lambda (filename (flags open-mode open/binary open/excl open/fsync open/noctty open/nonblock open/rdonly open/rdwr open/read open/sync open/text) :optional mode) fileno))
- (file-owner (lambda (filename)))
- (file-permissions (lambda (filename) int))
- (file-position (lambda (port-or-fileno) int))
- (file-read (lambda (fileno size :optional buffer-string)))
- (file-read-access? (lambda (filename) bool))
- (file-select (lambda (read-fd-list write-fd-list :optional timeout)))
- (file-size (lambda (filename) int))
- (file-stat (lambda (filename :optional follow-link?)))
- (file-test-lock (lambda (port :optional start len)))
- (file-truncate (lambda (filename-or-fileno offset)))
- (file-unlock (lambda (lock)))
- (file-write (lambda (fileno buffer-string :optional size)))
- (file-write-access? (lambda (filename)))
- (fileno/stderr integer)
- (fileno/stdin integer)
- (fileno/stdout integer)
- (find-files (lambda (dir pred :optional action-proc identity limit)))
- (get-groups (lambda ()))
- (get-host-name (lambda ()))
- (glob (lambda (pattern1 \.\.\.)))
- (group-information (lambda (group-name-or-n)))
- (initialize-groups (lambda (user-name base-group-n)))
- (local-time->seconds (lambda (vector)))
- (local-timezone-abbreviation (lambda ()))
- (map-file-to-memory (lambda (address len protection flag fileno :optional offset)))
- (memory-mapped-file-pointer (lambda (mmap)))
- (memory-mapped-file? (lambda (obj)))
- (open-input-file* (lambda (fileno :optional (flags open-mode open/binary open/excl open/fsync open/noctty open/nonblock open/rdonly open/rdwr open/read open/sync open/text))))
- (open-input-pipe (lambda (cmdline-string :optional mode)))
- (open-output-file* (lambda (fileno :optional (flags open-mode open/append open/binary open/creat open/excl open/fsync open/noctty open/nonblock open/rdwr open/sync open/text open/trunc open/write open/wronly))))
- (open-output-pipe (lambda (cmdline-string :optional mode)))
- (open/append integer)
- (open/binary integer)
- (open/creat integer)
- (open/excl integer)
- (open/fsync integer)
- (open/noctty integer)
- (open/nonblock integer)
- (open/rdonly integer)
- (open/rdwr integer)
- (open/read integer)
- (open/sync integer)
- (open/text integer)
- (open/trunc integer)
- (open/write integer)
- (open/wronly integer)
- (parent-process-id (lambda ()))
- (perm/irgrp integer)
- (perm/iroth integer)
- (perm/irusr integer)
- (perm/irwxg integer)
- (perm/irwxo integer)
- (perm/irwxu integer)
- (perm/isgid integer)
- (perm/isuid integer)
- (perm/isvtx integer)
- (perm/iwgrp integer)
- (perm/iwoth integer)
- (perm/iwusr integer)
- (perm/ixgrp integer)
- (perm/ixoth integer)
- (perm/ixusr integer)
- (pipe/buf integer)
- (port->fileno (lambda (port)))
- (process (lambda (cmdline-string :optional arg-list env-list)))
- (process-execute (lambda (filename :optional arg-list env-list)))
- (process-fork (lambda (:optional thunk)))
- (process-group-id (lambda ()))
- (process-run (lambda (filename :optional list)))
- (process-signal (lambda (pid :optional signal)))
- (process-wait (lambda (:optional pid nohang?)))
- (read-symbolic-link (lambda (filename) filename))
- (regular-file? (lambda (filename)))
- (seconds->local-time (lambda (seconds)))
- (seconds->string (lambda (seconds)))
- (seconds->utc-time (lambda (seconds)))
- (set-alarm! (lambda (seconds)))
- (set-buffering-mode! (lambda (port mode :optional buf-size)))
- (set-file-position! (lambda (port-or-fileno pos :optional whence)))
- (set-group-id! (lambda (n)))
- (set-groups! (lambda (group-n-list)))
- (set-process-group-id! (lambda (process-n n)))
- (set-root-directory! (lambda (dir)) "chroot")
- (set-signal-handler! (lambda (sig-n proc)))
- (set-signal-mask! (lambda (sig-n-list)))
- (set-user-id! (lambda (n)))
- (setenv (lambda (name value-string)))
- (signal/abrt integer)
- (signal/alrm integer)
- (signal/chld integer)
- (signal/cont integer)
- (signal/fpe integer)
- (signal/hup integer)
- (signal/ill integer)
- (signal/int integer)
- (signal/io integer)
- (signal/kill integer)
- (signal/pipe integer)
- (signal/prof integer)
- (signal/quit integer)
- (signal/segv integer)
- (signal/stop integer)
- (signal/term integer)
- (signal/trap integer)
- (signal/tstp integer)
- (signal/urg integer)
- (signal/usr1 integer)
- (signal/usr2 integer)
- (signal/vtalrm integer)
- (signal/winch integer)
- (signal/xcpu integer)
- (signal/xfsz integer)
- (sleep (lambda (seconds)))
- (symbolic-link? (lambda (filename)))
- (system-information (lambda ()))
- (terminal-name (lambda (port)))
- (terminal-port? (lambda (port)))
- (time->string (lambda (vector)))
- (unmap-file-from-memory (lambda (mmap :optional len)))
- (unsetenv (lambda (name) undefined))
- (user-information (lambda ((or integer (string scheme-complete-user-name))) list))
- (utc-time->seconds (lambda (vector)))
- (with-input-from-pipe (lambda (cmdline-string thunk :optional mode)))
- (with-output-to-pipe (lambda (cmdline-string thunk :optional mode)))
- )
- (regex
- (glob->regexp (lambda (pattern)))
- (glob? (lambda (obj)))
- (grep (lambda (pattern list) list))
- (regexp (lambda (pattern ignore-case? ignore-space? utf-8?)))
- (regexp-escape (lambda (str) str))
- (regexp? (lambda (obj) bool))
- (string-match (lambda (pattern str :optional start)))
- (string-match-positions (lambda (pattern str :optional start)))
- (string-search (lambda (pattern str :optional start)))
- (string-search-positions (lambda (pattern str :optional start)))
- (string-split-fields (lambda (pattern str :optional mode start)))
- (string-substitute (lambda (pattern subst str :optional mode)))
- (string-substitute* (lambda (str subst-list :optional mode)))
- )
- (tcp
- (tcp-abandon-port (lambda (port)))
- (tcp-accept (lambda (listener)))
- (tcp-accept-ready? (lambda (listener)))
- (tcp-accept-timeout (lambda (:optional number)))
- (tcp-addresses (lambda (port)))
- (tcp-buffer-size (lambda (:optional new-size)))
- (tcp-close (lambda (listener)))
- (tcp-connect (lambda ((string scheme-complete-host-name) :optional (string scheme-complete-port-name))))
- (tcp-connect-timeout (lambda (:optional number)))
- (tcp-listen (lambda (tcp-port-n :optional backlog-n host-string)))
- (tcp-listener-fileno (lambda (listener)))
- (tcp-listener-port (lambda (listener)))
- (tcp-listener? (lambda (obj)))
- (tcp-port-numbers (lambda (port)))
- (tcp-read-timeout (lambda (:optional number)))
- (tcp-write-timeout (lambda (:optional number)))
- )
- (utils
- (for-each-argv-line (lambda (proc) undefined))
- (for-each-line (lambda (proc :optional input-port) undefined))
- (read-all (lambda (:optional file-or-port)))
- (shift! (lambda (list :optional default)))
- (system* (lambda (format-string arg1 \.\.\.)))
- (compile-file (lambda (filename)))
- (qs (lambda (str :optional platform) str)
- "quote string for shell")
- )
- ))
-
-;; another big table - consider moving to a separate file
-(defvar *scheme-implementation-exports*
- '((chicken
- (abort (lambda (obj) undefined))
- (add1 (lambda (z) z))
- (andmap (lambda (pred list) bool))
- (argc+argv (lambda () (values n ptr)))
- (argv (lambda () list))
- (bit-set? (lambda (n index) bool))
- (bitwise-and (lambda (n \.\.\.) n))
- (bitwise-ior (lambda (n \.\.\.) n))
- (bitwise-not (lambda (n \.\.\.) n))
- (bitwise-xor (lambda (n \.\.\.) n))
- (blob->string (lambda (blob) string))
- (blob-size (lambda (blob) n))
- (blob? (lambda (obj) bool))
- (breakpoint (lambda (:optional name)))
- (build-platform (lambda () symbol))
- (c-runtime (lambda () symbol))
- (call/cc (lambda (proc)))
- (case-sensitive (lambda (:optional on?)))
- (chicken-home (lambda () string))
- (chicken-version (lambda () string))
- (command-line-arguments (lambda () list))
- (cond-expand (syntax))
- (condition-predicate (lambda (kind) pred))
- (condition-property-accessor (lambda (kind prop :optional err?) proc))
- (condition? (lambda (obj) bool))
- (continuation-capture (lambda (proc)))
- (continuation-graft (lambda (continuation thunk)))
- (continuation-return (lambda (continuation vals\.\.\.)))
- (continuation? (lambda (obj) bool))
- (copy-read-table (lambda (read-table) read-table))
- (cpu-time (lambda () (values n n)))
- (current-error-port (lambda () output-port))
- (current-exception-handler (lambda () proc))
- (current-gc-milliseconds (lambda () n))
- (current-milliseconds (lambda () n))
- (current-read-table (lambda () read-table))
- (current-seconds (lambda () x1))
- (cut (syntax))
- (cute (lambda (args \.\.\.) proc))
- (declare (syntax))
- (define-record (syntax))
- (define-record-printer (syntax))
- (define-reader-ctor (lambda (sym proc) undefined))
- (delete-file (lambda (filename) undefined))
- (disable-interrupts (lambda () undefined))
- (dynamic-load-libraries (lambda () list))
- (dynamic-wind (lambda (before-thunk thunk after-thunk)))
- (enable-interrupts (lambda () undefined))
- (enable-warnings (lambda () undefined))
- (er-macro-transformer (syntax))
- (errno (lambda () n))
- (error (lambda (error-string args \.\.\.) undefined))
- (eval-handler (lambda () proc))
- (exit (lambda (:optional n) undefined))
- (exit-handler (lambda () proc))
- (extension-info (lambda (proc)))
- (extension-information (lambda (proc)))
- (feature? (lambda (sym) bool))
- (features (lambda () list))
- (file-exists? (lambda (filename) bool))
- (finite? (lambda (z) bool))
- (fixnum? (lambda (obj) bool))
- (flonum? (lambda (obj) bool))
- (flush-output (lambda (:optional port) undefined))
- (force (lambda (promise)))
- (force-finalizers (lambda (f args \.\.\.)))
- (fp* (lambda (x1 x2) x3))
- (fp+ (lambda (x1 x2) x3))
- (fp- (lambda (x1 x2) x3))
- (fp/ (lambda (x1 x2) x3))
- (fp< (lambda (x1 x2) x3))
- (fp<= (lambda (x1 x2) x3))
- (fp= (lambda (x1 x2) x3))
- (fp> (lambda (x1 x2) x3))
- (fp>= (lambda (x1 x2) x3))
- (fpmax (lambda (x1 x2) x3))
- (fpmin (lambda (x1 x2) x3))
- (fpneg (lambda (x1 x2) x3))
- (fx* (lambda (n1 n2) n))
- (fx+ (lambda (n1 n2) n))
- (fx- (lambda (n1 n2) n))
- (fx/ (lambda (n1 n2) n))
- (fx< (lambda (n1 n2) n))
- (fx<= (lambda (n1 n2) n))
- (fx= (lambda (n1 n2) n))
- (fx> (lambda (n1 n2) n))
- (fx>= (lambda (n1 n2) n))
- (fxand (lambda (n1 n2) n))
- (fxior (lambda (n1 n2) n))
- (fxmax (lambda (n1 n2) n))
- (fxmin (lambda (n1 n2) n))
- (fxmod (lambda (n1 n2) n))
- (fxneg (lambda (n1 n2) n))
- (fxnot (lambda (n1 n2) n))
- (fxshl (lambda (n1 n2) n))
- (fxshr (lambda (n1 n2) n))
- (fxxor (lambda (n1 n2) n))
- (gc (lambda () n))
- (gensym (lambda (:optional name) sym))
- (get-call-chain (lambda (:optional n) list))
- (get-keyword (lambda (sym list :optional default)))
- (get-line-number (lambda (sexp) n))
- (get-output-string (lambda (string-output-port) string))
- (getenv (lambda (name) string))
- (get-environment-variable (lambda (name) string))
- (getter-with-setter (lambda (get-proc set-proc) proc))
- (import (special symbol scheme-chicken-available-modules)
- "import extensions into the current module")
- (implicit-exit-handler (lambda (:optional proc) proc))
- (invalid-procedure-call-handler (lambda (:optional proc) proc))
- (keyword->string (lambda (sym) string))
- (keyword-style (lambda (:optional sym) sym))
- (keyword? (lambda (obj) bool))
- (load-library (lambda (sym) undefined))
- (load-noisily (lambda (string) undefined))
- (load-relative (lambda (string) undefined))
- (load-verbose (lambda (:optional bool) bool))
- (machine-byte-order (lambda () sym))
- (machine-type (lambda () sym))
- (macro? (lambda (obj) bool))
- (macroexpand (lambda (sexp) sexp))
- (macroexpand-1 (lambda (sexp) sexp))
- (make-blob (lambda (size) blob))
- (make-composite-condition (lambda (condition \.\.\.) condition))
- (make-parameter (lambda (val) proc))
- (make-property-condition (lambda (kind \.\.\.) condition))
- (match-error-control (lambda (:optional proc) proc))
- (match-error-procedure (lambda (:optional proc) proc))
- (memory-statistics (lambda () vector))
- (on-exit (lambda (thunk) undefined))
- (open-input-string (lambda (string) string-input-port))
- (open-output-string (lambda () string-output-port))
- (ormap (lambda (pred list \.\.\.) bool))
- (port-name (lambda (:optional port) name))
- (port-position (lambda (:optional port) n))
- (port? (lambda (obj) bool))
- (print (lambda (obj \.\.\.) undefined))
- (print* (lambda (obj \.\.\.) undefined))
- (print-backtrace (lambda (:optional n) undefined))
- (print-call-chain (lambda (:optional n) undefined))
- (print-error-message (lambda (err args \.\.\.) undefined))
- (procedure-information (lambda (proc)))
- (program-name (lambda (:optional name) name))
- (provide (lambda (name)))
- (provided? (lambda (name) bool))
- (rational? (lambda (obj) bool))
- (read-byte (lambda (:optional input-port) n))
- (register-feature! (lambda (name) undefined))
- (rename-file (lambda (old-name new-name) undefined))
- (repl (lambda () undefined))
- (repository-path (lambda (:optional dirname) dirname))
- (require (lambda (sym \.\.\.) undefined))
- (require-extension
- (special symbol scheme-chicken-available-modules)
- "import extensions into top-level namespace")
- (require-library
- (special symbol scheme-chicken-available-modules)
- "load (but don't import) extensions")
- (reset (lambda () undefined))
- (reset-handler (lambda (:optional proc) proc))
- (return-to-host (lambda () undefined))
- (reverse-list->string (lambda (list) string))
- (set-dynamic-load-mode! (lambda (obj) undefined))
- (set-extension-specifier! (lambda (name proc) undefined))
- (set-finalizer! (lambda (obj proc) undefined))
- (set-gc-report! (lambda (bool) undefined))
- (set-parameterized-read-syntax! (lambda (ch proc) undefined))
- (set-port-name! (lambda (port name) undefined))
- (set-read-syntax! (lambda (ch proc) undefined))
- (set-sharp-read-syntax! (lambda (ch proc) undefined))
- (setter (lambda (proc) proc))
- (signal (lambda (n) undefined))
- (signum (lambda (x1) x2))
- (singlestep (lambda (thunk)))
- (software-type (lambda () sym))
- (software-version (lambda () sym))
- (string->blob (lambda (string) blob))
- (string->keyword (lambda (string) sym))
- (string->uninterned-symbol (lambda (string) sym))
- (string-copy (lambda (string) string))
- (sub1 (lambda (z1) z2))
- (syntax-error (lambda (args \.\.\.) undefined))
- (system (lambda (str) n))
- (test-feature? (lambda (obj) bool))
- (undefine-macro! (lambda (sym) undefined))
- (unregister-feature! (lambda (sym) undefined))
- (use (special symbol scheme-chicken-available-modules)
- "import extensions into top-level namespace")
- (vector-copy! (lambda (from-vector to-vector :optional start) undefined))
- (vector-resize (lambda (vec n :optional init)))
- (void (lambda () undefined))
- (warning (lambda (msg-str args \.\.\.) undefined))
- (with-exception-handler (lambda (handler thunk)))
- (write-byte (lambda (n :optional output-port) undefined))
- )
- (gauche
- (E2BIG integer)
- (EACCES integer)
- (EADDRINUSE integer)
- (EADDRNOTAVAIL integer)
- (EADV integer)
- (EAFNOSUPPORT integer)
- (EAGAIN integer)
- (EALREADY integer)
- (EBADE integer)
- (EBADF integer)
- (EBADFD integer)
- (EBADMSG integer)
- (EBADR integer)
- (EBADRQC integer)
- (EBADSLT integer)
- (EBFONT integer)
- (EBUSY integer)
- (ECANCELED integer)
- (ECHILD integer)
- (ECHRNG integer)
- (ECOMM integer)
- (ECONNABORTED integer)
- (ECONNREFUSED integer)
- (ECONNRESET integer)
- (EDEADLK integer)
- (EDEADLOCK integer)
- (EDESTADDRREQ integer)
- (EDOM integer)
- (EDOTDOT integer)
- (EDQUOT integer)
- (EEXIST integer)
- (EFAULT integer)
- (EFBIG integer)
- (EHOSTDOWN integer)
- (EHOSTUNREACH integer)
- (EIDRM integer)
- (EILSEQ integer)
- (EINPROGRESS integer)
- (EINTR integer)
- (EINVAL integer)
- (EIO integer)
- (EISCONN integer)
- (EISDIR integer)
- (EISNAM integer)
- (EKEYEXPIRED integer)
- (EKEYREJECTED integer)
- (EKEYREVOKED integer)
- (EL2HLT integer)
- (EL2NSYNC integer)
- (EL3HLT integer)
- (EL3RST integer)
- (ELIBACC integer)
- (ELIBBAD integer)
- (ELIBEXEC integer)
- (ELIBMAX integer)
- (ELIBSCN integer)
- (ELNRNG integer)
- (ELOOP integer)
- (EMEDIUMTYPE integer)
- (EMFILE integer)
- (EMLINK integer)
- (EMSGSIZE integer)
- (EMULTIHOP integer)
- (ENAMETOOLONG integer)
- (ENAVAIL integer)
- (ENETDOWN integer)
- (ENETRESET integer)
- (ENETUNREACH integer)
- (ENFILE integer)
- (ENOANO integer)
- (ENOBUFS integer)
- (ENOCSI integer)
- (ENODATA integer)
- (ENODEV integer)
- (ENOENT integer)
- (ENOEXEC integer)
- (ENOKEY integer)
- (ENOLCK integer)
- (ENOLINK integer)
- (ENOMEDIUM integer)
- (ENOMEM integer)
- (ENOMSG integer)
- (ENONET integer)
- (ENOPKG integer)
- (ENOPROTOOPT integer)
- (ENOSPC integer)
- (ENOSR integer)
- (ENOSTR integer)
- (ENOSYS integer)
- (ENOTBLK integer)
- (ENOTCONN integer)
- (ENOTDIR integer)
- (ENOTEMPTY integer)
- (ENOTNAM integer)
- (ENOTSOCK integer)
- (ENOTTY integer)
- (ENOTUNIQ integer)
- (ENXIO integer)
- (EOPNOTSUPP integer)
- (EOVERFLOW integer)
- (EPERM integer)
- (EPFNOSUPPORT integer)
- (EPIPE integer)
- (EPROTO integer)
- (EPROTONOSUPPORT integer)
- (EPROTOTYPE integer)
- (ERANGE integer)
- (EREMCHG integer)
- (EREMOTE integer)
- (EREMOTEIO integer)
- (ERESTART integer)
- (EROFS integer)
- (ESHUTDOWN integer)
- (ESOCKTNOSUPPORT integer)
- (ESPIPE integer)
- (ESRCH integer)
- (ESRMNT integer)
- (ESTALE integer)
- (ESTRPIPE integer)
- (ETIME integer)
- (ETIMEDOUT integer)
- (ETOOMANYREFS integer)
- (ETXTBSY integer)
- (EUCLEAN integer)
- (EUNATCH integer)
- (EUSERS integer)
- (EWOULDBLOCK integer)
- (EXDEV integer)
- (EXFULL integer)
- (F_OK integer)
- (LC_ALL integer)
- (LC_COLLATE integer)
- (LC_CTYPE integer)
- (LC_MONETARY integer)
- (LC_NUMERIC integer)
- (LC_TIME integer)
- (RAND_MAX integer)
- (R_OK integer)
- (SEEK_CUR integer)
- (SEEK_END integer)
- (SEEK_SET integer)
- (SIGABRT integer)
- (SIGALRM integer)
- (SIGBUS integer)
- (SIGCHLD integer)
- (SIGCONT integer)
- (SIGFPE integer)
- (SIGHUP integer)
- (SIGILL integer)
- (SIGINT integer)
- (SIGIO integer)
- (SIGIOT integer)
- (SIGKILL integer)
- (SIGPIPE integer)
- (SIGPOLL integer)
- (SIGPROF integer)
- (SIGPWR integer)
- (SIGQUIT integer)
- (SIGSEGV integer)
- (SIGSTKFLT integer)
- (SIGSTOP integer)
- (SIGTERM integer)
- (SIGTRAP integer)
- (SIGTSTP integer)
- (SIGTTIN integer)
- (SIGTTOU integer)
- (SIGURG integer)
- (SIGUSR1 integer)
- (SIGUSR2 integer)
- (SIGVTALRM integer)
- (SIGWINCH integer)
- (SIGXCPU integer)
- (SIGXFSZ integer)
- (SIG_BLOCK integer)
- (SIG_SETMASK integer)
- (SIG_UNBLOCK integer)
- (W_OK integer)
- (X_OK integer)
- (acons (lambda (key value alist) alist))
- (acosh (lambda (z) z))
- (add-load-path (lambda (path) undefined))
- (add-method! (lambda (generic method) undefined))
- (all-modules (lambda () list))
- (allocate-instance (lambda (class list)))
- (and-let* (syntax))
- (any (lambda (pred list)))
- (any$ (lambda (pred) proc))
- (any-pred (lambda (pred \.\.\.) pred))
- (append! (lambda (list \.\.\.) list))
- (apply$ (lambda (proc) proc))
- (apply-generic (lambda (generic list)))
- (apply-method (lambda (method list)))
- (apply-methods (lambda (generic list list)))
- (arity (lambda (proc) n))
- (arity-at-least-value (lambda (n)))
- (arity-at-least? (lambda (proc) bool))
- (ash (lambda (n i) n))
- (asinh (lambda (z) z))
- (assoc$ (lambda (obj) proc))
- (atanh (lambda (z) z))
- (autoload (syntax))
- (begin0 (syntax))
- (bignum? (lambda (obj) bool))
- (bit-field (lambda (n start end) n))
- (byte-ready? (lambda (:optional input-port) bool))
- (call-with-input-string (lambda (str proc)))
- (call-with-output-string (lambda (proc) str))
- (call-with-string-io (lambda (str proc) str))
- (case-lambda (syntax))
- (change-class (lambda (obj new-class)))
- (change-object-class (lambda (obj orig-class new-class)))
- (char->ucs (lambda (ch) int))
- (char-set (lambda (ch \.\.\.) char-set))
- (char-set-contains? (lambda (char-set ch) bool))
- (char-set-copy (lambda (char-set) char-set))
- (char-set? (lambda (obj) bool))
- (check-arg (syntax))
- (circular-list? (lambda (obj) bool))
- (clamp (lambda (x1 :optional min-x max-x) x2))
- (class-direct-methods (lambda (class) list))
- (class-direct-slots (lambda (class) list))
- (class-direct-subclasses (lambda (class) list))
- (class-direct-supers (lambda (class) list))
- (class-name (lambda (class) sym))
- (class-of (lambda (obj) class))
- (class-precedence-list (lambda (class) list))
- (class-slot-accessor (lambda (class id) proc))
- (class-slot-bound? (lambda (class id) bool))
- (class-slot-definition (lambda (class id)))
- (class-slot-ref (lambda (class slot)))
- (class-slot-set! (lambda (class slot val) undefined))
- (class-slots (lambda (class) list))
- (closure-code (lambda (proc)))
- (closure? (lambda (obj) bool))
- (compare (lambda (obj1 obj2) n))
- (complement (lambda (proc) proc))
- (compose (lambda (proc \.\.\.) proc))
- (compute-applicable-methods (lambda (generic list)))
- (compute-cpl (lambda (generic list)))
- (compute-get-n-set (lambda (class slot)))
- (compute-slot-accessor (lambda (class slot)))
- (compute-slots (lambda (class)))
- (cond-expand (syntax))
- (condition (syntax))
- (condition-has-type? (lambda (condition obj)))
- (condition-ref (lambda (condition id)))
- (condition-type? (lambda (obj) bool))
- (condition? (lambda (obj) bool))
- (copy-bit (lambda (index n i) n))
- (copy-bit-field (lambda (n start end from) n))
- (copy-port (lambda (from-port to-port :optional unit-sym) undefined))
- (cosh (lambda (z) z))
- (count$ (lambda (pred) proc))
- (current-class-of (lambda (obj) class))
- (current-error-port (lambda () output-port))
- (current-exception-handler (lambda () handler))
- (current-load-history (lambda () list))
- (current-load-next (lambda () list))
- (current-load-port (lambda () port))
- (current-module (lambda () env))
- (current-thread (lambda () thread))
- (current-time (lambda () time))
- (cut (syntax))
- (cute (lambda (args \.\.\.) proc))
- (debug-print (lambda (obj)))
- (debug-print-width (lambda () int))
- (debug-source-info (lambda (obj)))
- (dec! (syntax))
- (decode-float (lambda (x1) vector))
- (define-class (syntax))
- (define-condition-type (syntax))
- (define-constant (syntax))
- (define-generic (syntax))
- (define-in-module (syntax))
- (define-inline (syntax))
- (define-macro (syntax))
- (define-method (syntax))
- (define-module (syntax))
- (define-reader-ctor (lambda (sym proc) undefined))
- (define-values (syntax))
- (delete$ (lambda (obj) proc))
- (delete-keyword (lambda (id list) list))
- (delete-keyword! (lambda (id list) list))
- (delete-method! (lambda (generic method) undefined))
- (digit->integer (lambda (ch) n))
- (disasm (lambda (proc) undefined))
- (dolist (syntax))
- (dotimes (syntax))
- (dotted-list? (lambda (obj) bool))
- (dynamic-load (lambda (file)))
- (eager (lambda (obj)))
- (eq-hash (lambda (obj)))
- (eqv-hash (lambda (obj)))
- (error (lambda (msg-string args \.\.\.)))
- (errorf (lambda (fmt-string args \.\.\.)))
- (eval-when (syntax))
- (every$ (lambda (pred) pred))
- (every-pred (lambda (pred \.\.\.) pred))
- (exit (lambda (:optional n) undefined))
- (export (syntax))
- (export-all (syntax))
- (export-if-defined (syntax))
- (extend (syntax))
- (extract-condition (lambda (condition type)))
- (file-exists? (lambda (filename) bool))
- (file-is-directory? (lambda (filename) bool))
- (file-is-regular? (lambda (filename) bool))
- (filter$ (lambda (pred) proc))
- (find (lambda (pred list)))
- (find$ (lambda (pred) proc))
- (find-module (lambda (id) env))
- (find-tail$ (lambda (pred) proc))
- (fixnum? (lambda (obj) bool))
- (flonum? (lambda (obj) bool))
- (fluid-let (syntax))
- (flush (lambda (:optional output-port) undefined))
- (flush-all-ports (lambda () undefined))
- (fmod (lambda (x1 x2) x3))
- (fold (lambda (proc init list)))
- (fold$ (lambda (proc :optional init) proc))
- (fold-right (lambda (proc init list)))
- (fold-right$ (lambda (proc :optional init)))
- (for-each$ (lambda (proc) (lambda (ls) undefined)))
- (foreign-pointer-attribute-get (lambda (ptr attr)))
- (foreign-pointer-attribute-set (lambda (ptr attr val)))
- (foreign-pointer-attributes (lambda (ptr) list))
- (format (lambda (fmt-string arg \.\.\.)))
- (format/ss (lambda (fmt-string arg \.\.\.)))
- (frexp (lambda (x1) x2))
- (gauche-architecture (lambda () string))
- (gauche-architecture-directory (lambda () string))
- (gauche-character-encoding (lambda () symbol))
- (gauche-dso-suffix (lambda () string))
- (gauche-library-directory (lambda () string))
- (gauche-site-architecture-directory (lambda () string))
- (gauche-site-library-directory (lambda () string))
- (gauche-version (lambda () string))
- (gc (lambda () undefined))
- (gc-stat (lambda () list))
- (gensym (lambda (:optional name) symbol))
- (get-keyword (lambda (id list :optional default)))
- (get-keyword* (syntax))
- (get-optional (syntax))
- (get-output-string (lambda (string-output-port) string))
- (get-remaining-input-string (lambda (port) string))
- (get-signal-handler (lambda (n) proc))
- (get-signal-handler-mask (lambda (n) n))
- (get-signal-handlers (lambda () list))
- (get-signal-pending-limit (lambda () n))
- (getter-with-setter (lambda (get-proc set-proc) proc))
- (global-variable-bound? (lambda (sym) bool))
- (global-variable-ref (lambda (sym)))
- (guard (syntax))
- (has-setter? (lambda (proc) bool))
- (hash (lambda (obj)))
- (hash-table (lambda (id pair \.\.\.) hash-table))
- (hash-table-delete! (lambda (hash-table key) undefined))
- (hash-table-exists? (lambda (hash-table key) bool))
- (hash-table-fold (lambda (hash-table proc init)))
- (hash-table-for-each (lambda (hash-table proc) undefined))
- (hash-table-get (lambda (hash-table key :optional default)))
- (hash-table-keys (lambda (hash-table) list))
- (hash-table-map (lambda (hash-table proc) list))
- (hash-table-num-entries (lambda (hash-table) n))
- (hash-table-pop! (lambda (hash-table key :optional default)))
- (hash-table-push! (lambda (hash-table key value) undefined))
- (hash-table-put! (lambda (hash-table key value) undefined))
- (hash-table-stat (lambda (hash-table) list))
- (hash-table-type (lambda (hash-table) id))
- (hash-table-update! (lambda (hash-table key proc :optional default) undefined))
- (hash-table-values (lambda (hash-table) list))
- (hash-table? (lambda (obj) bool))
- (identifier->symbol (lambda (obj) sym))
- (identifier? (lambda (obj) bool))
- (identity (lambda (obj)))
- (import (syntax))
- (inc! (syntax))
- (inexact-/ (lambda (x1 x2) x3))
- (initialize (lambda (obj)))
- (instance-slot-ref (lambda (obj id)))
- (instance-slot-set (lambda (obj id value)))
- (integer->digit (lambda (n) ch))
- (integer-length (lambda (n) n))
- (is-a? (lambda (obj class) bool))
- (keyword->string (lambda (id) string))
- (keyword? (lambda (obj) bool))
- (last-pair (lambda (pair) pair))
- (lazy (syntax))
- (ldexp (lambda (x1 n) x2))
- (let-keywords* (syntax))
- (let-optionals* (syntax))
- (let/cc (syntax))
- (let1 (syntax))
- (library-exists? (lambda (filename) bool))
- (library-fold (lambda (string proc init)))
- (library-for-each (lambda (string proc) undefined))
- (library-has-module? (lambda (filename id) bool))
- (library-map (lambda (string proc) list))
- (list* (lambda (obj \.\.\.) list))
- (list-copy (lambda (list) list))
- (logand (lambda (n \.\.\.) n))
- (logbit? (lambda (index n) bool))
- (logcount (lambda (n) n))
- (logior (lambda (n \.\.\.) n))
- (lognot (lambda (n) n))
- (logtest (lambda (n \.\.\.) bool))
- (logxor (lambda (n \.\.\.) n))
- (macroexpand (lambda (obj)))
- (macroexpand-1 (lambda (obj)))
- (make (lambda (class args \.\.\.)))
- (make-byte-string (lambda (n :optional int) byte-string))
- (make-compound-condition (lambda (condition \.\.\.) condition))
- (make-condition (lambda (condition-type field+value \.\.\.) condition))
- (make-condition-type (lambda (id condition-type list) condition-type))
- (make-hash-table (lambda (:optional id) hash-table))
- (make-keyword (lambda (string) sym))
- (make-list (lambda (n :optional init) list))
- (make-module (lambda (id :optional if-exists-proc) env))
- (make-weak-vector (lambda (n) vector))
- (map$ (lambda (proc) proc))
- (member$ (lambda (obj) proc))
- (merge (lambda (list1 list2 proc) list))
- (merge! (lambda (list1 list2 proc) list))
- (method-more-specific? (lambda (method1 method2 list) bool))
- (min&max (lambda (x1 \.\.\.) (values x2 x3)))
- (modf (lambda (x1) x2))
- (module-exports (lambda (env) list))
- (module-imports (lambda (env) list))
- (module-name (lambda (env) sym))
- (module-name->path (lambda (sym) string))
- (module-parents (lambda (env) list))
- (module-precedence-list (lambda (env) list))
- (module-table (lambda (env) hash-table))
- (module? (lambda (obj) bool))
- (null-list? (lambda (obj) bool))
- (object-* (lambda (z \.\.\.) z))
- (object-+ (lambda (z \.\.\.) z))
- (object-- (lambda (z \.\.\.) z))
- (object-/ (lambda (z \.\.\.) z))
- (object-apply (lambda (proc arg \.\.\.)))
- (object-compare (lambda (obj1 obj2) n))
- (object-equal? (lambda (obj1 obj2) bool))
- (object-hash (lambda (obj) n))
- (open-coding-aware-port (lambda (input-port) input-port))
- (open-input-buffered-port (lambda ()))
- (open-input-fd-port (lambda (fileno) input-port))
- (open-input-string (lambda (str) input-port))
- (open-output-buffered-port (lambda ()))
- (open-output-fd-port (lambda (fileno) output-port))
- (open-output-string (lambda () string-output-port))
- (pa$ (lambda (proc arg \.\.\.) proc))
- (partition$ (lambda (pred) proc))
- (path->module-name (lambda (str) sym))
- (peek-byte (lambda (:optional input-port) n))
- (pop! (syntax (list)))
- (port->byte-string (lambda (input-port) byte-string))
- (port->list (lambda (proc input-port) list))
- (port->sexp-list (lambda (port) list))
- (port->string (lambda (port) string))
- (port->string-list (lambda (port) list))
- (port-buffering (lambda (port) sym))
- (port-closed? (lambda (port) bool))
- (port-current-line (lambda (port) n))
- (port-file-number (lambda (port) n))
- (port-fold (lambda (proc init port)))
- (port-fold-right (lambda (proc init port)))
- (port-for-each (lambda (proc read-proc) undefined))
- (port-map (lambda (proc read-proc)))
- (port-name (lambda (port) name))
- (port-position-prefix (lambda ()))
- (port-seek (lambda (port offset (set int SEEK_SET SEEK_CUR SEEK_END))))
- (port-tell (lambda (port) n))
- (port-type (lambda (port) sym))
- (print (lambda (obj \.\.\.)))
- (procedure-arity-includes? (lambda (proc n) bool))
- (procedure-info (lambda (proc)))
- (profiler-reset (lambda () undefined))
- (profiler-show (lambda () undefined))
- (profiler-show-load-stats (lambda () undefined))
- (profiler-start (lambda () undefined))
- (profiler-stop (lambda () undefined))
- (program (syntax))
- (promise-kind (lambda ()))
- (promise? (lambda (obj) bool))
- (proper-list? (lambda (obj) bool))
- (provide (lambda (str) undefined))
- (provided? (lambda (str) bool))
- (push! (syntax))
- (quotient&remainder (lambda (n1 n2) (values n1 n2)))
- (raise (lambda (exn) undefined))
- (read-block (lambda (n :optional input-port) string))
- (read-byte (lambda (:optional input-port) n))
- (read-eval-print-loop (lambda () undefined))
- (read-from-string (lambda (str)))
- (read-line (lambda (:optional input-port) str))
- (read-list (lambda (ch :optional input-port)))
- (read-reference-has-value? (lambda ()))
- (read-reference-value (lambda ()))
- (read-reference? (lambda ()))
- (read-with-shared-structure (lambda (:optional input-port)))
- (read/ss (lambda (:optional input-port)))
- (rec (syntax))
- (receive (syntax))
- (redefine-class! (lambda ()))
- (reduce$ (lambda (proc :optional default) proc))
- (reduce-right$ (lambda (proc :optional default) proc))
- (ref (lambda (obj key \.\.\.)))
- (ref* (lambda (obj key \.\.\.)))
- (regexp->string (lambda (regexp) string))
- (regexp-case-fold? (lambda (regexp) bool))
- (regexp-compile (lambda (str) regexp))
- (regexp-optimize (lambda (str) str))
- (regexp-parse (lambda (str) list))
- (regexp-quote (lambda (str) str))
- (regexp-replace (lambda (regexp string subst) string))
- (regexp-replace* (lambda (string regexp subst \.\.\.) string))
- (regexp-replace-all (lambda (regexp string subst) string))
- (regexp-replace-all* (lambda (string regexp subst \.\.\.)))
- (regexp? (lambda (obj) bool))
- (regmatch? (lambda (obj) bool))
- (remove$ (lambda (pred) proc))
- (report-error (lambda ()))
- (require (syntax))
- (require-extension (syntax))
- (reverse! (lambda (list) list))
- (rxmatch (lambda (regexp string) regmatch))
- (rxmatch-after (lambda (regmatch :optional i) str))
- (rxmatch-before (lambda (regmatch :optional i) str))
- (rxmatch-case (syntax))
- (rxmatch-cond (syntax))
- (rxmatch-end (lambda (regmatch :optional i) n))
- (rxmatch-if (syntax))
- (rxmatch-let (syntax))
- (rxmatch-num-matches (lambda (regmatch) i))
- (rxmatch-start (lambda (regmatch :optional i) n))
- (rxmatch-substring (lambda (regmatch :optional i) str))
- (seconds->time (lambda (x1) time))
- (select-module (syntax))
- (set!-values (syntax))
- (set-signal-handler! (lambda (signals handler) undefined))
- (set-signal-pending-limit (lambda (n) undefined))
- (setter (lambda (proc) proc))
- (sinh (lambda (z) z))
- (slot-bound-using-accessor? (lambda (proc obj id) bool))
- (slot-bound-using-class? (lambda (class obj id) bool))
- (slot-bound? (lambda (obj id) bool))
- (slot-definition-accessor (lambda ()))
- (slot-definition-allocation (lambda ()))
- (slot-definition-getter (lambda ()))
- (slot-definition-name (lambda ()))
- (slot-definition-option (lambda ()))
- (slot-definition-options (lambda ()))
- (slot-definition-setter (lambda ()))
- (slot-exists-using-class? (lambda (class obj id) bool))
- (slot-exists? (lambda (obj id) bool))
- (slot-initialize-using-accessor! (lambda ()))
- (slot-missing (lambda (class obj id)))
- (slot-push! (lambda (obj id value) undefined))
- (slot-ref (lambda (obj id)))
- (slot-ref-using-accessor (lambda (proc obj id)))
- (slot-ref-using-class (lambda (class obj id)))
- (slot-set! (lambda (obj id value) undefined))
- (slot-set-using-accessor! (lambda (proc obj id value) undefined))
- (slot-set-using-class! (lambda (class obj id value) undefined))
- (slot-unbound (lambda (class obj id)))
- (sort (lambda (seq :optional proc)))
- (sort! (lambda (seq :optional proc)))
- (sort-applicable-methods (lambda ()))
- (sorted? (lambda (seq :optional proc)))
- (split-at (lambda (list i) (values list list)))
- (stable-sort (lambda (seq :optional proc)))
- (stable-sort! (lambda (seq :optional proc)))
- (standard-error-port (lambda () output-port))
- (standard-input-port (lambda () input-port))
- (standard-output-port (lambda () output-port))
- (string->regexp (lambda (str) regexp))
- (string-byte-ref (lambda (str i) n))
- (string-byte-set! (lambda (str i n) undefined))
- (string-complete->incomplete (lambda (str) str))
- (string-immutable? (lambda (str) bool))
- (string-incomplete->complete (lambda (str) str))
- (string-incomplete->complete! (lambda (str) str))
- (string-incomplete? (lambda (str) bool))
- (string-interpolate (lambda (str) list))
- (string-join (lambda (list :optional delim-str (set grammar infix strict-infix prefix suffix))))
-;; deprecated
-;; (string-pointer-byte-index (lambda ()))
-;; (string-pointer-copy (lambda ()))
-;; (string-pointer-index (lambda ()))
-;; (string-pointer-next! (lambda ()))
-;; (string-pointer-prev! (lambda ()))
-;; (string-pointer-ref (lambda ()))
-;; (string-pointer-set! (lambda ()))
-;; (string-pointer-substring (lambda ()))
-;; (string-pointer? (lambda ()))
- (string-scan (lambda (string item :optional (set return index before after before* after* both))))
- (string-size (lambda (str) n))
- (string-split (lambda (str splitter) list))
- (string-substitute! (lambda ()))
- (subr? (lambda (obj) bool))
- (supported-character-encoding? (lambda (id) bool))
- (supported-character-encodings (lambda () list))
- (symbol-bound? (lambda (id) bool))
- (syntax-error (syntax))
- (syntax-errorf (syntax))
- (sys-abort (lambda () undefined))
- (sys-access (lambda (filename (flags amode R_OK W_OK X_OK F_OK))))
- (sys-alarm (lambda (x1) x2))
- (sys-asctime (lambda (time) str))
- (sys-basename (lambda (filename) str))
- (sys-chdir (lambda (dirname)))
- (sys-chmod (lambda (filename n)))
- (sys-chown (lambda (filename uid gid)))
- (sys-close (lambda (fileno)))
- (sys-crypt (lambda (key-str salt-str) str))
- (sys-ctermid (lambda () string))
- (sys-ctime (lambda (time) string))
- (sys-difftime (lambda (time1 time2) x1))
- (sys-dirname (lambda (filename) string))
- (sys-exec (lambda (command-string list) n))
- (sys-exit (lambda (n) undefined))
- (sys-fchmod (lambda (port-or-fileno n)))
- (sys-fdset-max-fd (lambda (fdset)))
- (sys-fdset-ref (lambda (fdset port-or-fileno)))
- (sys-fdset-set! (lambda (fdset port-or-fileno)))
- (sys-fork (lambda () n))
- (sys-fork-and-exec (lambda (command-string list) n))
- (sys-fstat (lambda (port-or-fileno) sys-stat))
- (sys-ftruncate (lambda (port-or-fileno n)))
- (sys-getcwd (lambda () string))
- (sys-getdomainname (lambda () string))
- (sys-getegid (lambda () gid))
- (sys-getenv (lambda (name) string))
- (sys-geteuid (lambda () uid))
- (sys-getgid (lambda () gid))
- (sys-getgrgid (lambda () gid))
- (sys-getgrnam (lambda (name)))
- (sys-getgroups (lambda () list))
- (sys-gethostname (lambda () string))
- (sys-getloadavg (lambda () list))
- (sys-getlogin (lambda () string))
- (sys-getpgid (lambda () gid))
- (sys-getpgrp (lambda () gid))
- (sys-getpid (lambda () pid))
- (sys-getppid (lambda () pid))
- (sys-getpwnam (lambda (name)))
- (sys-getpwuid (lambda () uid))
- (sys-gettimeofday (lambda () (values x1 x2)))
- (sys-getuid (lambda () uid))
- (sys-gid->group-name (lambda (gid) name))
- (sys-glob (lambda (string) list))
- (sys-gmtime (lambda (time) string))
- (sys-group-name->gid (lambda (name) gid))
- (sys-isatty (lambda (port-or-fileno) bool))
- (sys-kill (lambda (pid)))
- (sys-lchown (lambda (filename uid gid)))
- (sys-link (lambda (old-filename new-filename)))
- (sys-localeconv (lambda () alist))
- (sys-localtime (lambda (time) string))
- (sys-lstat (lambda (filename) sys-stat))
- (sys-mkdir (lambda (dirname)))
- (sys-mkfifo (lambda (filename)))
- (sys-mkstemp (lambda (filename)))
- (sys-mktime (lambda (time) x1))
- (sys-nanosleep (lambda (x1)))
- (sys-normalize-pathname (lambda (filename) string))
- (sys-pause (lambda (x1)))
- (sys-pipe (lambda (:optional buffering) (values input-port output-port)))
- (sys-putenv (lambda (name string)))
- (sys-random (lambda () n))
- (sys-readdir (lambda (dirname) list))
- (sys-readlink (lambda (filename) string))
- (sys-realpath (lambda (filename) string))
- (sys-remove (lambda (filename)))
- (sys-rename (lambda (old-filename new-filename)))
- (sys-rmdir (lambda (dirname)))
- (sys-select (lambda (read-filenos write-filenos execpt-filenos :optional timeout-x)))
- (sys-select! (lambda (read-filenos write-filenos execpt-filenos :optional timeout-x)))
- (sys-setenv (lambda (name string)))
- (sys-setgid (lambda (gid)))
- (sys-setlocale (lambda (locale-string)))
- (sys-setpgid (lambda (gid)))
- (sys-setsid (lambda ()))
- (sys-setuid (lambda (uid)))
- (sys-sigmask (lambda ((set how SIG_SETMASK SIG_BLOCK SIG_UNBLOCK) sigset)))
- (sys-signal-name (lambda (n)))
- (sys-sigset (lambda (n \.\.\.) sigset))
- (sys-sigset-add! (lambda (sigset n)))
- (sys-sigset-delete! (lambda (sigset n)))
- (sys-sigset-empty! (lambda (sigset)))
- (sys-sigset-fill! (lambda (sigset)))
- (sys-sigsuspend (lambda (sigset)))
- (sys-sigwait (lambda (sigset)))
- (sys-sleep (lambda (x1)))
- (sys-srandom (lambda (n)))
- (sys-stat (lambda (filename)))
-;; deprecated
-;; (sys-stat->atime (lambda ()))
-;; (sys-stat->ctime (lambda ()))
-;; (sys-stat->dev (lambda ()))
-;; (sys-stat->file-type (lambda ()))
-;; (sys-stat->gid (lambda ()))
-;; (sys-stat->ino (lambda ()))
-;; (sys-stat->mode (lambda ()))
-;; (sys-stat->mtime (lambda ()))
-;; (sys-stat->nlink (lambda ()))
-;; (sys-stat->rdev (lambda ()))
-;; (sys-stat->size (lambda ()))
-;; (sys-stat->type (lambda ()))
-;; (sys-stat->uid (lambda ()))
- (sys-strerror (lambda (errno) string))
- (sys-strftime (lambda (format-string time)))
- (sys-symlink (lambda (old-filename new-filename)))
- (sys-system (lambda (command) n))
- (sys-time (lambda () n))
- (sys-times (lambda () list))
-;; (sys-tm->alist (lambda ()))
- (sys-tmpnam (lambda () string))
- (sys-truncate (lambda (filename n)))
- (sys-ttyname (lambda (port-or-fileno) string))
- (sys-uid->user-name (lambda (uid) name))
- (sys-umask (lambda () n))
- (sys-uname (lambda () string))
- (sys-unlink (lambda (filename)))
- (sys-unsetenv (lambda (name)))
- (sys-user-name->uid (lambda (name) uid))
- (sys-utime (lambda (filename)))
- (sys-wait (lambda ()))
- (sys-wait-exit-status (lambda (n) n))
- (sys-wait-exited? (lambda (n) bool))
- (sys-wait-signaled? (lambda (n) bool))
- (sys-wait-stopped? (lambda (n) bool))
- (sys-wait-stopsig (lambda (n) n))
- (sys-wait-termsig (lambda (n) n))
- (sys-waitpid (lambda (pid)))
- (tanh (lambda (z) z))
- (time (syntax))
- (time->seconds (lambda (time) x1))
- (time? (lambda (obj) bool))
- (toplevel-closure? (lambda (obj) bool))
- (touch-instance! (lambda ()))
- (ucs->char (lambda (n) ch))
- (undefined (lambda () undefined))
- (undefined? (lambda (obj) bool))
- (unless (syntax))
- (until (syntax))
- (unwrap-syntax (lambda (obj)))
- (update! (syntax))
- (update-direct-method! (lambda ()))
- (update-direct-subclass! (lambda ()))
- (use (special symbol scheme-gauche-available-modules))
- (use-version (syntax))
- (values-ref (syntax))
- (vector-copy (lambda (vector :optional start end fill) vector))
- (vm-dump (lambda () undefined))
- (vm-get-stack-trace (lambda () undefined))
- (vm-get-stack-trace-lite (lambda () undefined))
- (vm-set-default-exception-handler (lambda (handler) undefined))
- (warn (lambda (message-str args) undefined))
- (weak-vector-length (lambda (vector) n))
- (weak-vector-ref (lambda (vector i)))
- (weak-vector-set! (lambda (vector i value) undefined))
- (when (syntax))
- (while (syntax))
- (with-error-handler (lambda (handler thunk)))
- (with-error-to-port (lambda (port thunk)))
- (with-exception-handler (lambda (handler thunk)))
- (with-input-from-port (lambda (port thunk)))
- (with-input-from-string (lambda (string thunk)))
- (with-module (syntax))
- (with-output-to-port (lambda (port thunk)))
- (with-output-to-string (lambda (thunk) string))
- (with-port-locking (lambda (port thunk)))
- (with-ports (lambda (input-port output-port error-port thunk)))
- (with-signal-handlers (syntax))
- (with-string-io (lambda (string thunk) string))
- (write* (lambda (obj :optional output-port) undefined))
- (write-byte (lambda (n :optional output-port) undefined))
- (write-limited (lambda (obj :optional output-port)))
- (write-object (lambda (obj output-port)))
- (write-to-string (lambda (obj) string))
- (write-with-shared-structure (lambda (obj :optional output-port)))
- (write/ss (lambda (obj :optional output-port)))
- (x->integer (lambda (obj) integer))
- (x->number (lambda (obj) number))
- (x->string (lambda (obj) string))
- )))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; special lookups (XXXX add more impls, try to abstract better)
-
-(defvar *scheme-chicken-base-repo*
- (or (let ((repo (getenv "CHICKEN_REPOSITORY")))
- (and repo (file-exists-p repo) repo))
- (let ((dir
- (car (remove-if-not #'file-directory-p
- '("/usr/lib/chicken"
- "/usr/local/lib/chicken"
- "/opt/lib/chicken"
- "/opt/local/lib/chicken"
- )))))
- (and dir
- (car (reverse (sort (directory-files dir t "^[0-9]+$")
- #'string-lessp)))))
- (and (fboundp 'shell-command-to-string)
- (let* ((res (shell-command-to-string
- "csi -e '(print (repository-path))'"))
- (res (substring res 0 (- (length res) 1))))
- (and res (file-directory-p res) res)))
- "/usr/local/lib/chicken/4"))
-
-(defvar *scheme-chicken-repo-dirs*
- (remove-if-not
- #'(lambda (x) (and (stringp x) (not (equal x ""))))
- (let ((home (getenv "CHICKEN_HOME")))
- (if (and home (not (equal home "")))
- (let ((res (split-string home ";"))) ;
- (if (member *scheme-chicken-base-repo* res)
- res
- (cons *scheme-chicken-repo-dirs* res)))
- (list *scheme-chicken-base-repo*)))))
-
-(defun scheme-chicken-available-modules (&optional sym)
- (append
- (mapcar #'symbol-name (mapcar #'car *scheme-chicken-modules*))
- (mapcar
- #'(lambda (f)
- (let ((f (file-name-sans-extension f)))
- (if (equalp "import" (file-name-extension f))
- (file-name-sans-extension f)
- f)))
- (directory-files "." nil "^[^.].*\\.scm$" t))
- (scheme-append-map
- #'(lambda (dir)
- (mapcar
- #'(lambda (f)
- (let ((f (file-name-sans-extension f)))
- (if (equalp "import" (file-name-extension f))
- (file-name-sans-extension f)
- f)))
- (if (string-match "/4" dir)
- (directory-files dir nil "^[^.].*\\.import\\.\\(so\\|scm\\)$" t)
- (directory-files dir nil "^[^.].*\\.\\(so\\|scm\\)$" t))))
- *scheme-chicken-repo-dirs*)))
-
-(defvar *scheme-gauche-repo-path*
- (or (car (remove-if-not #'file-directory-p
- '("/usr/share/gauche"
- "/usr/local/share/gauche"
- "/opt/share/gauche"
- "/opt/local/share/gauche")))
- (and (fboundp 'shell-command-to-string)
- (let* ((res (shell-command-to-string "gauche-config --syslibdir"))
- (res (substring res 0 (- (length res) 1))))
- (and res (file-directory-p res)
- (let* ((dir (file-name-directory res))
- (dir2 (file-name-directory
- (substring dir 0 (- (length dir) 1)))))
- (substring dir2 0 (- (length dir2) 1))))))
- "/usr/local/share/gauche"))
-
-(defvar *scheme-gauche-site-repo-path*
- (concat *scheme-gauche-repo-path* "/site/lib"))
-
-(defun scheme-gauche-available-modules (&optional sym)
- (let ((version-dir
- (concat
- (car (directory-files *scheme-gauche-repo-path* t "^[0-9]"))
- "/lib"))
- (site-dir *scheme-gauche-site-repo-path*)
- (other-dirs
- (remove-if-not
- #'(lambda (d) (and (not (equal d "")) (file-directory-p d)))
- (split-string (or (getenv "GAUCHE_LOAD_PATH") "") ":"))))
- (mapcar
- #'(lambda (f) (subst-char-in-string ?/ ?. f))
- (mapcar
- #'file-name-sans-extension
- (scheme-append-map
- #'(lambda (dir)
- (let ((len (length dir)))
- (mapcar #'(lambda (f) (substring f (+ 1 len)))
- (scheme-directory-tree-files dir t "\\.scm"))))
- (cons version-dir (cons site-dir other-dirs)))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; utilities
-
-(defun scheme-append-map (proc init-ls)
- (if (null init-ls)
- '()
- (let* ((ls (reverse init-ls))
- (res (funcall proc (pop ls))))
- (while (consp ls)
- (setq res (append (funcall proc (pop ls)) res)))
- res)))
-
-(defun scheme-flatten (ls)
- (cond
- ((consp ls) (cons (car ls) (scheme-flatten (cdr ls))))
- ((null ls) '())
- (t (list ls))))
-
-(defun scheme-in-string-p ()
- (let ((orig (point)))
- (save-excursion
- (goto-char (point-min))
- (let ((parses (parse-partial-sexp (point) orig)))
- (nth 3 parses)))))
-
-(defun scheme-beginning-of-sexp ()
- (let ((syn (char-syntax (char-before (point)))))
- (if (or (eq syn ?\()
- (and (eq syn ?\") (scheme-in-string-p)))
- (forward-char -1)
- (forward-sexp -1))))
-
-(defun scheme-find-file-in-path (file path)
- (car (remove-if-not
- #'(lambda (dir) (file-exists-p (concat dir "/" file)))
- path)))
-
-;; visit a file and kill the buffer only if it wasn't already open
-(defmacro scheme-with-find-file (path-expr &rest body)
- (let ((path (gensym "path"))
- (buf (gensym "buf"))
- (res (gensym "res")))
- `(save-window-excursion
- (let* ((,path (file-truename ,path-expr))
- (,buf (find-if
- #'(lambda (x)
- (let ((buf-file (buffer-file-name x)))
- (and buf-file
- (equal ,path (file-truename buf-file)))))
- (buffer-list))))
- (if ,buf
- (switch-to-buffer ,buf)
- (switch-to-buffer (find-file-noselect ,path t)))
- (let ((,res (ignore-errors (save-excursion ,@body))))
- (unless ,buf (kill-buffer (current-buffer)))
- ,res)))))
-
-(defun scheme-directory-tree-files (init-dir &optional full match)
- (let ((res '())
- (stack (list init-dir)))
- (while (consp stack)
- (let* ((dir (pop stack))
- (files (remove-if #'(lambda (f) (or (equal f ".") (equal f "..")))
- (directory-files dir)))
- (full-files (mapcar #'(lambda (f) (concat dir "/" f)) files)))
- (setq res (append (if match
- (remove-if-not
- #'(lambda (f) (string-match match f))
- (if full full-files files))
- (if full full-files files))
- res))
- (setq stack
- (append (remove-if-not #'file-directory-p full-files) stack))))
- res))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; sexp manipulation
-
-;; returns current argument position within sexp
-(defun scheme-beginning-of-current-sexp-operator ()
- (let ((pos 0))
- (skip-syntax-backward "w_")
- (while (and (not (bobp)) (not (eq ?\( (char-before))))
- (scheme-beginning-of-sexp)
- (incf pos))
- pos))
-
-(defun scheme-beginning-of-next-sexp ()
- (forward-sexp 2)
- (backward-sexp 1))
-
-(defun scheme-beginning-of-string ()
- (interactive)
- (search-backward "\"" nil t)
- (while (and (> (point) (point-min)) (eq ?\\ (char-before)))
- (search-backward "\"" nil t)))
-
-;; for the enclosing sexp, returns a cons of the leading symbol (if
-;; any) and the current position within the sexp (starting at 0)
-;; (defun scheme-enclosing-sexp-prefix ()
-;; (save-excursion
-;; (let ((pos (scheme-beginning-of-current-sexp-operator)))
-;; (cons (scheme-symbol-at-point) pos))))
-
-(defun scheme-enclosing-2-sexp-prefixes ()
- (save-excursion
- (let* ((pos1 (scheme-beginning-of-current-sexp-operator))
- (sym1 (scheme-symbol-at-point)))
- (backward-char)
- (or
- (ignore-errors
- (let ((pos2 (scheme-beginning-of-current-sexp-operator)))
- (list sym1 pos1 (scheme-symbol-at-point) pos2)))
- (list sym1 pos1 nil 0)))))
-
-;; sexp-at-point is always fragile, both because the user can input
-;; incomplete sexps and because some scheme sexps are not valid elisp
-;; sexps. this is one of the few places we use it, so we're careful
-;; to wrap it in ignore-errors.
-(defun scheme-nth-sexp-at-point (n)
- (ignore-errors
- (save-excursion
- (forward-sexp (+ n 1))
- (let ((end (point)))
- (forward-sexp -1)
- (car (read-from-string (buffer-substring-no-properties (point) end)))))))
-
-(defun scheme-symbol-at-point ()
- (save-excursion
- (skip-syntax-backward "w_")
- (let ((start (point)))
- (skip-syntax-forward "w_")
- (and (< start (point))
- (intern (buffer-substring-no-properties start (point)))))))
-
-;; should be called from start of current top-level
-(defun scheme-goto-next-top-level (&optional in-mod-p)
- (let ((here (point)))
- (or (if in-mod-p
- (or (ignore-errors (forward-sexp 2) (forward-sexp -1)
- (< here (point)))
- (progn (goto-char here)
- ;;(forward-char)
- ;; heuristic, if the parens are unbalanced look
- ;; for a define starting after a blank line.
- ;; better might be to assume they're using a
- ;; consistent identation for the module body.
- (and (re-search-forward "\n\\s-*\n\\(;[^\n]*\n\\)?\\s-*(" nil t)
- (progn (backward-char 1) t))))
- (or (ignore-errors (end-of-defun) (end-of-defun)
- (beginning-of-defun)
- (< here (point)))
- (progn (goto-char here)
- (forward-char)
- (and (re-search-forward "^(" nil t)
- (progn (backward-char 1) t)))))
- (goto-char (point-max)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; variable extraction
-
-(defun scheme-sexp-type-at-point (&optional env)
- (case (and (not (eobp)) (char-syntax (char-after)))
- ((?\()
- (forward-char 1)
- (if (eq ?w (char-syntax (char-after)))
- (let ((op (scheme-symbol-at-point)))
- (cond
- ((eq op 'lambda)
- (let ((params
- (scheme-nth-sexp-at-point 1)))
- `(lambda ,params)))
- (t
- (let ((spec (scheme-env-lookup env op)))
- (and spec
- (consp (cadr spec))
- (eq 'lambda (caadr spec))
- (cddadr spec)
- (car (cddadr spec)))))))
- nil))
- ((?\")
- 'string)
- ((?\w)
- (if (string-match "[0-9]" (string (char-after)))
- 'number
- nil))
- (t
- nil)))
-
-(defun scheme-let-vars-at-point (&optional env limit loopp)
- (let ((end (min (or limit (point-max))
- (or (ignore-errors
- (save-excursion (forward-sexp) (point)))
- (point-min))))
- (vars '()))
- (forward-char 1)
- (while (< (point) end)
- (when (eq ?\( (char-after))
- (save-excursion
- (forward-char 1)
- (if (and loopp (looking-at "\\(for\\|let\\|with\\)\\>"))
- (scheme-beginning-of-next-sexp))
- (if (eq ?w (char-syntax (char-after)))
- (let* ((sym (scheme-symbol-at-point))
- (type (and (not loopp)
- (ignore-errors
- (scheme-beginning-of-next-sexp)
- (scheme-sexp-type-at-point env)))))
- (push (if type (list sym type) (list sym)) vars)))
- (when loopp
- (while (and (< (point) end)
- (ignore-errors
- (scheme-beginning-of-next-sexp)
- (eq ?w (char-syntax (char-after)))))
- (push (list (scheme-symbol-at-point)) vars)))))
- (unless (ignore-errors (let ((here (point)))
- (scheme-beginning-of-next-sexp)
- (> (point) here)))
- (goto-char end)))
- (reverse vars)))
-
-(defun scheme-extract-match-clause-vars (x)
- (cond
- ((null x) '())
- ((symbolp x)
- (if (memq x '(_ ___ \.\.\.))
- '()
- (list (list x))))
- ((consp x)
- (case (car x)
- ((or not)
- (scheme-extract-match-clause-vars (cdr x)))
- ((and)
- (if (and (consp (cdr x))
- (consp (cddr x))
- (symbolp (cadr x))
- (consp (caddr x))
- (not (memq (caaddr x)
- '(= $ @ ? and or not quote quasiquote get! set!))))
- (cons (list (cadr x) (if (listp (caddr x)) 'list 'pair))
- (scheme-extract-match-clause-vars (cddr x)))
- (scheme-extract-match-clause-vars (cddr x))))
- ((= $ @)
- (if (consp (cdr x)) (scheme-extract-match-clause-vars (cddr x)) '()))
- ((\? ? ) ; XXXX this is a hack, the lone ? gets read as a char (space)
- (if (and (consp (cdr x))
- (consp (cddr x))
- (symbolp (cadr x))
- (symbolp (caddr x)))
- (cons (list (caddr x) (scheme-predicate->type (cadr x)))
- (scheme-extract-match-clause-vars (cdddr x)))
- (scheme-extract-match-clause-vars (cddr x))))
- ((get! set!)
- (if (consp (cdr x)) (scheme-extract-match-clause-vars (cadr x)) '()))
- ((quote) '())
- ((quasiquote) '()) ; XXXX
- (t
- (union (scheme-extract-match-clause-vars (car x))
- (scheme-extract-match-clause-vars (cdr x))))))
- ((vectorp x)
- (scheme-extract-match-clause-vars (concatenate 'list x)))
- (t
- '())))
-
-;; call this from the first opening paren of the match clauses
-(defun scheme-extract-match-vars (&optional pos limit)
- (let ((match-vars '())
- (limit (or limit
- (save-excursion
- (or
- (ignore-errors (end-of-defun) (point))
- (point-max))))))
- (save-excursion
- (while (< (point) limit)
- (let* ((end (ignore-errors (forward-sexp) (point)))
- (start (and end (progn (backward-sexp) (point)))))
- (cond
- ((and pos start end (or (< pos start) (> pos end)))
- (goto-char (if end (+ end 1) limit)))
- (t
- (forward-char 1)
- (let* ((pat (scheme-nth-sexp-at-point 0))
- (new-vars (ignore-errors
- (scheme-extract-match-clause-vars pat))))
- (setq match-vars (append new-vars match-vars)))
- (goto-char (if (or pos (not end)) limit (+ end 1)))))))
- match-vars)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; You can set the *scheme-default-implementation* to your preferred
-;; implementation, for when we can't figure out the file from
-;; heuristics. Alternately, in any given buffer, just
-;;
-;; (setq *scheme-current-implementation* whatever)
-
-(defgroup scheme-complete nil
- "Smart tab completion"
- :group 'scheme)
-
-(defcustom scheme-default-implementation nil
- "Default scheme implementation to provide completion for
-when scheme-complete can't infer the current implementation."
- :type 'symbol
- :group 'scheme-complete)
-
-(defcustom scheme-always-use-default-implementation-p nil
- "Always use `scheme-default-implementation' instead of heuristics."
- :type 'symbol
- :group 'scheme-complete)
-
-(defcustom scheme-complete-smart-indent-p t
- "Toggles using `scheme-smart-indent' for `scheme-complete-or-indent'."
- :type 'boolean
- :group 'scheme-complete)
-
-(defcustom scheme-indent-before-complete-p nil
- "Toggles indenting the current line before completing."
- :type 'boolean
- :group 'scheme-complete)
-
-(defcustom scheme-complete-empty-tab-behavior 'complete
- "Behavior for `scheme-complete-or-indent' when completing an empty symbol.
-A value of `complete' (the default) will complete all symbols
-elligible according to the normal type inference rules. Since
-they are not being filtered by any prefix, the list may be long -
-you can scroll through it or switch to the *Completions* buffer
-to view it. A value of `indent' will assume you meant to indent
-at that location, and `beep' will just beep and do nothing."
- :type '(choice (const complete) (const indent) (const beep))
- :group 'scheme-complete)
-
-(defcustom scheme-complete-from-end-of-symbol-p t
- "If true jump to the end when completing from the middle of a symbol."
- :type 'boolean
- :group 'scheme-complete)
-
-(defcustom scheme-complete-cache-p t
- "Toggles caching of module/load export information."
- :type 'boolean
- :group 'scheme-complete)
-
-;; (defcustom scheme-complete-learn-syntax-p nil
-;; "Toggles parsing of syntax-rules macros for completion info."
-;; :type 'boolean
-;; :group 'scheme-complete)
-
-(defcustom scheme-interleave-definitions-p nil
- "Allow internal defines to be mixed with expressions."
- :type 'boolean
- :group 'scheme-complete)
-
-(defvar *scheme-complete-module-cache* '())
-
-(defvar *scheme-current-implementation* nil)
-(make-variable-buffer-local '*scheme-current-implementation*)
-
-;; most implementations use their name as the script name
-(defvar *scheme-interpreter-alist*
- '(("csi" . chicken)
- ("gosh" . gauche)
- ("gsi" . gambit)
- ("mred" . mzscheme)
- ))
-
-(defvar *scheme-imported-modules* '())
-
-(defun scheme-guess-implementation ()
- (save-excursion
- (goto-char (point-min))
- (or
- (and (looking-at "#! *\\([^ \t\n]+\\)")
- (let ((script (file-name-nondirectory (match-string 1))))
- (cdr (assoc script *scheme-interpreter-alist*))))
- (cond
- ((re-search-forward "(define-module +\\(.\\)" nil t)
- (if (equal "(" (match-string 1))
- 'guile
- 'gauche))
- ((re-search-forward "(\\(?:use\\|require-library\\) " nil t)
- 'chicken)
- ((re-search-forward
- "#\\(?:lang\\|reader\\)" nil t)
- 'mzscheme)
- ((re-search-forward "(module\\s-" nil t)
- (if (eq scheme-default-implementation 'mzscheme)
- (if (looking-at "\\s-*\\sw") 'chicken 'mzscheme)
- (if (looking-at "\\s-*(") 'mzscheme 'chicken)))))))
-
-(defun scheme-current-implementation ()
- (when (and (not *scheme-current-implementation*)
- (not scheme-always-use-default-implementation-p))
- (setq *scheme-current-implementation* (scheme-guess-implementation)))
- (or *scheme-current-implementation*
- scheme-default-implementation))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun scheme-current-local-vars (&optional env)
- (let ((vars '())
- (start (point))
- (limit (save-excursion (beginning-of-defun) (+ (point) 1)))
- (let-limit (save-excursion (scheme-beginning-of-sexp)
- (scheme-beginning-of-sexp)
- (point)))
- (scan-internal))
- (save-excursion
- (while (> (point) limit)
- (or (ignore-errors
- (progn
- (skip-chars-backward " \t\n" limit)
- (scheme-beginning-of-sexp)
- t))
- (goto-char limit))
- (when (and (> (point) (point-min))
- (eq ?\( (char-syntax (char-before (point))))
- (eq ?w (char-syntax (char-after (point)))))
- (setq scan-internal t)
- (let ((sym (scheme-symbol-at-point)))
- (case sym
- ((lambda)
- (setq vars
- (append
- (mapcar #'list
- (scheme-flatten (scheme-nth-sexp-at-point 1)))
- vars)))
- ((match match-let match-let*)
- (setq vars
- (append
- (ignore-errors
- (save-excursion
- (let ((limit (save-excursion
- (cond
- ((eq sym 'match)
- (backward-char 1)
- (forward-sexp 1))
- (t
- (forward-sexp 2)))
- (point))))
- (forward-sexp 2)
- (if (eq sym 'match)
- (forward-sexp 1))
- (backward-sexp 1)
- (if (not (eq sym 'match))
- (forward-char 1))
- (scheme-extract-match-vars
- (and (or (eq sym 'match) (< start limit)) start)
- limit))))
- vars)))
- ((let let* letrec letrec* let-syntax letrec-syntax
- and-let* do loop)
- (or
- (ignore-errors
- (save-excursion
- (scheme-beginning-of-next-sexp)
- (let* ((loop-name
- (and (memq sym '(let loop))
- (eq ?w (char-syntax (char-after (point))))
- (prog1 (scheme-symbol-at-point)
- (scheme-beginning-of-next-sexp))))
- (let-vars
- (scheme-let-vars-at-point
- env let-limit (eq sym 'loop))))
- (if loop-name
- ;; named let
- (setq vars
- (cons `(,loop-name (lambda ,(mapcar #'car let-vars)))
- (append let-vars vars)))
- (setq vars (append let-vars vars))))
- t))
- (goto-char limit)))
- ((let-values let*-values)
- (setq vars
- (append (mapcar
- #'list
- (scheme-append-map
- #'scheme-flatten
- (remove-if-not #'consp
- (scheme-nth-sexp-at-point 1))))
- vars)))
- ((receive defun defmacro)
- (setq vars
- (append (mapcar #'list
- (scheme-flatten
- (scheme-nth-sexp-at-point 1)))
- vars)))
- (t
- (if (string-match "^\\(jazz\\.\\)?define\\(-.*\\)?" (symbol-name sym))
- (let ((defs (save-excursion
- (backward-char)
- (scheme-extract-definitions))))
- (setq vars
- (append (scheme-append-map
- #'(lambda (x)
- (and (consp (cdr x))
- (consp (cadr x))
- (eq 'lambda (caadr x))
- (mapcar #'list
- (scheme-flatten
- (cadadr x)))))
- defs)
- (and (not (= 1 (current-column))) defs)
- vars)))
- (setq scan-internal nil))))
- ;; check for internal defines
- (when scan-internal
- (ignore-errors
- (save-excursion
- (forward-sexp
- (+ 1 (if (numberp scan-internal) scan-internal 2)))
- (backward-sexp)
- (if (< (point) start)
- (setq vars (append (scheme-current-definitions) vars))
- ))))))))
- (reverse vars)))
-
-(defun scheme-extract-import-module-imports (sexp)
- (case (and (consp sexp) (car sexp))
- ((prefix prefix-in)
- (let* ((ids (scheme-extract-import-module-imports (cadr sexp)))
- (prefix0 (caddr sexp))
- (prefix (if (symbolp prefix0) (symbol-name prefix0) prefix0)))
- (mapcar #'(lambda (x)
- (cons (intern (concat prefix (symbol-name (car x))))
- (cdr x)))
- ids)))
- ((prefix-all-except)
- (let ((prefix
- (if (symbolp (cadr sexp)) (symbol-name (cadr sexp)) (cadr sexp)))
- (exceptions (cddr sexp)))
- (mapcar #'(lambda (x)
- (if (memq (car x) exceptions)
- x
- (cons (intern (concat prefix (symbol-name (car x))))
- (cdr x))))
- (scheme-extract-import-module-imports (caddr sexp)))))
- ((for for-syntax for-template for-label for-meta)
- (scheme-extract-import-module-imports (cadr sexp)))
- ((rename rename-in)
- (let ((renames (cddr sexp)))
- (mapcar #'(lambda (x)
- (cons (or (cadr (assq (car x) renames)) (car x)) (cdr x)))
- (scheme-extract-import-module-imports (cadr sexp)))))
- ((except except-in)
- (remove-if #'(lambda (x) (memq (car x) (cddr sexp)))
- (scheme-extract-import-module-imports (cadr sexp))))
- ((only only-in)
- (remove-if-not
- #'(lambda (x) (memq (car x) (cddr sexp)))
- (scheme-extract-import-module-imports (cadr sexp))))
- ((import import-for-syntax require)
- (scheme-append-map #'scheme-extract-import-module-imports (cdr sexp)))
- ((library)
- (if (and (stringp (cadr sexp)) (file-exists-p (cadr sexp)))
- (scheme-module-exports (intern (cadr sexp)))))
- ((lib)
- (if (and (equal "srfi" (caddr sexp))
- (stringp (cadr sexp))
- (string-match "^[0-9]+\\." (cadr sexp)))
- (scheme-module-exports
- (intern (file-name-sans-extension (concat "srfi-" (cadr sexp)))))
- (scheme-module-exports
- (intern (apply 'concat (append (cddr sexp) (list (cadr sexp))))))))
- (t
- (scheme-module-exports sexp))))
-
-(defun scheme-extract-sexp-imports (sexp)
- (case (and (consp sexp) (car sexp))
- ((begin define-module)
- (scheme-append-map #'scheme-extract-sexp-imports (cdr sexp)))
- ((cond-expand)
- (scheme-append-map #'scheme-extract-sexp-imports
- (scheme-append-map #'cdr (cdr sexp))))
- ((use require-extension)
- (scheme-append-map #'scheme-module-exports (cdr sexp)))
- ((import)
- (scheme-append-map #'scheme-extract-import-module-imports (cdr sexp)))
- ((autoload)
- (unless (member (cadr sexp) *scheme-imported-modules*)
- (push (cadr sexp) *scheme-imported-modules*)
- (mapcar #'(lambda (x) (cons (if (consp x) (car x) x) '((lambda obj))))
- (cddr sexp))))
- ((load)
- (unless (member (cadr sexp) *scheme-imported-modules*)
- (push (cadr sexp) *scheme-imported-modules*)
- (and (stringp (cadr sexp))
- (file-exists-p (cadr sexp))
- (scheme-with-find-file (cadr sexp)
- (scheme-current-globals)))))
- ((library module)
- (scheme-append-map #'scheme-extract-import-module-imports
- (remove-if #'(lambda (x)
- (memq (car x) '(import require)))
- (cdr sexp))))
- ))
-
-(defun scheme-module-symbol-p (sym)
- (memq sym '(use require require-extension begin cond-expand
- module library define-module autoload load import)))
-
-(defun scheme-skip-shebang ()
- ;; skip shebang if present
- (if (looking-at "#!")
- ;; guile skips until a closing !#
- (if (eq 'guile (scheme-current-implementation))
- (re-search-forward "!#" nil t)
- (forward-line))))
-
-(defun scheme-current-imports ()
- (let ((imports '())
- (*scheme-imported-modules* '())
- (in-mod-p nil))
- (save-excursion
- (goto-char (point-min))
- (scheme-skip-shebang)
- (if (re-search-forward "^(" nil t)
- (forward-char -1))
- ;; scan for module forms
- (while (not (eobp))
- (when (eq ?\( (char-after))
- (forward-char 1)
- (when (not (eq ?\( (char-after)))
- (let ((sym (scheme-symbol-at-point)))
- (cond
- ((memq sym '(module library))
- (forward-sexp 3)
- (forward-sexp -1)
- (setq in-mod-p t))
- ((scheme-module-symbol-p sym)
- (forward-char -1)
- (ignore-errors
- (setq imports
- (append (scheme-extract-sexp-imports
- (scheme-nth-sexp-at-point 0))
- imports))))
- (t
- (forward-char -1))))))
- (scheme-goto-next-top-level in-mod-p)))
- imports))
-
-;; we should be just inside the opening paren of an expression
-(defun scheme-name-of-define ()
- (save-excursion
- (scheme-beginning-of-next-sexp)
- (if (eq ?\( (char-syntax (char-after)))
- (forward-char))
- (and (memq (char-syntax (char-after)) '(?\w ?\_))
- (scheme-symbol-at-point))))
-
-(defun scheme-type-of-define ()
- (save-excursion
- (scheme-beginning-of-next-sexp)
- (cond
- ((eq ?\( (char-syntax (char-after)))
- `(lambda ,(cdr (scheme-nth-sexp-at-point 0))))
- (t
- (ignore-errors (scheme-beginning-of-next-sexp)
- (scheme-sexp-type-at-point))))))
-
-;; we should be at the opening paren of an expression
-(defun scheme-extract-definitions (&optional env)
- (save-excursion
- (let ((sym (ignore-errors (and (eq ?\( (char-syntax (char-after)))
- (progn (forward-char)
- (scheme-symbol-at-point))))))
- (case sym
- ((define-syntax define-compiled-syntax defmacro define-macro)
- (list (list (scheme-name-of-define) '(syntax))))
- ((define define-inline define-constant define-primitive defun)
- (let ((name (scheme-name-of-define))
- (type (scheme-type-of-define)))
- (list (if type (list name type) (list name)))))
- ((defvar define-class)
- (list (list (scheme-name-of-define) 'non-procedure)))
- ((define-record)
- (backward-char)
- (ignore-errors
- (let* ((sexp (scheme-nth-sexp-at-point 0))
- (name (symbol-name (cadr sexp))))
- `((,(intern (concat name "?")) (lambda (obj) boolean))
- (,(intern (concat "make-" name)) (lambda ,(cddr sexp) ))
- ,@(scheme-append-map
- #'(lambda (x)
- `((,(intern (concat name "-" (symbol-name x)))
- (lambda (non-procedure)))
- (,(intern (concat name "-" (symbol-name x) "-set!"))
- (lambda (non-procedure val) undefined))))
- (cddr sexp))))))
- ((define-record-type)
- (backward-char)
- (ignore-errors
- (let ((sexp (scheme-nth-sexp-at-point 0)))
- `((,(caaddr sexp) (lambda ,(cdaddr sexp)))
- (,(cadddr sexp) (lambda (obj)))
- ,@(scheme-append-map
- #'(lambda (x)
- (if (consp x)
- (if (consp (cddr x))
- `((,(cadr x) (lambda (non-procedure)))
- (,(caddr x)
- (lambda (non-procedure val) undefined)))
- `((,(cadr x) (lambda (non-procedure)))))))
- (cddddr sexp))))))
- ((begin progn)
- (forward-sexp)
- (scheme-current-definitions))
- (t
- '())))))
-
-(defun scheme-in-defun-name ()
- (save-excursion
- (dotimes (i 2)
- (scheme-beginning-of-sexp)
- (backward-char))
- (and (save-excursion
- (beginning-of-line)
- (looking-at "\\s-*(define"))
- (point))))
-
-;; a little more liberal than -definitions, we try to scan to a new
-;; top-level form (i.e. a line beginning with an open paren) if
-;; there's an error during normal sexp movement
-(defun scheme-current-globals ()
- (let ((here (point))
- (in-mod-p nil)
- (skip (scheme-in-defun-name))
- (globals '())
- (end (point-max)))
- (save-excursion
- (goto-char (point-min))
- (or (ignore-errors (end-of-defun) (backward-sexp) t)
- (and (re-search-forward "^(" nil t) (progn (backward-char) t))
- (goto-char (point-max)))
- ;; scan over each top-level form
- (while (< (point) end)
- (cond
- ((and (< (point) here) (looking-at "(\\(module\\|library\\)\\s-"))
- ;; module definition
- (let ((module-end (ignore-errors
- (save-excursion (forward-sexp) (point)))))
- (cond
- ((or (not module-end) (< here module-end)) ; inside the module
- ;; setup to only parse until the module end, continue
- ;; scanning top-level module forms
- (setq globals '())
- (setq in-mod-p t)
- (when module-end
- (setq end module-end))
- (forward-word 1) ;; skip the module/library word
- (forward-sexp 1) ;; skip the module name
- (scheme-beginning-of-next-sexp))
- (t ;; we're not completing from inside the module, skip
- ;; the module definition altogether
- (forward-sexp 1)
- (scheme-goto-next-top-level nil)))))
- (t
- ;; other form, extract the definitions unless it's a
- ;; definition for which we're trying to complete the name
- (if (not (eq (point) skip))
- (setq globals
- (append
- (ignore-errors (scheme-extract-definitions))
- globals)))
- (scheme-goto-next-top-level in-mod-p)))))
- globals))
-
-;; for internal defines, etc.
-(defun scheme-current-definitions (&optional enclosing-end)
- (let ((defs '())
- (end (or enclosing-end (point-max))))
- (save-excursion
- (while (< (point) end)
- (let ((here (point))
- (new-defs (scheme-extract-definitions)))
- (cond
- (new-defs
- (setq defs (append new-defs defs))
- (or (ignore-errors (scheme-beginning-of-next-sexp)
- (> (point) here))
- (goto-char end)))
- ;; non-definition form, maybe stop scanning
- ((not scheme-interleave-definitions-p)
- (goto-char end))))))
- defs))
-
-(defun scheme-current-exports ()
- (let ((res '()))
- (save-excursion
- (goto-char (point-min))
- (or (ignore-errors (end-of-defun) (beginning-of-defun) t)
- (re-search-forward "^(" nil t)
- (goto-char (point-max)))
- (while (not (eobp))
- (when (and (eq ?\( (char-syntax (char-after)))
- (eq ?w (char-syntax (char-after (1+ (point))))))
- (let ((sym (save-excursion (forward-char) (scheme-symbol-at-point))))
- (case sym
- ((declare define-module)
- (let ((decls (scheme-nth-sexp-at-point 0)))
- (cond
- ((and (listp decls) (assq 'export decls))
- (setq res (nconc (cdr (assq 'export decls)) res)))
- ((and (listp decls) (assq 'export-all decls))
- (goto-char (point-max))))))
- ((export provide)
- (unless (and (eq 'provide sym)
- (eq 'chicken (scheme-current-implementation)))
- (setq res (nconc (cdr (scheme-nth-sexp-at-point 0)) res))))
- ((export-all)
- (goto-char (point-max)))
- ((extend)
- (let ((parents (cdr (scheme-nth-sexp-at-point 0))))
- (setq res (nconc (mapcar #'car
- (scheme-append-map
- #'scheme-module-exports
- parents))
- res))))
- ((module)
- (forward-char)
- (forward-sexp)
- (let ((x (scheme-nth-sexp-at-point 0)))
- (cond
- ((eq '* x)
- (goto-char (point-max)))
- ((listp x)
- (setq res
- (nconc (remove-if-not #'symbolp (cdr x)) res))))))
- )))
- (scheme-goto-next-top-level)))
- res))
-
-(defun scheme-srfi-exports (i)
- (and (integerp i)
- (>= i 0)
- (< i (length *scheme-srfi-info*))
- (let ((info (cdr (aref *scheme-srfi-info* i))))
- (if (and (consp info) (null (cdr info)) (symbolp (car info)))
- (scheme-module-exports (car info))
- info))))
-
-(defvar scheme-module-exports-function nil)
-
-(defvar *scheme-module-exports-functions*
- '((chicken . scheme-module-exports/chicken)
- (gauche . scheme-module-exports/gauche)
- (mzscheme . scheme-module-exports/mzscheme)))
-
-(defun scheme-module-exports (mod)
- (unless (member mod *scheme-imported-modules*)
- (push mod *scheme-imported-modules*)
- (cond
- ((and (consp mod) (eq 'srfi (car mod)))
- (scheme-append-map #'scheme-srfi-exports (cdr mod)))
- ((and (symbolp mod) (string-match "^srfi-" (symbol-name mod)))
- (scheme-srfi-exports
- (string-to-number (substring (symbol-name mod) 5))))
- (t
- (let ((cached (assq mod *scheme-complete-module-cache*)))
- ;; remove stale caches
- (when (and cached
- (stringp (cadr cached))
- (ignore-errors
- (let ((mtime (nth 5 (file-attributes (cadr cached))))
- (ptime (caddr cached)))
- (or (> (car mtime) (car ptime))
- (and (= (car mtime) (car ptime))
- (> (cadr mtime) (cadr ptime)))))))
- (setq *scheme-complete-module-cache*
- (assq-delete-all mod *scheme-complete-module-cache*))
- (setq cached nil))
- (if cached
- (cadddr cached)
- ;; (re)compute module exports
- (let ((export-fun
- (or scheme-module-exports-function
- (cdr (assq (scheme-current-implementation)
- *scheme-module-exports-functions*)))))
- (when export-fun
- (let ((res (funcall export-fun mod)))
- (when res
- (when (and scheme-complete-cache-p (car res))
- (push (list mod
- (car res)
- (nth 5 (file-attributes (car res)))
- (cadr res))
- *scheme-complete-module-cache*))
- (cadr res)))))))))))
-
-(defun scheme-module-exports/chicken (mod)
- (let ((predefined (assq mod *scheme-chicken-modules*)))
- (if predefined
- (list nil (cdr predefined))
- (let* ((mod-str (symbol-name mod))
- (export-file
- (concat *scheme-chicken-base-repo* "/" mod-str ".exports"))
- (setup-file
- (concat *scheme-chicken-base-repo* "/" mod-str ".setup-info"))
- ;; look for the source in the current directory
- (source-file (concat mod-str ".scm"))
- ;; try the chicken 4 modules db
- (modules-db (concat *scheme-chicken-base-repo* "/modules.db")))
- (cond
- ((eq mod 'scheme)
- (list nil *scheme-r5rs-info*))
- ((eq mod 'chicken)
- (list nil (cdr (assq 'chicken *scheme-implementation-exports*))))
- ((file-exists-p source-file)
- (list source-file
- (scheme-with-find-file source-file
- (let ((env (scheme-current-globals))
- (exports (scheme-current-exports)))
- (if (consp exports)
- (remove-if-not #'(lambda (x) (memq (car x) exports)) env)
- env)))))
- ((file-exists-p export-file)
- (list export-file
- (mapcar #'(lambda (x) (cons (intern x) '((lambda obj))))
- (scheme-file->lines export-file))))
- (t
- (let ((setup-file-exports
- (and (file-exists-p setup-file)
- (scheme-with-find-file setup-file
- (let* ((alist (scheme-nth-sexp-at-point 0))
- (cell (assq 'exports alist)))
- (cdr cell))))))
- (cond
- (setup-file-exports
- (list setup-file
- (mapcar #'(lambda (x) (cons (intern x) '((lambda obj))))
- setup-file-exports)))
- ((file-exists-p modules-db)
- (list modules-db
- (mapcar
- #'(lambda (x)
- (cons (intern (car (split-string (substring x 1))))
- '((lambda ()))))
- (remove-if-not
- #'(lambda (x) (string-match (concat " " mod-str ")") x))
- (scheme-file->lines modules-db))))))))
- )))))
-
-(defun scheme-module-exports/gauche (mod)
- (let* ((file (concat (subst-char-in-string ?. ?/ (symbol-name mod)) ".scm"))
- (dir
- (scheme-find-file-in-path
- file
- (cons
- (concat *scheme-gauche-site-repo-path* "/site/lib")
- (mapcar
- #'(lambda (x) (concat x "/lib"))
- (reverse
- (directory-files *scheme-gauche-repo-path* t "^[0-9]")))))))
- (when dir
- (list
- (concat dir "/" file)
- (scheme-with-find-file (concat dir "/" file)
- (let ((env (scheme-current-globals))
- (exports (scheme-current-exports)))
- (if (consp exports)
- (remove-if-not #'(lambda (x) (memq (car x) exports)) env)
- env)))))))
-
-(defun scheme-module-exports/mzscheme (mod)
- (let ((dir (scheme-find-file-in-path
- (symbol-name mod)
- '("."
- "/usr/local/lib/plt/collects"
- "/usr/local/lib/plt/collects/mzlib"))))
- (when dir
- ;; XXXX parse, don't use regexps
- (list
- (concat dir "/" (symbol-name mod))
- (scheme-with-find-file (concat dir "/" (symbol-name mod))
- (when (re-search-forward "(provide" nil t)
- (backward-sexp)
- (backward-char)
- (mapcar #'list (cdr (ignore-errors (scheme-nth-sexp-at-point 0))))
- ))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; This is rather complicated because we want to auto-generate
-;; docstring summaries from the type information, which means
-;; inferring various types from common names. The benefit is that you
-;; don't have to input the same information twice, and can often
-;; cut&paste&munge procedure descriptions from the original
-;; documentation.
-
-(defun scheme-translate-type (type)
- (if (not (symbolp type))
- type
- (case type
- ((pred proc thunk handler dispatch producer consumer f fn g kons)
- 'procedure)
- ((num) 'number)
- ((z) 'complex)
- ((x1 x2 x3 y timeout seconds nanoseconds) 'real)
- ((i j k n m int index size count len length bound nchars start end
- pid uid gid fd fileno errno)
- 'integer)
- ((ch) 'char)
- ((str name pattern) 'string)
- ((file path pathname) 'filename)
- ((dir dirname) 'directory)
- ((sym id identifier) 'symbol)
- ((ls lis lst alist lists) 'list)
- ((vec) 'vector)
- ((exc excn err error) 'exception)
- ((ptr) 'pointer)
- ((bool) 'boolean)
- ((env) 'environment)
- ((char string boolean number complex real integer procedure char-set
- port input-port output-port pair list vector array stream hash-table
- thread mutex condition-variable time exception date duration locative
- random-source state condition condition-type queue pointer
- u8vector s8vector u16vector s16vector u32vector s32vector
- u64vector s64vector f32vector f64vector undefined symbol
- block filename directory mmap listener environment non-procedure
- read-table continuation blob generic method class regexp regmatch
- sys-stat fdset)
- type)
- ((parent seed option mode) 'non-procedure)
- (t
- (let* ((str (symbol-name type))
- (i (string-match "-?[0-9]+$" str)))
- (if i
- (scheme-translate-type (intern (substring str 0 i)))
- (let ((i (string-match "-\\([^-]+\\)$" str)))
- (if i
- (scheme-translate-type (intern (substring str (+ i 1))))
- (if (string-match "\\?$" str)
- 'boolean
- 'object)))))))))
-
-(defun scheme-lookup-type (spec pos)
- (let ((i 1)
- (type nil))
- (while (and (consp spec) (<= i pos))
- (cond
- ((eq :optional (car spec))
- (if (and (= i pos) (consp (cdr spec)))
- (setq type (cadr spec)))
- (setq i (+ pos 1)))
- ((= i pos)
- (setq type (car spec))
- (setq spec nil))
- ((and (consp (cdr spec)) (eq '\.\.\. (cadr spec)))
- (setq type (car spec))
- (setq spec nil)))
- (setq spec (cdr spec))
- (incf i))
- (if type
- (setq type (scheme-translate-type type)))
- type))
-
-(defun scheme-predicate->type (pred)
- (case pred
- ((even? odd?) 'integer)
- ((char-upper-case? char-lower-case?
- char-alphabetic? char-numeric? char-whitespace?)
- 'char)
- (t
- ;; catch all the `type?' predicates with pattern matching
- ;; ... we could be smarter if the env was passed
- (let ((str (symbol-name pred)))
- (if (string-match "\\?$" str)
- (scheme-translate-type
- (intern (substring str 0 (- (length str) 1))))
- 'object)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; completion
-
-(eval-when (compile load eval)
- (unless (fboundp 'event-matches-key-specifier-p)
- (defalias 'event-matches-key-specifier-p 'eq)))
-
-(unless (fboundp 'read-event)
- (defun read-event ()
- (aref (read-key-sequence nil) 0)))
-
-(unless (fboundp 'event-basic-type)
- (defalias 'event-basic-type 'event-key))
-
-(defun scheme-string-prefix-p (pref str)
- (let ((p-len (length pref))
- (s-len (length str)))
- (and (<= p-len s-len)
- (equal pref (substring str 0 p-len)))))
-
-(defun scheme-do-completion (str coll &optional strs pred)
- (let* ((coll (mapcar #'(lambda (x)
- (cond
- ((symbolp x) (list (symbol-name x)))
- ((stringp x) (list x))
- (t x)))
- coll))
- (completion1 (try-completion str coll pred))
- (completion2 (and strs (try-completion str strs pred)))
- (completion (if (and completion2
- (or (not completion1)
- (< (length completion2)
- (length completion1))))
- completion2
- completion1)))
- (cond
- ((eq completion t))
- ((not completion)
- (message "Can't find completion for \"%s\"" str)
- (ding))
- ((not (string= str completion))
- (let ((prefix-p (scheme-string-prefix-p completion completion1)))
- (unless prefix-p
- (save-excursion
- (backward-char (length str))
- (insert "\"")))
- (insert (substring completion (length str)))
- (unless prefix-p
- (insert "\"")
- (backward-char))))
- (t
- (let ((win-config (current-window-configuration))
- (done nil))
- (message "Hit space to flush")
- (with-output-to-temp-buffer "*Completions*"
- (display-completion-list
- (sort
- (all-completions str (append strs coll) pred)
- 'string-lessp)))
- (while (not done)
- (let* ((orig-event
- (with-current-buffer (get-buffer "*Completions*")
- (read-event)))
- (event (event-basic-type orig-event)))
- (cond
- ((or (event-matches-key-specifier-p event 'tab)
- (event-matches-key-specifier-p event 9))
- (save-selected-window
- (select-window (get-buffer-window "*Completions*"))
- (if (pos-visible-in-window-p (point-max))
- (goto-char (point-min))
- (scroll-up))))
- (t
- (set-window-configuration win-config)
- (if (or (event-matches-key-specifier-p event 'space)
- (event-matches-key-specifier-p event 32))
- (bury-buffer (get-buffer "*Completions*"))
- (setq unread-command-events (list orig-event)))
- (setq done t))))))
- ))))
-
-(defun scheme-env-lookup (env sym)
- (let ((spec nil)
- (ls env))
- (while (and ls (not spec))
- (setq spec (assq sym (pop ls))))
- spec))
-
-(defun scheme-inside-module-p ()
- (save-excursion
- (ignore-errors
- (let ((here (point))
- res)
- (goto-char (point-min))
- (while (< (point) here)
- (if (not (re-search-forward "^(\\(?:module\\|library\\)\\s-"))
- (goto-char (point-max))
- (beginning-of-line)
- (let ((mod-point (point)))
- (if (ignore-errors (forward-sexp) t)
- (if (and (<= mod-point here) (<= here (point)))
- (setq res t))
- (setq res (<= mod-point here))
- (goto-char (point-max))))))
- res))))
-
-(defun scheme-current-env ()
- (let ((in-mod-p (scheme-inside-module-p)))
- ;; r5rs
- (let ((env (if in-mod-p
- '(((import
- (special symbol scheme-chicken-available-modules))))
- (list *scheme-r5rs-info*))))
- ;; base language
- (let ((base (cdr (assq (scheme-current-implementation)
- *scheme-implementation-exports*))))
- (if (and base (not in-mod-p)) (push base env)))
- ;; imports
- (let ((imports (ignore-errors (scheme-current-imports))))
- (if imports (push imports env)))
- ;; top-level defs
- (let ((top (ignore-errors (scheme-current-globals))))
- (if top (push top env)))
- ;; current local vars
- (let ((locals (ignore-errors (scheme-current-local-vars env))))
- (if locals (push locals env)))
- env)))
-
-(defun scheme-env-filter (pred env)
- (mapcar #'car
- (apply #'concatenate
- 'list
- (mapcar #'(lambda (e) (remove-if-not pred e)) env))))
-
-;; checking return values:
-;; a should be capable of returning instances of b
-(defun scheme-type-match-p (a b)
- (let ((a1 (scheme-translate-type a))
- (b1 (scheme-translate-type b)))
- (and (not (eq a1 'undefined)) ; check a *does* return something
- (or (eq a1 b1) ; and they're the same
- (eq a1 'object) ; ... or a can return anything
- (eq b1 'object) ; ... or b can receive anything
- (if (symbolp a1)
- (if (symbolp b1)
- (case a1 ; ... or the types overlap
- ((number complex real rational integer)
- (memq b1 '(number complex real rational integer)))
- ((port input-port output-port)
- (memq b1 '(port input-port output-port)))
- ((pair list)
- (memq b1 '(pair list)))
- ((non-procedure)
- (not (eq 'procedure b1))))
- (and
- (consp b1)
- (if (eq 'or (car b1))
- ;; type unions
- (find-if
- #'(lambda (x)
- (scheme-type-match-p
- a1 (scheme-translate-type x)))
- (cdr b1))
- (let ((b2 (scheme-translate-special-type b1)))
- (and (not (equal b1 b2))
- (scheme-type-match-p a1 b2))))))
- (and (consp a1)
- (case (car a1)
- ((or)
- ;; type unions
- (find-if
- #'(lambda (x)
- (scheme-type-match-p (scheme-translate-type x) b1))
- (cdr a1)))
- ((lambda)
- ;; procedures
- (or (eq 'procedure b1)
- (and (consp b1)
- (eq 'lambda (car b1))
- (scheme-param-list-match-p (cadr a1)
- (cadr b1)))))
- (t
- ;; other special types
- (let ((a2 (scheme-translate-special-type a1))
- (b2 (scheme-translate-special-type b1)))
- (and (or (not (equal a1 a2)) (not (equal b1 b2)))
- (scheme-type-match-p a2 b2)))))))))))
-
-(defun scheme-param-list-match-p (p1 p2)
- (or (and (symbolp p1) (not (null p1)))
- (and (symbolp p2) (not (null p2)))
- (and (null p1) (null p2))
- (and (consp p1) (consp p2)
- (scheme-param-list-match-p (cdr p1) (cdr p2)))))
-
-(defun scheme-translate-special-type (x)
- (if (not (consp x))
- x
- (case (car x)
- ((list string) (car x))
- ((set special) (cadr x))
- ((flags) 'integer)
- (t x))))
-
-(defun scheme-nth* (n ls)
- (while (and (consp ls) (> n 0))
- (setq n (- n 1)
- ls (cdr ls)))
- (and (consp ls) (car ls)))
-
-(defun scheme-file->lines (file)
- (and (file-readable-p file)
- (scheme-with-find-file file
- (goto-char (point-min))
- (let ((res '()))
- (while (not (eobp))
- (let ((start (point)))
- (forward-line)
- (push (buffer-substring-no-properties start (- (point) 1))
- res)))
- (reverse res)))))
-
-(defun scheme-passwd-file-names (file &optional pat)
- (delete
- nil
- (mapcar
- #'(lambda (line)
- (and (not (string-match "^[ ]*#" line))
- (or (not pat) (string-match pat line))
- (string-match "^\\([^:]*\\):" line)
- (match-string 1 line)))
- (scheme-file->lines file))))
-
-(defun scheme-host-file-names (file)
- (scheme-append-map
- #'(lambda (line)
- (let ((i (string-match "#" line)))
- (if i (setq line (substring line 0 i))))
- (cdr (split-string line)))
- (scheme-file->lines file)))
-
-(defun scheme-ssh-known-hosts-file-names (file)
- (scheme-append-map
- #'(lambda (line)
- (split-string (car (split-string line)) ","))
- (scheme-file->lines file)))
-
-(defun scheme-ssh-config-file-names (file)
- (scheme-append-map
- #'(lambda (line)
- (and (string-match "^ *Host" line)
- (cdr (split-string line))))
- (scheme-file->lines file)))
-
-(defun scheme-complete-user-name (trans sym)
- (if (string-match "apple" (emacs-version))
- (append (scheme-passwd-file-names "/etc/passwd" "^[^_].*")
- (delete "Shared" (directory-files "/Users" nil "^[^.].*")))
- (scheme-passwd-file-names "/etc/passwd")))
-
-(defun scheme-complete-host-name (trans sym)
- (append (scheme-host-file-names "/etc/hosts")
- (scheme-ssh-known-hosts-file-names "~/.ssh/known_hosts")
- (scheme-ssh-config-file-names "~/.ssh/config")))
-
-;; my /etc/services is 14k lines, so we try to optimize this
-(defun scheme-complete-port-name (trans sym)
- (and (file-readable-p "/etc/services")
- (scheme-with-find-file "/etc/services"
- (goto-char (point-min))
- (let ((rx (concat "^\\(" (regexp-quote (if (symbolp sym)
- (symbol-name sym)
- sym))
- "[^ ]*\\)"))
- (res '()))
- (while (not (eobp))
- (if (not (re-search-forward rx nil t))
- (goto-char (point-max))
- (let ((str (match-string-no-properties 1)))
- (if (not (equal str (car res)))
- (push str res)))
- (forward-char 1)))
- res))))
-
-(defun scheme-complete-file-name (trans sym)
- (let* ((file (file-name-nondirectory sym))
- (dir (file-name-directory sym))
- (res (file-name-all-completions file (or dir "."))))
- (if dir
- (mapcar #'(lambda (f) (concat dir f)) res)
- res)))
-
-(defun scheme-complete-directory-name (trans sym)
- (let* ((file (file-name-nondirectory sym))
- (dir (file-name-directory sym))
- (res (file-name-all-completions file (or dir ".")))
- (res2 (if dir (mapcar #'(lambda (f) (concat dir f)) res) res)))
- (remove-if-not #'file-directory-p res2)))
-
-(defun scheme-string-completer (type)
- (case type
- ((filename)
- '(scheme-complete-file-name file-name-nondirectory))
- ((directory)
- '(scheme-complete-directory-name file-name-nondirectory))
- (t
- (cond
- ((and (consp type) (eq 'string (car type)))
- (cadr type))
- ((and (consp type) (eq 'or (car type)))
- (car (delete nil (mapcar #'scheme-string-completer (cdr type)))))))))
-
-(defun scheme-apply-string-completer (cmpl sym)
- (let ((func (if (consp cmpl) (car cmpl) cmpl))
- (trans (and (consp cmpl) (cadr cmpl))))
- (funcall func trans sym)))
-
-(defun scheme-smart-complete (&optional arg)
- (interactive "P")
- (if scheme-indent-before-complete-p
- (lisp-indent-line))
- (if (and scheme-complete-from-end-of-symbol-p
- (not (eobp))
- (eq ?w (char-syntax (char-after)))
- (not (bobp))
- (eq ?w (char-syntax (char-before))))
- (forward-sexp 1))
- (let* ((end (point))
- (start (save-excursion (skip-syntax-backward "w_") (point)))
- (sym (buffer-substring-no-properties start end))
- (in-str-p (scheme-in-string-p))
- (x (save-excursion
- (if in-str-p (scheme-beginning-of-string))
- (scheme-enclosing-2-sexp-prefixes)))
- (inner-proc (car x))
- (inner-pos (cadr x))
- (outer-proc (caddr x))
- (outer-pos (cadddr x))
- (env (save-excursion
- (if in-str-p (scheme-beginning-of-string))
- (scheme-current-env)))
- (outer-spec (scheme-env-lookup env outer-proc))
- (outer-type (scheme-translate-type (cadr outer-spec)))
- (inner-spec (scheme-env-lookup env inner-proc))
- (inner-type (scheme-translate-type (cadr inner-spec))))
- (cond
- ;; return all env symbols when a prefix arg is given
- (arg
- (scheme-do-completion sym (scheme-env-filter #'(lambda (x) t) env)))
- ;; allow different types of strings
- (in-str-p
- (let* ((param-type
- (and (consp inner-type)
- (eq 'lambda (car inner-type))
- (scheme-lookup-type (cadr inner-type) inner-pos)))
- (completer (or (scheme-string-completer param-type)
- '(scheme-complete-file-name
- file-name-nondirectory))))
- (scheme-do-completion
- ;;(if (consp completer) (funcall (cadr completer) sym) sym)
- sym
- (scheme-apply-string-completer completer sym))))
- ;; outer special
- ((and (consp outer-type)
- (eq 'special (car outer-type))
- (cadddr outer-type))
- (scheme-do-completion sym (funcall (cadddr outer-type) sym)))
- ;; inner special
- ((and (consp inner-type)
- (eq 'special (car inner-type))
- (caddr inner-type))
- (scheme-do-completion sym (funcall (caddr inner-type) sym)))
- ;; completing inner procedure, complete procedures with a
- ;; matching return type
- ((and (consp outer-type)
- (eq 'lambda (car outer-type))
- (not (zerop outer-pos))
- (scheme-nth* (- outer-pos 1) (cadr outer-type))
- (or (zerop inner-pos)
- (and (>= 1 inner-pos)
- (consp inner-type)
- (eq 'lambda (car inner-type))
- (let ((param-type
- (scheme-lookup-type (cadr inner-type) inner-pos)))
- (and (consp param-type)
- (eq 'lambda (car param-type))
- (eq (caddr inner-type) (caddr param-type)))))))
- (let ((want-type (scheme-lookup-type (cadr outer-type) outer-pos)))
- (scheme-do-completion
- sym
- (scheme-env-filter
- #'(lambda (x)
- (let ((type (cadr x)))
- (or (memq type '(procedure object nil))
- (and (consp type)
- (or (and (eq 'syntax (car type))
- (not (eq 'undefined (caddr type))))
- (and (eq 'lambda (car type))
- (scheme-type-match-p (caddr type)
- want-type)))))))
- env))))
- ;; completing a normal parameter
- ((and inner-proc
- (not (zerop inner-pos))
- (consp inner-type)
- (eq 'lambda (car inner-type)))
- (let* ((param-type (scheme-lookup-type (cadr inner-type) inner-pos))
- (set-or-flags
- (or (and (consp param-type)
- (case (car param-type)
- ((set) (cddr param-type))
- ((flags) (cdr param-type))))
- ;; handle nested arithmetic functions inside a flags
- ;; parameter
- (and (not (zerop outer-pos))
- (consp outer-type)
- (eq 'lambda (car outer-type))
- (let ((outer-param-type
- (scheme-lookup-type (cadr outer-type)
- outer-pos)))
- (and (consp outer-param-type)
- (eq 'flags (car outer-param-type))
- (memq (scheme-translate-type param-type)
- '(number complex real rational integer))
- (memq (scheme-translate-type (caddr inner-type))
- '(number complex real rational integer))
- (cdr outer-param-type))))))
- (base-type (if set-or-flags
- (if (and (consp param-type)
- (eq 'set (car param-type)))
- (scheme-translate-type (cadr param-type))
- 'integer)
- param-type))
- (base-completions
- (scheme-env-filter
- #'(lambda (x)
- (and (not (and (consp (cadr x)) (eq 'syntax (caadr x))))
- (scheme-type-match-p (cadr x) base-type)))
- env))
- (str-completions
- (let ((completer (scheme-string-completer base-type)))
- (and
- completer
- (scheme-apply-string-completer completer sym)))))
- (scheme-do-completion
- sym
- (append set-or-flags base-completions)
- str-completions)))
- ;; completing a function
- ((zerop inner-pos)
- (scheme-do-completion
- sym
- (scheme-env-filter
- #'(lambda (x)
- (or (null (cdr x))
- (memq (cadr x) '(procedure object nil))
- (and (consp (cadr x))
- (memq (caadr x) '(lambda syntax special)))))
- env)))
- ;; complete everything
- (t
- (scheme-do-completion sym (scheme-env-filter #'(lambda (x) t) env)) ))))
-
-(defun scheme-complete-or-indent (&optional arg)
- (interactive "P")
- (let* ((end (point))
- (func
- (if (or (and (not (bobp))
- (eq ?w (char-syntax (char-before))))
- (and (save-excursion
- (beginning-of-line)
- (re-search-forward "\\S-" end t))
- (case scheme-complete-empty-tab-behavior
- ((indent) nil)
- ((beep) (beep))
- (t t))))
- 'scheme-smart-complete
- 'lisp-indent-line)))
- (funcall func arg)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; optional indentation handling
-
-(defvar calculate-lisp-indent-last-sexp)
-
-;; Copied from scheme-indent-function, but ignore
-;; scheme-indent-function property for local variables.
-(defun scheme-smart-indent-function (indent-point state)
- (let ((normal-indent (current-column)))
- (goto-char (1+ (elt state 1)))
- (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t)
- (if (and (elt state 2)
- (not (looking-at "\\sw\\|\\s_")))
- ;; car of form doesn't seem to be a symbol
- (progn
- (if (not (> (save-excursion (forward-line 1) (point))
- calculate-lisp-indent-last-sexp))
- (progn (goto-char calculate-lisp-indent-last-sexp)
- (beginning-of-line)
- (parse-partial-sexp (point)
- calculate-lisp-indent-last-sexp 0 t)))
- ;; Indent under the list or under the first sexp on the same
- ;; line as calculate-lisp-indent-last-sexp. Note that first
- ;; thing on that line has to be complete sexp since we are
- ;; inside the innermost containing sexp.
- (backward-prefix-chars)
- (current-column))
- (let* ((function (buffer-substring-no-properties
- (point)
- (progn (forward-sexp 1) (point))))
- (function-sym (intern-soft function))
- (method (and (not (assq function-sym (scheme-current-local-vars)))
- (get function-sym 'scheme-indent-function))))
- (cond ((or (eq method 'defun)
- (and (null method)
- (> (length function) 3)
- (string-match "\\`def" function)))
- (lisp-indent-defform state indent-point))
- ((integerp method)
- (lisp-indent-specform method state
- indent-point normal-indent))
- (method
- (funcall method state indent-point normal-indent)))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; optional eldoc function
-
-(defun scheme-translate-dot-to-optional (ls)
- (let ((res '()))
- (while (consp ls)
- (setq res (cons (car ls) res))
- (setq ls (cdr ls)))
- (if (not (null ls))
- (setq res (cons ls (cons :optional res))))
- (reverse res)))
-
-(defun scheme-optional-in-brackets (ls)
- ;; put optional arguments inside brackets (via a vector)
- (if (memq :optional ls)
- (let ((res '()))
- (while (and (consp ls) (not (eq :optional (car ls))))
- (push (pop ls) res))
- (reverse (cons (apply #'vector (cdr ls)) res)))
- ls))
-
-(defun scheme-base-type (x)
- (if (not (consp x))
- x
- (case (car x)
- ((string list) (car x))
- ((set) (or (cadr x) (car x)))
- ((flags) 'integer)
- ((lambda) 'procedure)
- ((syntax) 'syntax)
- (t x))))
-
-(defun scheme-sexp-to-string (sexp)
- (with-output-to-string (princ sexp)))
-
-(defun scheme-get-current-symbol-info ()
- (let* ((sym (eldoc-current-symbol))
- (fnsym0 (eldoc-fnsym-in-current-sexp))
- (fnsym (if (consp fnsym0) (car fnsym0) fnsym0))
- (env (save-excursion
- (if (scheme-in-string-p) (scheme-beginning-of-string))
- (scheme-current-env)))
- (spec (or (and sym (scheme-env-lookup env sym))
- (and fnsym (scheme-env-lookup env fnsym)))))
- (and (consp spec)
- (consp (cdr spec))
- (let ((type (cadr spec)))
- (concat
- (cond
- ((nth 3 spec)
- "")
- ((and (consp type)
- (memq (car type) '(syntax lambda)))
- (concat
- (if (eq (car type) 'syntax)
- "syntax: "
- "")
- (scheme-sexp-to-string
- (cons (car spec)
- (scheme-optional-in-brackets
- (mapcar #'scheme-base-type
- (scheme-translate-dot-to-optional
- (cadr type))))))
- (if (and (consp (cddr type))
- (not (memq (caddr type) '(obj object))))
- (concat " => " (scheme-sexp-to-string (caddr type)))
- "")))
- ((and (consp type) (eq (car type) 'special))
- (scheme-sexp-to-string (car spec)))
- (t
- (scheme-sexp-to-string type)))
- (if (and (not (nth 3 spec)) (nth 4 spec)) " - " "")
- (or (nth 4 spec) ""))))))
-
-(provide 'scheme-complete)
-
-;; Local Variables:
-;; eval: (put 'scheme-with-find-file 'lisp-indent-hook 1)
-;; End:
-
diff --git a/scripts/README b/scripts/README
index 0905509c..62902f41 100644
--- a/scripts/README
+++ b/scripts/README
@@ -4,16 +4,6 @@ README for scripts/
This directory contains a couple of things that might be useful:
- scheme
-
- A wrapper sh(1) script that allows automatic compilation of Scheme
- scripts. If you precede a Scheme file with a header line like this
-
- #!/usr/bin/env scheme
-
- then a compiled version of the code will be stored in $HOME/.cache
- and executed, instead of the original source file.
-
tools.scm
Helper functions for some of the scripts here.
diff --git a/scripts/makedist.scm b/scripts/makedist.scm
index a6100b27..69b80cb0 100644
--- a/scripts/makedist.scm
+++ b/scripts/makedist.scm
@@ -5,6 +5,8 @@
(load-relative "tools.scm")
+(define *help* #f)
+
(set! *verbose* #t)
(define BUILDVERSION (with-input-from-file "buildversion" read))
@@ -52,6 +54,7 @@
(define (make-html)
(unless (file-exists? "html")
(create-directory "html"))
+ (run (rm -f "manual/*~"))
(run (,(or (get-environment-variable "CSI")
(let ((this (car (argv))))
(if (string=? "csi" (pathname-file this))
@@ -62,12 +65,16 @@
,@(map (o qs (cut make-pathname "manual" <>))
(directory "manual")))))
+(define (usage . _)
+ (print "usage: makedist [--release] [--make=PROGRAM] [--platform=PLATFORM] MAKEOPTION ...")
+ (exit 1))
+
(define *makeargs*
(simple-args
(command-line-arguments)
- (lambda _
- (print "usage: makedist [--release] [--make=PROGRAM] [--platform=PLATFORM] MAKEOPTION ...")
- (exit 1))) )
+ usage))
+
+(when *help* (usage))
(run (,*make* -f ,(conc "Makefile." *platform*) distfiles ,@*makeargs*))
Trap