~ chicken-core (chicken-5) /library.scm
Trap1;;;; library.scm - R5RS library for the CHICKEN compiler2;3; Copyright (c) 2008-2022, The CHICKEN Team4; Copyright (c) 2000-2007, Felix L. Winkelmann5; All rights reserved.6;7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following8; conditions are met:9;10; Redistributions of source code must retain the above copyright notice, this list of conditions and the following11; disclaimer.12; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following13; disclaimer in the documentation and/or other materials provided with the distribution.14; Neither the name of the author nor the names of its contributors may be used to endorse or promote15; products derived from this software without specific prior written permission.16;17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE25; POSSIBILITY OF SUCH DAMAGE.262728(declare29 (unit library)30 (uses build-version)31 (disable-interrupts)32 (hide ##sys#dynamic-unwind33 ##sys#vector-resize ##sys#default-parameter-vector34 current-print-length setter-tag35 ##sys#print-exit36 ##sys#format-here-doc-warning37 exit-in-progress cleanup-before-exit chicken.base#cleanup-tasks38 maximal-string-length find-ratio-between find-ratio39 make-complex flonum->ratnum ratnum40 +maximum-allowed-exponent+ mantexp->dbl ldexp round-quotient41 ##sys#string->compnum ##sys#internal-gcd)42 (not inline chicken.base#sleep-hook ##sys#change-directory-hook43 ##sys#user-read-hook ##sys#error-hook ##sys#signal-hook ##sys#signal-hook/errno44 ##sys#default-read-info-hook ##sys#infix-list-hook45 ##sys#sharp-number-hook ##sys#user-print-hook46 ##sys#user-interrupt-hook ##sys#windows-platform47 ##sys#resume-thread-on-event ##sys#suspend-thread-on-event48 ##sys#schedule ##sys#features)49 (foreign-declare #<<EOF50#include <errno.h>51#include <float.h>5253#ifdef HAVE_SYSEXITS_H54# include <sysexits.h>55#endif5657#ifndef EX_SOFTWARE58# define EX_SOFTWARE 7059#endif6061#define C_close_file(p) (C_fclose((C_FILEPTR)(C_port_file(p))), C_SCHEME_UNDEFINED)62#define C_a_f64peek(ptr, c, b, i) C_flonum(ptr, ((double *)C_data_pointer(b))[ C_unfix(i) ])63#define C_fetch_c_strlen(b, i) C_fix(strlen((C_char *)C_block_item(b, C_unfix(i))))64#define C_asciiz_strlen(str) C_fix(strlen(C_c_string(str)))65#define C_peek_c_string(b, i, to, len) (C_memcpy(C_data_pointer(to), (C_char *)C_block_item(b, C_unfix(i)), C_unfix(len)), C_SCHEME_UNDEFINED)66#define C_free_mptr(p, i) (C_free((void *)C_block_item(p, C_unfix(i))), C_SCHEME_UNDEFINED)67#define C_free_sptr(p, i) (C_free((void *)(((C_char **)C_block_item(p, 0))[ C_unfix(i) ])), C_SCHEME_UNDEFINED)6869#define C_a_get_current_seconds(ptr, c, dummy) C_int64_to_num(ptr, time(NULL))70#define C_peek_c_string_at(ptr, i) ((C_char *)(((C_char **)ptr)[ i ]))7172static C_word73fast_read_line_from_file(C_word str, C_word port, C_word size) {74 int n = C_unfix(size);75 int i;76 int c;77 char *buf = C_c_string(str);78 C_FILEPTR fp = C_port_file(port);7980 if ((c = C_getc(fp)) == EOF) {81 if (ferror(fp)) {82 clearerr(fp);83 return C_fix(-1);84 } else { /* feof (fp) */85 return C_SCHEME_END_OF_FILE;86 }87 }8889 C_ungetc(c, fp);9091 for (i = 0; i < n; i++) {92 c = C_getc(fp);9394 if(c == EOF && ferror(fp)) {95 clearerr(fp);96 return C_fix(-(i + 1));97 }9899 switch (c) {100 case '\r': if ((c = C_getc(fp)) != '\n') C_ungetc(c, fp);101 case EOF: clearerr(fp);102 case '\n': return C_fix(i);103 }104 buf[i] = c;105 }106 return C_SCHEME_FALSE;107}108109static C_word110fast_read_string_from_file(C_word dest, C_word port, C_word len, C_word pos)111{112 size_t m;113 int n = C_unfix (len);114 char * buf = ((char *)C_data_pointer (dest) + C_unfix (pos));115 C_FILEPTR fp = C_port_file (port);116117 if(feof(fp)) return C_SCHEME_END_OF_FILE;118119 m = fread (buf, sizeof (char), n, fp);120121 if (m < n) {122 if (ferror(fp)) /* Report to Scheme, which may retry, so clear errors */123 clearerr(fp);124 else if (feof(fp) && 0 == m) /* eof but m > 0? Return data first, below */125 return C_SCHEME_END_OF_FILE; /* Calling again will get us here */126 }127128 return C_fix (m);129}130131static C_word132shallow_equal(C_word x, C_word y)133{134 /* assumes x and y are non-immediate */135 int i, len = C_header_size(x);136137 if(C_header_size(y) != len) return C_SCHEME_FALSE;138 else return C_mk_bool(!C_memcmp((void *)x, (void *)y, len * sizeof(C_word)));139}140141static C_word142signal_debug_event(C_word mode, C_word msg, C_word args)143{144 C_DEBUG_INFO cell;145 C_word av[ 3 ];146 cell.enabled = 1;147 cell.event = C_DEBUG_SIGNAL;148 cell.loc = "";149 cell.val = "";150 av[ 0 ] = mode;151 av[ 1 ] = msg;152 av[ 2 ] = args;153 C_debugger(&cell, 3, av);154 return C_SCHEME_UNDEFINED;155}156157static C_word C_i_sleep_until_interrupt(C_word secs)158{159 while(C_i_process_sleep(secs) == C_fix(-1) && errno == EINTR);160 return C_SCHEME_UNDEFINED;161}162163#ifdef NO_DLOAD2164# define HAVE_DLOAD 0165#else166# define HAVE_DLOAD 1167#endif168169#ifdef C_ENABLE_PTABLES170# define HAVE_PTABLES 1171#else172# define HAVE_PTABLES 0173#endif174175#ifdef C_GC_HOOKS176# define HAVE_GCHOOKS 1177#else178# define HAVE_GCHOOKS 0179#endif180181#if defined(C_CROSS_CHICKEN) && C_CROSS_CHICKEN182# define IS_CROSS_CHICKEN 1183#else184# define IS_CROSS_CHICKEN 0185#endif186EOF187) )188189;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;190;; NOTE: Modules defined here will typically exclude syntax191;; definitions, those are handled by expand.scm or modules.scm.192;; Handwritten import libraries (or a special-case module in193;; modules.scm for scheme) contain the value exports merged with194;; syntactic exports. The upshot of this is that any module that195;; refers to another module defined *earlier* in this file cannot use196;; macros from the earlier module!197;;198;; We get around this problem by using the "chicken.internal.syntax"199;; module, which is baked in and exports *every* available core macro.200;; See modules.scm, expand.scm and chicken-syntax.scm for details.201;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;202203;; Pre-declaration of scheme, so it can be used later on. We only use204;; scheme macros and core language forms in here, to avoid a cyclic205;; dependency on itself. All actual definitions are set! below.206;; Also, this declaration is incomplete: the module itself is defined207;; as a primitive module due to syntax exports, which are missing208;; here. See modules.scm for the full definition.209(module scheme210 (;; [syntax]211 ;; We are reexporting these because otherwise the module here212 ;; will be inconsistent with the built-in one, and be void of213 ;; syntax definitions, causing problems below.214 begin and case cond define define-syntax delay do lambda215 if let let* let-syntax letrec letrec-syntax or216 quasiquote quote set! syntax-rules217218 not boolean? eq? eqv? equal? pair?219 cons car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar220 cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr221 caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar222 cddddr set-car! set-cdr!223 null? list? list length list-tail list-ref append reverse memq memv224 member assq assv assoc symbol? symbol->string string->symbol number?225 integer? exact? real? complex? inexact? rational? zero? odd? even?226 positive? negative? max min + - * / = > < >= <= quotient remainder227 modulo gcd lcm abs floor ceiling truncate round rationalize228 exact->inexact inexact->exact exp log expt sqrt229 sin cos tan asin acos atan230 number->string string->number char? char=? char>? char<? char>=?231 char<=? char-ci=? char-ci<? char-ci>? char-ci>=? char-ci<=?232 char-alphabetic? char-whitespace? char-numeric? char-upper-case?233 char-lower-case? char-upcase char-downcase234 char->integer integer->char235 string? string=? string>? string<? string>=? string<=? string-ci=?236 string-ci<? string-ci>? string-ci>=? string-ci<=? make-string237 string-length string-ref string-set! string-append string-copy238 string->list list->string substring string-fill! vector? make-vector239 vector-ref vector-set! string vector vector-length vector->list240 list->vector vector-fill! procedure? map for-each apply force241 call-with-current-continuation input-port? output-port?242 current-input-port current-output-port call-with-input-file243 call-with-output-file open-input-file open-output-file244 close-input-port close-output-port245 read read-char peek-char write display write-char newline246 eof-object? with-input-from-file with-output-to-file247 char-ready? imag-part real-part make-rectangular make-polar angle248 magnitude numerator denominator values call-with-values dynamic-wind249250 ;; The following procedures are overwritten in eval.scm:251 eval interaction-environment null-environment252 scheme-report-environment load)253254(import chicken.internal.syntax) ;; See note above255256;;; Operations on booleans:257258(define (not x) (##core#inline "C_i_not" x))259(define (boolean? x) (##core#inline "C_booleanp" x))260261262;;; Equivalence predicates:263264(define (eq? x y) (##core#inline "C_eqp" x y))265(define (eqv? x y) (##core#inline "C_i_eqvp" x y))266(define (equal? x y) (##core#inline "C_i_equalp" x y))267268269;;; Pairs and lists:270271(define (pair? x) (##core#inline "C_i_pairp" x))272(define (cons x y) (##core#inline_allocate ("C_a_i_cons" 3) x y))273(define (car x) (##core#inline "C_i_car" x))274(define (cdr x) (##core#inline "C_i_cdr" x))275276(define (set-car! x y) (##core#inline "C_i_set_car" x y))277(define (set-cdr! x y) (##core#inline "C_i_set_cdr" x y))278(define (cadr x) (##core#inline "C_i_cadr" x))279(define (caddr x) (##core#inline "C_i_caddr" x))280(define (cadddr x) (##core#inline "C_i_cadddr" x))281(define (cddddr x) (##core#inline "C_i_cddddr" x))282283(define (caar x) (##core#inline "C_i_caar" x))284(define (cdar x) (##core#inline "C_i_cdar" x))285(define (cddr x) (##core#inline "C_i_cddr" x))286(define (caaar x) (car (car (car x))))287(define (caadr x) (car (##core#inline "C_i_cadr" x)))288(define (cadar x) (##core#inline "C_i_cadr" (car x)))289(define (cdaar x) (cdr (car (car x))))290(define (cdadr x) (cdr (##core#inline "C_i_cadr" x)))291(define (cddar x) (cdr (cdr (car x))))292(define (cdddr x) (cdr (cdr (cdr x))))293(define (caaaar x) (car (car (car (car x)))))294(define (caaadr x) (car (car (##core#inline "C_i_cadr" x))))295(define (caadar x) (car (##core#inline "C_i_cadr" (car x))))296(define (caaddr x) (car (##core#inline "C_i_caddr" x)))297(define (cadaar x) (##core#inline "C_i_cadr" (car (car x))))298(define (cadadr x) (##core#inline "C_i_cadr" (##core#inline "C_i_cadr" x)))299(define (caddar x) (##core#inline "C_i_caddr" (car x)))300(define (cdaaar x) (cdr (car (car (car x)))))301(define (cdaadr x) (cdr (car (##core#inline "C_i_cadr" x))))302(define (cdadar x) (cdr (##core#inline "C_i_cadr" (car x))))303(define (cdaddr x) (cdr (##core#inline "C_i_caddr" x)))304(define (cddaar x) (cdr (cdr (car (car x)))))305(define (cddadr x) (cdr (cdr (##core#inline "C_i_cadr" x))))306(define (cdddar x) (cdr (cdr (cdr (car x)))))307308(define (null? x) (eq? x '()))309(define (list . lst) lst)310(define (length lst) (##core#inline "C_i_length" lst))311(define (list-tail lst i) (##core#inline "C_i_list_tail" lst i))312(define (list-ref lst i) (##core#inline "C_i_list_ref" lst i))313314(define append)315316(define (reverse lst0)317 (let loop ((lst lst0) (rest '()))318 (cond ((eq? lst '()) rest)319 ((pair? lst)320 (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest)) )321 (else (##sys#error-not-a-proper-list lst0 'reverse)) ) ))322323(define (memq x lst) (##core#inline "C_i_memq" x lst))324(define (memv x lst) (##core#inline "C_i_memv" x lst))325(define (member x lst) (##core#inline "C_i_member" x lst))326(define (assq x lst) (##core#inline "C_i_assq" x lst))327(define (assv x lst) (##core#inline "C_i_assv" x lst))328(define (assoc x lst) (##core#inline "C_i_assoc" x lst))329330(define (list? x) (##core#inline "C_i_listp" x))331332;;; Strings:333334(define make-string)335336(define (string? x) (##core#inline "C_i_stringp" x))337(define (string-length s) (##core#inline "C_i_string_length" s))338(define (string-ref s i) (##core#inline "C_i_string_ref" s i))339(define (string-set! s i c) (##core#inline "C_i_string_set" s i c))340341(define (string=? x y)342 (##core#inline "C_i_string_equal_p" x y))343344(define (string-ci=? x y) (##core#inline "C_i_string_ci_equal_p" x y))345346(define string->list)347(define list->string)348(define string-fill)349(define string-copy)350(define substring)351(define string-fill!)352353(define string<?)354(define string>?)355(define string<=?)356(define string>=?)357358(define string-ci<?)359(define string-ci>?)360(define string-ci<=?)361(define string-ci>=?)362363(define string)364(define string-append)365366;; Complex numbers367(define make-rectangular)368(define make-polar)369(define real-part)370(define imag-part)371(define angle)372(define magnitude)373374;; Rational numbers375(define numerator)376(define denominator)377(define inexact->exact)378(define (exact->inexact x)379 (##core#inline_allocate ("C_a_i_exact_to_inexact" 12) x))380381;; Numerical operations382(define (abs x) (##core#inline_allocate ("C_s_a_i_abs" 7) x))383(define + (##core#primitive "C_plus"))384(define - (##core#primitive "C_minus"))385(define * (##core#primitive "C_times"))386(define /)387(define floor)388(define ceiling)389(define truncate)390(define round)391(define rationalize)392393(define (quotient a b) (##core#inline_allocate ("C_s_a_i_quotient" 5) a b))394(define (remainder a b) (##core#inline_allocate ("C_s_a_i_remainder" 5) a b))395(define (modulo a b) (##core#inline_allocate ("C_s_a_i_modulo" 5) a b))396397(define (even? n) (##core#inline "C_i_evenp" n))398(define (odd? n) (##core#inline "C_i_oddp" n))399400(define max)401(define min)402(define exp)403(define log)404(define sin)405(define cos)406(define tan)407(define asin)408(define acos)409(define atan)410411(define sqrt)412(define expt)413(define gcd)414(define lcm)415416(define = (##core#primitive "C_nequalp"))417(define > (##core#primitive "C_greaterp"))418(define < (##core#primitive "C_lessp"))419(define >= (##core#primitive "C_greater_or_equal_p"))420(define <= (##core#primitive "C_less_or_equal_p"))421(define (number? x) (##core#inline "C_i_numberp" x))422(define complex? number?)423(define (real? x) (##core#inline "C_i_realp" x))424(define (rational? n) (##core#inline "C_i_rationalp" n))425(define (integer? x) (##core#inline "C_i_integerp" x))426(define (exact? x) (##core#inline "C_i_exactp" x))427(define (inexact? x) (##core#inline "C_i_inexactp" x))428(define (zero? n) (##core#inline "C_i_zerop" n))429(define (positive? n) (##core#inline "C_i_positivep" n))430(define (negative? n) (##core#inline "C_i_negativep" n))431432(define number->string (##core#primitive "C_number_to_string"))433(define string->number)434435;;; Symbols:436437(define (symbol? x) (##core#inline "C_i_symbolp" x))438(define symbol->string)439(define string->symbol)440441;;; Vectors:442443(define (vector? x) (##core#inline "C_i_vectorp" x))444(define (vector-length v) (##core#inline "C_i_vector_length" v))445(define (vector-ref v i) (##core#inline "C_i_vector_ref" v i))446(define (vector-set! v i x) (##core#inline "C_i_vector_set" v i x))447(define make-vector)448(define list->vector)449(define vector->list)450(define vector)451(define vector-fill!)452453;;; Characters:454455(define (char? x) (##core#inline "C_charp" x))456(define (char->integer c)457 (##sys#check-char c 'char->integer)458 (##core#inline "C_fix" (##core#inline "C_character_code" c)) )459460(define (integer->char n)461 (##sys#check-fixnum n 'integer->char)462 (##core#inline "C_make_character" (##core#inline "C_unfix" n)) )463464(define (char=? c1 c2) (##core#inline "C_i_char_equalp" c1 c2))465(define (char>? c1 c2) (##core#inline "C_i_char_greaterp" c1 c2))466(define (char<? c1 c2) (##core#inline "C_i_char_lessp" c1 c2))467(define (char>=? c1 c2) (##core#inline "C_i_char_greater_or_equal_p" c1 c2))468(define (char<=? c1 c2) (##core#inline "C_i_char_less_or_equal_p" c1 c2))469470(define (char-upcase c)471 (##sys#check-char c 'char-upcase)472 (##core#inline "C_u_i_char_upcase" c))473474(define (char-downcase c)475 (##sys#check-char c 'char-downcase)476 (##core#inline "C_u_i_char_downcase" c))477478(define char-ci=?)479(define char-ci>?)480(define char-ci<?)481(define char-ci>=?)482(define char-ci<=?)483484(define (char-upper-case? c)485 (##sys#check-char c 'char-upper-case?)486 (##core#inline "C_u_i_char_upper_casep" c) )487488(define (char-lower-case? c)489 (##sys#check-char c 'char-lower-case?)490 (##core#inline "C_u_i_char_lower_casep" c) )491492(define (char-numeric? c)493 (##sys#check-char c 'char-numeric?)494 (##core#inline "C_u_i_char_numericp" c) )495496(define (char-whitespace? c)497 (##sys#check-char c 'char-whitespace?)498 (##core#inline "C_u_i_char_whitespacep" c) )499500(define (char-alphabetic? c)501 (##sys#check-char c 'char-alphabetic?)502 (##core#inline "C_u_i_char_alphabeticp" c) )503504;;; Procedures:505506(define (procedure? x) (##core#inline "C_i_closurep" x))507(define apply (##core#primitive "C_apply"))508(define values (##core#primitive "C_values"))509(define call-with-values (##core#primitive "C_call_with_values"))510(define call-with-current-continuation)511512;;; Ports:513514(define (input-port? x)515 (and (##core#inline "C_blockp" x)516 (##core#inline "C_input_portp" x)))517518(define (output-port? x)519 (and (##core#inline "C_blockp" x)520 (##core#inline "C_output_portp" x)))521522(define current-input-port)523(define current-output-port)524(define open-input-file)525(define open-output-file)526(define close-input-port)527(define close-output-port)528(define call-with-input-file)529(define call-with-output-file)530(define with-input-from-file)531(define with-output-to-file)532533;;; Input:534535(define (eof-object? x) (##core#inline "C_eofp" x))536(define char-ready?)537(define read-char)538(define peek-char)539(define read)540541;;; Output:542543(define write-char)544(define newline)545(define write)546(define display)547548;;; Evaluation environments:549550;; All of the stuff below is overwritten with their "real"551;; implementations by chicken.eval (see eval.scm)552553(define (eval x . env)554 (##sys#error 'eval "`eval' is not defined - the `eval' unit was probably not linked with this executable"))555556(define (interaction-environment)557 (##sys#error 'interaction-environment "`interaction-environment' is not defined - the `eval' unit was probably not linked with this executable"))558559(define (scheme-report-environment n)560 (##sys#error 'scheme-report-environment "`scheme-report-environment' is not defined - the `eval' unit was probably not linked with this executable"))561562(define (null-environment)563 (##sys#error 'null-environment "`null-environment' is not defined - the `eval' unit was probably not linked with this executable"))564565(define (load filename . evaluator)566 (##sys#error 'load "`load' is not defined - the `eval' unit was probably not linked with this executable"))567568;; Other stuff:569570(define force)571(define for-each)572(define map)573(define dynamic-wind)574575) ; scheme576577(import scheme)578579;; Pre-declaration of chicken.base, so it can be used later on. Much580;; like the "scheme" module, most declarations will be set! further581;; down in this file, mostly to avoid a cyclic dependency on itself.582;; The full definition (with macros) is in its own import library.583(module chicken.base584 (;; [syntax] and-let* case-lambda cut cute declare define-constant585 ;; define-inline define-record define-record-type586 ;; define-record-printer define-values delay-force fluid-let include587 ;; include-relative let-optionals let-values let*-values letrec*588 ;; letrec-values nth-value optional parameterize rec receive589 ;; require-library require-extension set!-values syntax unless when590 bignum? flonum? fixnum? ratnum? cplxnum? finite? infinite? nan?591 exact-integer? exact-integer-sqrt exact-integer-nth-root592593 port? port-closed? input-port-open? output-port-open? flush-output594 get-output-string open-input-string open-output-string595 get-call-chain print print* add1 sub1 sleep call/cc596 current-error-port error void gensym print-call-chain597 make-promise promise? char-name enable-warnings598 equal=? finite? foldl foldr getter-with-setter make-parameter599 notice procedure-information setter signum string->uninterned-symbol600 subvector symbol-append vector-copy! vector-resize601 warning quotient&remainder quotient&modulo602 record-printer set-record-printer!603 alist-ref alist-update alist-update! rassoc atom? butlast chop604 compress flatten intersperse join list-of? tail? constantly605 complement compose conjoin disjoin each flip identity o606607 case-sensitive keyword-style parentheses-synonyms symbol-escape608609 on-exit exit exit-handler implicit-exit-handler emergency-exit610 bwp-object? weak-cons weak-pair?)611612(import scheme chicken.internal.syntax)613614(define (fixnum? x) (##core#inline "C_fixnump" x))615(define (flonum? x) (##core#inline "C_i_flonump" x))616(define (bignum? x) (##core#inline "C_i_bignump" x))617(define (ratnum? x) (##core#inline "C_i_ratnump" x))618(define (cplxnum? x) (##core#inline "C_i_cplxnump" x))619(define (exact-integer? x) (##core#inline "C_i_exact_integerp" x))620(define exact-integer-sqrt)621(define exact-integer-nth-root)622623(define quotient&remainder (##core#primitive "C_quotient_and_remainder"))624;; Modulo's sign follows y (whereas remainder's sign follows x)625;; Inlining this is not much use: quotient&remainder is primitive626(define (quotient&modulo x y)627 (call-with-values (lambda () (quotient&remainder x y))628 (lambda (div rem)629 (if (positive? y)630 (if (negative? rem)631 (values div (+ rem y))632 (values div rem))633 (if (positive? rem)634 (values div (+ rem y))635 (values div rem))))))636637638(define (finite? x) (##core#inline "C_i_finitep" x))639(define (infinite? x) (##core#inline "C_i_infinitep" x))640(define (nan? x) (##core#inline "C_i_nanp" x))641642(define signum (##core#primitive "C_signum"))643644(define equal=?)645(define get-call-chain)646(define print-call-chain)647(define print)648(define print*)649(define (add1 n) (+ n 1))650(define (sub1 n) (- n 1))651(define current-error-port)652653(define (error . args)654 (if (pair? args)655 (apply ##sys#signal-hook #:error args)656 (##sys#signal-hook #:error #f)))657658(define (void . _) (##core#undefined))659660(define sleep)661662(define call/cc)663(define char-name)664(define enable-warnings)665; (define enable-notices)???666(define getter-with-setter)667(define make-parameter)668(define procedure-information)669(define setter)670(define string->uninterned-symbol)671(define record-printer)672(define set-record-printer!)673674(define gensym)675676(define vector-copy!)677(define subvector)678(define vector-resize)679680(define symbol-append)681(define warning)682(define notice)683684(define port?)685(define port-closed?)686(define input-port-open?)687(define output-port-open?)688(define get-output-string)689(define open-input-string)690(define open-output-string)691(define flush-output)692693;;; Promises:694695(define (promise? x)696 (##sys#structure? x 'promise))697698(define (##sys#make-promise proc)699 (##sys#make-structure 'promise proc))700701(define (make-promise obj)702 (if (promise? obj) obj703 (##sys#make-promise (lambda () obj))))704705;;; fast folds with correct argument order706707(define (foldl f z lst)708 (##sys#check-list lst 'foldl)709 (let loop ((lst lst) (z z))710 (if (not (pair? lst))711 z712 (loop (##sys#slot lst 1) (f z (##sys#slot lst 0))))))713714(define (foldr f z lst)715 (##sys#check-list lst 'foldr)716 (let loop ((lst lst))717 (if (not (pair? lst))718 z719 (f (##sys#slot lst 0) (loop (##sys#slot lst 1))))))720721;;; Exit:722723(define implicit-exit-handler)724(define exit-handler)725726(define chicken.base#cleanup-tasks '())727728(define (on-exit thunk)729 (set! cleanup-tasks (cons thunk chicken.base#cleanup-tasks)))730731(define (exit #!optional (code 0))732 ((exit-handler) code))733734(define (emergency-exit #!optional (code 0))735 (##sys#check-fixnum code 'emergency-exit)736 (##core#inline "C_exit_runtime" code))737738;;; Parameters:739740(define case-sensitive)741(define keyword-style)742(define parentheses-synonyms)743(define symbol-escape)744745;;; Combinators:746747(define (identity x) x)748749(define (conjoin . preds)750 (lambda (x)751 (let loop ((preds preds))752 (or (null? preds)753 (and ((##sys#slot preds 0) x)754 (loop (##sys#slot preds 1)) ) ) ) ) )755756(define (disjoin . preds)757 (lambda (x)758 (let loop ((preds preds))759 (and (not (null? preds))760 (or ((##sys#slot preds 0) x)761 (loop (##sys#slot preds 1)) ) ) ) ) )762763(define (constantly . xs)764 (if (eq? 1 (length xs))765 (let ((x (car xs)))766 (lambda _ x) )767 (lambda _ (apply values xs)) ) )768769(define (flip proc) (lambda (x y) (proc y x)))770771(define complement772 (lambda (p)773 (lambda args (not (apply p args))) ) )774775(define (compose . fns)776 (define (rec f0 . fns)777 (if (null? fns)778 f0779 (lambda args780 (call-with-values781 (lambda () (apply (apply rec fns) args))782 f0) ) ) )783 (if (null? fns)784 values785 (apply rec fns) ) )786787(define (o . fns)788 (if (null? fns)789 identity790 (let loop ((fns fns))791 (let ((h (##sys#slot fns 0))792 (t (##sys#slot fns 1)) )793 (if (null? t)794 h795 (lambda (x) (h ((loop t) x))))))))796797(define (list-of? pred)798 (lambda (lst)799 (let loop ((lst lst))800 (cond ((null? lst) #t)801 ((not (pair? lst)) #f)802 ((pred (##sys#slot lst 0)) (loop (##sys#slot lst 1)))803 (else #f) ) ) ) )804805(define (each . procs)806 (cond ((null? procs) (lambda _ (void)))807 ((null? (##sys#slot procs 1)) (##sys#slot procs 0))808 (else809 (lambda args810 (let loop ((procs procs))811 (let ((h (##sys#slot procs 0))812 (t (##sys#slot procs 1)) )813 (if (null? t)814 (apply h args)815 (begin816 (apply h args)817 (loop t) ) ) ) ) ) ) ) )818819820;;; Weak pairs:821(define (bwp-object? x) (##core#inline "C_bwpp" x))822(define (weak-cons x y) (##core#inline_allocate ("C_a_i_weak_cons" 3) x y))823(define (weak-pair? x) (##core#inline "C_i_weak_pairp" x))824825;;; List operators:826827(define (atom? x) (##core#inline "C_i_not_pair_p" x))828829(define (tail? x y)830 (##sys#check-list y 'tail?)831 (let loop ((y y))832 (cond ((##core#inline "C_eqp" x y) #t)833 ((and (##core#inline "C_blockp" y)834 (##core#inline "C_pairp" y))835 (loop (##sys#slot y 1)))836 (else #f))))837838(define intersperse839 (lambda (lst x)840 (let loop ((ns lst))841 (if (##core#inline "C_eqp" ns '())842 ns843 (let ((tail (cdr ns)))844 (if (##core#inline "C_eqp" tail '())845 ns846 (cons (##sys#slot ns 0) (cons x (loop tail))) ) ) ) ) ) )847848(define (butlast lst)849 (##sys#check-pair lst 'butlast)850 (let loop ((lst lst))851 (let ((next (##sys#slot lst 1)))852 (if (and (##core#inline "C_blockp" next) (##core#inline "C_pairp" next))853 (cons (##sys#slot lst 0) (loop next))854 '() ) ) ) )855856(define (flatten . lists0)857 (let loop ((lists lists0) (rest '()))858 (cond ((null? lists) rest)859 (else860 (let ((head (##sys#slot lists 0))861 (tail (##sys#slot lists 1)) )862 (if (list? head)863 (loop head (loop tail rest))864 (cons head (loop tail rest)) ) ) ) ) ) )865866(define chop)867868(define (join lsts . lst)869 (let ((lst (if (pair? lst) (car lst) '())))870 (##sys#check-list lst 'join)871 (let loop ((lsts lsts))872 (cond ((null? lsts) '())873 ((not (pair? lsts))874 (##sys#error-not-a-proper-list lsts) )875 (else876 (let ((l (##sys#slot lsts 0))877 (r (##sys#slot lsts 1)) )878 (if (null? r)879 l880 (##sys#append l lst (loop r)) ) ) ) ) ) ) )881882(define compress883 (lambda (blst lst)884 (let ((msg "bad argument type - not a proper list"))885 (##sys#check-list lst 'compress)886 (let loop ((blst blst) (lst lst))887 (cond ((null? blst) '())888 ((not (pair? blst))889 (##sys#signal-hook #:type-error 'compress msg blst) )890 ((not (pair? lst))891 (##sys#signal-hook #:type-error 'compress msg lst) )892 ((##sys#slot blst 0)893 (cons (##sys#slot lst 0) (loop (##sys#slot blst 1) (##sys#slot lst 1))))894 (else (loop (##sys#slot blst 1) (##sys#slot lst 1))) ) ) ) ) )895896897;;; Alists:898899(define (alist-update! x y lst #!optional (cmp eqv?))900 (let* ((aq (cond ((eq? eq? cmp) assq)901 ((eq? eqv? cmp) assv)902 ((eq? equal? cmp) assoc)903 (else904 (lambda (x lst)905 (let loop ((lst lst))906 (and (pair? lst)907 (let ((a (##sys#slot lst 0)))908 (if (and (pair? a) (cmp x (##sys#slot a 0)))909 a910 (loop (##sys#slot lst 1)) ) ) ) ) ) ) ) )911 (item (aq x lst)) )912 (if item913 (begin914 (##sys#setslot item 1 y)915 lst)916 (cons (cons x y) lst) ) ) )917918(define (alist-update k v lst #!optional (cmp eqv?))919 (let loop ((lst lst))920 (cond ((null? lst)921 (list (cons k v)))922 ((not (pair? lst))923 (error 'alist-update "bad argument type" lst))924 (else925 (let ((a (##sys#slot lst 0)))926 (cond ((not (pair? a))927 (error 'alist-update "bad argument type" a))928 ((cmp k (##sys#slot a 0))929 (cons (cons k v) (##sys#slot lst 1)))930 (else931 (cons (cons (##sys#slot a 0) (##sys#slot a 1))932 (loop (##sys#slot lst 1))))))))))933934(define (alist-ref x lst #!optional (cmp eqv?) (default #f))935 (let* ((aq (cond ((eq? eq? cmp) assq)936 ((eq? eqv? cmp) assv)937 ((eq? equal? cmp) assoc)938 (else939 (lambda (x lst)940 (let loop ((lst lst))941 (cond942 ((null? lst) #f)943 ((pair? lst)944 (let ((a (##sys#slot lst 0)))945 (##sys#check-pair a 'alist-ref)946 (if (cmp x (##sys#slot a 0))947 a948 (loop (##sys#slot lst 1)) ) ))949 (else (error 'alist-ref "bad argument type" lst)) ) ) ) ) ) )950 (item (aq x lst)) )951 (if item952 (##sys#slot item 1)953 default) ) )954955;; TODO: Make inlineable in C without "tst", to be more like assoc?956(define (rassoc x lst . tst)957 (##sys#check-list lst 'rassoc)958 (let ((tst (if (pair? tst) (car tst) eqv?)))959 (let loop ((l lst))960 (and (pair? l)961 (let ((a (##sys#slot l 0)))962 (##sys#check-pair a 'rassoc)963 (if (tst x (##sys#slot a 1))964 a965 (loop (##sys#slot l 1)) ) ) ) ) ) )966967) ; chicken.base968969(import chicken.base)970971(define-constant char-name-table-size 37)972(define-constant output-string-initial-size 256)973(define-constant read-line-buffer-initial-size 1024)974(define-constant default-parameter-vector-size 16)975(define maximal-string-length (foreign-value "C_HEADER_SIZE_MASK" unsigned-long))976977;;; Fixnum arithmetic:978979(module chicken.fixnum *980(import scheme)981(import chicken.foreign)982983(define most-positive-fixnum (foreign-value "C_MOST_POSITIVE_FIXNUM" int))984(define most-negative-fixnum (foreign-value "C_MOST_NEGATIVE_FIXNUM" int))985(define fixnum-bits (foreign-value "(C_WORD_SIZE - 1)" int))986(define fixnum-precision (foreign-value "(C_WORD_SIZE - (1 + 1))" int))987988(define (fx+ x y) (##core#inline "C_fixnum_plus" x y))989(define (fx- x y) (##core#inline "C_fixnum_difference" x y))990(define (fx* x y) (##core#inline "C_fixnum_times" x y))991(define (fx= x y) (eq? x y))992(define (fx> x y) (##core#inline "C_fixnum_greaterp" x y))993(define (fx< x y) (##core#inline "C_fixnum_lessp" x y))994(define (fx>= x y) (##core#inline "C_fixnum_greater_or_equal_p" x y))995(define (fx<= x y) (##core#inline "C_fixnum_less_or_equal_p" x y))996(define (fxmin x y) (##core#inline "C_i_fixnum_min" x y))997(define (fxmax x y) (##core#inline "C_i_fixnum_max" x y))998(define (fxneg x) (##core#inline "C_fixnum_negate" x))999(define (fxand x y) (##core#inline "C_fixnum_and" x y))1000(define (fxior x y) (##core#inline "C_fixnum_or" x y))1001(define (fxxor x y) (##core#inline "C_fixnum_xor" x y))1002(define (fxnot x) (##core#inline "C_fixnum_not" x))1003(define (fxshl x y) (##core#inline "C_fixnum_shift_left" x y))1004(define (fxshr x y) (##core#inline "C_fixnum_shift_right" x y))1005(define (fxodd? x) (##core#inline "C_i_fixnumoddp" x))1006(define (fxeven? x) (##core#inline "C_i_fixnumevenp" x))1007(define (fxlen x) (##core#inline "C_i_fixnum_length" x))1008(define (fx/ x y) (##core#inline "C_fixnum_divide" x y) )1009(define (fxgcd x y) (##core#inline "C_i_fixnum_gcd" x y))1010(define (fxmod x y) (##core#inline "C_fixnum_modulo" x y) )1011(define (fxrem x y) (##core#inline "C_i_fixnum_remainder_checked" x y) )10121013;; Overflow-detecting versions of some of the above1014(define (fx+? x y) (##core#inline "C_i_o_fixnum_plus" x y) )1015(define (fx-? x y) (##core#inline "C_i_o_fixnum_difference" x y) )1016(define (fx*? x y) (##core#inline "C_i_o_fixnum_times" x y) )1017(define (fx/? x y) (##core#inline "C_i_o_fixnum_quotient" x y))10181019) ; chicken.fixnum10201021(import chicken.fixnum)102210231024;;; System routines:10251026(define (##sys#debug-mode?) (##core#inline "C_i_debug_modep"))10271028(define ##sys#warnings-enabled #t)1029(define ##sys#notices-enabled (##sys#debug-mode?))10301031(set! chicken.base#warning1032 (lambda (msg . args)1033 (when ##sys#warnings-enabled1034 (apply ##sys#signal-hook #:warning msg args))))10351036(set! chicken.base#notice1037 (lambda (msg . args)1038 (when (and ##sys#notices-enabled1039 ##sys#warnings-enabled)1040 (apply ##sys#signal-hook #:notice msg args))))10411042(set! chicken.base#enable-warnings1043 (lambda bool1044 (if (pair? bool)1045 (set! ##sys#warnings-enabled (car bool))1046 ##sys#warnings-enabled)))10471048(define ##sys#error error)1049(define ##sys#warn warning)1050(define ##sys#notice notice)10511052(define (##sys#error/errno err . args)1053 (if (pair? args)1054 (apply ##sys#signal-hook/errno #:error err #f args)1055 (##sys#signal-hook/errno #:error err #f)))10561057(define-foreign-variable strerror c-string "strerror(errno)")10581059(define ##sys#gc (##core#primitive "C_gc"))1060(define (##sys#setslot x i y) (##core#inline "C_i_setslot" x i y))1061(define (##sys#setislot x i y) (##core#inline "C_i_set_i_slot" x i y))1062(define ##sys#allocate-vector (##core#primitive "C_allocate_vector"))1063(define ##sys#make-structure (##core#primitive "C_make_structure"))1064(define ##sys#ensure-heap-reserve (##core#primitive "C_ensure_heap_reserve"))1065(define ##sys#symbol-table-info (##core#primitive "C_get_symbol_table_info"))1066(define ##sys#memory-info (##core#primitive "C_get_memory_info"))10671068(define (##sys#start-timer)1069 (##sys#gc #t)1070 (##core#inline "C_start_timer"))10711072(define (##sys#stop-timer)1073 (let ((info ((##core#primitive "C_stop_timer"))))1074 ;; Run a major GC one more time to get memory usage information in1075 ;; case there was no major GC while the timer was running1076 (##sys#gc #t)1077 (##sys#setslot info 6 (##sys#slot ((##core#primitive "C_stop_timer")) 6))1078 info))10791080(define (##sys#immediate? x) (not (##core#inline "C_blockp" x)))1081(define (##sys#message str) (##core#inline "C_message" str))1082(define (##sys#byte x i) (##core#inline "C_subbyte" x i))1083(define (##sys#setbyte x i n) (##core#inline "C_setbyte" x i n))1084(define ##sys#void void)1085(define ##sys#undefined-value (##core#undefined))1086(define (##sys#halt msg) (##core#inline "C_halt" msg))1087(define ##sys#become! (##core#primitive "C_become"))1088(define (##sys#block-ref x i) (##core#inline "C_i_block_ref" x i))1089(define ##sys#apply-values (##core#primitive "C_apply_values"))1090(define ##sys#copy-closure (##core#primitive "C_copy_closure"))10911092(define (##sys#block-set! x i y)1093 (when (or (not (##core#inline "C_blockp" x))1094 (and (##core#inline "C_specialp" x) (fx= i 0))1095 (##core#inline "C_byteblockp" x) )1096 (##sys#signal-hook '#:type-error '##sys#block-set! "slot not accessible" x) )1097 (##sys#check-range i 0 (##sys#size x) '##sys#block-set!)1098 (##sys#setslot x i y) )10991100(module chicken.time1101 ;; NOTE: We don't emit the import lib. Due to syntax exports, it has1102 ;; to be a hardcoded primitive module.1103 ;;1104 ;; [syntax] time1105 (cpu-time1106 current-milliseconds ; DEPRECATED1107 current-process-milliseconds current-seconds)11081109(import scheme)1110(import (only chicken.module reexport))11111112;; Deprecated1113(define (current-milliseconds)1114 (##core#inline_allocate ("C_a_i_current_milliseconds" 7) #f))11151116(define (current-process-milliseconds)1117 (##core#inline_allocate ("C_a_i_current_process_milliseconds" 7) #f))11181119(define (current-seconds)1120 (##core#inline_allocate ("C_a_get_current_seconds" 7) #f))11211122(define cpu-time1123 (let () ;; ((buf (vector #f #f))) Disabled for now: vector is defined below!1124 (lambda ()1125 (let ((buf (vector #f #f)))1126 ;; should be thread-safe as no context-switch will occur after1127 ;; function entry and `buf' contents will have been extracted1128 ;; before `values' gets called.1129 (##core#inline_allocate ("C_a_i_cpu_time" 8) buf)1130 (values (##sys#slot buf 0) (##sys#slot buf 1)) )) ))11311132) ; chicken.time11331134(define (##sys#check-structure x y . loc)1135 (if (pair? loc)1136 (##core#inline "C_i_check_structure_2" x y (car loc))1137 (##core#inline "C_i_check_structure" x y) ) )11381139(define (##sys#check-blob x . loc)1140 (if (pair? loc)1141 (##core#inline "C_i_check_bytevector_2" x (car loc))1142 (##core#inline "C_i_check_bytevector" x) ) )11431144(define ##sys#check-byte-vector ##sys#check-blob)11451146(define (##sys#check-pair x . loc)1147 (if (pair? loc)1148 (##core#inline "C_i_check_pair_2" x (car loc))1149 (##core#inline "C_i_check_pair" x) ) )11501151(define (##sys#check-list x . loc)1152 (if (pair? loc)1153 (##core#inline "C_i_check_list_2" x (car loc))1154 (##core#inline "C_i_check_list" x) ) )11551156(define (##sys#check-string x . loc)1157 (if (pair? loc)1158 (##core#inline "C_i_check_string_2" x (car loc))1159 (##core#inline "C_i_check_string" x) ) )11601161(define (##sys#check-number x . loc)1162 (if (pair? loc)1163 (##core#inline "C_i_check_number_2" x (car loc))1164 (##core#inline "C_i_check_number" x) ) )11651166(define (##sys#check-fixnum x . loc)1167 (if (pair? loc)1168 (##core#inline "C_i_check_fixnum_2" x (car loc))1169 (##core#inline "C_i_check_fixnum" x) ) )11701171(define (##sys#check-exact x . loc) ;; DEPRECATED1172 (if (pair? loc)1173 (##core#inline "C_i_check_exact_2" x (car loc))1174 (##core#inline "C_i_check_exact" x) ) )11751176(define (##sys#check-inexact x . loc)1177 (if (pair? loc)1178 (##core#inline "C_i_check_inexact_2" x (car loc))1179 (##core#inline "C_i_check_inexact" x) ) )11801181(define (##sys#check-symbol x . loc)1182 (if (pair? loc)1183 (##core#inline "C_i_check_symbol_2" x (car loc))1184 (##core#inline "C_i_check_symbol" x) ) )11851186(define (##sys#check-keyword x . loc)1187 (if (pair? loc)1188 (##core#inline "C_i_check_keyword_2" x (car loc))1189 (##core#inline "C_i_check_keyword" x) ) )11901191(define (##sys#check-vector x . loc)1192 (if (pair? loc)1193 (##core#inline "C_i_check_vector_2" x (car loc))1194 (##core#inline "C_i_check_vector" x) ) )11951196(define (##sys#check-char x . loc)1197 (if (pair? loc)1198 (##core#inline "C_i_check_char_2" x (car loc))1199 (##core#inline "C_i_check_char" x) ) )12001201(define (##sys#check-boolean x . loc)1202 (if (pair? loc)1203 (##core#inline "C_i_check_boolean_2" x (car loc))1204 (##core#inline "C_i_check_boolean" x) ) )12051206(define (##sys#check-locative x . loc)1207 (if (pair? loc)1208 (##core#inline "C_i_check_locative_2" x (car loc))1209 (##core#inline "C_i_check_locative" x) ) )12101211(define (##sys#check-integer x . loc)1212 (unless (##core#inline "C_i_integerp" x)1213 (##sys#error-bad-integer x (and (pair? loc) (car loc))) ) )12141215(define (##sys#check-exact-integer x . loc)1216 (unless (##core#inline "C_i_exact_integerp" x)1217 (##sys#error-bad-exact-integer x (and (pair? loc) (car loc))) ) )12181219(define (##sys#check-exact-uinteger x . loc)1220 (when (or (not (##core#inline "C_i_exact_integerp" x))1221 (##core#inline "C_i_integer_negativep" x))1222 (##sys#error-bad-exact-uinteger x (and (pair? loc) (car loc))) ) )12231224(define (##sys#check-real x . loc)1225 (unless (##core#inline "C_i_realp" x)1226 (##sys#error-bad-real x (and (pair? loc) (car loc))) ) )12271228(define (##sys#check-range i from to . loc)1229 (##sys#check-fixnum i loc)1230 (unless (and (fx<= from i) (fx< i to))1231 (##sys#error-hook1232 (foreign-value "C_OUT_OF_RANGE_ERROR" int)1233 (and (pair? loc) (car loc)) i from to) ) )12341235(define (##sys#check-special ptr . loc)1236 (unless (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr))1237 (##sys#signal-hook #:type-error (and (pair? loc) (car loc)) "bad argument type - not a pointer-like object" ptr) ) )12381239(define (##sys#check-closure x . loc)1240 (if (pair? loc)1241 (##core#inline "C_i_check_closure_2" x (car loc))1242 (##core#inline "C_i_check_closure" x) ) )12431244(set! scheme#force1245 (lambda (obj)1246 (if (##sys#structure? obj 'promise)1247 (let lp ((promise obj)1248 (forward #f))1249 (let ((val (##sys#slot promise 1)))1250 (cond ((null? val) (##sys#values))1251 ((pair? val) (apply ##sys#values val))1252 ((procedure? val)1253 (when forward (##sys#setslot forward 1 promise))1254 (let ((results (##sys#call-with-values val ##sys#list)))1255 (cond ((not (procedure? (##sys#slot promise 1)))1256 (lp promise forward)) ; in case of reentrance1257 ((and (not (null? results)) (null? (cdr results))1258 (##sys#structure? (##sys#slot results 0) 'promise))1259 (let ((result0 (##sys#slot results 0)))1260 (##sys#setslot promise 1 (##sys#slot result0 1))1261 (lp promise result0)))1262 (else1263 (##sys#setslot promise 1 results)1264 (apply ##sys#values results)))))1265 ((##sys#structure? val 'promise)1266 (lp val forward)))))1267 obj)))126812691270;;; Dynamic Load12711272(define ##sys#dload (##core#primitive "C_dload"))1273(define ##sys#set-dlopen-flags! (##core#primitive "C_set_dlopen_flags"))12741275(define (##sys#error-not-a-proper-list arg #!optional loc)1276 (##sys#error-hook1277 (foreign-value "C_NOT_A_PROPER_LIST_ERROR" int) loc arg))12781279(define (##sys#error-bad-number arg #!optional loc)1280 (##sys#error-hook1281 (foreign-value "C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR" int) loc arg))12821283(define (##sys#error-bad-integer arg #!optional loc)1284 (##sys#error-hook1285 (foreign-value "C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR" int) loc arg))12861287(define (##sys#error-bad-exact-integer arg #!optional loc)1288 (##sys#error-hook1289 (foreign-value "C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR" int) loc arg))12901291(define (##sys#error-bad-exact-uinteger arg #!optional loc)1292 (##sys#error-hook1293 (foreign-value "C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR" int) loc arg))12941295(define (##sys#error-bad-inexact arg #!optional loc)1296 (##sys#error-hook1297 (foreign-value "C_CANT_REPRESENT_INEXACT_ERROR" int) loc arg))12981299(define (##sys#error-bad-real arg #!optional loc)1300 (##sys#error-hook1301 (foreign-value "C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR" int) loc arg))13021303(define (##sys#error-bad-base arg #!optional loc)1304 (##sys#error-hook1305 (foreign-value "C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR" int) loc arg))13061307(set! scheme#append1308 (lambda lsts1309 (if (eq? lsts '())1310 lsts1311 (let loop ((lsts lsts))1312 (if (eq? (##sys#slot lsts 1) '())1313 (##sys#slot lsts 0)1314 (let copy ((node (##sys#slot lsts 0)))1315 (cond ((eq? node '()) (loop (##sys#slot lsts 1)))1316 ((pair? node)1317 (cons (##sys#slot node 0) (copy (##sys#slot node 1))) )1318 (else1319 (##sys#error-not-a-proper-list1320 (##sys#slot lsts 0) 'append)) ) )))) ) )13211322(define (##sys#fast-reverse lst0)1323 (let loop ((lst lst0) (rest '()))1324 (if (pair? lst)1325 (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest))1326 rest)))132713281329;;; Strings:13301331(define-inline (%make-string size fill)1332 (##sys#allocate-vector size #t fill #f) )13331334(define (##sys#make-string size #!optional (fill #\space))1335 (%make-string size fill))13361337(set! scheme#make-string1338 (lambda (size . fill)1339 (##sys#check-fixnum size 'make-string)1340 (when (fx< size 0)1341 (##sys#signal-hook #:bounds-error 'make-string "size is negative" size))1342 (%make-string1343 size1344 (if (null? fill)1345 #\space1346 (let ((c (car fill)))1347 (##sys#check-char c 'make-string)1348 c ) ) ) ) )13491350(set! scheme#string->list1351 (lambda (s)1352 (##sys#check-string s 'string->list)1353 (let ((len (##sys#size s)))1354 (let loop ((i (fx- len 1)) (ls '()))1355 (if (fx< i 0)1356 ls1357 (loop (fx- i 1)1358 (cons (##core#inline "C_subchar" s i) ls)) ) ) )))13591360(define ##sys#string->list string->list)13611362(set! scheme#list->string1363 (lambda (lst0)1364 (if (not (list? lst0))1365 (##sys#error-not-a-proper-list lst0 'list->string)1366 (let* ([len (length lst0)]1367 [s (##sys#make-string len)] )1368 (do ([i 0 (fx+ i 1)]1369 [lst lst0 (##sys#slot lst 1)] )1370 ((fx>= i len) s)1371 (let ([c (##sys#slot lst 0)])1372 (##sys#check-char c 'list->string)1373 (##core#inline "C_setsubchar" s i c) ) ) ) )))13741375(define ##sys#list->string list->string)13761377;;; By Sven Hartrumpf:13781379(define (##sys#reverse-list->string l)1380 (if (list? l)1381 (let* ((n (length l))1382 (s (##sys#make-string n)))1383 (let iter ((l2 l) (n2 (fx- n 1)))1384 (cond ((fx>= n2 0)1385 (let ((c (##sys#slot l2 0)))1386 (##sys#check-char c 'reverse-list->string)1387 (##core#inline "C_setsubchar" s n2 c) )1388 (iter (##sys#slot l2 1) (fx- n2 1)) ) ) )1389 s )1390 (##sys#error-not-a-proper-list l 'reverse-list->string) ) )13911392(set! scheme#string-fill!1393 (lambda (s c)1394 (##sys#check-string s 'string-fill!)1395 (##sys#check-char c 'string-fill!)1396 (##core#inline "C_set_memory" s c (##sys#size s))1397 (##core#undefined) ))13981399(set! scheme#string-copy1400 (lambda (s)1401 (##sys#check-string s 'string-copy)1402 (let* ([len (##sys#size s)]1403 [s2 (##sys#make-string len)] )1404 (##core#inline "C_copy_memory" s2 s len)1405 s2) ) )14061407(set! scheme#substring1408 (lambda (s start . end)1409 (##sys#check-string s 'substring)1410 (##sys#check-fixnum start 'substring)1411 (let ((end (if (pair? end)1412 (let ((end (car end)))1413 (##sys#check-fixnum end 'substring)1414 end)1415 (##sys#size s) ) ) )1416 (let ((len (##sys#size s)))1417 (if (and (fx<= start end)1418 (fx>= start 0)1419 (fx<= end len) )1420 (##sys#substring s start end)1421 (##sys#error-hook1422 (foreign-value "C_OUT_OF_RANGE_ERROR" int)1423 'substring start end) ) ) )))14241425(define (##sys#substring s start end)1426 (let ([s2 (##sys#make-string (fx- end start))])1427 (##core#inline "C_substring_copy" s s2 start end 0)1428 s2 ) )14291430(letrec ((compare1431 (lambda (s1 s2 loc k)1432 (##sys#check-string s1 loc)1433 (##sys#check-string s2 loc)1434 (let ((len1 (##core#inline "C_block_size" s1))1435 (len2 (##core#inline "C_block_size" s2)) )1436 (k len1 len21437 (##core#inline "C_string_compare"1438 s11439 s21440 (if (fx< len1 len2)1441 len11442 len2) ) ) ) ) ) )1443 (set! scheme#string<? (lambda (s1 s2)1444 (compare1445 s1 s2 'string<?1446 (lambda (len1 len2 cmp)1447 (or (fx< cmp 0)1448 (and (fx< len1 len2)1449 (eq? cmp 0) ) ) ) ) ) )1450 (set! scheme#string>? (lambda (s1 s2)1451 (compare1452 s1 s2 'string>?1453 (lambda (len1 len2 cmp)1454 (or (fx> cmp 0)1455 (and (fx< len2 len1)1456 (eq? cmp 0) ) ) ) ) ) )1457 (set! scheme#string<=? (lambda (s1 s2)1458 (compare1459 s1 s2 'string<=?1460 (lambda (len1 len2 cmp)1461 (if (eq? cmp 0)1462 (fx<= len1 len2)1463 (fx< cmp 0) ) ) ) ) )1464 (set! scheme#string>=? (lambda (s1 s2)1465 (compare1466 s1 s2 'string>=?1467 (lambda (len1 len2 cmp)1468 (if (eq? cmp 0)1469 (fx>= len1 len2)1470 (fx> cmp 0) ) ) ) ) ) )14711472(letrec ((compare1473 (lambda (s1 s2 loc k)1474 (##sys#check-string s1 loc)1475 (##sys#check-string s2 loc)1476 (let ((len1 (##core#inline "C_block_size" s1))1477 (len2 (##core#inline "C_block_size" s2)) )1478 (k len1 len21479 (##core#inline "C_string_compare_case_insensitive"1480 s11481 s21482 (if (fx< len1 len2)1483 len11484 len2) ) ) ) ) ) )1485 (set! scheme#string-ci<? (lambda (s1 s2)1486 (compare1487 s1 s2 'string-ci<?1488 (lambda (len1 len2 cmp)1489 (or (fx< cmp 0)1490 (and (fx< len1 len2)1491 (eq? cmp 0) ) ) ) ) ) )1492 (set! scheme#string-ci>? (lambda (s1 s2)1493 (compare1494 s1 s2 'string-ci>?1495 (lambda (len1 len2 cmp)1496 (or (fx> cmp 0)1497 (and (fx< len2 len1)1498 (eq? cmp 0) ) ) ) ) ) )1499 (set! scheme#string-ci<=? (lambda (s1 s2)1500 (compare1501 s1 s2 'string-ci<=?1502 (lambda (len1 len2 cmp)1503 (if (eq? cmp 0)1504 (fx<= len1 len2)1505 (fx< cmp 0) ) ) ) ) )1506 (set! scheme#string-ci>=? (lambda (s1 s2)1507 (compare1508 s1 s2 'string-ci>=?1509 (lambda (len1 len2 cmp)1510 (if (eq? cmp 0)1511 (fx>= len1 len2)1512 (fx> cmp 0) ) ) ) ) ) )15131514(define (##sys#string-append x y)1515 (let* ([s1 (##sys#size x)]1516 [s2 (##sys#size y)]1517 [z (##sys#make-string (fx+ s1 s2))] )1518 (##core#inline "C_substring_copy" x z 0 s1 0)1519 (##core#inline "C_substring_copy" y z 0 s2 s1)1520 z) )15211522(set! scheme#string-append1523 (lambda all1524 (let ([snew #f])1525 (let loop ([strs all] [n 0])1526 (if (eq? strs '())1527 (set! snew (##sys#make-string n))1528 (let ([s (##sys#slot strs 0)])1529 (##sys#check-string s 'string-append)1530 (let ([len (##sys#size s)])1531 (loop (##sys#slot strs 1) (fx+ n len))1532 (##core#inline "C_substring_copy" s snew 0 len n) ) ) ) )1533 snew ) ))15341535(set! scheme#string1536 (let ([list->string list->string])1537 (lambda chars (list->string chars)) ) )15381539(define (##sys#fragments->string total fs)1540 (let ([dest (##sys#make-string total)])1541 (let loop ([fs fs] [pos 0])1542 (if (null? fs)1543 dest1544 (let* ([f (##sys#slot fs 0)]1545 [flen (##sys#size f)] )1546 (##core#inline "C_substring_copy" f dest 0 flen pos)1547 (loop (##sys#slot fs 1) (fx+ pos flen)) ) ) ) ) )15481549(set! chicken.base#chop1550 (lambda (lst n)1551 (##sys#check-fixnum n 'chop)1552 (when (fx<= n 0) (##sys#error 'chop "invalid numeric argument" n))1553 (let ((len (length lst)))1554 (let loop ((lst lst) (i len))1555 (cond ((null? lst) '())1556 ((fx< i n) (list lst))1557 (else1558 (do ((hd '() (cons (##sys#slot tl 0) hd))1559 (tl lst (##sys#slot tl 1))1560 (c n (fx- c 1)) )1561 ((fx= c 0)1562 (cons (reverse hd) (loop tl (fx- i n))) ) ) ) ) ) ) ) )15631564;;; Numeric routines:1565;; Abbreviations of paper and book titles used in comments are:1566;; [Knuth] Donald E. Knuth, "The Art of Computer Programming", Volume 21567;; [MpNT] Tiplea at al., "MpNT: A Multi-Precision Number Theory Package"1568;; [MCA] Richard P. Brent & Paul Zimmermann, "Modern Computer Arithmetic"15691570(module chicken.flonum *1571(import scheme)1572(import chicken.foreign)1573(import (only chicken.base flonum?))1574(import chicken.internal.syntax)15751576(define maximum-flonum (foreign-value "DBL_MAX" double))1577(define minimum-flonum (foreign-value "DBL_MIN" double))1578(define flonum-radix (foreign-value "FLT_RADIX" int))1579(define flonum-epsilon (foreign-value "DBL_EPSILON" double))1580(define flonum-precision (foreign-value "DBL_MANT_DIG" int))1581(define flonum-decimal-precision (foreign-value "DBL_DIG" int))1582(define flonum-maximum-exponent (foreign-value "DBL_MAX_EXP" int))1583(define flonum-minimum-exponent (foreign-value "DBL_MIN_EXP" int))1584(define flonum-maximum-decimal-exponent (foreign-value "DBL_MAX_10_EXP" int))1585(define flonum-minimum-decimal-exponent (foreign-value "DBL_MIN_10_EXP" int))15861587(define-inline (fp-check-flonum x loc)1588 (unless (flonum? x)1589 (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int) loc x) ) )15901591(define-inline (fp-check-flonums x y loc)1592 (unless (and (flonum? x) (flonum? y))1593 (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int) loc x y) ) )15941595(define (fp+ x y)1596 (fp-check-flonums x y 'fp+)1597 (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y) )15981599(define (fp- x y)1600 (fp-check-flonums x y 'fp-)1601 (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y) )16021603(define (fp* x y)1604 (fp-check-flonums x y 'fp*)1605 (##core#inline_allocate ("C_a_i_flonum_times" 4) x y) )16061607(define (fp/ x y)1608 (fp-check-flonums x y 'fp/)1609 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y) )16101611(define (fp*+ x y z)1612 (unless (and (flonum? x) (flonum? y) (flonum? z))1613 (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int)1614 'fp*+ x y z) )1615 (##core#inline_allocate ("C_a_i_flonum_multiply_add" 4) x y z) )16161617(define (fpgcd x y)1618 (fp-check-flonums x y 'fpgcd)1619 (##core#inline_allocate ("C_a_i_flonum_gcd" 4) x y))16201621(define (fp/? x y) ; undocumented1622 (fp-check-flonums x y 'fp/?)1623 (##core#inline_allocate ("C_a_i_flonum_quotient_checked" 4) x y) )16241625(define (fp= x y)1626 (fp-check-flonums x y 'fp=)1627 (##core#inline "C_flonum_equalp" x y) )16281629(define (fp> x y)1630 (fp-check-flonums x y 'fp>)1631 (##core#inline "C_flonum_greaterp" x y) )16321633(define (fp< x y)1634 (fp-check-flonums x y 'fp<)1635 (##core#inline "C_flonum_lessp" x y) )16361637(define (fp>= x y)1638 (fp-check-flonums x y 'fp>=)1639 (##core#inline "C_flonum_greater_or_equal_p" x y) )16401641(define (fp<= x y)1642 (fp-check-flonums x y 'fp<=)1643 (##core#inline "C_flonum_less_or_equal_p" x y) )16441645(define (fpneg x)1646 (fp-check-flonum x 'fpneg)1647 (##core#inline_allocate ("C_a_i_flonum_negate" 4) x) )16481649(define (fpmax x y)1650 (fp-check-flonums x y 'fpmax)1651 (##core#inline "C_i_flonum_max" x y) )16521653(define (fpmin x y)1654 (fp-check-flonums x y 'fpmin)1655 (##core#inline "C_i_flonum_min" x y) )16561657(define (fpfloor x)1658 (fp-check-flonum x 'fpfloor)1659 (##core#inline_allocate ("C_a_i_flonum_floor" 4) x))16601661(define (fptruncate x)1662 (fp-check-flonum x 'fptruncate)1663 (##core#inline_allocate ("C_a_i_flonum_truncate" 4) x))16641665(define (fpround x)1666 (fp-check-flonum x 'fpround)1667 (##core#inline_allocate ("C_a_i_flonum_round" 4) x))16681669(define (fpceiling x)1670 (fp-check-flonum x 'fpceiling)1671 (##core#inline_allocate ("C_a_i_flonum_ceiling" 4) x))16721673(define (fpsin x)1674 (fp-check-flonum x 'fpsin)1675 (##core#inline_allocate ("C_a_i_flonum_sin" 4) x))16761677(define (fpcos x)1678 (fp-check-flonum x 'fpcos)1679 (##core#inline_allocate ("C_a_i_flonum_cos" 4) x))16801681(define (fptan x)1682 (fp-check-flonum x 'fptan)1683 (##core#inline_allocate ("C_a_i_flonum_tan" 4) x))16841685(define (fpasin x)1686 (fp-check-flonum x 'fpasin)1687 (##core#inline_allocate ("C_a_i_flonum_asin" 4) x))16881689(define (fpacos x)1690 (fp-check-flonum x 'fpacos)1691 (##core#inline_allocate ("C_a_i_flonum_acos" 4) x))16921693(define (fpatan x)1694 (fp-check-flonum x 'fpatan)1695 (##core#inline_allocate ("C_a_i_flonum_atan" 4) x))16961697(define (fpatan2 x y)1698 (fp-check-flonums x y 'fpatan2)1699 (##core#inline_allocate ("C_a_i_flonum_atan2" 4) x y))17001701(define (fpsinh x)1702 (fp-check-flonum x 'fpsinh)1703 (##core#inline_allocate ("C_a_i_flonum_sinh" 4) x))17041705(define (fpcosh x)1706 (fp-check-flonum x 'fpcosh)1707 (##core#inline_allocate ("C_a_i_flonum_cosh" 4) x))17081709(define (fptanh x)1710 (fp-check-flonum x 'fptanh)1711 (##core#inline_allocate ("C_a_i_flonum_tanh" 4) x))17121713(define (fpasinh x)1714 (fp-check-flonum x 'fpasinh)1715 (##core#inline_allocate ("C_a_i_flonum_asinh" 4) x))17161717(define (fpacosh x)1718 (fp-check-flonum x 'fpacosh)1719 (##core#inline_allocate ("C_a_i_flonum_acosh" 4) x))17201721(define (fpatanh x)1722 (fp-check-flonum x 'fpatanh)1723 (##core#inline_allocate ("C_a_i_flonum_atanh" 4) x))17241725(define (fpexp x)1726 (fp-check-flonum x 'fpexp)1727 (##core#inline_allocate ("C_a_i_flonum_exp" 4) x))17281729(define (fpexpt x y)1730 (fp-check-flonums x y 'fpexpt)1731 (##core#inline_allocate ("C_a_i_flonum_expt" 4) x y))17321733(define (fplog x)1734 (fp-check-flonum x 'fplog)1735 (##core#inline_allocate ("C_a_i_flonum_log" 4) x))17361737(define (fpsqrt x)1738 (fp-check-flonum x 'fpsqrt)1739 (##core#inline_allocate ("C_a_i_flonum_sqrt" 4) x))17401741(define (fpabs x)1742 (fp-check-flonum x 'fpabs)1743 (##core#inline_allocate ("C_a_i_flonum_abs" 4) x))17441745(define (fpinteger? x)1746 (fp-check-flonum x 'fpinteger?)1747 (##core#inline "C_u_i_fpintegerp" x))17481749(define (flonum-print-precision #!optional prec)1750 (let ((prev (##core#inline "C_get_print_precision")))1751 (when prec1752 (##sys#check-fixnum prec 'flonum-print-precision)1753 (##core#inline "C_set_print_precision" prec))1754 prev)))17551756(import chicken.flonum)17571758(define-inline (integer-negate x)1759 (##core#inline_allocate ("C_s_a_u_i_integer_negate" 5) x))17601761(define ##sys#number? number?)1762(define ##sys#integer? integer?)1763(define ##sys#exact? exact?)1764(define ##sys#inexact? inexact?)17651766;;; Complex numbers17671768(define-inline (%cplxnum-real c) (##core#inline "C_u_i_cplxnum_real" c))1769(define-inline (%cplxnum-imag c) (##core#inline "C_u_i_cplxnum_imag" c))17701771(define (make-complex r i)1772 (if (or (eq? i 0) (and (##core#inline "C_i_flonump" i) (fp= i 0.0)))1773 r1774 (##core#inline_allocate ("C_a_i_cplxnum" 3)1775 (if (inexact? i) (exact->inexact r) r)1776 (if (inexact? r) (exact->inexact i) i)) ) )17771778(set! scheme#make-rectangular1779 (lambda (r i)1780 (##sys#check-real r 'make-rectangular)1781 (##sys#check-real i 'make-rectangular)1782 (make-complex r i) ))17831784(set! scheme#make-polar1785 (lambda (r phi)1786 (##sys#check-real r 'make-polar)1787 (##sys#check-real phi 'make-polar)1788 (let ((fphi (exact->inexact phi)))1789 (make-complex1790 (* r (##core#inline_allocate ("C_a_i_cos" 4) fphi))1791 (* r (##core#inline_allocate ("C_a_i_sin" 4) fphi))) ) ))17921793(set! scheme#real-part1794 (lambda (x)1795 (cond ((cplxnum? x) (%cplxnum-real x))1796 ((number? x) x)1797 (else (##sys#error-bad-number x 'real-part)) )))17981799(set! scheme#imag-part1800 (lambda (x)1801 (cond ((cplxnum? x) (%cplxnum-imag x))1802 ((##core#inline "C_i_flonump" x) 0.0)1803 ((number? x) 0)1804 (else (##sys#error-bad-number x 'imag-part)) )))18051806(set! scheme#angle1807 (lambda (n)1808 (##sys#check-number n 'angle)1809 (##core#inline_allocate ("C_a_i_atan2" 4)1810 (exact->inexact (imag-part n))1811 (exact->inexact (real-part n))) ))18121813(set! scheme#magnitude1814 (lambda (x)1815 (cond ((cplxnum? x)1816 (let ((r (%cplxnum-real x))1817 (i (%cplxnum-imag x)) )1818 (sqrt (+ (* r r) (* i i))) ))1819 ((number? x) (abs x))1820 (else (##sys#error-bad-number x 'magnitude))) ))18211822;;; Rational numbers18231824(define-inline (%ratnum-numerator r) (##core#inline "C_u_i_ratnum_num" r))1825(define-inline (%ratnum-denominator r) (##core#inline "C_u_i_ratnum_denom" r))1826(define-inline (%make-ratnum n d) (##core#inline_allocate ("C_a_i_ratnum" 3) n d))18271828(define (ratnum m n)1829 (cond1830 ((eq? n 1) m)1831 ((eq? n -1) (integer-negate m))1832 ((negative? n)1833 (%make-ratnum (integer-negate m) (integer-negate n)))1834 (else (%make-ratnum m n))))18351836(set! scheme#numerator1837 (lambda (n)1838 (cond ((exact-integer? n) n)1839 ((##core#inline "C_i_flonump" n)1840 (cond ((not (finite? n)) (##sys#error-bad-inexact n 'numerator))1841 ((##core#inline "C_u_i_fpintegerp" n) n)1842 (else (exact->inexact (numerator (inexact->exact n))))))1843 ((ratnum? n) (%ratnum-numerator n))1844 (else (##sys#signal-hook1845 #:type-error 'numerator1846 "bad argument type - not a rational number" n) ) )))18471848(set! scheme#denominator1849 (lambda (n)1850 (cond ((exact-integer? n) 1)1851 ((##core#inline "C_i_flonump" n)1852 (cond ((not (finite? n)) (##sys#error-bad-inexact n 'denominator))1853 ((##core#inline "C_u_i_fpintegerp" n) 1.0)1854 (else (exact->inexact (denominator (inexact->exact n))))))1855 ((ratnum? n) (%ratnum-denominator n))1856 (else (##sys#signal-hook1857 #:type-error 'numerator1858 "bad argument type - not a rational number" n) ) )))18591860(define (##sys#extended-signum x)1861 (cond1862 ((ratnum? x) (##core#inline "C_u_i_integer_signum" (%ratnum-numerator x)))1863 ((cplxnum? x) (make-polar 1 (angle x)))1864 (else (##sys#error-bad-number x 'signum))))18651866(define-inline (%flo->int x)1867 (##core#inline_allocate ("C_s_a_u_i_flo_to_int" 5) x))18681869(define (flonum->ratnum x)1870 ;; Try to multiply by two until we reach an integer1871 (define (float-fraction-length x)1872 (do ((x x (fp* x 2.0))1873 (i 0 (fx+ i 1)))1874 ((##core#inline "C_u_i_fpintegerp" x) i)))18751876 (define (deliver y d)1877 (let* ((q (##sys#integer-power 2 (float-fraction-length y)))1878 (scaled-y (* y (exact->inexact q))))1879 (if (finite? scaled-y) ; Shouldn't this always be true?1880 (##sys#/-2 (##sys#/-2 (%flo->int scaled-y) q) d)1881 (##sys#error-bad-inexact x 'inexact->exact))))18821883 (if (and (fp< x 1.0) ; Watch out for denormalized numbers1884 (fp> x -1.0)) ; XXX: Needs a test, it seems pointless1885 (deliver (* x (expt 2.0 flonum-precision))1886 ;; Can be bignum (is on 32-bit), so must wait until after init.1887 ;; We shouldn't need to calculate this every single time, tho..1888 (##sys#integer-power 2 flonum-precision))1889 (deliver x 1)))18901891(set! scheme#inexact->exact1892 (lambda (x)1893 (cond ((exact? x) x)1894 ((##core#inline "C_i_flonump" x)1895 (cond ((##core#inline "C_u_i_fpintegerp" x) (%flo->int x))1896 ((##core#inline "C_u_i_flonum_finitep" x) (flonum->ratnum x))1897 (else (##sys#error-bad-inexact x 'inexact->exact))))1898 ((cplxnum? x)1899 (make-complex (inexact->exact (%cplxnum-real x))1900 (inexact->exact (%cplxnum-imag x))))1901 (else (##sys#error-bad-number x 'inexact->exact)) )))19021903(define ##sys#exact->inexact exact->inexact)1904(define ##sys#inexact->exact inexact->exact)190519061907;;; Bitwise operations:19081909;; From SRFI-3319101911(module chicken.bitwise *1912(import scheme)1913(define bitwise-and (##core#primitive "C_bitwise_and"))1914(define bitwise-ior (##core#primitive "C_bitwise_ior"))1915(define bitwise-xor (##core#primitive "C_bitwise_xor"))1916(define (bitwise-not n) (##core#inline_allocate ("C_s_a_i_bitwise_not" 5) n))1917(define (bit->boolean n i) (##core#inline "C_i_bit_to_bool" n i)) ; DEPRECATED1918;; XXX NOT YET! Reintroduce at a later time. See #1385:1919;; (define (bit-set? i n) (##core#inline "C_i_bit_setp" i n))1920(define (integer-length x) (##core#inline "C_i_integer_length" x))1921(define (arithmetic-shift n m)1922 (##core#inline_allocate ("C_s_a_i_arithmetic_shift" 5) n m))19231924) ; chicken.bitwise19251926(import chicken.bitwise)19271928;;; Basic arithmetic:19291930(define-inline (%integer-gcd a b)1931 (##core#inline_allocate ("C_s_a_u_i_integer_gcd" 5) a b))19321933(set! scheme#/1934 (lambda (arg1 . args)1935 (if (null? args)1936 (##sys#/-2 1 arg1)1937 (let loop ((args (##sys#slot args 1))1938 (x (##sys#/-2 arg1 (##sys#slot args 0))))1939 (if (null? args)1940 x1941 (loop (##sys#slot args 1)1942 (##sys#/-2 x (##sys#slot args 0))) ) ) ) ))19431944(define-inline (%integer-quotient a b)1945 (##core#inline_allocate ("C_s_a_u_i_integer_quotient" 5) a b))19461947(define (##sys#/-2 x y)1948 (when (eq? y 0)1949 (##sys#error-hook (foreign-value "C_DIVISION_BY_ZERO_ERROR" int) '/ x y))1950 (cond ((and (exact-integer? x) (exact-integer? y))1951 (let ((g (%integer-gcd x y)))1952 (ratnum (%integer-quotient x g) (%integer-quotient y g))))1953 ;; Compnum *must* be checked first1954 ((or (cplxnum? x) (cplxnum? y))1955 (let* ((a (real-part x)) (b (imag-part x))1956 (c (real-part y)) (d (imag-part y))1957 (r (+ (* c c) (* d d)))1958 (x (##sys#/-2 (+ (* a c) (* b d)) r))1959 (y (##sys#/-2 (- (* b c) (* a d)) r)) )1960 (make-complex x y) ))1961 ((or (##core#inline "C_i_flonump" x) (##core#inline "C_i_flonump" y))1962 ;; This may be incorrect when one is a ratnum consisting of bignums1963 (fp/ (exact->inexact x) (exact->inexact y)))1964 ((ratnum? x)1965 (if (ratnum? y)1966 ;; a/b / c/d = a*d / b*c [generic]1967 ;; = ((a / g1) * (d / g2) * sign(a)) / abs((b / g2) * (c / g1))1968 ;; With g1 = gcd(a, c) and g2 = gcd(b, d) [Knuth, 4.5.1 ex. 4]1969 (let* ((a (%ratnum-numerator x)) (b (%ratnum-denominator x))1970 (c (%ratnum-numerator y)) (d (%ratnum-denominator y))1971 (g1 (%integer-gcd a c))1972 (g2 (%integer-gcd b d)))1973 (ratnum (* (quotient a g1) (quotient d g2))1974 (* (quotient b g2) (quotient c g1))))1975 ;; a/b / c/d = a*d / b*c [with d = 1]1976 ;; = ((a / g) * sign(a)) / abs(b * (c / g))1977 ;; With g = gcd(a, c) and c = y [Knuth, 4.5.1 ex. 4]1978 (let* ((a (%ratnum-numerator x))1979 (g (##sys#internal-gcd '/ a y))1980 (num (quotient a g))1981 (denom (* (%ratnum-denominator x) (quotient y g))))1982 (if (##core#inline "C_i_flonump" denom)1983 (##sys#/-2 num denom)1984 (ratnum num denom)))))1985 ((ratnum? y)1986 ;; a/b / c/d = a*d / b*c [with b = 1]1987 ;; = ((a / g1) * d * sign(a)) / abs(c / g1)1988 ;; With g1 = gcd(a, c) and a = x [Knuth, 4.5.1 ex. 4]1989 (let* ((c (%ratnum-numerator y))1990 (g (##sys#internal-gcd '/ x c))1991 (num (* (quotient x g) (%ratnum-denominator y)))1992 (denom (quotient c g)))1993 (if (##core#inline "C_i_flonump" denom)1994 (##sys#/-2 num denom)1995 (ratnum num denom))))1996 ((not (number? x)) (##sys#error-bad-number x '/))1997 (else (##sys#error-bad-number y '/))) )19981999(set! scheme#floor2000 (lambda (x)2001 (cond ((exact-integer? x) x)2002 ((##core#inline "C_i_flonump" x) (fpfloor x))2003 ;; (floor x) = greatest integer <= x2004 ((ratnum? x) (let* ((n (%ratnum-numerator x))2005 (q (quotient n (%ratnum-denominator x))))2006 (if (>= n 0) q (- q 1))))2007 (else (##sys#error-bad-real x 'floor)) )))20082009(set! scheme#ceiling2010 (lambda (x)2011 (cond ((exact-integer? x) x)2012 ((##core#inline "C_i_flonump" x) (fpceiling x))2013 ;; (ceiling x) = smallest integer >= x2014 ((ratnum? x) (let* ((n (%ratnum-numerator x))2015 (q (quotient n (%ratnum-denominator x))))2016 (if (>= n 0) (+ q 1) q)))2017 (else (##sys#error-bad-real x 'ceiling)) )))20182019(set! scheme#truncate2020 (lambda (x)2021 (cond ((exact-integer? x) x)2022 ((##core#inline "C_i_flonump" x) (fptruncate x))2023 ;; (rational-truncate x) = integer of largest magnitude <= (abs x)2024 ((ratnum? x) (quotient (%ratnum-numerator x)2025 (%ratnum-denominator x)))2026 (else (##sys#error-bad-real x 'truncate)) )))20272028(set! scheme#round2029 (lambda (x)2030 (cond ((exact-integer? x) x)2031 ((##core#inline "C_i_flonump" x)2032 (##core#inline_allocate ("C_a_i_flonum_round_proper" 4) x))2033 ((ratnum? x)2034 (let* ((x+1/2 (+ x (%make-ratnum 1 2)))2035 (r (floor x+1/2)))2036 (if (and (= r x+1/2) (odd? r)) (- r 1) r)))2037 (else (##sys#error-bad-real x 'round)) )))20382039(define (find-ratio-between x y)2040 (define (sr x y)2041 (let ((fx (inexact->exact (floor x)))2042 (fy (inexact->exact (floor y))))2043 (cond ((not (< fx x)) (list fx 1))2044 ((= fx fy)2045 (let ((rat (sr (##sys#/-2 1 (- y fy))2046 (##sys#/-2 1 (- x fx)))))2047 (list (+ (cadr rat) (* fx (car rat)))2048 (car rat))))2049 (else (list (+ 1 fx) 1)))))2050 (cond ((< y x) (find-ratio-between y x))2051 ((not (< x y)) (list x 1))2052 ((positive? x) (sr x y))2053 ((negative? y) (let ((rat (sr (- y) (- x))))2054 (list (- (car rat)) (cadr rat))))2055 (else '(0 1))))20562057(define (find-ratio x e) (find-ratio-between (- x e) (+ x e)))20582059(set! scheme#rationalize2060 (lambda (x e)2061 (let ((result (apply ##sys#/-2 (find-ratio x e))))2062 (if (or (inexact? x) (inexact? e))2063 (exact->inexact result)2064 result)) ))20652066(set! scheme#max2067 (lambda (x1 . xs)2068 (let loop ((i (##core#inline "C_i_flonump" x1)) (m x1) (xs xs))2069 (##sys#check-number m 'max)2070 (if (null? xs)2071 (if i (exact->inexact m) m)2072 (let ((h (##sys#slot xs 0)))2073 (loop (or i (##core#inline "C_i_flonump" h))2074 (if (> h m) h m)2075 (##sys#slot xs 1)) ) ) ) ))20762077(set! scheme#min2078 (lambda (x1 . xs)2079 (let loop ((i (##core#inline "C_i_flonump" x1)) (m x1) (xs xs))2080 (##sys#check-number m 'min)2081 (if (null? xs)2082 (if i (exact->inexact m) m)2083 (let ((h (##sys#slot xs 0)))2084 (loop (or i (##core#inline "C_i_flonump" h))2085 (if (< h m) h m)2086 (##sys#slot xs 1)) ) ) ) ))20872088(set! scheme#exp2089 (lambda (n)2090 (##sys#check-number n 'exp)2091 (if (cplxnum? n)2092 (* (##core#inline_allocate ("C_a_i_exp" 4)2093 (exact->inexact (%cplxnum-real n)))2094 (let ((p (%cplxnum-imag n)))2095 (make-complex2096 (##core#inline_allocate ("C_a_i_cos" 4) (exact->inexact p))2097 (##core#inline_allocate ("C_a_i_sin" 4) (exact->inexact p)) ) ) )2098 (##core#inline_allocate ("C_a_i_flonum_exp" 4) (exact->inexact n)) ) ))20992100(define (##sys#log-1 x) ; log_e(x)2101 (cond2102 ((eq? x 0) ; Exact zero? That's undefined2103 (##sys#signal-hook #:arithmetic-error 'log "log of exact 0 is undefined" x))2104 ;; avoid calling inexact->exact on X here (to avoid overflow?)2105 ((or (cplxnum? x) (negative? x)) ; General case2106 (+ (##sys#log-1 (magnitude x))2107 (* (make-complex 0 1) (angle x))))2108 (else ; Real number case (< already ensured the argument type is a number)2109 (##core#inline_allocate ("C_a_i_log" 4) (exact->inexact x)))))21102111(set! scheme#log2112 (lambda (a #!optional b)2113 (if b (##sys#/-2 (##sys#log-1 a) (##sys#log-1 b)) (##sys#log-1 a))))21142115(set! scheme#sin2116 (lambda (n)2117 (##sys#check-number n 'sin)2118 (if (cplxnum? n)2119 (let ((in (* +i n)))2120 (##sys#/-2 (- (exp in) (exp (- in))) +2i))2121 (##core#inline_allocate ("C_a_i_sin" 4) (exact->inexact n)) ) ))21222123(set! scheme#cos2124 (lambda (n)2125 (##sys#check-number n 'cos)2126 (if (cplxnum? n)2127 (let ((in (* +i n)))2128 (##sys#/-2 (+ (exp in) (exp (- in))) 2) )2129 (##core#inline_allocate ("C_a_i_cos" 4) (exact->inexact n)) ) ))21302131(set! scheme#tan2132 (lambda (n)2133 (##sys#check-number n 'tan)2134 (if (cplxnum? n)2135 (##sys#/-2 (sin n) (cos n))2136 (##core#inline_allocate ("C_a_i_tan" 4) (exact->inexact n)) ) ))21372138;; General case: sin^{-1}(z) = -i\ln(iz + \sqrt{1-z^2})2139(set! scheme#asin2140 (lambda (n)2141 (##sys#check-number n 'asin)2142 (cond ((and (##core#inline "C_i_flonump" n) (fp>= n -1.0) (fp<= n 1.0))2143 (##core#inline_allocate ("C_a_i_asin" 4) n))2144 ((and (##core#inline "C_fixnump" n) (fx>= n -1) (fx<= n 1))2145 (##core#inline_allocate ("C_a_i_asin" 4)2146 (##core#inline_allocate2147 ("C_a_i_fix_to_flo" 4) n)))2148 ;; General definition can return compnums2149 (else (* -i (##sys#log-12150 (+ (* +i n)2151 (##sys#sqrt/loc 'asin (- 1 (* n n))))) )) ) ))21522153;; General case:2154;; cos^{-1}(z) = 1/2\pi + i\ln(iz + \sqrt{1-z^2}) = 1/2\pi - sin^{-1}(z) = sin(1) - sin(z)2155(set! scheme#acos2156 (let ((asin1 (##core#inline_allocate ("C_a_i_asin" 4) 1)))2157 (lambda (n)2158 (##sys#check-number n 'acos)2159 (cond ((and (##core#inline "C_i_flonump" n) (fp>= n -1.0) (fp<= n 1.0))2160 (##core#inline_allocate ("C_a_i_acos" 4) n))2161 ((and (##core#inline "C_fixnump" n) (fx>= n -1) (fx<= n 1))2162 (##core#inline_allocate ("C_a_i_acos" 4)2163 (##core#inline_allocate2164 ("C_a_i_fix_to_flo" 4) n)))2165 ;; General definition can return compnums2166 (else (- asin1 (asin n)))))))21672168(set! scheme#atan2169 (lambda (n #!optional b)2170 (##sys#check-number n 'atan)2171 (cond ((cplxnum? n)2172 (if b2173 (##sys#error-bad-real n 'atan)2174 (let ((in (* +i n)))2175 (##sys#/-2 (- (##sys#log-1 (+ 1 in))2176 (##sys#log-1 (- 1 in))) +2i))))2177 (b2178 (##core#inline_allocate2179 ("C_a_i_atan2" 4) (exact->inexact n) (exact->inexact b)))2180 (else2181 (##core#inline_allocate2182 ("C_a_i_atan" 4) (exact->inexact n))) ) ))21832184;; This is "Karatsuba Square Root" as described by Paul Zimmermann,2185;; which is 3/2K(n) + O(n log n) for an input of 2n words, where K(n)2186;; is the number of operations performed by Karatsuba multiplication.2187(define (##sys#exact-integer-sqrt a)2188 ;; Because we assume a3b+a2 >= b^2/4, we must check a few edge cases:2189 (if (and (fixnum? a) (fx<= a 4))2190 (case a2191 ((0 1) (values a 0))2192 ((2) (values 1 1))2193 ((3) (values 1 2))2194 ((4) (values 2 0))2195 (else (error "this should never happen")))2196 (let*-values2197 (((len/4) (fxshr (fx+ (integer-length a) 1) 2))2198 ((len/2) (fxshl len/4 1))2199 ((s^ r^) (##sys#exact-integer-sqrt2200 (arithmetic-shift a (fxneg len/2))))2201 ((mask) (- (arithmetic-shift 1 len/4) 1))2202 ((a0) (bitwise-and a mask))2203 ((a1) (bitwise-and (arithmetic-shift a (fxneg len/4)) mask))2204 ((q u) ((##core#primitive "C_u_integer_quotient_and_remainder")2205 (+ (arithmetic-shift r^ len/4) a1)2206 (arithmetic-shift s^ 1)))2207 ((s) (+ (arithmetic-shift s^ len/4) q))2208 ((r) (+ (arithmetic-shift u len/4) (- a0 (* q q)))))2209 (if (negative? r)2210 (values (- s 1)2211 (- (+ r (arithmetic-shift s 1)) 1))2212 (values s r)))))22132214(set! chicken.base#exact-integer-sqrt2215 (lambda (x)2216 (##sys#check-exact-uinteger x 'exact-integer-sqrt)2217 (##sys#exact-integer-sqrt x)))22182219;; This procedure is so large because it tries very hard to compute2220;; exact results if at all possible.2221(define (##sys#sqrt/loc loc n)2222 (cond ((cplxnum? n) ; Must be checked before we call "negative?"2223 (let ((p (##sys#/-2 (angle n) 2))2224 (m (##core#inline_allocate ("C_a_i_sqrt" 4) (magnitude n))) )2225 (make-complex (* m (cos p)) (* m (sin p)) ) ))2226 ((negative? n)2227 (make-complex .0 (##core#inline_allocate2228 ("C_a_i_sqrt" 4) (exact->inexact (- n)))))2229 ((exact-integer? n)2230 (receive (s^2 r) (##sys#exact-integer-sqrt n)2231 (if (eq? 0 r)2232 s^22233 (##core#inline_allocate ("C_a_i_sqrt" 4) (exact->inexact n)))))2234 ((ratnum? n) ; Try to compute exact sqrt (we already know n is positive)2235 (receive (ns^2 nr) (##sys#exact-integer-sqrt (%ratnum-numerator n))2236 (if (eq? nr 0)2237 (receive (ds^2 dr)2238 (##sys#exact-integer-sqrt (%ratnum-denominator n))2239 (if (eq? dr 0)2240 (##sys#/-2 ns^2 ds^2)2241 (##sys#sqrt/loc loc (exact->inexact n))))2242 (##sys#sqrt/loc loc (exact->inexact n)))))2243 (else (##core#inline_allocate ("C_a_i_sqrt" 4) (exact->inexact n)))))22442245(set! scheme#sqrt (lambda (x) (##sys#sqrt/loc 'sqrt x)))22462247(set! chicken.base#exact-integer-nth-root2248 (lambda (k n)2249 (##sys#check-exact-uinteger k 'exact-integer-nth-root)2250 (##sys#check-exact-uinteger n 'exact-integer-nth-root)2251 (##sys#exact-integer-nth-root/loc 'exact-integer-nth-root k n)))22522253;; Generalized Newton's algorithm for positive integers, with a little help2254;; from Wikipedia ;) https://en.wikipedia.org/wiki/Nth_root_algorithm2255(define (##sys#exact-integer-nth-root/loc loc k n)2256 (if (or (eq? 0 k) (eq? 1 k) (eq? 1 n)) ; Maybe call exact-integer-sqrt on n=2?2257 (values k 0)2258 (let ((len (integer-length k)))2259 (if (< len n) ; Idea from Gambit: 2^{len-1} <= k < 2^{len}2260 (values 1 (- k 1)) ; Since x >= 2, we know x^{n} can't exist2261 ;; Set initial guess to (at least) 2^ceil(ceil(log2(k))/n)2262 (let* ((shift-amount (inexact->exact (ceiling (/ (fx+ len 1) n))))2263 (g0 (arithmetic-shift 1 shift-amount))2264 (n-1 (- n 1)))2265 (let lp ((g0 g0)2266 (g1 (quotient2267 (+ (* n-1 g0)2268 (quotient k (##sys#integer-power g0 n-1)))2269 n)))2270 (if (< g1 g0)2271 (lp g1 (quotient2272 (+ (* n-1 g1)2273 (quotient k (##sys#integer-power g1 n-1)))2274 n))2275 (values g0 (- k (##sys#integer-power g0 n))))))))))22762277(define (##sys#integer-power base e)2278 (define (square x) (* x x))2279 (if (negative? e)2280 (##sys#/-2 1 (##sys#integer-power base (integer-negate e)))2281 (let lp ((res 1) (e2 e))2282 (cond2283 ((eq? e2 0) res)2284 ((even? e2) ; recursion is faster than iteration here2285 (* res (square (lp 1 (arithmetic-shift e2 -1)))))2286 (else2287 (lp (* res base) (- e2 1)))))))22882289(set! scheme#expt2290 (lambda (a b)2291 (define (log-expt a b)2292 (exp (* b (##sys#log-1 a))))2293 (define (slow-expt a b)2294 (if (eq? 0 a)2295 (##sys#signal-hook2296 #:arithmetic-error 'expt2297 "exponent of exact 0 with complex argument is undefined" a b)2298 (exp (* b (##sys#log-1 a)))))2299 (cond ((not (number? a)) (##sys#error-bad-number a 'expt))2300 ((not (number? b)) (##sys#error-bad-number b 'expt))2301 ((and (ratnum? a) (not (inexact? b)))2302 ;; (n*d)^b = n^b * d^b = n^b * x^{-b} | x = 1/b2303 ;; Hopefully faster than integer-power2304 (* (expt (%ratnum-numerator a) b)2305 (expt (%ratnum-denominator a) (- b))))2306 ((ratnum? b)2307 ;; x^{a/b} = (x^{1/b})^a2308 (cond2309 ((exact-integer? a)2310 (if (negative? a)2311 (log-expt (exact->inexact a) (exact->inexact b))2312 (receive (ds^n r)2313 (##sys#exact-integer-nth-root/loc2314 'expt a (%ratnum-denominator b))2315 (if (eq? r 0)2316 (##sys#integer-power ds^n (%ratnum-numerator b))2317 (##core#inline_allocate ("C_a_i_flonum_expt" 4)2318 (exact->inexact a)2319 (exact->inexact b))))))2320 ((##core#inline "C_i_flonump" a)2321 (log-expt a (exact->inexact b)))2322 (else (slow-expt a b))))2323 ((or (cplxnum? b) (and (cplxnum? a) (not (integer? b))))2324 (slow-expt a b))2325 ((and (##core#inline "C_i_flonump" b)2326 (not (##core#inline "C_u_i_fpintegerp" b)))2327 (if (negative? a)2328 (log-expt (exact->inexact a) (exact->inexact b))2329 (##core#inline_allocate2330 ("C_a_i_flonum_expt" 4) (exact->inexact a) b)))2331 ((##core#inline "C_i_flonump" a)2332 (##core#inline_allocate ("C_a_i_flonum_expt" 4) a (exact->inexact b)))2333 ;; this doesn't work that well, yet...2334 ;; (XXX: What does this mean? why not? I do know this is ugly... :P)2335 (else (if (or (inexact? a) (inexact? b))2336 (exact->inexact (##sys#integer-power a (inexact->exact b)))2337 (##sys#integer-power a b)))) ))23382339;; Useful for sane error messages2340(define (##sys#internal-gcd loc a b)2341 (cond ((exact-integer? a)2342 (cond ((exact-integer? b) (%integer-gcd a b))2343 ((and (##core#inline "C_i_flonump" b)2344 (##core#inline "C_u_i_fpintegerp" b))2345 (exact->inexact (%integer-gcd a (inexact->exact b))))2346 (else (##sys#error-bad-integer b loc))))2347 ((and (##core#inline "C_i_flonump" a)2348 (##core#inline "C_u_i_fpintegerp" a))2349 (cond ((##core#inline "C_i_flonump" b)2350 (##core#inline_allocate ("C_a_i_flonum_gcd" 4) a b))2351 ((exact-integer? b)2352 (exact->inexact (%integer-gcd (inexact->exact a) b)))2353 (else (##sys#error-bad-integer b loc))))2354 (else (##sys#error-bad-integer a loc))))2355;; For compat reasons, we define this2356(define (##sys#gcd a b) (##sys#internal-gcd 'gcd a b))23572358(set! scheme#gcd2359 (lambda ns2360 (if (eq? ns '())2361 02362 (let loop ((head (##sys#slot ns 0))2363 (next (##sys#slot ns 1)))2364 (if (null? next)2365 (if (integer? head) (abs head) (##sys#error-bad-integer head 'gcd))2366 (let ((n2 (##sys#slot next 0)))2367 (loop (##sys#internal-gcd 'gcd head n2)2368 (##sys#slot next 1)) ) ) ) ) ))23692370(define (##sys#lcm x y)2371 (let ((gcd (##sys#internal-gcd 'lcm x y))) ; Ensure better error message2372 (abs (quotient (* x y) gcd) ) ) )23732374(set! scheme#lcm2375 (lambda ns2376 (if (null? ns)2377 12378 (let loop ((head (##sys#slot ns 0))2379 (next (##sys#slot ns 1)))2380 (if (null? next)2381 (if (integer? head) (abs head) (##sys#error-bad-integer head 'lcm))2382 (let* ((n2 (##sys#slot next 0))2383 (gcd (##sys#internal-gcd 'lcm head n2)))2384 (loop (quotient (* head n2) gcd)2385 (##sys#slot next 1)) ) ) ) ) ))23862387;; This simple enough idea is from2388;; http://www.numberworld.org/y-cruncher/internals/radix-conversion.html2389(define (##sys#integer->string/recursive n base expected-string-size)2390 (let*-values (((halfsize) (fxshr (fx+ expected-string-size 1) 1))2391 ((b^M/2) (##sys#integer-power base halfsize))2392 ((hi lo) ((##core#primitive "C_u_integer_quotient_and_remainder")2393 n b^M/2))2394 ((strhi) (number->string hi base))2395 ((strlo) (number->string (abs lo) base)))2396 (string-append strhi2397 ;; Fix up any leading zeroes that were stripped from strlo2398 (make-string (fx- halfsize (string-length strlo)) #\0)2399 strlo)))24002401(define ##sys#extended-number->string2402 (let ((string-append string-append))2403 (lambda (n base)2404 (cond2405 ((ratnum? n)2406 (string-append (number->string (%ratnum-numerator n) base)2407 "/"2408 (number->string (%ratnum-denominator n) base)))2409 ;; What about bases that include an "i"? That could lead to2410 ;; ambiguous results.2411 ((cplxnum? n) (let ((r (%cplxnum-real n))2412 (i (%cplxnum-imag n)) )2413 (string-append2414 (number->string r base)2415 ;; The infinities and NaN always print their sign2416 (if (and (finite? i) (positive? i)) "+" "")2417 (number->string i base) "i") ))2418 (else (##sys#error-bad-number n 'number->string))) ) ) )24192420(define ##sys#number->string number->string) ; for printer24212422;; We try to prevent memory exhaustion attacks by limiting the2423;; maximum exponent value. Perhaps this should be a parameter?2424(define-constant +maximum-allowed-exponent+ 10000)24252426;; From "Easy Accurate Reading and Writing of Floating-Point Numbers"2427;; by Aubrey Jaffer.2428(define (mantexp->dbl mant point)2429 (if (not (negative? point))2430 (exact->inexact (* mant (##sys#integer-power 10 point)))2431 (let* ((scl (##sys#integer-power 10 (abs point)))2432 (bex (fx- (fx- (integer-length mant)2433 (integer-length scl))2434 flonum-precision)))2435 (if (fx< bex 0)2436 (let* ((num (arithmetic-shift mant (fxneg bex)))2437 (quo (round-quotient num scl)))2438 (cond ((> (integer-length quo) flonum-precision)2439 ;; Too many bits of quotient; readjust2440 (set! bex (fx+ 1 bex))2441 (set! quo (round-quotient num (* scl 2)))))2442 (ldexp (exact->inexact quo) bex))2443 ;; Fall back to exact calculation in extreme cases2444 (* mant (##sys#integer-power 10 point))))))24452446(define ldexp (foreign-lambda double "ldexp" double int))24472448;; Should we export this?2449(define (round-quotient n d)2450 (let ((q (%integer-quotient n d)))2451 (if ((if (even? q) > >=) (* (abs (remainder n d)) 2) (abs d))2452 (+ q (if (eqv? (negative? n) (negative? d)) 1 -1))2453 q)))24542455;; Shorthand for readability. TODO: Replace other C_subchar calls with this2456(define-inline (%subchar s i) (##core#inline "C_subchar" s i))2457(define (##sys#string->compnum radix str offset exactness)2458 ;; Flipped when a sign is encountered (for inexact numbers only)2459 (define negative #f)2460 ;; Go inexact unless exact was requested (with #e prefix)2461 (define (go-inexact! neg?)2462 (unless (eq? exactness 'e)2463 (set! exactness 'i)2464 (set! negative (or negative neg?))))2465 (define (safe-exponent value e)2466 (and e (cond2467 ((not value) 0)2468 ((> e +maximum-allowed-exponent+)2469 (and (eq? exactness 'i)2470 (cond ((zero? value) 0.0)2471 ((> value 0.0) +inf.0)2472 (else -inf.0))))2473 ((< e (fxneg +maximum-allowed-exponent+))2474 (and (eq? exactness 'i) +0.0))2475 ((eq? exactness 'i) (mantexp->dbl value e))2476 (else (* value (##sys#integer-power 10 e))))))2477 (define (make-nan)2478 ;; Return fresh NaNs, so eqv? returns #f on two read NaNs. This2479 ;; is not mandated by the standard, but compatible with earlier2480 ;; CHICKENs and it just makes more sense.2481 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) 0.0 0.0))2482 (let* ((len (##sys#size str))2483 (0..r (integer->char (fx+ (char->integer #\0) (fx- radix 1))))2484 (a..r (integer->char (fx+ (char->integer #\a) (fx- radix 11))))2485 (A..r (integer->char (fx+ (char->integer #\A) (fx- radix 11))))2486 ;; Ugly flag which we need (note that "exactness" is mutated too!)2487 ;; Since there is (almost) no backtracking we can do this.2488 (seen-hashes? #f)2489 ;; All these procedures return #f or an object consed onto an end2490 ;; position. If the cdr is false, that's the end of the string.2491 ;; If just #f is returned, the string contains invalid number syntax.2492 (scan-digits2493 (lambda (start)2494 (let lp ((i start))2495 (if (fx= i len)2496 (and (fx> i start) (cons i #f))2497 (let ((c (%subchar str i)))2498 (if (fx<= radix 10)2499 (if (and (char>=? c #\0) (char<=? c 0..r))2500 (lp (fx+ i 1))2501 (and (fx> i start) (cons i i)))2502 (if (or (and (char>=? c #\0) (char<=? c #\9))2503 (and (char>=? c #\a) (char<=? c a..r))2504 (and (char>=? c #\A) (char<=? c A..r)))2505 (lp (fx+ i 1))2506 (and (fx> i start) (cons i i)))))))))2507 (scan-hashes2508 (lambda (start)2509 (let lp ((i start))2510 (if (fx= i len)2511 (and (fx> i start) (cons i #f))2512 (let ((c (%subchar str i)))2513 (if (eq? c #\#)2514 (lp (fx+ i 1))2515 (and (fx> i start) (cons i i))))))))2516 (scan-digits+hashes2517 (lambda (start neg? all-hashes-ok?)2518 (let* ((digits (and (not seen-hashes?) (scan-digits start)))2519 (hashes (if digits2520 (and (cdr digits) (scan-hashes (cdr digits)))2521 (and all-hashes-ok? (scan-hashes start))))2522 (end (or hashes digits)))2523 (and-let* ((end)2524 (num (##core#inline_allocate2525 ("C_s_a_i_digits_to_integer" 6)2526 str start (car end) radix neg?)))2527 (when hashes ; Eeewww. Feeling dirty yet?2528 (set! seen-hashes? #t)2529 (go-inexact! neg?))2530 (cons num (cdr end))))))2531 (scan-exponent2532 (lambda (start)2533 (and (fx< start len)2534 (let ((sign (case (%subchar str start)2535 ((#\+) 'pos) ((#\-) 'neg) (else #f))))2536 (and-let* ((start (if sign (fx+ start 1) start))2537 (end (scan-digits start)))2538 (cons (##core#inline_allocate2539 ("C_s_a_i_digits_to_integer" 6)2540 str start (car end) radix (eq? sign 'neg))2541 (cdr end)))))))2542 (scan-decimal-tail ; The part after the decimal dot2543 (lambda (start neg? decimal-head)2544 (and (fx< start len)2545 (let* ((tail (scan-digits+hashes start neg? decimal-head))2546 (next (if tail (cdr tail) start)))2547 (and (or decimal-head (not next)2548 (fx> next start)) ; Don't allow empty "."2549 (case (and next (%subchar str next))2550 ((#\e #\s #\f #\d #\l2551 #\E #\S #\F #\D #\L)2552 (and-let* (((fx> len next))2553 (ee (scan-exponent (fx+ next 1)))2554 (e (car ee))2555 (h (safe-exponent decimal-head e)))2556 (let* ((te (and tail (fx- e (fx- (cdr tail) start))))2557 (num (and tail (car tail)))2558 (t (safe-exponent num te)))2559 (cons (if t (+ h t) h) (cdr ee)))))2560 (else (let* ((last (or next len))2561 (te (and tail (fx- start last)))2562 (num (and tail (car tail)))2563 (t (safe-exponent num te))2564 (h (or decimal-head 0)))2565 (cons (if t (+ h t) h) next)))))))))2566 (scan-ureal2567 (lambda (start neg?)2568 (if (and (fx> len (fx+ start 1)) (eq? radix 10)2569 (eq? (%subchar str start) #\.))2570 (begin2571 (go-inexact! neg?)2572 (scan-decimal-tail (fx+ start 1) neg? #f))2573 (and-let* ((end (scan-digits+hashes start neg? #f)))2574 (case (and (cdr end) (%subchar str (cdr end)))2575 ((#\.)2576 (go-inexact! neg?)2577 (and (eq? radix 10)2578 (if (fx> len (fx+ (cdr end) 1))2579 (scan-decimal-tail (fx+ (cdr end) 1) neg? (car end))2580 (cons (car end) #f))))2581 ((#\e #\s #\f #\d #\l2582 #\E #\S #\F #\D #\L)2583 (go-inexact! neg?)2584 (and-let* (((eq? radix 10))2585 ((fx> len (cdr end)))2586 (ee (scan-exponent (fx+ (cdr end) 1)))2587 (num (car end))2588 (val (safe-exponent num (car ee))))2589 (cons val (cdr ee))))2590 ((#\/)2591 (set! seen-hashes? #f) ; Reset flag for denominator2592 (and-let* (((fx> len (cdr end)))2593 (d (scan-digits+hashes (fx+ (cdr end) 1) #f #f))2594 (num (car end))2595 (denom (car d)))2596 (if (not (eq? denom 0))2597 (cons (##sys#/-2 num denom) (cdr d))2598 ;; Hacky: keep around an inexact until we decide we2599 ;; *really* need exact values, then fail at the end.2600 (and (not (eq? exactness 'e))2601 (case (signum num)2602 ((-1) (cons -inf.0 (cdr d)))2603 ((0) (cons (make-nan) (cdr d)))2604 ((+1) (cons +inf.0 (cdr d))))))))2605 (else end))))))2606 (scan-real2607 (lambda (start)2608 (and (fx< start len)2609 (let* ((sign (case (%subchar str start)2610 ((#\+) 'pos) ((#\-) 'neg) (else #f)))2611 (next (if sign (fx+ start 1) start)))2612 (and (fx< next len)2613 (case (%subchar str next)2614 ((#\i #\I)2615 (or (and sign2616 (cond2617 ((fx= (fx+ next 1) len) ; [+-]i2618 (cons (if (eq? sign 'neg) -1 1) next))2619 ((and (fx<= (fx+ next 5) len)2620 (string-ci=? (substring str next (fx+ next 5)) "inf.0"))2621 (go-inexact! (eq? sign 'neg))2622 (cons (if (eq? sign 'neg) -inf.0 +inf.0)2623 (and (fx< (fx+ next 5) len)2624 (fx+ next 5))))2625 (else #f)))2626 (scan-ureal next (eq? sign 'neg))))2627 ((#\n #\N)2628 (or (and sign2629 (fx<= (fx+ next 5) len)2630 (string-ci=? (substring str next (fx+ next 5)) "nan.0")2631 (begin (go-inexact! (eq? sign 'neg))2632 (cons (make-nan)2633 (and (fx< (fx+ next 5) len)2634 (fx+ next 5)))))2635 (scan-ureal next (eq? sign 'neg))))2636 (else (scan-ureal next (eq? sign 'neg)))))))))2637 (number (and-let* ((r1 (scan-real offset)))2638 (case (and (cdr r1) (%subchar str (cdr r1)))2639 ((#f) (car r1))2640 ((#\i #\I) (and (fx= len (fx+ (cdr r1) 1))2641 (or (eq? (%subchar str offset) #\+) ; ugh2642 (eq? (%subchar str offset) #\-))2643 (make-rectangular 0 (car r1))))2644 ((#\+ #\-)2645 (set! seen-hashes? #f) ; Reset flag for imaginary part2646 (and-let* ((r2 (scan-real (cdr r1)))2647 ((cdr r2))2648 ((fx= len (fx+ (cdr r2) 1)))2649 ((or (eq? (%subchar str (cdr r2)) #\i)2650 (eq? (%subchar str (cdr r2)) #\I))))2651 (make-rectangular (car r1) (car r2))))2652 ((#\@)2653 (set! seen-hashes? #f) ; Reset flag for angle2654 (and-let* ((r2 (scan-real (fx+ (cdr r1) 1)))2655 ((not (cdr r2))))2656 (make-polar (car r1) (car r2))))2657 (else #f)))))2658 (and number (if (eq? exactness 'i)2659 (let ((r (exact->inexact number)))2660 ;; Stupid hack because flonums can represent negative zero,2661 ;; but we're coming from an exact which has no such thing.2662 (if (and negative (zero? r)) (fpneg r) r))2663 ;; Ensure we didn't encounter +inf.0 or +nan.0 with #e2664 (and (finite? number) number)))))26652666(set! scheme#string->number2667 (lambda (str #!optional (base 10))2668 (##sys#check-string str 'string->number)2669 (unless (and (##core#inline "C_fixnump" base)2670 (fx< 1 base) (fx< base 37)) ; We only have 0-9 and the alphabet!2671 (##sys#error-bad-base base 'string->number))2672 (let scan-prefix ((i 0)2673 (exness #f)2674 (radix #f)2675 (len (##sys#size str)))2676 (if (and (fx< (fx+ i 2) len) (eq? (%subchar str i) #\#))2677 (case (%subchar str (fx+ i 1))2678 ((#\i #\I) (and (not exness) (scan-prefix (fx+ i 2) 'i radix len)))2679 ((#\e #\E) (and (not exness) (scan-prefix (fx+ i 2) 'e radix len)))2680 ((#\b #\B) (and (not radix) (scan-prefix (fx+ i 2) exness 2 len)))2681 ((#\o #\O) (and (not radix) (scan-prefix (fx+ i 2) exness 8 len)))2682 ((#\d #\D) (and (not radix) (scan-prefix (fx+ i 2) exness 10 len)))2683 ((#\x #\X) (and (not radix) (scan-prefix (fx+ i 2) exness 16 len)))2684 (else #f))2685 (##sys#string->compnum (or radix base) str i exness)))))26862687(define (##sys#string->number str #!optional (radix 10) exactness)2688 (##sys#string->compnum radix str 0 exactness))26892690(define ##sys#fixnum->string (##core#primitive "C_fixnum_to_string"))2691(define ##sys#flonum->string (##core#primitive "C_flonum_to_string"))2692(define ##sys#integer->string (##core#primitive "C_integer_to_string"))2693(define ##sys#number->string number->string)26942695(set! chicken.base#equal=?2696 (lambda (x y)2697 (define (compare-slots x y start)2698 (let ((l1 (##sys#size x))2699 (l2 (##sys#size y)))2700 (and (eq? l1 l2)2701 (or (fx<= l1 start)2702 (let ((l1n (fx- l1 1)))2703 (let loop ((i start))2704 (if (fx= i l1n)2705 (walk (##sys#slot x i) (##sys#slot y i)) ; tailcall2706 (and (walk (##sys#slot x i) (##sys#slot y i))2707 (loop (fx+ i 1))))))))))2708 (define (walk x y)2709 (cond ((eq? x y))2710 ((number? x)2711 (if (number? y)2712 (= x y)2713 (eq? x y)))2714 ((not (##core#inline "C_blockp" x)) #f)2715 ((not (##core#inline "C_blockp" y)) #f)2716 ((not (##core#inline "C_sametypep" x y)) #f)2717 ((##core#inline "C_specialp" x)2718 (and (##core#inline "C_specialp" y)2719 (if (##core#inline "C_closurep" x)2720 (##core#inline "shallow_equal" x y)2721 (compare-slots x y 1))))2722 ((##core#inline "C_byteblockp" x)2723 (and (##core#inline "C_byteblockp" y)2724 (let ((s1 (##sys#size x)))2725 (and (eq? s1 (##sys#size y))2726 (##core#inline "C_substring_compare" x y 0 0 s1)))))2727 (else2728 (let ((s1 (##sys#size x)))2729 (and (eq? s1 (##sys#size y))2730 (compare-slots x y 0))))))2731 (walk x y) ))273227332734;;; Symbols:27352736(define ##sys#snafu '##sys#fnord)2737(define ##sys#intern-symbol (##core#primitive "C_string_to_symbol"))2738(define ##sys#intern-keyword (##core#primitive "C_string_to_keyword"))2739(define (##sys#interned-symbol? x) (##core#inline "C_lookup_symbol" x))27402741(define (##sys#string->symbol str)2742 (##sys#check-string str)2743 (##sys#intern-symbol str) )27442745(define (##sys#symbol->string s)2746 (##sys#slot s 1))27472748(set! scheme#symbol->string2749 (lambda (s)2750 (##sys#check-symbol s 'symbol->string)2751 (string-copy (##sys#symbol->string s) ) ))27522753(set! scheme#string->symbol2754 (let ((string-copy string-copy))2755 (lambda (str)2756 (##sys#check-string str 'string->symbol)2757 (##sys#intern-symbol (string-copy str)) ) ) )27582759(set! chicken.base#string->uninterned-symbol2760 (let ((string-copy string-copy))2761 (lambda (str)2762 (##sys#check-string str 'string->uninterned-symbol)2763 ((##core#primitive "C_make_symbol") (string-copy str)))))27642765(set! chicken.base#gensym2766 (let ((counter -1))2767 (lambda str-or-sym2768 (let ((err (lambda (prefix) (##sys#signal-hook #:type-error 'gensym "argument is not a string or symbol" prefix))))2769 (set! counter (fx+ counter 1))2770 ((##core#primitive "C_make_symbol")2771 (##sys#string-append2772 (if (eq? str-or-sym '())2773 "g"2774 (let ((prefix (car str-or-sym)))2775 (or (and (##core#inline "C_blockp" prefix)2776 (cond ((##core#inline "C_stringp" prefix) prefix)2777 ((##core#inline "C_symbolp" prefix) (##sys#symbol->string prefix))2778 (else (err prefix))))2779 (err prefix) ) ) )2780 (##sys#number->string counter) ) ) ) ) ) )27812782(set! chicken.base#symbol-append2783 (let ((string-append string-append))2784 (lambda ss2785 (##sys#intern-symbol2786 (apply2787 string-append2788 (map (lambda (s)2789 (##sys#check-symbol s 'symbol-append)2790 (##sys#symbol->string s))2791 ss))))))27922793;;; Keywords:27942795(module chicken.keyword2796 (keyword? get-keyword keyword->string string->keyword)27972798(import scheme)2799(import chicken.fixnum)28002801(define (keyword? x) (##core#inline "C_i_keywordp" x) )28022803(define string->keyword2804 (let ([string string] )2805 (lambda (s)2806 (##sys#check-string s 'string->keyword)2807 (##sys#intern-keyword s) ) ) )28082809(define keyword->string2810 (let ([keyword? keyword?])2811 (lambda (kw)2812 (if (keyword? kw)2813 (##sys#symbol->string kw)2814 (##sys#signal-hook #:type-error 'keyword->string "bad argument type - not a keyword" kw) ) ) ) )28152816(define get-keyword2817 (let ((tag (list 'tag)))2818 (lambda (key args #!optional thunk)2819 (##sys#check-keyword key 'get-keyword)2820 (##sys#check-list args 'get-keyword)2821 (let ((r (##core#inline "C_i_get_keyword" key args tag)))2822 (if (eq? r tag) ; not found2823 (and thunk (thunk))2824 r)))))28252826(define ##sys#get-keyword get-keyword))28272828(import chicken.keyword)282928302831;;; Blob:28322833(module chicken.blob2834 (blob->string string->blob blob? blob=? blob-size make-blob)28352836(import scheme)28372838(define (##sys#make-blob size)2839 (let ([bv (##sys#allocate-vector size #t #f #t)])2840 (##core#inline "C_string_to_bytevector" bv)2841 bv) )28422843(define (make-blob size)2844 (##sys#check-fixnum size 'make-blob)2845 (##sys#make-blob size) )28462847(define (blob? x)2848 (and (##core#inline "C_blockp" x)2849 (##core#inline "C_bytevectorp" x) ) )28502851(define (blob-size bv)2852 (##sys#check-blob bv 'blob-size)2853 (##sys#size bv) )28542855(define (string->blob s)2856 (##sys#check-string s 'string->blob)2857 (let* ([n (##sys#size s)]2858 [bv (##sys#make-blob n)] )2859 (##core#inline "C_copy_memory" bv s n)2860 bv) )28612862(define (blob->string bv)2863 (##sys#check-blob bv 'blob->string)2864 (let* ([n (##sys#size bv)]2865 [s (##sys#make-string n)] )2866 (##core#inline "C_copy_memory" s bv n)2867 s) )28682869(define (blob=? b1 b2)2870 (##sys#check-blob b1 'blob=?)2871 (##sys#check-blob b2 'blob=?)2872 (let ((n (##sys#size b1)))2873 (and (eq? (##sys#size b2) n)2874 (zero? (##core#inline "C_string_compare" b1 b2 n)))))28752876) ; chicken.blob2877287828792880;;; Vectors:2881(set! scheme#make-vector2882 (lambda (size . fill)2883 (##sys#check-fixnum size 'make-vector)2884 (when (fx< size 0) (##sys#error 'make-vector "size is negative" size))2885 (##sys#allocate-vector2886 size #f2887 (if (null? fill)2888 (##core#undefined)2889 (car fill) )2890 #f) ))28912892(define ##sys#make-vector make-vector)28932894(set! scheme#list->vector2895 (lambda (lst0)2896 (if (not (list? lst0))2897 (##sys#error-not-a-proper-list lst0 'list->vector)2898 (let* ([len (length lst0)]2899 [v (##sys#make-vector len)] )2900 (let loop ([lst lst0]2901 [i 0])2902 (if (null? lst)2903 v2904 (begin2905 (##sys#setslot v i (##sys#slot lst 0))2906 (loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) ) )))29072908(set! scheme#vector->list2909 (lambda (v)2910 (##sys#check-vector v 'vector->list)2911 (let ((len (##core#inline "C_block_size" v)))2912 (let loop ((i 0))2913 (if (fx>= i len)2914 '()2915 (cons (##sys#slot v i)2916 (loop (fx+ i 1)) ) ) ) ) ))29172918(set! scheme#vector (lambda xs (list->vector xs) ))29192920(set! scheme#vector-fill!2921 (lambda (v x)2922 (##sys#check-vector v 'vector-fill!)2923 (let ((len (##core#inline "C_block_size" v)))2924 (do ((i 0 (fx+ i 1)))2925 ((fx>= i len))2926 (##sys#setslot v i x) ) ) ))29272928(set! chicken.base#vector-copy!2929 (lambda (from to . n)2930 (##sys#check-vector from 'vector-copy!)2931 (##sys#check-vector to 'vector-copy!)2932 (let* ((len-from (##sys#size from))2933 (len-to (##sys#size to))2934 (n (if (pair? n) (car n) (fxmin len-to len-from))))2935 (##sys#check-fixnum n 'vector-copy!)2936 (when (or (fx> n len-to) (fx> n len-from))2937 (##sys#signal-hook2938 #:bounds-error 'vector-copy!2939 "cannot copy vector - count exceeds length" from to n))2940 (do ((i 0 (fx+ i 1)))2941 ((fx>= i n))2942 (##sys#setslot to i (##sys#slot from i))))))29432944(set! chicken.base#subvector2945 (lambda (v i #!optional j)2946 (##sys#check-vector v 'subvector)2947 (let* ((len (##sys#size v))2948 (j (or j len))2949 (len2 (fx- j i)))2950 (##sys#check-range i 0 (fx+ len 1) 'subvector)2951 (##sys#check-range j 0 (fx+ len 1) 'subvector)2952 (let ((v2 (make-vector len2)))2953 (do ((k 0 (fx+ k 1)))2954 ((fx>= k len2) v2)2955 (##sys#setslot v2 k (##sys#slot v (fx+ k i))))))))29562957(set! chicken.base#vector-resize2958 (lambda (v n #!optional init)2959 (##sys#check-vector v 'vector-resize)2960 (##sys#check-fixnum n 'vector-resize)2961 (##sys#vector-resize v n init)))29622963(define (##sys#vector-resize v n init)2964 (let ((v2 (##sys#make-vector n init))2965 (len (min (##sys#size v) n)) )2966 (do ((i 0 (fx+ i 1)))2967 ((fx>= i len) v2)2968 (##sys#setslot v2 i (##sys#slot v i)) ) ) )29692970;;; Characters:29712972(let ((char-downcase char-downcase))2973 (set! scheme#char-ci=? (lambda (x y)2974 (eq? (char-downcase x)2975 (char-downcase y))))2976 (set! scheme#char-ci>? (lambda (x y)2977 (##core#inline "C_u_i_char_greaterp"2978 (char-downcase x)2979 (char-downcase y))))2980 (set! scheme#char-ci<? (lambda (x y)2981 (##core#inline "C_u_i_char_lessp"2982 (char-downcase x)2983 (char-downcase y))))2984 (set! scheme#char-ci>=? (lambda (x y)2985 (##core#inline "C_u_i_char_greater_or_equal_p"2986 (char-downcase x)2987 (char-downcase y))))2988 (set! scheme#char-ci<=? (lambda (x y)2989 (##core#inline "C_u_i_char_less_or_equal_p"2990 (char-downcase x)2991 (char-downcase y)))) )29922993(set! chicken.base#char-name2994 (let ((chars-to-names (make-vector char-name-table-size '()))2995 (names-to-chars '()))2996 (define (lookup-char c)2997 (let* ([code (char->integer c)]2998 [key (##core#inline "C_fixnum_modulo" code char-name-table-size)] )2999 (let loop ([b (##sys#slot chars-to-names key)])3000 (and (pair? b)3001 (let ([a (##sys#slot b 0)])3002 (if (eq? (##sys#slot a 0) c)3003 a3004 (loop (##sys#slot b 1)) ) ) ) ) ) )3005 (lambda (x . y)3006 (let ([chr (if (pair? y) (car y) #f)])3007 (cond [(char? x)3008 (and-let* ([a (lookup-char x)])3009 (##sys#slot a 1) ) ]3010 [chr3011 (##sys#check-symbol x 'char-name)3012 (##sys#check-char chr 'char-name)3013 (when (fx< (##sys#size (##sys#slot x 1)) 2)3014 (##sys#signal-hook #:type-error 'char-name "invalid character name" x) )3015 (let ([a (lookup-char chr)])3016 (if a3017 (let ([b (assq x names-to-chars)])3018 (##sys#setslot a 1 x)3019 (if b3020 (##sys#setislot b 1 chr)3021 (set! names-to-chars (cons (cons x chr) names-to-chars)) ) )3022 (let ([key (##core#inline "C_fixnum_modulo" (char->integer chr) char-name-table-size)])3023 (set! names-to-chars (cons (cons x chr) names-to-chars))3024 (##sys#setslot3025 chars-to-names key3026 (cons (cons chr x) (##sys#slot chars-to-names key))) ) ) ) ]3027 [else3028 (##sys#check-symbol x 'char-name)3029 (and-let* ([a (assq x names-to-chars)])3030 (##sys#slot a 1) ) ] ) ) ) ) )30313032;; TODO: Use the character names here in the next release? Or just3033;; use the numbers everywhere, for clarity?3034(char-name 'space #\space)3035(char-name 'tab #\tab)3036(char-name 'linefeed #\linefeed)3037(char-name 'newline #\newline)3038(char-name 'vtab (integer->char 11))3039(char-name 'delete (integer->char 127))3040(char-name 'esc (integer->char 27))3041(char-name 'escape (integer->char 27))3042(char-name 'alarm (integer->char 7))3043(char-name 'nul (integer->char 0))3044(char-name 'null (integer->char 0))3045(char-name 'return #\return)3046(char-name 'page (integer->char 12))3047(char-name 'backspace (integer->char 8))304830493050;;; Procedures:30513052(define ##sys#call-with-current-continuation (##core#primitive "C_call_cc"))3053(define ##sys#call-with-cthulhu (##core#primitive "C_call_with_cthulhu"))3054(define ##sys#call-with-values call-with-values)30553056(define (##sys#for-each p lst0)3057 (let loop ((lst lst0))3058 (cond ((eq? lst '()) (##core#undefined))3059 ((pair? lst)3060 (p (##sys#slot lst 0))3061 (loop (##sys#slot lst 1)) )3062 (else (##sys#error-not-a-proper-list lst0 'for-each)) ) ))30633064(define (##sys#map p lst0)3065 (let loop ((lst lst0))3066 (cond ((eq? lst '()) lst)3067 ((pair? lst)3068 (cons (p (##sys#slot lst 0)) (loop (##sys#slot lst 1))) )3069 (else (##sys#error-not-a-proper-list lst0 'map)) ) ))30703071(letrec ((mapsafe3072 (lambda (p lsts loc)3073 (call-with-current-continuation3074 (lambda (empty)3075 (let lp ((lsts lsts))3076 (if (eq? lsts '())3077 lsts3078 (let ((item (##sys#slot lsts 0)))3079 (cond ((eq? item '()) (empty '()))3080 ((pair? item)3081 (cons (p item) (lp (##sys#slot lsts 1))))3082 (else (##sys#error-not-a-proper-list item loc)))))))))))30833084 (set! scheme#for-each3085 (lambda (fn lst1 . lsts)3086 (if (null? lsts)3087 (##sys#for-each fn lst1)3088 (let loop ((all (cons lst1 lsts)))3089 (let* ((first (##sys#slot all 0))3090 (safe-args (mapsafe (lambda (x) (car x)) all 'for-each))) ; ensure inlining3091 (when (pair? safe-args)3092 (apply fn safe-args)3093 (loop (mapsafe (lambda (x) (cdr x)) all 'for-each))))))))30943095 (set! scheme#map3096 (lambda (fn lst1 . lsts)3097 (if (null? lsts)3098 (##sys#map fn lst1)3099 (let loop ((all (cons lst1 lsts)))3100 (let* ((first (##sys#slot all 0))3101 (safe-args (mapsafe (lambda (x) (car x)) all 'map)))3102 (if (pair? safe-args)3103 (cons (apply fn safe-args)3104 (loop (mapsafe (lambda (x) (cdr x)) all 'map)))3105 '())))))))310631073108;;; dynamic-wind:3109;3110; (taken more or less directly from SLIB)3111;3112; This implementation is relatively costly: we have to shadow call/cc3113; with a new version that unwinds suspended thunks, but for this to3114; happen the return-values of the escaping procedure have to be saved3115; temporarily in a list. Since call/cc is very efficient under this3116; implementation, and because allocation of memory that is to be3117; garbage soon has also quite low overhead, the performance-penalty3118; might be acceptable (ctak needs about 4 times longer).31193120(define ##sys#dynamic-winds '())31213122(set! scheme#dynamic-wind3123 (lambda (before thunk after)3124 (before)3125 (set! ##sys#dynamic-winds (cons (cons before after) ##sys#dynamic-winds))3126 (##sys#call-with-values3127 thunk3128 (lambda results3129 (set! ##sys#dynamic-winds (##sys#slot ##sys#dynamic-winds 1))3130 (after)3131 (apply ##sys#values results) ) ) ))31323133(define ##sys#dynamic-wind dynamic-wind)31343135(set! scheme#call-with-current-continuation3136 (lambda (proc)3137 (let ((winds ##sys#dynamic-winds))3138 (##sys#call-with-current-continuation3139 (lambda (cont)3140 (define (continuation . results)3141 (unless (eq? ##sys#dynamic-winds winds)3142 (##sys#dynamic-unwind winds (fx- (length ##sys#dynamic-winds) (length winds))) )3143 (apply cont results) )3144 (proc continuation) ))) ))31453146(set! chicken.base#call/cc call-with-current-continuation)31473148(define (##sys#dynamic-unwind winds n)3149 (cond [(eq? ##sys#dynamic-winds winds)]3150 [(fx< n 0)3151 (##sys#dynamic-unwind (##sys#slot winds 1) (fx+ n 1))3152 ((##sys#slot (##sys#slot winds 0) 0))3153 (set! ##sys#dynamic-winds winds) ]3154 [else3155 (let ([after (##sys#slot (##sys#slot ##sys#dynamic-winds 0) 1)])3156 (set! ##sys#dynamic-winds (##sys#slot ##sys#dynamic-winds 1))3157 (after)3158 (##sys#dynamic-unwind winds (fx- n 1)) ) ] ) )315931603161;;; Ports:31623163(set! chicken.base#port?3164 (lambda (x)3165 (and (##core#inline "C_blockp" x)3166 (##core#inline "C_portp" x))))31673168(set! chicken.base#input-port-open?3169 (lambda (p)3170 (##sys#check-input-port p 'input-port-open?)3171 (##core#inline "C_input_port_openp" p)))31723173(set! chicken.base#output-port-open?3174 (lambda (p)3175 (##sys#check-output-port p 'output-port-open?)3176 (##core#inline "C_output_port_openp" p)))31773178(set! chicken.base#port-closed?3179 (lambda (p)3180 (##sys#check-port p 'port-closed?)3181 (eq? (##sys#slot p 8) 0)))31823183;;; Custom ports:31843185;;; Port layout:3186;3187; 0: FP (special)3188; 1: direction (fixnum)3189; 2: class (vector of procedures)3190; 3: name (string)3191; 4: row (fixnum)3192; 5: col (fixnum)3193; 6: EOF (bool)3194; 7: type ('stream | 'custom | 'string | 'socket)3195; 8: closed (fixnum)3196; 9: data3197; 10-15: reserved, port class specific3198;3199; Port-class:3200;3201; 0: (read-char PORT) -> CHAR | EOF3202; 1: (peek-char PORT) -> CHAR | EOF3203; 2: (write-char PORT CHAR)3204; 3: (write-string PORT STRING)3205; 4: (close PORT)3206; 5: (flush-output PORT)3207; 6: (char-ready? PORT) -> BOOL3208; 7: (read-string! PORT COUNT STRING START) -> COUNT'3209; 8: (read-line PORT LIMIT) -> STRING | EOF3210; 9: (read-buffered PORT) -> STRING32113212(define (##sys#make-port i/o class name type)3213 (let ([port (##core#inline_allocate ("C_a_i_port" 17))])3214 (##sys#setislot port 1 i/o)3215 (##sys#setslot port 2 class)3216 (##sys#setslot port 3 name)3217 (##sys#setislot port 4 1)3218 (##sys#setislot port 5 0)3219 (##sys#setslot port 7 type)3220 (##sys#setslot port 8 i/o)3221 port) )32223223;;; Stream ports:3224; Input port slots:3225; 12: Static buffer for read-line, allocated on-demand32263227(define ##sys#stream-port-class3228 (vector (lambda (p) ; read-char3229 (let loop ()3230 (let ((c (##core#inline "C_read_char" p)))3231 (cond3232 ((eq? -1 c)3233 (let ((err (##sys#update-errno)))3234 (if (eq? err (foreign-value "EINTR" int))3235 (##sys#dispatch-interrupt loop)3236 (##sys#signal-hook/errno3237 #:file-error err 'read-char3238 (##sys#string-append "cannot read from port - " strerror)3239 p))))3240 (else c)))))3241 (lambda (p) ; peek-char3242 (let loop ()3243 (let ((c (##core#inline "C_peek_char" p)))3244 (cond3245 ((eq? -1 c)3246 (let ((err (##sys#update-errno)))3247 (if (eq? err (foreign-value "EINTR" int))3248 (##sys#dispatch-interrupt loop)3249 (##sys#signal-hook/errno3250 #:file-error err 'peek-char3251 (##sys#string-append "cannot read from port - " strerror)3252 p))))3253 (else c)))))3254 (lambda (p c) ; write-char3255 (##core#inline "C_display_char" p c) )3256 (lambda (p s) ; write-string3257 (##core#inline "C_display_string" p s) )3258 (lambda (p d) ; close3259 (##core#inline "C_close_file" p)3260 (##sys#update-errno) )3261 (lambda (p) ; flush-output3262 (##core#inline "C_flush_output" p) )3263 (lambda (p) ; char-ready?3264 (##core#inline "C_char_ready_p" p) )3265 (lambda (p n dest start) ; read-string!3266 (let loop ([rem (or n (fx- (##sys#size dest) start))] [act 0] [start start])3267 (let ([len (##core#inline "fast_read_string_from_file" dest p rem start)])3268 (cond ((eof-object? len) ; EOF returns 0 bytes read3269 act)3270 ((fx< len 0)3271 (let ((err (##sys#update-errno)))3272 (if (eq? err (foreign-value "EINTR" int))3273 (##sys#dispatch-interrupt3274 (lambda ()3275 (loop (fx- rem len) (fx+ act len) (fx+ start len))))3276 (##sys#signal-hook/errno3277 #:file-error err 'read-string!3278 (##sys#string-append "cannot read from port - " strerror)3279 p n dest start))))3280 ((fx< len rem)3281 (loop (fx- rem len) (fx+ act len) (fx+ start len)))3282 (else3283 (fx+ act len) ) ) )))3284 (lambda (p rlimit) ; read-line3285 (if rlimit (##sys#check-fixnum rlimit 'read-line))3286 (let ((sblen read-line-buffer-initial-size))3287 (unless (##sys#slot p 12)3288 (##sys#setslot p 12 (##sys#make-string sblen)))3289 (let loop ([len sblen]3290 [limit (or rlimit maximal-string-length)] ; guaranteed fixnum?3291 [buffer (##sys#slot p 12)]3292 [result ""]3293 [f #f])3294 (let ([n (##core#inline "fast_read_line_from_file" buffer p3295 (fxmin limit len))])3296 (cond [(eof-object? n) (if f result #!eof)]3297 [(not n)3298 (if (fx< limit len)3299 (##sys#string-append result (##sys#substring buffer 0 limit))3300 (loop (fx* len 2)3301 (fx- limit len)3302 (##sys#make-string (fx* len 2))3303 (##sys#string-append result buffer)3304 #t)) ]3305 ((fx< n 0)3306 (let ((err (##sys#update-errno)))3307 (if (eq? err (foreign-value "EINTR" int))3308 (let ((n (fx- (fxneg n) 1)))3309 (##sys#dispatch-interrupt3310 (lambda ()3311 (loop len limit buffer3312 (##sys#string-append3313 result (##sys#substring buffer 0 n))3314 #t))))3315 (##sys#signal-hook/errno3316 #:file-error err 'read-line3317 (##sys#string-append "cannot read from port - " strerror)3318 p rlimit))))3319 [f (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))3320 (##sys#string-append result (##sys#substring buffer 0 n))]3321 [else3322 (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))3323 (##sys#substring buffer 0 n)] ) ) ) ) )3324 #f ; read-buffered3325 ) )33263327(define ##sys#open-file-port (##core#primitive "C_open_file_port"))33283329(define ##sys#standard-input (##sys#make-port 1 ##sys#stream-port-class "(stdin)" 'stream))3330(define ##sys#standard-output (##sys#make-port 2 ##sys#stream-port-class "(stdout)" 'stream))3331(define ##sys#standard-error (##sys#make-port 2 ##sys#stream-port-class "(stderr)" 'stream))33323333(##sys#open-file-port ##sys#standard-input 0 #f)3334(##sys#open-file-port ##sys#standard-output 1 #f)3335(##sys#open-file-port ##sys#standard-error 2 #f)33363337(define (##sys#check-input-port x open . loc)3338 (if (pair? loc)3339 (##core#inline "C_i_check_port_2" x 1 open (car loc))3340 (##core#inline "C_i_check_port" x 1 open)))33413342(define (##sys#check-output-port x open . loc)3343 (if (pair? loc)3344 (##core#inline "C_i_check_port_2" x 2 open (car loc))3345 (##core#inline "C_i_check_port" x 2 open)))33463347(define (##sys#check-port x . loc)3348 (if (pair? loc)3349 (##core#inline "C_i_check_port_2" x 0 #f (car loc))3350 (##core#inline "C_i_check_port" x 0 #f) ) )33513352(define (##sys#check-open-port x . loc)3353 (if (pair? loc)3354 (##core#inline "C_i_check_port_2" x 0 #t (car loc))3355 (##core#inline "C_i_check_port" x 0 #t) ) )33563357(set! scheme#current-input-port3358 (lambda args3359 (if (null? args)3360 ##sys#standard-input3361 (let ((p (car args)))3362 (##sys#check-port p 'current-input-port)3363 (let-optionals (cdr args) ((convert? #t) (set? #t))3364 (when set? (set! ##sys#standard-input p)))3365 p) ) ))33663367(set! scheme#current-output-port3368 (lambda args3369 (if (null? args)3370 ##sys#standard-output3371 (let ((p (car args)))3372 (##sys#check-port p 'current-output-port)3373 (let-optionals (cdr args) ((convert? #t) (set? #t))3374 (when set? (set! ##sys#standard-output p)))3375 p) ) ))33763377(set! chicken.base#current-error-port3378 (lambda args3379 (if (null? args)3380 ##sys#standard-error3381 (let ((p (car args)))3382 (##sys#check-port p 'current-error-port)3383 (let-optionals (cdr args) ((convert? #t) (set? #t))3384 (when set? (set! ##sys#standard-error p)))3385 p))))33863387(define (##sys#tty-port? port)3388 (and (not (zero? (##sys#peek-unsigned-integer port 0)))3389 (##core#inline "C_tty_portp" port) ) )33903391(define (##sys#port-data port) (##sys#slot port 9))3392(define (##sys#set-port-data! port data) (##sys#setslot port 9 data))33933394(let ()3395 (define (open name inp modes loc)3396 (##sys#check-string name loc)3397 (let ([fmode (if inp "r" "w")]3398 [bmode ""] )3399 (do ([modes modes (##sys#slot modes 1)])3400 ((null? modes))3401 (let ([o (##sys#slot modes 0)])3402 (case o3403 [(#:binary) (set! bmode "b")]3404 [(#:text) (set! bmode "")]3405 [(#:append)3406 (if inp3407 (##sys#error loc "cannot use append mode with input file")3408 (set! fmode "a") ) ]3409 [else (##sys#error loc "invalid file option" o)] ) ) )3410 (let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class name 'stream)))3411 (unless (##sys#open-file-port port name (##sys#string-append fmode bmode))3412 (##sys#signal-hook/errno #:file-error (##sys#update-errno) loc3413 (##sys#string-append "cannot open file - " strerror)3414 name))3415 port) ) )34163417 (define (close port inp loc)3418 (##sys#check-port port loc)3419 ; repeated closing is ignored3420 (let ((direction (if inp 1 2)))3421 (when (##core#inline "C_port_openp" port direction)3422 (##sys#setislot port 8 (fxand (##sys#slot port 8) (fxnot direction)))3423 ((##sys#slot (##sys#slot port 2) 4) port direction))))34243425 (set! scheme#open-input-file (lambda (name . mode) (open name #t mode 'open-input-file)))3426 (set! scheme#open-output-file (lambda (name . mode) (open name #f mode 'open-output-file)))3427 (set! scheme#close-input-port (lambda (port) (close port #t 'close-input-port)))3428 (set! scheme#close-output-port (lambda (port) (close port #f 'close-output-port))))34293430(set! scheme#call-with-input-file3431 (let ((open-input-file open-input-file)3432 (close-input-port close-input-port) )3433 (lambda (name p . mode)3434 (let ((f (apply open-input-file name mode)))3435 (##sys#call-with-values3436 (lambda () (p f))3437 (lambda results3438 (close-input-port f)3439 (apply ##sys#values results) ) ) ) ) ) )34403441(set! scheme#call-with-output-file3442 (let ((open-output-file open-output-file)3443 (close-output-port close-output-port) )3444 (lambda (name p . mode)3445 (let ((f (apply open-output-file name mode)))3446 (##sys#call-with-values3447 (lambda () (p f))3448 (lambda results3449 (close-output-port f)3450 (apply ##sys#values results) ) ) ) ) ) )34513452(set! scheme#with-input-from-file3453 (let ((open-input-file open-input-file)3454 (close-input-port close-input-port) )3455 (lambda (str thunk . mode)3456 (let ((file (apply open-input-file str mode)))3457 (fluid-let ((##sys#standard-input file))3458 (##sys#call-with-values thunk3459 (lambda results3460 (close-input-port file)3461 (apply ##sys#values results) ) ) ) ) ) ) )34623463(set! scheme#with-output-to-file3464 (let ((open-output-file open-output-file)3465 (close-output-port close-output-port) )3466 (lambda (str thunk . mode)3467 (let ((file (apply open-output-file str mode)))3468 (fluid-let ((##sys#standard-output file))3469 (##sys#call-with-values thunk3470 (lambda results3471 (close-output-port file)3472 (apply ##sys#values results) ) ) ) ) ) ) )34733474(define (##sys#file-exists? name file? dir? loc)3475 (case (##core#inline "C_i_file_exists_p" (##sys#make-c-string name loc) file? dir?)3476 ((#f) #f)3477 ((#t) #t)3478 (else3479 (##sys#signal-hook3480 #:file-error loc "system error while trying to access file"3481 name))))34823483(define (##sys#flush-output port)3484 ((##sys#slot (##sys#slot port 2) 5) port) ; flush-output3485 (##core#undefined) )34863487(set! chicken.base#flush-output3488 (lambda (#!optional (port ##sys#standard-output))3489 (##sys#check-output-port port #t 'flush-output)3490 (##sys#flush-output port)))34913492(define (##sys#port-line port)3493 (and (##core#inline "C_input_portp" port)3494 (##sys#slot port 4) ) )34953496;;; Decorate procedure with arbitrary data3497;3498; warning: may modify proc, if it already has a suitable decoration!34993500(define (##sys#decorate-lambda proc pred decorator)3501 (let ((len (##sys#size proc)))3502 (let loop ((i (fx- len 1)))3503 (cond ((zero? i)3504 (let ((p2 (make-vector (fx+ len 1))))3505 (do ((i 1 (fx+ i 1)))3506 ((fx>= i len)3507 (##core#inline "C_vector_to_closure" p2)3508 (##core#inline "C_copy_pointer" proc p2)3509 (decorator p2 i) )3510 (##sys#setslot p2 i (##sys#slot proc i)) ) ) )3511 (else3512 (let ((x (##sys#slot proc i)))3513 (if (pred x)3514 (decorator proc i)3515 (loop (fx- i 1)) ) ) ) ) ) ) )35163517(define (##sys#lambda-decoration proc pred)3518 (let loop ((i (fx- (##sys#size proc) 1)))3519 (and (fx> i 0)3520 (let ((x (##sys#slot proc i)))3521 (if (pred x)3522 x3523 (loop (fx- i 1)) ) ) ) ) )352435253526;;; Create lambda-info object35273528(define (##sys#make-lambda-info str)3529 (let* ((sz (##sys#size str))3530 (info (##sys#make-string sz)) )3531 (##core#inline "C_copy_memory" info str sz)3532 (##core#inline "C_string_to_lambdainfo" info)3533 info) )353435353536;;; Function debug info:35373538(define (##sys#lambda-info? x)3539 (and (not (##sys#immediate? x)) (##core#inline "C_lambdainfop" x)))35403541(define (##sys#lambda-info proc)3542 (##sys#lambda-decoration proc ##sys#lambda-info?))35433544(define (##sys#lambda-info->string info)3545 (let* ((sz (##sys#size info))3546 (s (##sys#make-string sz)) )3547 (##core#inline "C_copy_memory" s info sz)3548 s) )35493550(set! chicken.base#procedure-information3551 (lambda (x)3552 (##sys#check-closure x 'procedure-information)3553 (and-let* ((info (##sys#lambda-info x)))3554 (##sys#read (open-input-string (##sys#lambda-info->string info)) #f) ) ) )355535563557;;; SRFI-1735583559(define setter-tag (vector 'setter))35603561(define-inline (setter? x)3562 (and (pair? x) (eq? setter-tag (##sys#slot x 0))) )35633564(set! chicken.base#setter3565 (##sys#decorate-lambda3566 (lambda (proc)3567 (or (and-let* (((procedure? proc))3568 (d (##sys#lambda-decoration proc setter?)) )3569 (##sys#slot d 1) )3570 (##sys#error 'setter "no setter defined" proc) ) )3571 setter?3572 (lambda (proc i)3573 (##sys#setslot3574 proc i3575 (cons3576 setter-tag3577 (lambda (get set)3578 (if (procedure? get)3579 (let ((get2 (##sys#decorate-lambda3580 get3581 setter?3582 (lambda (proc i) (##sys#setslot proc i (cons setter-tag set)) proc))))3583 (if (eq? get get2)3584 get3585 (##sys#become! (list (cons get get2))) ) )3586 (error "can not set setter of non-procedure" get) ) ) ) )3587 proc) ) )35883589(define ##sys#setter setter)35903591(set! chicken.base#getter-with-setter3592 (lambda (get set #!optional info)3593 (##sys#check-closure get 'getter-with-setter)3594 (##sys#check-closure set 'getter-with-setter)3595 (let ((getdec (cond (info3596 (##sys#check-string info 'getter-with-setter)3597 (##sys#make-lambda-info info))3598 (else (##sys#lambda-info get))))3599 (p1 (##sys#decorate-lambda3600 (##sys#copy-closure get)3601 setter?3602 (lambda (proc i)3603 (##sys#setslot proc i (cons setter-tag set))3604 proc))))3605 (if getdec3606 (##sys#decorate-lambda3607 p13608 ##sys#lambda-info?3609 (lambda (p i)3610 (##sys#setslot p i getdec)3611 p))3612 p1))))36133614(set! scheme#car (getter-with-setter scheme#car set-car!))3615(set! scheme#cdr (getter-with-setter scheme#cdr set-cdr!))3616(set! scheme#caar (getter-with-setter scheme#caar (lambda (x y) (set-car! (car x) y))))3617(set! scheme#cadr (getter-with-setter scheme#cadr (lambda (x y) (set-car! (cdr x) y))))3618(set! scheme#cdar (getter-with-setter scheme#cdar (lambda (x y) (set-cdr! (car x) y))))3619(set! scheme#cddr (getter-with-setter scheme#cddr (lambda (x y) (set-cdr! (cdr x) y))))3620(set! scheme#caaar (getter-with-setter scheme#caaar (lambda (x y) (set-car! (caar x) y))))3621(set! scheme#caadr (getter-with-setter scheme#caadr (lambda (x y) (set-car! (cadr x) y))))3622(set! scheme#cadar (getter-with-setter scheme#cadar (lambda (x y) (set-car! (cdar x) y))))3623(set! scheme#caddr (getter-with-setter scheme#caddr (lambda (x y) (set-car! (cddr x) y))))3624(set! scheme#cdaar (getter-with-setter scheme#cdaar (lambda (x y) (set-cdr! (caar x) y))))3625(set! scheme#cdadr (getter-with-setter scheme#cdadr (lambda (x y) (set-cdr! (cadr x) y))))3626(set! scheme#cddar (getter-with-setter scheme#cddar (lambda (x y) (set-cdr! (cdar x) y))))3627(set! scheme#cdddr (getter-with-setter scheme#cdddr (lambda (x y) (set-cdr! (cddr x) y))))3628(set! scheme#string-ref (getter-with-setter scheme#string-ref string-set!))3629(set! scheme#vector-ref (getter-with-setter scheme#vector-ref vector-set!))36303631(set! scheme#list-ref3632 (getter-with-setter3633 scheme#list-ref3634 (lambda (x i y) (set-car! (list-tail x i) y))))363536363637;;; Parameters:36383639(define ##sys#default-parameter-vector (##sys#make-vector default-parameter-vector-size))3640(define ##sys#current-parameter-vector '#())36413642(set! chicken.base#make-parameter3643 (let ((count 0))3644 (lambda (init #!optional (guard (lambda (x) x)))3645 (let* ((val (guard init))3646 (i count)3647 (assign (lambda (val n convert? set?)3648 (when (fx>= i n)3649 (set! ##sys#current-parameter-vector3650 (##sys#vector-resize3651 ##sys#current-parameter-vector3652 (fx+ i 1)3653 ##sys#snafu) ) )3654 (let ((val (if convert? (guard val) val)))3655 (when set?3656 (##sys#setslot ##sys#current-parameter-vector i val))3657 val))))36583659 (set! count (fx+ count 1))3660 (when (fx>= i (##sys#size ##sys#default-parameter-vector))3661 (set! ##sys#default-parameter-vector3662 (##sys#vector-resize3663 ##sys#default-parameter-vector3664 (fx+ i 1)3665 (##core#undefined)) ) )3666 (##sys#setslot ##sys#default-parameter-vector i val)36673668 (getter-with-setter3669 (lambda args3670 (let ((n (##sys#size ##sys#current-parameter-vector)))3671 (cond ((pair? args)3672 (let-optionals (cdr args) ((convert? #t)3673 (set? #t))3674 (assign (car args) n convert? set?)))3675 ((fx>= i n)3676 (##sys#slot ##sys#default-parameter-vector i) )3677 (else3678 (let ((val (##sys#slot ##sys#current-parameter-vector i)))3679 (if (eq? val ##sys#snafu)3680 (##sys#slot ##sys#default-parameter-vector i)3681 val) ) ) ) ) )3682 (lambda (val)3683 (let ((n (##sys#size ##sys#current-parameter-vector)))3684 (assign val n #f #t))))))))368536863687;;; Input:36883689(set! scheme#char-ready?3690 (lambda (#!optional (port ##sys#standard-input))3691 (##sys#check-input-port port #t 'char-ready?)3692 ((##sys#slot (##sys#slot port 2) 6) port) )) ; char-ready?36933694(set! scheme#read-char3695 (lambda (#!optional (port ##sys#standard-input))3696 (##sys#check-input-port port #t 'read-char)3697 (##sys#read-char-0 port) ))36983699(define (##sys#read-char-0 p)3700 (let ([c (if (##sys#slot p 6)3701 (begin3702 (##sys#setislot p 6 #f)3703 #!eof)3704 ((##sys#slot (##sys#slot p 2) 0) p) ) ] ) ; read-char3705 (cond [(eq? c #\newline)3706 (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))3707 (##sys#setislot p 5 0) ]3708 [(not (##core#inline "C_eofp" c))3709 (##sys#setislot p 5 (fx+ (##sys#slot p 5) 1)) ] )3710 c) )37113712(define (##sys#read-char/port port)3713 (##sys#check-input-port port #t 'read-char)3714 (##sys#read-char-0 port) )37153716(define (##sys#peek-char-0 p)3717 (if (##sys#slot p 6)3718 #!eof3719 (let ([c ((##sys#slot (##sys#slot p 2) 1) p)]) ; peek-char3720 (when (##core#inline "C_eofp" c)3721 (##sys#setislot p 6 #t) )3722 c) ) )37233724(set! scheme#peek-char3725 (lambda (#!optional (port ##sys#standard-input))3726 (##sys#check-input-port port #t 'peek-char)3727 (##sys#peek-char-0 port) ))37283729(set! scheme#read3730 (lambda (#!optional (port ##sys#standard-input))3731 (##sys#check-input-port port #t 'read)3732 (##sys#read port ##sys#default-read-info-hook) ))37333734(define ##sys#default-read-info-hook #f)3735(define ##sys#read-error-with-line-number #f)3736(define (##sys#read-prompt-hook) #f) ; just here so that srfi-18 works without eval3737(define (##sys#infix-list-hook lst) lst)37383739(define (##sys#sharp-number-hook port n)3740 (##sys#read-error port "invalid `#...' read syntax" n) )37413742(set! chicken.base#case-sensitive (make-parameter #t))3743(set! chicken.base#parentheses-synonyms (make-parameter #t))3744(set! chicken.base#symbol-escape (make-parameter #t))37453746(set! chicken.base#keyword-style3747 (make-parameter #:suffix (lambda (x) (when x (##sys#check-keyword x 'keyword-style)) x)))37483749(define ##sys#current-read-table (make-parameter (##sys#make-structure 'read-table #f #f #f)))37503751(define ##sys#read-warning3752 (let ([string-append string-append])3753 (lambda (port msg . args)3754 (apply3755 ##sys#warn3756 (let ((ln (##sys#port-line port)))3757 (if (and ##sys#read-error-with-line-number ln)3758 (string-append "(line " (##sys#number->string ln) ") " msg)3759 msg) )3760 args) ) ) )37613762(define ##sys#read-error3763 (let ([string-append string-append] )3764 (lambda (port msg . args)3765 (apply3766 ##sys#signal-hook3767 #:syntax-error3768 (let ((ln (##sys#port-line port)))3769 (if (and ##sys#read-error-with-line-number ln)3770 (string-append "(line " (##sys#number->string ln) ") " msg)3771 msg) )3772 args) ) ) )37733774(define ##sys#read3775 (let ((string-append string-append)3776 (keyword-style keyword-style)3777 (case-sensitive case-sensitive)3778 (parentheses-synonyms parentheses-synonyms)3779 (symbol-escape symbol-escape)3780 (current-read-table ##sys#current-read-table))3781 (lambda (port infohandler)3782 (let ((csp (case-sensitive))3783 (ksp (keyword-style))3784 (psp (parentheses-synonyms))3785 (sep (symbol-escape))3786 (crt (current-read-table))3787 ; set below - needs more state to make a decision3788 (terminating-characters '(#\, #\; #\( #\) #\' #\" #\[ #\] #\{ #\}))3789 (reserved-characters #f) )37903791 (define (container c)3792 (##sys#read-error port "unexpected list terminator" c) )37933794 (define (info class data val)3795 (if infohandler3796 (infohandler class data val)3797 data) )37983799 (define (skip-to-eol)3800 (let skip ((c (##sys#read-char-0 port)))3801 (if (and (not (##core#inline "C_eofp" c)) (not (eq? #\newline c)))3802 (skip (##sys#read-char-0 port)) ) ) )38033804 (define (reserved-character c)3805 (##sys#read-char-0 port)3806 (##sys#read-error port "reserved character" c) )38073808 (define (read-unreserved-char-0 port)3809 (let ((c (##sys#read-char-0 port)))3810 (if (memq c reserved-characters)3811 (reserved-character c)3812 c) ) )38133814 (define (readrec)38153816 (define (r-spaces)3817 (let loop ([c (##sys#peek-char-0 port)])3818 (cond ((##core#inline "C_eofp" c))3819 ((eq? #\; c)3820 (skip-to-eol)3821 (loop (##sys#peek-char-0 port)) )3822 ((char-whitespace? c)3823 (##sys#read-char-0 port)3824 (loop (##sys#peek-char-0 port)) ) ) ) )38253826 (define (r-usequence u n base)3827 (let loop ((seq '()) (n n))3828 (if (eq? n 0)3829 (let* ((str (##sys#reverse-list->string seq))3830 (n (string->number str base)))3831 (or n3832 (##sys#read-error3833 port3834 (string-append3835 "invalid escape-sequence '\\" u str "\'")) ) )3836 (let ((x (##sys#read-char-0 port)))3837 (if (or (eof-object? x) (char=? #\" x))3838 (##sys#read-error port "unterminated string constant")3839 (loop (cons x seq) (fx- n 1)) ) ) ) ) )38403841 (define (r-cons-codepoint cp lst)3842 (let* ((s (##sys#char->utf8-string (integer->char cp)))3843 (len (##sys#size s)))3844 (let lp ((i 0) (lst lst))3845 (if (fx>= i len)3846 lst3847 (lp (fx+ i 1) (cons (##core#inline "C_subchar" s i) lst))))))38483849 (define (r-string term)3850 (let loop ((c (##sys#read-char-0 port)) (lst '()))3851 (cond ((##core#inline "C_eofp" c)3852 (##sys#read-error port "unterminated string") )3853 ((eq? #\\ c)3854 (set! c (##sys#read-char-0 port))3855 (case c3856 ((#\t) (loop (##sys#read-char-0 port) (cons #\tab lst)))3857 ((#\r) (loop (##sys#read-char-0 port) (cons #\return lst)))3858 ((#\b) (loop (##sys#read-char-0 port) (cons #\backspace lst)))3859 ((#\n) (loop (##sys#read-char-0 port) (cons #\newline lst)))3860 ((#\a) (loop (##sys#read-char-0 port) (cons (integer->char 7) lst)))3861 ((#\v) (loop (##sys#read-char-0 port) (cons (integer->char 11) lst)))3862 ((#\f) (loop (##sys#read-char-0 port) (cons (integer->char 12) lst)))3863 ((#\x)3864 (let ([ch (integer->char (r-usequence "x" 2 16))])3865 (loop (##sys#read-char-0 port) (cons ch lst)) ) )3866 ((#\u)3867 (let ([n (r-usequence "u" 4 16)])3868 (if (##sys#unicode-surrogate? n)3869 (if (and (eqv? #\\ (##sys#read-char-0 port))3870 (eqv? #\u (##sys#read-char-0 port)))3871 (let* ((m (r-usequence "u" 4 16))3872 (cp (##sys#surrogates->codepoint n m)))3873 (if cp3874 (loop (##sys#read-char-0 port)3875 (r-cons-codepoint cp lst))3876 (##sys#read-error port "bad surrogate pair" n m)))3877 (##sys#read-error port "unpaired escaped surrogate" n))3878 (loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) ) ))3879 ((#\U)3880 (let ([n (r-usequence "U" 8 16)])3881 (if (##sys#unicode-surrogate? n)3882 (##sys#read-error port "invalid escape (surrogate)" n)3883 (loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) )))3884 ((#\\ #\' #\" #\|)3885 (loop (##sys#read-char-0 port) (cons c lst)))3886 ((#\newline #\return #\space #\tab)3887 ;; Read "escaped" <intraline ws>* <nl> <intraline ws>*3888 (let eat-ws ((c c) (nl? #f))3889 (case c3890 ((#\space #\tab)3891 (eat-ws (##sys#read-char-0 port) nl?))3892 ((#\return)3893 (if nl?3894 (loop c lst)3895 (let ((nc (##sys#read-char-0 port)))3896 (if (eq? nc #\newline) ; collapse \r\n3897 (eat-ws (##sys#read-char-0 port) #t)3898 (eat-ws nc #t)))))3899 ((#\newline)3900 (if nl?3901 (loop c lst)3902 (eat-ws (##sys#read-char-0 port) #t)))3903 (else3904 (unless nl?3905 (##sys#read-warning3906 port3907 "escaped whitespace, but no newline - collapsing anyway"))3908 (loop c lst)))))3909 (else3910 (cond ((##core#inline "C_eofp" c)3911 (##sys#read-error port "unterminated string"))3912 ((and (char-numeric? c)3913 (char>=? c #\0)3914 (char<=? c #\7))3915 (let ((ch (integer->char3916 (fx+ (fx* (fx- (char->integer c) 48) 64)3917 (r-usequence "" 2 8)))))3918 (loop (##sys#read-char-0 port) (cons ch lst)) ))3919 (else3920 (##sys#read-warning3921 port3922 "undefined escape sequence in string - probably forgot backslash"3923 c)3924 (loop (##sys#read-char-0 port) (cons c lst))) ) )))3925 ((eq? term c) (##sys#reverse-list->string lst))3926 (else (loop (##sys#read-char-0 port) (cons c lst))) ) ))39273928 (define (r-list start end)3929 (if (eq? (##sys#read-char-0 port) start)3930 (let ((first #f)3931 (ln0 #f)3932 (outer-container container) )3933 (define (starting-line msg)3934 (if (and ln0 ##sys#read-error-with-line-number)3935 (string-append3936 msg ", starting in line "3937 (##sys#number->string ln0))3938 msg))3939 (##sys#call-with-current-continuation3940 (lambda (return)3941 (set! container3942 (lambda (c)3943 (if (eq? c end)3944 (return #f)3945 (##sys#read-error3946 port3947 (starting-line "list-terminator mismatch")3948 c end) ) ) )3949 (let loop ([last '()])3950 (r-spaces)3951 (unless first (set! ln0 (##sys#port-line port)))3952 (let ([c (##sys#peek-char-0 port)])3953 (cond ((##core#inline "C_eofp" c)3954 (##sys#read-error3955 port3956 (starting-line "unterminated list") ) )3957 ((eq? c end)3958 (##sys#read-char-0 port) )3959 ((eq? c #\.)3960 (##sys#read-char-0 port)3961 (let ((c2 (##sys#peek-char-0 port)))3962 (cond ((or (char-whitespace? c2)3963 (eq? c2 #\()3964 (eq? c2 #\))3965 (eq? c2 #\")3966 (eq? c2 #\;) )3967 (unless (pair? last)3968 (##sys#read-error port "invalid use of `.'") )3969 (r-spaces)3970 (##sys#setslot last 1 (readrec))3971 (r-spaces)3972 (unless (eq? (##sys#read-char-0 port) end)3973 (##sys#read-error3974 port3975 (starting-line "missing list terminator")3976 end)))3977 (else3978 (r-xtoken3979 (lambda (tok kw)3980 (let* ((tok (##sys#string-append "." tok))3981 (val3982 (cond ((and (string=? tok ".:")3983 (eq? ksp #:suffix))3984 ;; Edge case: r-xtoken sees3985 ;; a bare ":" and sets kw to #f3986 (build-keyword "."))3987 (kw (build-keyword tok))3988 ((and (char-numeric? c2)3989 (##sys#string->number tok)))3990 (else (build-symbol tok))))3991 (node (cons val '())))3992 (if first3993 (##sys#setslot last 1 node)3994 (set! first node) )3995 (loop node))))))))3996 (else3997 (let ([node (cons (readrec) '())])3998 (if first3999 (##sys#setslot last 1 node)4000 (set! first node) )4001 (loop node) ) ) ) ) ) ) )4002 (set! container outer-container)4003 (if first4004 (info 'list-info (##sys#infix-list-hook first) ln0)4005 '() ) )4006 (##sys#read-error port "missing token" start) ) )40074008 (define (r-vector)4009 (let ((lst (r-list #\( #\))))4010 (if (list? lst)4011 (##sys#list->vector lst)4012 (##sys#read-error port "invalid vector syntax" lst) ) ) )40134014 (define (r-number radix exactness)4015 (r-xtoken4016 (lambda (tok kw)4017 (cond (kw4018 (let ((s (build-keyword tok)))4019 (info 'symbol-info s (##sys#port-line port)) ))4020 ((string=? tok ".")4021 (##sys#read-error port "invalid use of `.'"))4022 ((and (fx> (##sys#size tok) 0) (char=? (string-ref tok 0) #\#))4023 (##sys#read-error port "unexpected prefix in number syntax" tok))4024 ((##sys#string->number tok (or radix 10) exactness))4025 (radix (##sys#read-error port "illegal number syntax" tok))4026 (else (build-symbol tok)) ) ) ))40274028 (define (r-number-with-exactness radix)4029 (cond [(eq? #\# (##sys#peek-char-0 port))4030 (##sys#read-char-0 port)4031 (let ([c2 (##sys#read-char-0 port)])4032 (cond [(eof-object? c2)4033 (##sys#read-error port "unexpected end of numeric literal")]4034 [(char=? c2 #\i) (r-number radix 'i)]4035 [(char=? c2 #\e) (r-number radix 'e)]4036 [else4037 (##sys#read-error4038 port4039 "illegal number syntax - invalid exactness prefix" c2)] ) ) ]4040 [else (r-number radix #f)] ) )40414042 (define (r-number-with-radix exactness)4043 (cond [(eq? #\# (##sys#peek-char-0 port))4044 (##sys#read-char-0 port)4045 (let ([c2 (##sys#read-char-0 port)])4046 (cond [(eof-object? c2) (##sys#read-error port "unexpected end of numeric literal")]4047 [(char=? c2 #\x) (r-number 16 exactness)]4048 [(char=? c2 #\d) (r-number 10 exactness)]4049 [(char=? c2 #\o) (r-number 8 exactness)]4050 [(char=? c2 #\b) (r-number 2 exactness)]4051 [else (##sys#read-error port "illegal number syntax - invalid radix" c2)] ) ) ]4052 [else (r-number 10 exactness)] ) )40534054 (define (r-token)4055 (let loop ((c (##sys#peek-char-0 port)) (lst '()))4056 (cond ((or (eof-object? c)4057 (char-whitespace? c)4058 (memq c terminating-characters) )4059 (##sys#reverse-list->string lst) )4060 ((char=? c #\x00)4061 (##sys#read-error port "attempt to read expression from something that looks like binary data"))4062 (else4063 (read-unreserved-char-0 port)4064 (loop (##sys#peek-char-0 port)4065 (cons (if csp c (char-downcase c)) lst) ) ) ) ) )40664067 (define (r-digits)4068 (let loop ((c (##sys#peek-char-0 port)) (lst '()))4069 (cond ((or (eof-object? c) (not (char-numeric? c)))4070 (##sys#reverse-list->string lst) )4071 (else4072 (##sys#read-char-0 port)4073 (loop (##sys#peek-char-0 port) (cons c lst)) ) ) ) )40744075 (define (r-symbol)4076 (r-xtoken4077 (lambda (str kw)4078 (let ((s (if kw (build-keyword str) (build-symbol str))))4079 (info 'symbol-info s (##sys#port-line port)) ) )))40804081 (define (r-xtoken k)4082 (define pkw ; check for prefix keyword immediately4083 (and (eq? ksp #:prefix)4084 (eq? #\: (##sys#peek-char-0 port))4085 (begin (##sys#read-char-0 port) #t)))4086 (let loop ((lst '()) (skw #f) (qtd #f))4087 (let ((c (##sys#peek-char-0 port)))4088 (cond ((or (eof-object? c)4089 (char-whitespace? c)4090 (memq c terminating-characters))4091 ;; The various cases here cover:4092 ;; - Nonempty keywords formed with colon in the ksp position4093 ;; - Empty keywords formed explicitly with vbar quotes4094 ;; - Bare colon, which should always be a symbol4095 (cond ((and skw (eq? ksp #:suffix) (or qtd (not (null? (cdr lst)))))4096 (k (##sys#reverse-list->string (cdr lst)) #t))4097 ((and pkw (or qtd (not (null? lst))))4098 (k (##sys#reverse-list->string lst) #t))4099 ((and pkw (not qtd) (null? lst))4100 (k ":" #f))4101 (else4102 (k (##sys#reverse-list->string lst) #f))))4103 ((memq c reserved-characters)4104 (reserved-character c))4105 (else4106 (let ((c (##sys#read-char-0 port)))4107 (case c4108 ((#\|)4109 (let ((part (r-string #\|)))4110 (loop (append (##sys#fast-reverse (##sys#string->list part)) lst)4111 #f #t)))4112 ((#\newline)4113 (##sys#read-warning4114 port "escaped symbol syntax spans multiple lines"4115 (##sys#reverse-list->string lst))4116 (loop (cons #\newline lst) #f qtd))4117 ((#\:)4118 (loop (cons #\: lst) #t qtd))4119 ((#\\)4120 (let ((c (##sys#read-char-0 port)))4121 (if (eof-object? c)4122 (##sys#read-error4123 port4124 "unexpected end of file while reading escaped character")4125 (loop (cons c lst) #f qtd))))4126 (else4127 (loop4128 (cons (if csp c (char-downcase c)) lst)4129 #f qtd)))))))))41304131 (define (r-char)4132 ;; Code contributed by Alex Shinn4133 (let* ([c (##sys#peek-char-0 port)]4134 [tk (r-token)]4135 [len (##sys#size tk)])4136 (cond [(fx> len 1)4137 (cond [(and (or (char=? #\x c) (char=? #\u c) (char=? #\U c))4138 (##sys#string->number (##sys#substring tk 1 len) 16) )4139 => (lambda (n) (integer->char n)) ]4140 [(and-let* ((c0 (char->integer (##core#inline "C_subchar" tk 0)))4141 ((fx<= #xC0 c0)) ((fx<= c0 #xF7))4142 (n0 (fxand (fxshr c0 4) 3))4143 (n (fx+ 2 (fxand (fxior n0 (fxshr n0 1)) (fx- n0 1))))4144 ((fx= len n))4145 (res (fx+ (fxshl (fxand c0 (fx- (fxshl 1 (fx- 8 n)) 1))4146 6)4147 (fxand (char->integer4148 (##core#inline "C_subchar" tk 1))4149 #b111111))))4150 (cond ((fx>= n 3)4151 (set! res (fx+ (fxshl res 6)4152 (fxand4153 (char->integer4154 (##core#inline "C_subchar" tk 2))4155 #b111111)))4156 (if (fx= n 4)4157 (set! res (fx+ (fxshl res 6)4158 (fxand (char->integer4159 (##core#inline "C_subchar" tk 3))4160 #b111111))))))4161 (integer->char res))]4162 [(char-name (##sys#intern-symbol tk))]4163 [else (##sys#read-error port "unknown named character" tk)] ) ]4164 [(memq c terminating-characters) (##sys#read-char-0 port)]4165 [else c] ) ) )41664167 (define (r-comment)4168 (let loop ((i 0))4169 (let ((c (##sys#read-char-0 port)))4170 (case c4171 ((#\|) (if (eq? #\# (##sys#read-char-0 port))4172 (if (not (eq? i 0))4173 (loop (fx- i 1)) )4174 (loop i) ) )4175 ((#\#) (loop (if (eq? #\| (##sys#read-char-0 port))4176 (fx+ i 1)4177 i) ) )4178 (else (if (eof-object? c)4179 (##sys#read-error port "unterminated block-comment")4180 (loop i) ) ) ) ) ) )41814182 (define (r-ext-symbol)4183 (let ((tok (r-token)))4184 (build-symbol (string-append "##" tok))))41854186 (define (r-quote q)4187 (let ((ln (##sys#port-line port)))4188 (info 'list-info (list q (readrec)) ln)))41894190 (define (build-symbol tok)4191 (##sys#intern-symbol tok) )41924193 (define (build-keyword tok)4194 (##sys#intern-keyword tok))41954196 ;; now have the state to make a decision.4197 (set! reserved-characters4198 (append (if (not psp) '(#\[ #\] #\{ #\}) '())4199 (if (not sep) '(#\|) '())))42004201 (r-spaces)4202 (let* ((c (##sys#peek-char-0 port))4203 (srst (##sys#slot crt 1))4204 (h (and (not (eof-object? c)) srst4205 (##sys#slot srst (char->integer c)) ) ) )4206 (if h4207 ;; then handled by read-table entry4208 (##sys#call-with-values4209 (lambda () (h c port))4210 (lambda xs (if (null? xs) (readrec) (car xs))))4211 ;; otherwise chicken extended r5rs syntax4212 (case c4213 ((#\')4214 (##sys#read-char-0 port)4215 (r-quote 'quote))4216 ((#\`)4217 (##sys#read-char-0 port)4218 (r-quote 'quasiquote))4219 ((#\,)4220 (##sys#read-char-0 port)4221 (cond ((eq? (##sys#peek-char-0 port) #\@)4222 (##sys#read-char-0 port)4223 (r-quote 'unquote-splicing))4224 (else (r-quote 'unquote))))4225 ((#\#)4226 (##sys#read-char-0 port)4227 (let ((dchar (##sys#peek-char-0 port)))4228 (cond4229 ((eof-object? dchar)4230 (##sys#read-error4231 port "unexpected end of input after reading #-sign"))4232 ((char-numeric? dchar)4233 (let* ((n (string->number (r-digits)))4234 (dchar2 (##sys#peek-char-0 port))4235 (spdrst (##sys#slot crt 3))4236 (h (and (char? dchar2) spdrst4237 (##sys#slot spdrst (char->integer dchar2)) ) ) )4238 ;; #<num> handled by parameterized # read-table entry?4239 (cond ((eof-object? dchar2)4240 (##sys#read-error4241 port "unexpected end of input after reading"4242 c n))4243 (h (##sys#call-with-values4244 (lambda () (h dchar2 port n))4245 (lambda xs (if (null? xs) (readrec) (car xs)))))4246 ;; #<num>?4247 ((or (eq? dchar2 #\)) (char-whitespace? dchar2))4248 (##sys#sharp-number-hook port n))4249 (else (##sys#read-char-0 port) ; Consume it first4250 (##sys#read-error4251 port4252 "invalid parameterized read syntax"4253 c n dchar2) ) ) ))4254 (else (let* ((sdrst (##sys#slot crt 2))4255 (h (and sdrst (##sys#slot sdrst (char->integer dchar)) ) ) )4256 (if h4257 ;; then handled by # read-table entry4258 (##sys#call-with-values4259 (lambda () (h dchar port))4260 (lambda xs (if (null? xs) (readrec) (car xs))))4261 ;; otherwise chicken extended r5rs syntax4262 (case (char-downcase dchar)4263 ((#\x) (##sys#read-char-0 port) (r-number-with-exactness 16))4264 ((#\d) (##sys#read-char-0 port) (r-number-with-exactness 10))4265 ((#\o) (##sys#read-char-0 port) (r-number-with-exactness 8))4266 ((#\b) (##sys#read-char-0 port) (r-number-with-exactness 2))4267 ((#\i) (##sys#read-char-0 port) (r-number-with-radix 'i))4268 ((#\e) (##sys#read-char-0 port) (r-number-with-radix 'e))4269 ((#\c)4270 (##sys#read-char-0 port)4271 (let ([c (##sys#read-char-0 port)])4272 (fluid-let ([csp4273 (cond [(eof-object? c)4274 (##sys#read-error port "unexpected end of input while reading `#c...' sequence")]4275 [(eq? c #\i) #f]4276 [(eq? c #\s) #t]4277 [else (##sys#read-error port "invalid case specifier in `#c...' sequence" c)] ) ] )4278 (readrec) ) ) )4279 ((#\() (r-vector))4280 ((#\\) (##sys#read-char-0 port) (r-char))4281 ((#\|)4282 (##sys#read-char-0 port)4283 (r-comment) (readrec) )4284 ((#\#)4285 (##sys#read-char-0 port)4286 (r-ext-symbol) )4287 ((#\;)4288 (##sys#read-char-0 port)4289 (readrec) (readrec) )4290 ((#\`)4291 (##sys#read-char-0 port)4292 (r-quote 'quasisyntax))4293 ((#\$)4294 (##sys#read-char-0 port)4295 (let ((c (##sys#peek-char-0 port)))4296 (cond ((char=? c #\{)4297 (##sys#read-char-0 port)4298 (##sys#read-bytevector-literal port))4299 (else4300 ;; HACK: reuse r-quote to add line number info4301 (r-quote 'location)))))4302 ((#\:)4303 (##sys#read-char-0 port)4304 (let ((c (##sys#peek-char-0 port)))4305 (fluid-let ((ksp #f))4306 (r-xtoken4307 (lambda (str kw)4308 (if (and (eq? 0 (##sys#size str))4309 (not (char=? c #\|)))4310 (##sys#read-error port "empty keyword")4311 (build-keyword str)))))))4312 ((#\+)4313 (##sys#read-char-0 port)4314 (let* ((ln (##sys#port-line port))4315 (tst (readrec)))4316 (info 'list-info4317 (list 'cond-expand (list tst (readrec)) '(else))4318 ln)))4319 ((#\!)4320 (##sys#read-char-0 port)4321 (let ((c (##sys#peek-char-0 port)))4322 (cond ((and (char? c)4323 (or (char-whitespace? c) (char=? #\/ c)))4324 (skip-to-eol)4325 (readrec) )4326 (else4327 (let ([tok (r-token)])4328 (cond [(string=? "eof" tok) #!eof]4329 ;; TODO: use #!bwp when we have a bootstrapping compiler whose reader supports it4330 [(string=? "bwp" tok) (foreign-value "C_SCHEME_BROKEN_WEAK_PTR" scheme-object)]4331 [(member tok '("optional" "rest" "key"))4332 (build-symbol (##sys#string-append "#!" tok)) ]4333 [else4334 (let ((a (assq (string->symbol tok) ##sys#read-marks)))4335 (if a4336 ((##sys#slot a 1) port)4337 (##sys#read-error4338 port4339 "invalid `#!' token" tok) ) ) ] ) ) ) ) ) )4340 (else4341 (##sys#call-with-values (lambda () (##sys#user-read-hook dchar port))4342 (lambda xs (if (null? xs) (readrec) (car xs)))) ) ) ) )) ) ) )4343 ((#\() (r-list #\( #\)))4344 ((#\)) (##sys#read-char-0 port) (container c))4345 ((#\") (##sys#read-char-0 port) (r-string #\"))4346 ((#\.) (r-number #f #f))4347 ((#\- #\+) (r-number #f #f))4348 (else4349 (cond [(eof-object? c) c]4350 [(char-numeric? c) (r-number #f #f)]4351 ((memq c reserved-characters)4352 (reserved-character c))4353 (else4354 (case c4355 ((#\[) (r-list #\[ #\]))4356 ((#\{) (r-list #\{ #\}))4357 ((#\] #\}) (##sys#read-char-0 port) (container c))4358 (else (r-symbol) ) ) ) ) ) ) ) ) )43594360 (readrec) ) ) ) )436143624363;;; This is taken from Alex Shinn's UTF8 egg:43644365(define (##sys#char->utf8-string c)4366 (let ([i (char->integer c)])4367 (cond [(fx<= i #x7F)4368 (string c) ]4369 [(fx<= i #x7FF)4370 (string (integer->char (fxior #b11000000 (fxshr i 6)))4371 (integer->char (fxior #b10000000 (fxand i #b111111)))) ]4372 [(fx<= i #xFFFF)4373 (string (integer->char (fxior #b11100000 (fxshr i 12)))4374 (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))4375 (integer->char (fxior #b10000000 (fxand i #b111111)))) ]4376 [(fx<= i #x1FFFFF)4377 (string (integer->char (fxior #b11110000 (fxshr i 18)))4378 (integer->char (fxior #b10000000 (fxand (fxshr i 12) #b111111)))4379 (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))4380 (integer->char (fxior #b10000000 (fxand i #b111111)))) ]4381 [else4382 (error "UTF-8 codepoint out of range:" i) ] ) ) )43834384(define (##sys#unicode-surrogate? n)4385 (and (fx<= #xD800 n) (fx<= n #xDFFF)) )43864387;; returns #f if the inputs are not a valid surrogate pair (hi followed by lo)4388(define (##sys#surrogates->codepoint hi lo)4389 (and (fx<= #xD800 hi) (fx<= hi #xDBFF)4390 (fx<= #xDC00 lo) (fx<= lo #xDFFF)4391 (fxior (fxshl (fx+ 1 (fxand (fxshr hi 6) #b11111)) 16)4392 (fxior (fxshl (fxand hi #b111111) 10)4393 (fxand lo #b1111111111)))) )43944395(define (##sys#read-bytevector-literal port)4396 (define (hex c)4397 (let ((c (char-downcase c)))4398 (cond ((and (char>=? c #\a) (char<=? c #\f))4399 (fx- (char->integer c) 87) ) ; - #\a + 104400 ((and (char>=? c #\0) (char<=? c #\9))4401 (fx- (char->integer c) 48))4402 (else (##sys#read-error port "invalid hex-code in blob-literal")))))4403 (let loop ((lst '()) (h #f))4404 (let ((c (##sys#read-char-0 port)))4405 (cond ((eof-object? c)4406 (##sys#read-error port "unexpected end of blob literal"))4407 ((char=? #\} c)4408 (let ((str (##sys#reverse-list->string4409 (if h4410 (cons (integer->char (fxshr h 4)) lst)4411 lst))))4412 (##core#inline "C_string_to_bytevector" str)4413 str))4414 ((char-whitespace? c)4415 (if h4416 (loop (cons (integer->char (fxshr h 4)) lst) #f)4417 (loop lst h)))4418 (h (loop (cons (integer->char (fxior h (hex c))) lst) #f))4419 (else (loop lst (fxshl (hex c) 4)))))))442044214422;;; Hooks for user-defined read-syntax:4423;4424; - Redefine this to handle new read-syntaxes. If 'char' doesn't match4425; your character then call the previous handler.4426; - Don't forget to read 'char', it's only peeked at this point.44274428(define (##sys#user-read-hook char port)4429 (case char4430 ;; I put it here, so the SRFI-4 unit can intercept '#f...'4431 ((#\f #\F) (##sys#read-char-0 port) #f)4432 ((#\t #\T) (##sys#read-char-0 port) #t)4433 (else (##sys#read-error port "invalid sharp-sign read syntax" char) ) ) )443444354436;;; Table for specially-handled read-syntax:4437;4438; - entries should be #f or a 256-element vector containing procedures4439; - each procedure is called with two arguments, a char (peeked) and a4440; port, and should return an expression44414442(define ##sys#read-marks '()) ; TODO move to read-syntax module444344444445;;; Output:44464447(define (##sys#write-char-0 c p)4448 ((##sys#slot (##sys#slot p 2) 2) p c)4449 (##sys#void))44504451(define (##sys#write-char/port c port)4452 (##sys#check-output-port port #t 'write-char)4453 (##sys#check-char c 'write-char)4454 (##sys#write-char-0 c port) )44554456(set! scheme#write-char4457 (lambda (c #!optional (port ##sys#standard-output))4458 (##sys#check-char c 'write-char)4459 (##sys#check-output-port port #t 'write-char)4460 (##sys#write-char-0 c port) ))44614462(set! scheme#newline4463 (lambda (#!optional (port ##sys#standard-output))4464 (##sys#write-char/port #\newline port) ))44654466(set! scheme#write4467 (lambda (x #!optional (port ##sys#standard-output))4468 (##sys#check-output-port port #t 'write)4469 (##sys#print x #t port) ))44704471(set! scheme#display4472 (lambda (x #!optional (port ##sys#standard-output))4473 (##sys#check-output-port port #t 'display)4474 (##sys#print x #f port) ))44754476(define-inline (*print-each lst)4477 (for-each (cut ##sys#print <> #f ##sys#standard-output) lst) )44784479(set! chicken.base#print4480 (lambda args4481 (##sys#check-output-port ##sys#standard-output #t 'print)4482 (*print-each args)4483 (##sys#write-char-0 #\newline ##sys#standard-output)4484 (void)))44854486(set! chicken.base#print*4487 (lambda args4488 (##sys#check-output-port ##sys#standard-output #t 'print)4489 (*print-each args)4490 (##sys#flush-output ##sys#standard-output)4491 (void)))44924493(define current-print-length (make-parameter 0))4494(define ##sys#print-length-limit (make-parameter #f))4495(define ##sys#print-exit (make-parameter #f))44964497(define ##sys#print4498 (let ((case-sensitive case-sensitive)4499 (keyword-style keyword-style))4500 (lambda (x readable port)4501 (##sys#check-output-port port #t #f)4502 (let ([csp (case-sensitive)]4503 [ksp (keyword-style)]4504 [length-limit (##sys#print-length-limit)]4505 [special-characters '(#\( #\) #\, #\[ #\] #\{ #\} #\' #\" #\; #\ #\` #\| #\\)] )45064507 (define (outstr port str)4508 (if length-limit4509 (let* ((len (##sys#size str))4510 (cpp0 (current-print-length))4511 (cpl (fx+ cpp0 len)) )4512 (if (fx> cpl length-limit)4513 (let ((n (fx- length-limit cpp0)))4514 (when (fx> n 0) (outstr0 port (##sys#substring str 0 n)))4515 (outstr0 port "...")4516 ((##sys#print-exit) (##sys#void)))4517 (outstr0 port str) )4518 (current-print-length cpl) )4519 (outstr0 port str) ) )45204521 (define (outstr0 port str)4522 ((##sys#slot (##sys#slot port 2) 3) port str) )45234524 (define (outchr port chr)4525 (when length-limit4526 (let ((cpp0 (current-print-length)))4527 (current-print-length (fx+ cpp0 1))4528 (when (fx>= cpp0 length-limit)4529 (outstr0 port "...")4530 ((##sys#print-exit) (##sys#void)))))4531 ((##sys#slot (##sys#slot port 2) 2) port chr))45324533 (define (specialchar? chr)4534 (let ([c (char->integer chr)])4535 (or (fx<= c 32)4536 (memq chr special-characters) ) ) )45374538 (define (outsym port sym)4539 (let ((str (##sys#symbol->string sym)))4540 (if (or (not readable) (sym-is-readable? str))4541 (outstr port str)4542 (outreadablesym port str))))45434544 (define (outreadablesym port str)4545 (let ((len (##sys#size str)))4546 (outchr port #\|)4547 (let loop ((i 0))4548 (if (fx>= i len)4549 (outchr port #\|)4550 (let ((c (##core#inline "C_subchar" str i)))4551 (cond ((or (char<? c #\space) (char>? c #\~))4552 (outstr port "\\x")4553 (let ((n (char->integer c)))4554 (when (fx< n 16) (outchr port #\0))4555 (outstr port (##sys#number->string n 16))4556 (loop (fx+ i 1))))4557 (else4558 (when (or (eq? c #\|) (eq? c #\\)) (outchr port #\\))4559 (outchr port c)4560 (loop (fx+ i 1)) ) ) ) ) )))45614562 (define (sym-is-readable? str)4563 (let ((len (##sys#size str)))4564 (cond ((eq? len 0) #f)4565 ((eq? len 1)4566 (let ((c (##core#inline "C_subchar" str 0)))4567 (cond ((or (eq? #\# c) (eq? #\. c)) #f)4568 ((specialchar? c) #f)4569 ((char-numeric? c) #f)4570 (else #t))))4571 (else4572 (let loop ((i (fx- len 1)))4573 (if (eq? i 0)4574 (let ((c (##core#inline "C_subchar" str 0)))4575 (cond ((or (char-numeric? c)4576 (eq? c #\+)4577 (eq? c #\.)4578 (eq? c #\-) )4579 (not (##sys#string->number str)) )4580 ((eq? c #\:) #f)4581 ((and (eq? c #\#)4582 ;; Not a qualified symbol?4583 (not (and (fx> len 2)4584 (eq? (##core#inline "C_subchar" str 1) #\#)4585 (not (eq? (##core#inline "C_subchar" str 2) #\#)))))4586 (member str '("#!rest" "#!key" "#!optional")))4587 ((specialchar? c) #f)4588 (else #t) ) )4589 (let ((c (##core#inline "C_subchar" str i)))4590 (and (or csp (not (char-upper-case? c)))4591 (not (specialchar? c))4592 (or (not (eq? c #\:))4593 (fx< i (fx- len 1)))4594 (loop (fx- i 1)) ) ) ) ) ) ) ) )45954596 (let out ([x x])4597 (cond ((eq? x '()) (outstr port "()"))4598 ((eq? x #t) (outstr port "#t"))4599 ((eq? x #f) (outstr port "#f"))4600 ((##core#inline "C_eofp" x) (outstr port "#!eof"))4601 ((##core#inline "C_undefinedp" x) (outstr port "#<unspecified>"))4602 ((##core#inline "C_bwpp" x) (outstr port "#!bwp"))4603 ((##core#inline "C_charp" x)4604 (cond [readable4605 (outstr port "#\\")4606 (let ([code (char->integer x)])4607 (cond [(char-name x)4608 => (lambda (cn)4609 (outstr port (##sys#slot cn 1)) ) ]4610 [(or (fx< code 32) (fx> code 255))4611 (outchr port #\x)4612 (outstr port (##sys#number->string code 16)) ]4613 [else (outchr port x)] ) ) ]4614 [else (outchr port x)] ) )4615 ((##core#inline "C_fixnump" x) (outstr port (##sys#number->string x)))4616 ((##core#inline "C_unboundvaluep" x) (outstr port "#<unbound value>"))4617 ((not (##core#inline "C_blockp" x)) (outstr port "#<invalid immediate object>"))4618 ((##core#inline "C_forwardedp" x) (outstr port "#<invalid forwarded object>"))4619 ((##core#inline "C_i_keywordp" x)4620 ;; Force portable #: style for readable output4621 (case (and (not readable) ksp)4622 ((#:prefix)4623 (outchr port #\:)4624 (outsym port x))4625 ((#:suffix)4626 (outsym port x)4627 (outchr port #\:))4628 (else4629 (outstr port "#:")4630 (outsym port x))))4631 ((##core#inline "C_i_symbolp" x) (outsym port x))4632 ((##sys#number? x) (outstr port (##sys#number->string x)))4633 ((##core#inline "C_anypointerp" x) (outstr port (##sys#pointer->string x)))4634 ((##core#inline "C_stringp" x)4635 (cond (readable4636 (outchr port #\")4637 (do ((i 0 (fx+ i 1))4638 (c (##core#inline "C_block_size" x) (fx- c 1)) )4639 ((eq? c 0)4640 (outchr port #\") )4641 (let ((chr (##core#inline "C_subbyte" x i)))4642 (case chr4643 ((34) (outstr port "\\\""))4644 ((92) (outstr port "\\\\"))4645 (else4646 (cond ((or (fx< chr 32)4647 (fx= chr 127))4648 (outchr port #\\)4649 (case chr4650 ((7) (outchr port #\a))4651 ((8) (outchr port #\b))4652 ((9) (outchr port #\t))4653 ((10) (outchr port #\n))4654 ((11) (outchr port #\v))4655 ((12) (outchr port #\f))4656 ((13) (outchr port #\r))4657 (else4658 (outchr port #\x)4659 (when (fx< chr 16) (outchr port #\0))4660 (outstr port (##sys#number->string chr 16)) ) ) )4661 (else (outchr port (##core#inline "C_fix_to_char" chr)) ) ) ) ) ) ) )4662 (else (outstr port x)) ) )4663 ((##core#inline "C_pairp" x)4664 (outchr port #\()4665 (out (##sys#slot x 0))4666 (do ((x (##sys#slot x 1) (##sys#slot x 1)))4667 ((or (not (##core#inline "C_blockp" x)) (not (##core#inline "C_pairp" x)))4668 (if (not (eq? x '()))4669 (begin4670 (outstr port " . ")4671 (out x) ) )4672 (outchr port #\)) )4673 (outchr port #\space)4674 (out (##sys#slot x 0)) ) )4675 ((##core#inline "C_bytevectorp" x)4676 (outstr port "#${")4677 (let ((len (##sys#size x)))4678 (do ((i 0 (fx+ i 1)))4679 ((fx>= i len))4680 (let ((b (##sys#byte x i)))4681 (when (fx< b 16)4682 (outchr port #\0))4683 (outstr port (##sys#number->string b 16)))))4684 (outchr port #\}) )4685 ((##core#inline "C_structurep" x) (##sys#user-print-hook x readable port))4686 ((##core#inline "C_closurep" x) (outstr port (##sys#procedure->string x)))4687 ((##core#inline "C_locativep" x) (outstr port "#<locative>"))4688 ((##core#inline "C_lambdainfop" x)4689 (outstr port "#<lambda info ")4690 (outstr port (##sys#lambda-info->string x))4691 (outchr port #\>) )4692 ((##core#inline "C_portp" x)4693 (case (##sys#slot x 1)4694 ((1) (outstr port "#<input port \""))4695 ((2) (outstr port "#<output port \""))4696 (else (outstr port "#<port \"")))4697 (outstr port (##sys#slot x 3))4698 (outstr port "\">") )4699 ((##core#inline "C_vectorp" x)4700 (let ((n (##core#inline "C_block_size" x)))4701 (cond ((eq? 0 n)4702 (outstr port "#()") )4703 (else4704 (outstr port "#(")4705 (out (##sys#slot x 0))4706 (do ((i 1 (fx+ i 1))4707 (c (fx- n 1) (fx- c 1)) )4708 ((eq? c 0)4709 (outchr port #\)) )4710 (outchr port #\space)4711 (out (##sys#slot x i)) ) ) ) ) )4712 (else (##sys#error "unprintable block object encountered")))))4713 (##sys#void))))47144715(define ##sys#procedure->string4716 (let ((string-append string-append))4717 (lambda (x)4718 (let ((info (##sys#lambda-info x)))4719 (if info4720 (string-append "#<procedure " (##sys#lambda-info->string info) ">")4721 "#<procedure>") ) ) ) )47224723(define ##sys#record-printers '())47244725(set! chicken.base#record-printer4726 (lambda (type)4727 (##sys#check-symbol type 'record-printer)4728 (let ((a (assq type ##sys#record-printers)))4729 (and a (cdr a)))))47304731(set! chicken.base#set-record-printer!4732 (lambda (type proc)4733 (##sys#check-symbol type 'set-record-printer!)4734 (##sys#check-closure proc 'set-record-printer!)4735 (let ((a (assq type ##sys#record-printers)))4736 (if a4737 (##sys#setslot a 1 proc)4738 (set! ##sys#record-printers (cons (cons type proc) ##sys#record-printers)))4739 (##core#undefined))))47404741;; OBSOLETE can be removed after bootstrapping4742(set! ##sys#register-record-printer chicken.base#set-record-printer!)47434744(set! chicken.base#record-printer4745 (getter-with-setter record-printer set-record-printer!))47464747(define (##sys#user-print-hook x readable port)4748 (let* ((type (##sys#slot x 0))4749 (a (assq type ##sys#record-printers)) )4750 (cond (a (handle-exceptions ex4751 (begin4752 (##sys#print "#<Error in printer of record type `" #f port)4753 (##sys#print (##sys#symbol->string type) #f port)4754 (if (##sys#structure? ex 'condition)4755 (and-let* ((a (member '(exn . message) (##sys#slot ex 2))))4756 (##sys#print "': " #f port)4757 (##sys#print (cadr a) #f port)4758 (##sys#write-char-0 #\> port))4759 (##sys#print "'>" #f port)))4760 ((##sys#slot a 1) x port)))4761 (else4762 (##sys#print "#<" #f port)4763 (##sys#print (##sys#symbol->string type) #f port)4764 (case type4765 ((condition)4766 (##sys#print ": " #f port)4767 (##sys#print (##sys#slot x 1) #f port) )4768 ((thread)4769 (##sys#print ": " #f port)4770 (##sys#print (##sys#slot x 6) #f port) ) )4771 (##sys#write-char-0 #\> port) ) ) ) )47724773(define ##sys#with-print-length-limit4774 (let ([call-with-current-continuation call-with-current-continuation])4775 (lambda (limit thunk)4776 (call-with-current-continuation4777 (lambda (return)4778 (parameterize ((##sys#print-length-limit limit)4779 (##sys#print-exit return)4780 (current-print-length 0))4781 (thunk)))))))478247834784;;; String ports:4785;4786; - Port-slots:4787;4788; Input:4789;4790; 10: position4791; 11: len4792; 12: string4793;4794; Output:4795;4796; 10: position4797; 11: limit4798; 12: output47994800(define ##sys#string-port-class4801 (letrec ([check4802 (lambda (p n)4803 (let* ([position (##sys#slot p 10)]4804 [limit (##sys#slot p 11)]4805 [output (##sys#slot p 12)]4806 [limit2 (fx+ position n)] )4807 (when (fx>= limit2 limit)4808 (when (fx>= limit2 maximal-string-length)4809 (##sys#error "string buffer full" p) )4810 (let* ([limit3 (fxmin maximal-string-length (fx+ limit limit))]4811 [buf (##sys#make-string limit3)] )4812 (##sys#copy-bytes output buf 0 0 position)4813 (##sys#setslot p 12 buf)4814 (##sys#setislot p 11 limit3)4815 (check p n) ) ) ) ) ] )4816 (vector4817 (lambda (p) ; read-char4818 (let ([position (##sys#slot p 10)]4819 [string (##sys#slot p 12)]4820 [len (##sys#slot p 11)] )4821 (if (fx>= position len)4822 #!eof4823 (let ((c (##core#inline "C_subchar" string position)))4824 (##sys#setislot p 10 (fx+ position 1))4825 c) ) ) )4826 (lambda (p) ; peek-char4827 (let ([position (##sys#slot p 10)]4828 [string (##sys#slot p 12)]4829 [len (##sys#slot p 11)] )4830 (if (fx>= position len)4831 #!eof4832 (##core#inline "C_subchar" string position) ) ) )4833 (lambda (p c) ; write-char4834 (check p 1)4835 (let ([position (##sys#slot p 10)]4836 [output (##sys#slot p 12)] )4837 (##core#inline "C_setsubchar" output position c)4838 (##sys#setislot p 10 (fx+ position 1)) ) )4839 (lambda (p str) ; write-string4840 (let ([len (##core#inline "C_block_size" str)])4841 (check p len)4842 (let ([position (##sys#slot p 10)]4843 [output (##sys#slot p 12)] )4844 (##core#inline "C_substring_copy" str output 0 len position)4845 (##sys#setislot p 10 (fx+ position len)) ) ) )4846 void ; close4847 (lambda (p) #f) ; flush-output4848 (lambda (p) #t) ; char-ready?4849 (lambda (p n dest start) ; read-string!4850 (let* ((pos (##sys#slot p 10))4851 (n2 (fx- (##sys#slot p 11) pos) ) )4852 (when (or (not n) (fx> n n2)) (set! n n2))4853 (##core#inline "C_substring_copy" (##sys#slot p 12) dest pos (fx+ pos n) start)4854 (##sys#setislot p 10 (fx+ pos n))4855 n))4856 (lambda (p limit) ; read-line4857 (let* ((pos (##sys#slot p 10))4858 (size (##sys#slot p 11))4859 (buf (##sys#slot p 12))4860 (end (if limit (fx+ pos limit) size)))4861 (if (fx>= pos size)4862 #!eof4863 (receive (next line full-line?)4864 (##sys#scan-buffer-line4865 buf (if (fx> end size) size end) pos4866 (lambda (pos) (values #f pos #f) ) )4867 ;; Update row & column position4868 (if full-line?4869 (begin4870 (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))4871 (##sys#setislot p 5 0))4872 (##sys#setislot p 5 (fx+ (##sys#slot p 5) (##sys#size line))))4873 (##sys#setislot p 10 next)4874 line) ) ) )4875 (lambda (p) ; read-buffered4876 (let ((pos (##sys#slot p 10))4877 (string (##sys#slot p 12))4878 (len (##sys#slot p 11)) )4879 (if (fx>= pos len)4880 ""4881 (let ((buffered (##sys#substring string pos len)))4882 (##sys#setislot p 10 len)4883 buffered))))4884 )))48854886;; Invokes the eos handler when EOS is reached to get more data.4887;; The eos-handler is responsible for stopping, either when EOF is hit or4888;; a user-supplied limit is reached (ie, it's indistinguishable from EOF)4889(define (##sys#scan-buffer-line buf limit start-pos eos-handler)4890 (define (copy&append buf offset pos old-line)4891 (let* ((old-line-len (##sys#size old-line))4892 (new-line (##sys#make-string (fx+ old-line-len (fx- pos offset)))))4893 (##core#inline "C_substring_copy" old-line new-line 0 old-line-len 0)4894 (##core#inline "C_substring_copy" buf new-line offset pos old-line-len)4895 new-line))4896 (let loop ((buf buf)4897 (offset start-pos)4898 (pos start-pos)4899 (limit limit)4900 (line ""))4901 (if (fx= pos limit)4902 (let ((line (copy&append buf offset pos line)))4903 (receive (buf offset limit) (eos-handler pos)4904 (if buf4905 (loop buf offset offset limit line)4906 (values offset line #f))))4907 (let ((c (##core#inline "C_subchar" buf pos)))4908 (cond ((eq? c #\newline)4909 (values (fx+ pos 1) (copy&append buf offset pos line) #t))4910 ((and (eq? c #\return) ; \r\n -> drop \r from string4911 (fx> limit (fx+ pos 1))4912 (eq? (##core#inline "C_subchar" buf (fx+ pos 1)) #\newline))4913 (values (fx+ pos 2) (copy&append buf offset pos line) #t))4914 ((and (eq? c #\return) ; Edge case (#568): \r{read}[\n|xyz]4915 (fx= limit (fx+ pos 1)))4916 (let ((line (copy&append buf offset pos line)))4917 (receive (buf offset limit) (eos-handler pos)4918 (if buf4919 (if (eq? (##core#inline "C_subchar" buf offset) #\newline)4920 (values (fx+ offset 1) line #t)4921 ;; "Restore" \r we didn't copy, loop w/ new string4922 (loop buf offset offset limit4923 (##sys#string-append line "\r")))4924 ;; Restore \r here, too (when we reached EOF)4925 (values offset (##sys#string-append line "\r") #t)))))4926 ((eq? c #\return)4927 (values (fx+ pos 1) (copy&append buf offset pos line) #t))4928 (else (loop buf offset (fx+ pos 1) limit line)) ) ) ) ) )49294930(set! chicken.base#open-input-string4931 (lambda (string)4932 (##sys#check-string string 'open-input-string)4933 (let ((port (##sys#make-port 1 ##sys#string-port-class "(string)" 'string)))4934 (##sys#setislot port 11 (##core#inline "C_block_size" string))4935 (##sys#setislot port 10 0)4936 (##sys#setslot port 12 string)4937 port)))49384939(set! chicken.base#open-output-string4940 (lambda ()4941 (let ((port (##sys#make-port 2 ##sys#string-port-class "(string)" 'string)))4942 (##sys#setislot port 10 0)4943 (##sys#setislot port 11 output-string-initial-size)4944 (##sys#setslot port 12 (##sys#make-string output-string-initial-size))4945 port)))49464947(set! chicken.base#get-output-string4948 (lambda (port)4949 (##sys#check-output-port port #f 'get-output-string)4950 (if (not (eq? 'string (##sys#slot port 7)))4951 (##sys#signal-hook4952 #:type-error 'get-output-string "argument is not a string-output-port" port)4953 (##sys#substring (##sys#slot port 12) 0 (##sys#slot port 10)))))49544955(define ##sys#print-to-string4956 (let ([get-output-string get-output-string]4957 [open-output-string open-output-string] )4958 (lambda (xs)4959 (let ([out (open-output-string)])4960 (for-each (lambda (x) (##sys#print x #f out)) xs)4961 (get-output-string out) ) ) ) )49624963(define ##sys#pointer->string4964 (let ((string-append string-append))4965 (lambda (x)4966 (if (##core#inline "C_taggedpointerp" x)4967 (string-append4968 "#<tagged pointer "4969 (##sys#print-to-string4970 (let ((tag (##sys#slot x 1)))4971 (list (if (pair? tag) (car tag) tag) ) ) )4972 " "4973 (##sys#number->string (##sys#pointer->address x) 16)4974 ">")4975 (string-append "#<pointer 0x" (##sys#number->string (##sys#pointer->address x) 16) ">") ) ) ) )497649774978;;; Access backtrace:49794980(define-constant +trace-buffer-entry-slot-count+ 5)49814982(set! chicken.base#get-call-chain4983 (let ((extract4984 (foreign-lambda* nonnull-c-string ((scheme-object x)) "C_return((C_char *)x);")))4985 (lambda (#!optional (start 0) (thread ##sys#current-thread))4986 (let* ((tbl (foreign-value "C_trace_buffer_size" int))4987 ;; 5 slots: "raw" location (for compiled code), "cooked" location (for interpreted code), cooked1, cooked2, thread4988 (c +trace-buffer-entry-slot-count+)4989 (vec (##sys#make-vector (fx* c tbl) #f))4990 (r (##core#inline "C_fetch_trace" start vec))4991 (n (if (fixnum? r) r (fx* c tbl)))4992 (t-id (and thread (##sys#slot thread 14))))4993 (let loop ((i 0))4994 (if (fx>= i n)4995 '()4996 (let ((t (##sys#slot vec (fx+ i 4)))) ; thread id4997 (if (or (not t) (not thread) (eq? t-id t))4998 (cons (vector4999 (or (##sys#slot vec (fx+ i 1)) ; cooked_location5000 (extract (##sys#slot vec i))) ; raw_location5001 (##sys#slot vec (fx+ i 2)) ; cooked15002 (##sys#slot vec (fx+ i 3))) ; cooked25003 (loop (fx+ i c)))5004 (loop (fx+ i c))))))))))50055006(define (##sys#really-print-call-chain port chain header)5007 (when (pair? chain)5008 (##sys#print header #f port)5009 (for-each5010 (lambda (info)5011 (let* ((more1 (##sys#slot info 1)) ; cooked1 (expr/form)5012 (more2 (##sys#slot info 2)) ; cooked2 (cntr/frameinfo)5013 (fi (##sys#structure? more2 'frameinfo)))5014 (##sys#print "\n\t" #f port)5015 (##sys#print (##sys#slot info 0) #f port) ; raw (mode)5016 (##sys#print "\t " #f port)5017 (when (and more2 (if fi (##sys#slot more2 1)))5018 (##sys#write-char-0 #\[ port)5019 (##sys#print5020 (if fi5021 (##sys#slot more2 1) ; cntr5022 more2)5023 #f port)5024 (##sys#print "] " #f port))5025 (when more15026 (##sys#with-print-length-limit5027 1005028 (lambda ()5029 (##sys#print more1 #t port))))))5030 chain)5031 (##sys#print "\t<--\n" #f port)))50325033(set! chicken.base#print-call-chain5034 (lambda (#!optional (port ##sys#standard-output) (start 0)5035 (thread ##sys#current-thread)5036 (header "\n\tCall history:\n"))5037 (##sys#check-output-port port #t 'print-call-chain)5038 (##sys#check-fixnum start 'print-call-chain)5039 (##sys#check-string header 'print-call-chain)5040 (##sys#really-print-call-chain port (get-call-chain start thread) header)))504150425043;;; Interrupt handling:50445045(define (##sys#user-interrupt-hook)5046 (define (break) (##sys#signal-hook #:user-interrupt #f))5047 (if (eq? ##sys#current-thread ##sys#primordial-thread)5048 (break)5049 (##sys#setslot ##sys#primordial-thread 1 break) ) )505050515052;;; Default handlers50535054(define-foreign-variable _ex_software int "EX_SOFTWARE")50555056(define exit-in-progress #f)50575058(define (cleanup-before-exit)5059 (set! exit-in-progress #t)5060 (when (##core#inline "C_i_dump_heap_on_exitp")5061 (##sys#print "\n" #f ##sys#standard-error)5062 (##sys#dump-heap-state))5063 (when (##core#inline "C_i_profilingp")5064 (##core#inline "C_i_dump_statistical_profile"))5065 (let loop ()5066 (let ((tasks chicken.base#cleanup-tasks))5067 (set! chicken.base#cleanup-tasks '())5068 (unless (null? tasks)5069 (for-each (lambda (t) (t)) tasks)5070 (loop))))5071 (when (fx> (##sys#slot ##sys#pending-finalizers 0) 0)5072 (##sys#run-pending-finalizers #f))5073 (when (fx> (##core#inline "C_i_live_finalizer_count") 0)5074 (when (##sys#debug-mode?)5075 (##sys#print "[debug] forcing finalizers...\n" #f ##sys#standard-error))5076 (when (chicken.gc#force-finalizers)5077 (##sys#force-finalizers))))50785079(set! chicken.base#exit-handler5080 (make-parameter5081 (lambda (#!optional (code 0))5082 (##sys#check-fixnum code)5083 (cond (exit-in-progress5084 (##sys#warn "\"exit\" called while processing on-exit tasks"))5085 (else5086 (cleanup-before-exit)5087 (##core#inline "C_exit_runtime" code))))))50885089(set! chicken.base#implicit-exit-handler5090 (make-parameter5091 (lambda ()5092 (cleanup-before-exit))))50935094(define ##sys#reset-handler ; Exposed by chicken.repl5095 (make-parameter5096 (lambda ()5097 ((exit-handler) _ex_software))))509850995100;;; Condition handling:51015102(module chicken.condition5103 ;; NOTE: We don't emit the import lib. Due to syntax exports, it5104 ;; has to be a hardcoded primitive module.5105 (abort signal current-exception-handler5106 print-error-message with-exception-handler51075108 ;; [syntax] condition-case handle-exceptions51095110 ;; Condition object manipulation5111 make-property-condition make-composite-condition5112 condition condition? condition->list condition-predicate5113 condition-property-accessor get-condition-property)51145115(import scheme chicken.base chicken.fixnum chicken.foreign)5116(import chicken.internal.syntax)51175118(define (##sys#signal-hook/errno mode errno msg . args)5119 (##core#inline "C_dbg_hook" #f)5120 (##core#inline "signal_debug_event" mode msg args)5121 (case mode5122 [(#:user-interrupt)5123 (abort5124 (##sys#make-structure5125 'condition5126 '(user-interrupt)5127 '() ) ) ]5128 [(#:warning #:notice)5129 (##sys#print5130 (if (eq? mode #:warning) "\nWarning: " "\nNote: ")5131 #f ##sys#standard-error)5132 (##sys#print msg #f ##sys#standard-error)5133 (if (or (null? args) (fx> (length args) 1))5134 (##sys#write-char-0 #\newline ##sys#standard-error)5135 (##sys#print ": " #f ##sys#standard-error))5136 (for-each5137 (lambda (x)5138 (##sys#with-print-length-limit5139 4005140 (lambda ()5141 (##sys#print x #t ##sys#standard-error)5142 (##sys#write-char-0 #\newline ##sys#standard-error))))5143 args)5144 (##sys#flush-output ##sys#standard-error)]5145 (else5146 (when (and (symbol? msg) (null? args))5147 (set! msg (symbol->string msg)))5148 (let* ([hasloc (and (or (not msg) (symbol? msg)) (pair? args))]5149 [loc (and hasloc msg)]5150 [msg (if hasloc (##sys#slot args 0) msg)]5151 [args (if hasloc (##sys#slot args 1) args)] )5152 (abort5153 (##sys#make-structure5154 'condition5155 (case mode5156 [(#:type-error) '(exn type)]5157 [(#:syntax-error) '(exn syntax)]5158 [(#:bounds-error) '(exn bounds)]5159 [(#:arithmetic-error) '(exn arithmetic)]5160 [(#:file-error) '(exn i/o file)]5161 [(#:runtime-error) '(exn runtime)]5162 [(#:process-error) '(exn process)]5163 [(#:network-error) '(exn i/o net)]5164 [(#:network-timeout-error) '(exn i/o net timeout)]5165 [(#:limit-error) '(exn runtime limit)]5166 [(#:arity-error) '(exn arity)]5167 [(#:access-error) '(exn access)]5168 [(#:domain-error) '(exn domain)]5169 ((#:memory-error) '(exn memory))5170 [else '(exn)] )5171 (let ((props5172 (list '(exn . message) msg5173 '(exn . arguments) args5174 '(exn . call-chain) (get-call-chain)5175 '(exn . location) loc)))5176 (if errno5177 (cons '(exn . errno) (cons errno props))5178 props))))))))51795180(define (##sys#signal-hook mode msg . args)5181 (if (pair? args)5182 (apply ##sys#signal-hook/errno mode #f msg args)5183 (##sys#signal-hook/errno mode #f msg)))51845185(define (abort x)5186 (##sys#current-exception-handler x)5187 (abort5188 (##sys#make-structure5189 'condition5190 '(exn)5191 (list '(exn . message) "exception handler returned"5192 '(exn . arguments) '()5193 '(exn . location) #f) ) ) )51945195(define (signal x)5196 (##sys#current-exception-handler x) )51975198(define ##sys#error-handler5199 (make-parameter5200 (let ([string-append string-append])5201 (lambda (msg . args)5202 (##sys#error-handler (lambda args (##core#inline "C_halt" "error in error")))5203 (cond ((not (foreign-value "C_gui_mode" bool))5204 (##sys#print "\nError" #f ##sys#standard-error)5205 (when msg5206 (##sys#print ": " #f ##sys#standard-error)5207 (##sys#print msg #f ##sys#standard-error))5208 (##sys#with-print-length-limit5209 4005210 (lambda ()5211 (cond [(fx= 1 (length args))5212 (##sys#print ": " #f ##sys#standard-error)5213 (##sys#print (##sys#slot args 0) #t ##sys#standard-error)]5214 [else5215 (##sys#for-each5216 (lambda (x)5217 (##sys#print #\newline #f ##sys#standard-error)5218 (##sys#print x #t ##sys#standard-error))5219 args)])))5220 (##sys#print #\newline #f ##sys#standard-error)5221 (print-call-chain ##sys#standard-error)5222 (##core#inline "C_halt" #f))5223 (else5224 (let ((out (open-output-string)))5225 (when msg (##sys#print msg #f out))5226 (##sys#print #\newline #f out)5227 (##sys#for-each (lambda (x) (##sys#print x #t out) (##sys#print #\newline #f out)) args)5228 (##core#inline "C_halt" (get-output-string out)))))))))522952305231(define ##sys#last-exception #f) ; used in csi for ,exn command52325233(define ##sys#current-exception-handler5234 ;; Exception-handler for the primordial thread:5235 (let ((string-append string-append))5236 (lambda (c)5237 (when (##sys#structure? c 'condition)5238 (set! ##sys#last-exception c)5239 (let ((kinds (##sys#slot c 1)))5240 (cond ((memq 'exn kinds)5241 (let* ((props (##sys#slot c 2))5242 (msga (member '(exn . message) props))5243 (argsa (member '(exn . arguments) props))5244 (loca (member '(exn . location) props)) )5245 (apply5246 (##sys#error-handler)5247 (if msga5248 (let ((msg (cadr msga))5249 (loc (and loca (cadr loca))) )5250 (if (and loc (symbol? loc))5251 (string-append5252 "(" (##sys#symbol->string loc) ") "5253 (cond ((symbol? msg) (##sys#slot msg 1))5254 ((string? msg) msg)5255 (else "") ) ) ; Hm...5256 msg) )5257 "<exn: has no `message' property>")5258 (if argsa5259 (cadr argsa)5260 '() ) )5261 ;; in case error-handler returns, which shouldn't happen:5262 ((##sys#reset-handler)) ) )5263 ((eq? 'user-interrupt (##sys#slot kinds 0))5264 (##sys#print "\n*** user interrupt ***\n" #f ##sys#standard-error)5265 ((##sys#reset-handler)) )5266 ((eq? 'uncaught-exception (##sys#slot kinds 0))5267 ((##sys#error-handler)5268 "uncaught exception"5269 (cadr (member '(uncaught-exception . reason) (##sys#slot c 2))) )5270 ((##sys#reset-handler)) ) ) ) )5271 (abort5272 (##sys#make-structure5273 'condition5274 '(uncaught-exception)5275 (list '(uncaught-exception . reason) c)) ) ) ) )52765277(define (with-exception-handler handler thunk)5278 (let ([oldh ##sys#current-exception-handler])5279 (##sys#dynamic-wind5280 (lambda () (set! ##sys#current-exception-handler handler))5281 thunk5282 (lambda () (set! ##sys#current-exception-handler oldh)) ) ) )52835284;; TODO: Make this a proper parameter5285(define (current-exception-handler . args)5286 (if (null? args)5287 ##sys#current-exception-handler5288 (let ((proc (car args)))5289 (##sys#check-closure proc 'current-exception-handler)5290 (let-optionals (cdr args) ((convert? #t) (set? #t))5291 (when set? (set! ##sys#current-exception-handler proc)))5292 proc)))52935294;;; Condition object manipulation52955296(define (prop-list->kind-prefixed-prop-list loc kind plist)5297 (let loop ((props plist))5298 (cond ((null? props) '())5299 ((or (not (pair? props)) (not (pair? (cdr props))))5300 (##sys#signal-hook5301 #:type-error loc "argument is not an even property list" plist))5302 (else (cons (cons kind (car props))5303 (cons (cadr props)5304 (loop (cddr props))))))))53055306(define (make-property-condition kind . props)5307 (##sys#make-structure5308 'condition (list kind)5309 (prop-list->kind-prefixed-prop-list5310 'make-property-condition kind props)))53115312(define (make-composite-condition c1 . conds)5313 (let ([conds (cons c1 conds)])5314 (for-each (lambda (c) (##sys#check-structure c 'condition 'make-composite-condition)) conds)5315 (##sys#make-structure5316 'condition5317 (apply ##sys#append (map (lambda (c) (##sys#slot c 1)) conds))5318 (apply ##sys#append (map (lambda (c) (##sys#slot c 2)) conds)) ) ) )53195320(define (condition arg1 . args)5321 (let* ((args (cons arg1 args))5322 (keys (apply ##sys#append5323 (map (lambda (c)5324 (prop-list->kind-prefixed-prop-list5325 'condition (car c) (cdr c)))5326 args))))5327 (##sys#make-structure 'condition (map car args) keys)))53285329(define (condition? x) (##sys#structure? x 'condition))53305331(define (condition->list x)5332 (unless (condition? x)5333 (##sys#signal-hook5334 #:type-error 'condition->list5335 "argument is not a condition object" x))5336 (map (lambda (k)5337 (cons k (let loop ((props (##sys#slot x 2)))5338 (cond ((null? props) '())5339 ((eq? (caar props) k)5340 (cons (cdar props)5341 (cons (cadr props)5342 (loop (cddr props)))))5343 (else5344 (loop (cddr props)))))))5345 (##sys#slot x 1)))53465347(define (condition-predicate kind)5348 (lambda (c)5349 (and (condition? c)5350 (if (memv kind (##sys#slot c 1)) #t #f)) ) )53515352(define (condition-property-accessor kind prop . err-def)5353 (let ((err? (null? err-def))5354 (k+p (cons kind prop)) )5355 (lambda (c)5356 (##sys#check-structure c 'condition)5357 (and (memv kind (##sys#slot c 1))5358 (let ([a (member k+p (##sys#slot c 2))])5359 (cond [a (cadr a)]5360 [err? (##sys#signal-hook5361 #:type-error 'condition-property-accessor5362 "condition has no such property" prop) ]5363 [else (car err-def)] ) ) ) ) ) )53645365(define get-condition-property5366 (lambda (c kind prop . err-def)5367 ((apply condition-property-accessor kind prop err-def) c)))536853695370;;; Convenient error printing:53715372(define print-error-message5373 (let* ((display display)5374 (newline newline)5375 (write write)5376 (string-append string-append)5377 (errmsg (condition-property-accessor 'exn 'message #f))5378 (errloc (condition-property-accessor 'exn 'location #f))5379 (errargs (condition-property-accessor 'exn 'arguments #f))5380 (writeargs5381 (lambda (args port)5382 (##sys#for-each5383 (lambda (x)5384 (##sys#with-print-length-limit 80 (lambda () (write x port)))5385 (newline port) )5386 args) ) ) )5387 (lambda (ex . args)5388 (let-optionals args ((port ##sys#standard-output)5389 (header "Error"))5390 (##sys#check-output-port port #t 'print-error-message)5391 (newline port)5392 (display header port)5393 (cond ((and (not (##sys#immediate? ex)) (eq? 'condition (##sys#slot ex 0)))5394 (cond ((errmsg ex) =>5395 (lambda (msg)5396 (display ": " port)5397 (let ((loc (errloc ex)))5398 (when (and loc (symbol? loc))5399 (display (string-append "(" (##sys#symbol->string loc) ") ") port) ) )5400 (display msg port) ) )5401 (else5402 (let ((kinds (##sys#slot ex 1)))5403 (if (equal? '(user-interrupt) kinds)5404 (display ": *** user interrupt ***" port)5405 (begin5406 (display ": <condition> " port)5407 (display (##sys#slot ex 1) port) ) ) ) ) )5408 (let ((args (errargs ex)))5409 (cond5410 ((not args))5411 ((fx= 1 (length args))5412 (display ": " port)5413 (writeargs args port))5414 (else5415 (newline port)5416 (writeargs args port)))))5417 ((string? ex)5418 (display ": " port)5419 (display ex port)5420 (newline port))5421 (else5422 (display ": uncaught exception: " port)5423 (writeargs (list ex) port) ) ) ) ) ) )542454255426;;; Show exception message and backtrace as warning5427;;; (used for threads and finalizers)54285429(define ##sys#show-exception-warning5430 (let ((print-error-message print-error-message)5431 (display display)5432 (write-char write-char)5433 (print-call-chain print-call-chain)5434 (open-output-string open-output-string)5435 (get-output-string get-output-string) )5436 (lambda (exn cause #!optional (thread ##sys#current-thread))5437 (when ##sys#warnings-enabled5438 (let ((o (open-output-string)))5439 (display "Warning" o)5440 (when thread5441 (display " (" o)5442 (display thread o)5443 (write-char #\) o))5444 (display ": " o)5445 (display cause o)5446 (print-error-message exn ##sys#standard-error (get-output-string o))5447 (print-call-chain ##sys#standard-error 0 thread) ) ))))544854495450;;; Error hook (called by runtime-system):54515452(define ##sys#error-hook5453 (let ([string-append string-append])5454 (lambda (code loc . args)5455 (case code5456 ((1) (let ([c (car args)]5457 [n (cadr args)]5458 [fn (caddr args)] )5459 (apply5460 ##sys#signal-hook5461 #:arity-error loc5462 (string-append "bad argument count - received " (##sys#number->string n) " but expected "5463 (##sys#number->string c) )5464 (if fn (list fn) '())) ) )5465 ((2) (let ([c (car args)]5466 [n (cadr args)]5467 [fn (caddr args)] )5468 (apply5469 ##sys#signal-hook5470 #:arity-error loc5471 (string-append "too few arguments - received " (##sys#number->string n) " but expected "5472 (##sys#number->string c) )5473 (if fn (list fn) '()))))5474 ((3) (apply ##sys#signal-hook #:type-error loc "bad argument type" args))5475 ((4) (apply ##sys#signal-hook #:runtime-error loc "unbound variable" args))5476 ((5) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a keyword" args))5477 ((6) (apply ##sys#signal-hook #:limit-error loc "out of memory" args))5478 ((7) (apply ##sys#signal-hook #:arithmetic-error loc "division by zero" args))5479 ((8) (apply ##sys#signal-hook #:bounds-error loc "out of range" args))5480 ((9) (apply ##sys#signal-hook #:type-error loc "call of non-procedure" args))5481 ((10) (apply ##sys#signal-hook #:arity-error loc "continuation cannot receive multiple values" args))5482 ((11) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a non-cyclic list" args))5483 ((12) (apply ##sys#signal-hook #:limit-error loc "recursion too deep" args))5484 ((13) (apply ##sys#signal-hook #:type-error loc "inexact number cannot be represented as an exact number" args))5485 ((14) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a proper list" args))5486 ((15) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" args))5487 ((16) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a number" args))5488 ((17) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a string" args))5489 ((18) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a pair" args))5490 ((19) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a list" args))5491 ((20) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a character" args))5492 ((21) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a vector" args))5493 ((22) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a symbol" args))5494 ((23) (apply ##sys#signal-hook #:limit-error loc "stack overflow" args))5495 ((24) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a structure of the required type" args))5496 ((25) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a blob" args))5497 ((26) (apply ##sys#signal-hook #:type-error loc "locative refers to reclaimed object" args))5498 ((27) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a block object" args))5499 ((28) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a number vector" args))5500 ((29) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an integer" args))5501 ((30) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an unsigned integer" args))5502 ((31) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a pointer" args))5503 ((32) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a tagged pointer" args))5504 ((33) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a flonum" args))5505 ((34) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a procedure" args))5506 ((35) (apply ##sys#signal-hook #:type-error loc "bad argument type - invalid base" args))5507 ((36) (apply ##sys#signal-hook #:limit-error loc "recursion too deep or circular data encountered" args))5508 ((37) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a boolean" args))5509 ((38) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a locative" args))5510 ((39) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a port" args))5511 ((40) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a port of the correct type" args))5512 ((41) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an input-port" args))5513 ((42) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an output-port" args))5514 ((43) (apply ##sys#signal-hook #:file-error loc "port already closed" args))5515 ((44) (apply ##sys#signal-hook #:type-error loc "cannot represent string with NUL bytes as C string" args))5516 ((45) (apply ##sys#signal-hook #:memory-error loc "segmentation violation" args))5517 ((46) (apply ##sys#signal-hook #:arithmetic-error loc "floating-point exception" args))5518 ((47) (apply ##sys#signal-hook #:runtime-error loc "illegal instruction" args))5519 ((48) (apply ##sys#signal-hook #:memory-error loc "bus error" args))5520 ((49) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an exact number" args))5521 ((50) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an inexact number" args))5522 ((51) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a real" args))5523 ((52) (apply ##sys#signal-hook #:type-error loc "bad argument type - complex number has no ordering" args))5524 ((53) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an exact integer" args))5525 ((54) (apply ##sys#signal-hook #:type-error loc "number does not fit in foreign type" args))5526 ((55) (apply ##sys#signal-hook #:type-error loc "cannot compute absolute value of complex number" args))5527 ((56) (let ((c (car args))5528 (n (cadr args))5529 (fn (caddr args)))5530 (apply5531 ##sys#signal-hook5532 #:bounds-error loc5533 (string-append "attempted rest argument access at index " (##sys#number->string n)5534 " but rest list length is " (##sys#number->string c) )5535 (if fn (list fn) '()))))5536 (else (apply ##sys#signal-hook #:runtime-error loc "unknown internal error" args)) ) ) ) )55375538) ; chicken.condition55395540(import chicken.condition)55415542;;; Miscellaneous low-level routines:55435544(define (##sys#structure? x s) (##core#inline "C_i_structurep" x s))5545(define (##sys#generic-structure? x) (##core#inline "C_structurep" x))5546(define (##sys#slot x i) (##core#inline "C_slot" x i))5547(define (##sys#size x) (##core#inline "C_block_size" x))5548(define ##sys#make-pointer (##core#primitive "C_make_pointer"))5549(define ##sys#make-tagged-pointer (##core#primitive "C_make_tagged_pointer"))5550(define (##sys#pointer? x) (##core#inline "C_anypointerp" x))5551(define (##sys#set-pointer-address! ptr addr) (##core#inline "C_update_pointer" addr ptr))5552(define (##sys#bytevector? x) (##core#inline "C_bytevectorp" x))5553(define (##sys#string->pbytevector s) (##core#inline "C_string_to_pbytevector" s))5554(define (##sys#permanent? x) (##core#inline "C_permanentp" x))5555(define (##sys#block-address x) (##core#inline_allocate ("C_block_address" 6) x))5556(define (##sys#locative? x) (##core#inline "C_locativep" x))5557(define (##sys#srfi-4-vector? x) (##core#inline "C_i_srfi_4_vectorp" x))55585559(define (##sys#null-pointer)5560 (let ([ptr (##sys#make-pointer)])5561 (##core#inline "C_update_pointer" 0 ptr)5562 ptr) )55635564(define (##sys#null-pointer? x)5565 (eq? 0 (##sys#pointer->address x)) )55665567(define (##sys#address->pointer addr)5568 (let ([ptr (##sys#make-pointer)])5569 (##core#inline "C_update_pointer" addr ptr)5570 ptr) )55715572(define (##sys#pointer->address ptr)5573 ;;XXX '6' is platform dependent!5574 (##core#inline_allocate ("C_a_unsigned_int_to_num" 6) (##sys#slot ptr 0)) )55755576(define (##sys#make-c-string str #!optional (loc '##sys#make-c-string))5577 (let* ([len (##sys#size str)]5578 [buf (##sys#make-string (fx+ len 1))] )5579 (##core#inline "C_substring_copy" str buf 0 len 0)5580 (##core#inline "C_setsubchar" buf len #\nul)5581 (if (fx= (##core#inline "C_asciiz_strlen" buf) len)5582 buf5583 (##sys#error-hook (foreign-value "C_ASCIIZ_REPRESENTATION_ERROR" int)5584 loc str))) )55855586(define ##sys#peek-signed-integer (##core#primitive "C_peek_signed_integer"))5587(define ##sys#peek-unsigned-integer (##core#primitive "C_peek_unsigned_integer"))5588(define (##sys#peek-fixnum b i) (##core#inline "C_peek_fixnum" b i))5589(define (##sys#peek-byte ptr i) (##core#inline "C_peek_byte" ptr i))55905591(define (##sys#vector->structure! vec) (##core#inline "C_vector_to_structure" vec))55925593(define (##sys#peek-double b i)5594 (##core#inline_allocate ("C_a_f64peek" 4) b i))55955596(define (##sys#peek-c-string b i)5597 (and (not (##sys#null-pointer? b))5598 (let* ([len (##core#inline "C_fetch_c_strlen" b i)]5599 [str2 (##sys#make-string len)] )5600 (##core#inline "C_peek_c_string" b i str2 len)5601 str2 ) ) )56025603(define (##sys#peek-nonnull-c-string b i)5604 (let* ([len (##core#inline "C_fetch_c_strlen" b i)]5605 [str2 (##sys#make-string len)] )5606 (##core#inline "C_peek_c_string" b i str2 len)5607 str2 ) )56085609(define (##sys#peek-and-free-c-string b i)5610 (and (not (##sys#null-pointer? b))5611 (let* ([len (##core#inline "C_fetch_c_strlen" b i)]5612 [str2 (##sys#make-string len)] )5613 (##core#inline "C_peek_c_string" b i str2 len)5614 (##core#inline "C_free_mptr" b i)5615 str2 ) ) )56165617(define (##sys#peek-and-free-nonnull-c-string b i)5618 (let* ([len (##core#inline "C_fetch_c_strlen" b i)]5619 [str2 (##sys#make-string len)] )5620 (##core#inline "C_peek_c_string" b i str2 len)5621 (##core#inline "C_free_mptr" b i)5622 str2 ) )56235624(define (##sys#poke-c-string b i s)5625 (##core#inline "C_poke_c_string" b i (##sys#make-c-string s) s) )56265627(define (##sys#poke-integer b i n) (##core#inline "C_poke_integer" b i n))5628(define (##sys#poke-double b i n) (##core#inline "C_poke_double" b i n))56295630(define ##sys#peek-c-string-list5631 (let ((fetch (foreign-lambda c-string "C_peek_c_string_at" c-pointer int)))5632 (lambda (ptr n)5633 (let loop ((i 0))5634 (if (and n (fx>= i n))5635 '()5636 (let ((s (fetch ptr i)))5637 (if s5638 (cons s (loop (fx+ i 1)))5639 '() ) ) ) ) ) ) )56405641(define ##sys#peek-and-free-c-string-list5642 (let ((fetch (foreign-lambda c-string "C_peek_c_string_at" c-pointer int))5643 (free (foreign-lambda void "C_free" c-pointer)))5644 (lambda (ptr n)5645 (let ((lst (let loop ((i 0))5646 (if (and n (fx>= i n))5647 '()5648 (let ((s (fetch ptr i)))5649 (cond (s5650 (##core#inline "C_free_sptr" ptr i)5651 (cons s (loop (fx+ i 1))) )5652 (else '() ) ) ) ) ) ) )5653 (free ptr)5654 lst) ) ) )56555656(define (##sys#vector->closure! vec addr)5657 (##core#inline "C_vector_to_closure" vec)5658 (##core#inline "C_update_pointer" addr vec) )56595660(define (##sys#symbol-has-toplevel-binding? s)5661 (##core#inline "C_boundp" s))56625663(define (##sys#copy-bytes from to offset1 offset2 bytes)5664 (##core#inline5665 "C_substring_copy"5666 from to5667 offset1 (fx+ offset1 bytes)5668 offset2) )56695670(define (##sys#copy-words from to offset1 offset2 words)5671 (##core#inline5672 "C_subvector_copy"5673 from to5674 offset1 (fx+ offset1 words)5675 offset2) )56765677(define (##sys#compare-bytes from to offset1 offset2 bytes)5678 (##core#inline5679 "C_substring_compare"5680 from to5681 offset1 offset2 bytes) )56825683(define (##sys#block-pointer x)5684 (let ([ptr (##sys#make-pointer)])5685 (##core#inline "C_pointer_to_block" ptr x)5686 ptr) )568756885689;;; Support routines for foreign-function calling:56905691(define (##sys#foreign-char-argument x) (##core#inline "C_i_foreign_char_argumentp" x))5692(define (##sys#foreign-fixnum-argument x) (##core#inline "C_i_foreign_fixnum_argumentp" x))5693(define (##sys#foreign-flonum-argument x) (##core#inline "C_i_foreign_flonum_argumentp" x))5694(define (##sys#foreign-block-argument x) (##core#inline "C_i_foreign_block_argumentp" x))56955696(define (##sys#foreign-struct-wrapper-argument t x)5697 (##core#inline "C_i_foreign_struct_wrapper_argumentp" t x))56985699(define (##sys#foreign-string-argument x) (##core#inline "C_i_foreign_string_argumentp" x))5700(define (##sys#foreign-symbol-argument x) (##core#inline "C_i_foreign_symbol_argumentp" x))5701(define (##sys#foreign-pointer-argument x) (##core#inline "C_i_foreign_pointer_argumentp" x))5702(define (##sys#foreign-tagged-pointer-argument x tx) (##core#inline "C_i_foreign_tagged_pointer_argumentp" x tx))57035704(define (##sys#foreign-ranged-integer-argument obj size)5705 (##core#inline "C_i_foreign_ranged_integer_argumentp" obj size))5706(define (##sys#foreign-unsigned-ranged-integer-argument obj size)5707 (##core#inline "C_i_foreign_unsigned_ranged_integer_argumentp" obj size))57085709;;; Low-level threading interface:57105711(define ##sys#default-thread-quantum 10000)57125713(define (##sys#default-exception-handler arg)5714 (##core#inline "C_halt" "internal error: default exception handler shouldn't be called!") )57155716(define (##sys#make-thread thunk state name q)5717 (##sys#make-structure5718 'thread5719 thunk ; #1 thunk5720 #f ; #2 result list5721 state ; #3 state5722 #f ; #4 block-timeout5723 (vector ; #5 state buffer5724 ##sys#dynamic-winds5725 ##sys#standard-input5726 ##sys#standard-output5727 ##sys#standard-error5728 ##sys#default-exception-handler5729 (##sys#vector-resize ##sys#current-parameter-vector5730 (##sys#size ##sys#current-parameter-vector) #f) )5731 name ; #6 name5732 (##core#undefined) ; #7 end-exception5733 '() ; #8 owned mutexes5734 q ; #9 quantum5735 (##core#undefined) ; #10 specific5736 #f ; #11 block object (type depends on blocking type)5737 '() ; #12 recipients5738 #f ; #13 unblocked by timeout?5739 (cons #f #f))) ; #14 ID (just needs to be unique)57405741(define ##sys#primordial-thread5742 (##sys#make-thread #f 'running 'primordial ##sys#default-thread-quantum))57435744(define ##sys#current-thread ##sys#primordial-thread)57455746(define (##sys#make-mutex id owner)5747 (##sys#make-structure5748 'mutex5749 id ; #1 name5750 owner ; #2 thread or #f5751 '() ; #3 list of waiting threads5752 #f ; #4 abandoned5753 #f ; #5 locked5754 (##core#undefined) ) ) ; #6 specific57555756(define (##sys#schedule) ((##sys#slot ##sys#current-thread 1)))57575758(define (##sys#thread-yield!)5759 (##sys#call-with-current-continuation5760 (lambda (return)5761 (let ((ct ##sys#current-thread))5762 (##sys#setslot ct 1 (lambda () (return (##core#undefined))))5763 (##sys#schedule) ) ) ) )57645765(define (##sys#kill-other-threads thunk)5766 (thunk)) ; does nothing, will be modified by scheduler.scm57675768;; these two procedures should redefined in thread APIs (e.g. srfi-18):5769(define (##sys#resume-thread-on-event t) #f)57705771(define (##sys#suspend-thread-on-event t)5772 ;; wait until signal handler fires. If we are only waiting for a finalizer,5773 ;; then this will wait forever:5774 (##sys#sleep-until-interrupt))57755776(define (##sys#sleep-until-interrupt)5777 (##core#inline "C_i_sleep_until_interrupt" 100)5778 (##sys#dispatch-interrupt (lambda _ #f)))577957805781;;; event queues (for signals and finalizers)57825783(define (##sys#make-event-queue)5784 (##sys#make-structure 'event-queue5785 '() ; head5786 '() ; tail5787 #f)) ; suspended thread57885789(define (##sys#add-event-to-queue! q e)5790 (let ((h (##sys#slot q 1))5791 (t (##sys#slot q 2))5792 (item (cons e '())))5793 (if (null? h)5794 (##sys#setslot q 1 item)5795 (##sys#setslot t 1 item))5796 (##sys#setslot q 2 item)5797 (let ((st (##sys#slot q 3))) ; thread suspended?5798 (when st5799 (##sys#setslot q 3 #f)5800 (##sys#resume-thread-on-event st)))))58015802(define (##sys#get-next-event q)5803 (let ((st (##sys#slot q 3)))5804 (and (not st)5805 (let ((h (##sys#slot q 1)))5806 (and (not (null? h))5807 (let ((x (##sys#slot h 0))5808 (n (##sys#slot h 1)))5809 (##sys#setslot q 1 n)5810 (when (null? n) (##sys#setslot q 2 '()))5811 x))))))58125813(define (##sys#wait-for-next-event q)5814 (let ((st (##sys#slot q 3)))5815 (when st5816 (##sys#signal-hook #:runtime-error #f "event queue blocked" q))5817 (let again ()5818 (let ((h (##sys#slot q 1)))5819 (cond ((null? h)5820 (##sys#setslot q 3 ##sys#current-thread)5821 (##sys#suspend-thread-on-event ##sys#current-thread)5822 (again))5823 (else5824 (let ((x (##sys#slot h 0))5825 (n (##sys#slot h 1)))5826 (##sys#setslot q 1 n)5827 (when (null? n) (##sys#setslot q 2 '()))5828 x)))))))582958305831;;; Sleeping:58325833(define (chicken.base#sleep-hook n) ; modified by scheduler.scm5834 (##core#inline "C_i_process_sleep" n))58355836(set! chicken.base#sleep5837 (lambda (n)5838 (##sys#check-fixnum n 'sleep)5839 (chicken.base#sleep-hook n)5840 (##core#undefined)))584158425843;;; Interrupt-handling:58445845(define ##sys#context-switch (##core#primitive "C_context_switch"))58465847(define ##sys#signal-vector (make-vector 256 #f))58485849(define (##sys#interrupt-hook reason state)5850 (let loop ((reason reason))5851 (when reason5852 (let ((handler (##sys#slot ##sys#signal-vector reason)))5853 (when handler5854 (handler reason))5855 (loop (##core#inline "C_i_pending_interrupt" #f)))))5856 (cond ((fx> (##sys#slot ##sys#pending-finalizers 0) 0)5857 (##sys#run-pending-finalizers state) )5858 ((procedure? state) (state))5859 (else (##sys#context-switch state) ) ) )58605861(define (##sys#dispatch-interrupt k)5862 (##sys#interrupt-hook5863 (##core#inline "C_i_pending_interrupt" #f)5864 k))586558665867;;; Accessing "errno":58685869(define-foreign-variable _errno int "errno")58705871(define ##sys#update-errno)5872(define ##sys#errno)58735874(let ((n 0))5875 (set! ##sys#update-errno (lambda () (set! n _errno) n))5876 (set! ##sys#errno (lambda () n)))587758785879;;; Format error string for unterminated here-docs:58805881(define (##sys#format-here-doc-warning end)5882 (##sys#print-to-string `("unterminated here-doc string literal `" ,end "'")))58835884;;; Special string quoting syntax:58855886(set! ##sys#user-read-hook5887 (let ([old ##sys#user-read-hook]5888 [read read]5889 [display display] )5890 (define (readln port)5891 (let ([ln (open-output-string)])5892 (do ([c (##sys#read-char-0 port) (##sys#read-char-0 port)])5893 ((or (eof-object? c) (char=? #\newline c))5894 (if (eof-object? c) c (get-output-string ln)))5895 (##sys#write-char-0 c ln) ) ) )5896 (define (read-escaped-sexp port skip-brace?)5897 (when skip-brace? (##sys#read-char-0 port))5898 (let* ((form (read port)))5899 (when skip-brace?5900 (let loop ()5901 ;; Skips all characters until #\}5902 (let ([c (##sys#read-char-0 port)])5903 (cond [(eof-object? c)5904 (##sys#read-error port "unexpected end of file - unterminated `#{...}' item in `here' string literal") ]5905 [(not (char=? #\} c)) (loop)] ) ) ) )5906 form))5907 (lambda (char port)5908 (cond [(not (char=? #\< char)) (old char port)]5909 [else5910 (read-char port)5911 (case (##sys#peek-char-0 port)5912 [(#\<)5913 (##sys#read-char-0 port)5914 (let ([str (open-output-string)]5915 [end (readln port)]5916 [f #f] )5917 (let ((endlen (if (eof-object? end) 0 (string-length end))))5918 (cond5919 ((fx= endlen 0)5920 (##sys#read-warning5921 port "Missing tag after #<< here-doc token"))5922 ((or (char=? (string-ref end (fx- endlen 1)) #\space)5923 (char=? (string-ref end (fx- endlen 1)) #\tab))5924 (##sys#read-warning5925 port "Whitespace after #<< here-doc tag"))5926 ))5927 (do ([ln (readln port) (readln port)])5928 ((or (eof-object? ln) (string=? end ln))5929 (when (eof-object? ln)5930 (##sys#read-warning port5931 (##sys#format-here-doc-warning end)))5932 (get-output-string str) )5933 (if f5934 (##sys#write-char-0 #\newline str)5935 (set! f #t) )5936 (display ln str) ) ) ]5937 [(#\#)5938 (##sys#read-char-0 port)5939 (let ([end (readln port)]5940 [str (open-output-string)] )5941 (define (get/clear-str)5942 (let ((s (get-output-string str)))5943 (set! str (open-output-string))5944 s))59455946 (let ((endlen (if (eof-object? end) 0 (string-length end))))5947 (cond5948 ((fx= endlen 0)5949 (##sys#read-warning5950 port "Missing tag after #<# here-doc token"))5951 ((or (char=? (string-ref end (fx- endlen 1)) #\space)5952 (char=? (string-ref end (fx- endlen 1)) #\tab))5953 (##sys#read-warning5954 port "Whitespace after #<# here-doc tag"))5955 ))59565957 (let loop [(lst '())]5958 (let ([c (##sys#read-char-0 port)])5959 (case c5960 [(#\newline #!eof)5961 (let ([s (get/clear-str)])5962 (cond [(or (eof-object? c) (string=? end s))5963 (when (eof-object? c)5964 (##sys#read-warning5965 port (##sys#format-here-doc-warning end))5966 )5967 `(##sys#print-to-string5968 ;;Can't just use `(list ,@lst) because of 126 argument apply limit5969 ,(let loop2 ((lst (cdr lst)) (next-string '()) (acc ''())) ; drop last newline5970 (cond ((null? lst)5971 `(cons ,(##sys#print-to-string next-string) ,acc))5972 ((or (string? (car lst)) (char? (car lst)))5973 (loop2 (cdr lst) (cons (car lst) next-string) acc))5974 (else5975 (loop2 (cdr lst)5976 '()5977 `(cons ,(car lst)5978 (cons ,(##sys#print-to-string next-string) ,acc))))))) ]5979 [else (loop (cons #\newline (cons s lst)))] ) ) ]5980 [(#\#)5981 (let ([c (##sys#peek-char-0 port)])5982 (case c5983 [(#\#)5984 (##sys#write-char-0 (##sys#read-char-0 port) str)5985 (loop lst) ]5986 [(#\{) (loop (cons (read-escaped-sexp port #t)5987 (cons (get/clear-str) lst) ) ) ]5988 [else (loop (cons (read-escaped-sexp port #f)5989 (cons (get/clear-str) lst) ) ) ] ) ) ]5990 [else5991 (##sys#write-char-0 c str)5992 (loop lst) ] ) ) ) ) ]5993 [else (##sys#read-error port "unreadable object")] ) ] ) ) ) )599459955996;;; Accessing process information (cwd, environ, etc.)59975998#>59996000#define C_chdir(str) C_fix(chdir(C_c_string(str)))6001#define C_curdir(buf, size) (getcwd(C_c_string(buf), size) ? C_fix(strlen(C_c_string(buf))) : C_SCHEME_FALSE)6002#define C_getenventry(i) (environ[ i ])60036004#ifdef HAVE_CRT_EXTERNS_H6005# include <crt_externs.h>6006# define environ (*_NSGetEnviron())6007#else6008extern char **environ;6009#endif60106011#ifdef HAVE_SETENV6012# define C_unsetenv(s) (unsetenv((char *)C_data_pointer(s)), C_SCHEME_TRUE)6013# define C_setenv(x, y) C_fix(setenv((char *)C_data_pointer(x), (char *)C_data_pointer(y), 1))6014#else6015# if defined(_WIN32) && !defined(__CYGWIN__)6016# define C_unsetenv(s) C_setenv(s, C_SCHEME_FALSE)6017# else6018# define C_unsetenv(s) C_fix(putenv((char *)C_data_pointer(s)))6019# endif6020static C_word C_fcall C_setenv(C_word x, C_word y) {6021 char *sx = C_c_string(x),6022 *sy = (y == C_SCHEME_FALSE ? "" : C_c_string(y));6023 int n1 = C_strlen(sx), n2 = C_strlen(sy);6024 int buf_len = n1 + n2 + 2;6025 char *buf = (char *)C_malloc(buf_len);6026 if(buf == NULL) return(C_fix(0));6027 else {6028 C_strlcpy(buf, sx, buf_len);6029 C_strlcat(buf, "=", buf_len);6030 C_strlcat(buf, sy, buf_len);6031 return(C_fix(putenv(buf)));6032 }6033}6034#endif60356036<#60376038(module chicken.process-context6039 (argv argc+argv command-line-arguments6040 program-name executable-pathname6041 change-directory current-directory6042 get-environment-variable get-environment-variables6043 set-environment-variable! unset-environment-variable!)60446045(import scheme)6046(import chicken.base chicken.fixnum chicken.foreign)6047(import chicken.internal.syntax)604860496050;;; Current directory access:60516052(define (change-directory name)6053 (##sys#check-string name 'change-directory)6054 (let ((sname (##sys#make-c-string name 'change-directory)))6055 (unless (fx= (##core#inline "C_chdir" sname) 0)6056 (##sys#signal-hook/errno #:file-error (##sys#update-errno) 'change-directory6057 (string-append "cannot change current directory - " strerror) name))6058 name))60596060(define (##sys#change-directory-hook dir) ; set! by posix for fd support6061 (change-directory dir))60626063(define current-directory6064 (getter-with-setter6065 (lambda ()6066 (let* ((buffer-size (foreign-value "C_MAX_PATH" size_t))6067 (buffer (make-string buffer-size))6068 (len (##core#inline "C_curdir" buffer buffer-size)))6069 (unless ##sys#windows-platform ; FIXME need `cond-expand' here6070 (##sys#update-errno))6071 (if len6072 (##sys#substring buffer 0 len)6073 (##sys#signal-hook/errno6074 #:file-error6075 (##sys#errno)6076 'current-directory "cannot retrieve current directory"))))6077 (lambda (dir)6078 (##sys#change-directory-hook dir))6079 "(chicken.process-context#current-directory)"))608060816082;;; Environment access:60836084(define get-environment-variable6085 (foreign-lambda c-string "C_getenv" nonnull-c-string))60866087(define (set-environment-variable! var val)6088 (##sys#check-string var 'set-environment-variable!)6089 (##sys#check-string val 'set-environment-variable!)6090 (##core#inline "C_setenv"6091 (##sys#make-c-string var 'set-environment-variable!)6092 (##sys#make-c-string val 'set-environment-variable!))6093 (##core#undefined))60946095(define (unset-environment-variable! var)6096 (##sys#check-string var 'unset-environment-variable!)6097 (##core#inline "C_unsetenv"6098 (##sys#make-c-string var 'unset-environment-variable!))6099 (##core#undefined))61006101(define get-environment-variables6102 (let ((get (foreign-lambda c-string "C_getenventry" int)))6103 (lambda ()6104 (let loop ((i 0))6105 (let ((entry (get i)))6106 (if entry6107 (let scan ((j 0))6108 (if (char=? #\= (##core#inline "C_subchar" entry j))6109 (cons (cons (##sys#substring entry 0 j)6110 (##sys#substring entry (fx+ j 1) (##sys#size entry)))6111 (loop (fx+ i 1)))6112 (scan (fx+ j 1))))6113 '()))))))611461156116;;; Command line handling61176118(define-foreign-variable main_argc int "C_main_argc")6119(define-foreign-variable main_argv c-pointer "C_main_argv")61206121(define executable-pathname6122 (foreign-lambda c-string* "C_executable_pathname"))61236124(define (argc+argv)6125 (##sys#values main_argc main_argv))61266127(define argv ; includes program name6128 (let ((cache #f)6129 (fetch-arg (foreign-lambda* c-string ((scheme-object i))6130 "C_return(C_main_argv[C_unfix(i)]);")))6131 (lambda ()6132 (unless cache6133 (set! cache (do ((i (fx- main_argc 1) (fx- i 1))6134 (v '() (cons (fetch-arg i) v)))6135 ((fx< i 0) v))))6136 cache)))61376138(define program-name6139 (make-parameter6140 (if (null? (argv))6141 "<unknown>" ; may happen if embedded in C application6142 (car (argv)))6143 (lambda (x)6144 (##sys#check-string x 'program-name)6145 x) ) )61466147(define command-line-arguments6148 (make-parameter6149 (let ((args (argv)))6150 (if (pair? args)6151 (let loop ((args (##sys#slot args 1))) ; Skip over program name (argv[0])6152 (if (null? args)6153 '()6154 (let ((arg (##sys#slot args 0))6155 (rest (##sys#slot args 1)) )6156 (cond6157 ((string=? "-:" arg) ; Consume first "empty" runtime options list, return rest6158 rest)61596160 ((and (fx>= (##sys#size arg) 3)6161 (string=? "-:" (##sys#substring arg 0 2)))6162 (loop rest))61636164 ;; First non-runtime option and everything following it is returned as-is6165 (else args) ) ) ) )6166 args) )6167 (lambda (x)6168 (##sys#check-list x 'command-line-arguments)6169 x) ) )61706171) ; chicken.process-context617261736174(module chicken.gc6175 (current-gc-milliseconds gc memory-statistics6176 set-finalizer! make-finalizer add-to-finalizer6177 set-gc-report! force-finalizers)61786179(import scheme)6180(import chicken.base chicken.fixnum chicken.foreign)6181(import chicken.internal.syntax)61826183;;; GC info:61846185(define (current-gc-milliseconds)6186 (##core#inline "C_i_accumulated_gc_time"))61876188(define (set-gc-report! flag)6189 (##core#inline "C_set_gc_report" flag))61906191;;; Memory info:61926193(define (memory-statistics)6194 (let* ((free (##sys#gc #t))6195 (info (##sys#memory-info))6196 (half-size (fx/ (##sys#slot info 0) 2)))6197 (vector half-size (fx- half-size free) (##sys#slot info 1))))61986199;;; Finalization:62006201(define-foreign-variable _max_pending_finalizers int "C_max_pending_finalizers")62026203(define ##sys#pending-finalizers6204 (##sys#make-vector (fx+ (fx* 2 _max_pending_finalizers) 1) (##core#undefined)) )62056206(##sys#setislot ##sys#pending-finalizers 0 0)62076208(define ##sys#set-finalizer! (##core#primitive "C_register_finalizer"))62096210(define ##sys#init-finalizer6211 (let ((string-append string-append))6212 (lambda (x y)6213 (when (fx>= (##core#inline "C_i_live_finalizer_count") _max_pending_finalizers)6214 (cond ((##core#inline "C_resize_pending_finalizers" (fx* 2 _max_pending_finalizers))6215 (set! ##sys#pending-finalizers6216 (##sys#vector-resize ##sys#pending-finalizers6217 (fx+ (fx* 2 _max_pending_finalizers) 1)6218 (##core#undefined)))6219 (when (##sys#debug-mode?)6220 (##sys#print6221 (string-append6222 "[debug] too many finalizers ("6223 (##sys#number->string6224 (##core#inline "C_i_live_finalizer_count"))6225 "), resized max finalizers to "6226 (##sys#number->string _max_pending_finalizers)6227 "\n")6228 #f ##sys#standard-error)))6229 (else6230 (when (##sys#debug-mode?)6231 (##sys#print6232 (string-append6233 "[debug] too many finalizers ("6234 (##core#inline "C_i_live_finalizer_count")6235 "), forcing ...\n")6236 #f ##sys#standard-error))6237 (##sys#force-finalizers) ) ) )6238 (##sys#set-finalizer! x y) ) ) )62396240(define set-finalizer! ##sys#init-finalizer)62416242(define finalizer-tag (vector 'finalizer))62436244(define (finalizer? x)6245 (and (pair? x) (eq? finalizer-tag (##sys#slot x 0))) )62466247(define (make-finalizer . objects)6248 (let ((q (##sys#make-event-queue)))6249 (define (handler o) (##sys#add-event-to-queue! q o))6250 (define (handle o) (##sys#init-finalizer o handler))6251 (for-each handle objects)6252 (##sys#decorate-lambda6253 (lambda (#!optional mode)6254 (if mode6255 (##sys#wait-for-next-event q)6256 (##sys#get-next-event q)))6257 finalizer?6258 (lambda (proc i)6259 (##sys#setslot proc i (cons finalizer-tag handle))6260 proc))))62616262(define (add-to-finalizer f . objects)6263 (let ((af (and (procedure? f)6264 (##sys#lambda-decoration f finalizer?))))6265 (unless af6266 (error 'add-to-finalizer "bad argument type - not a finalizer procedure"6267 f))6268 (for-each (cdr af) objects)))62696270(define ##sys#run-pending-finalizers6271 (let ((vector-fill! vector-fill!)6272 (string-append string-append)6273 (working-thread #f) )6274 (lambda (state)6275 (cond6276 ((not working-thread)6277 (set! working-thread ##sys#current-thread)6278 (let* ((c (##sys#slot ##sys#pending-finalizers 0)) )6279 (when (##sys#debug-mode?)6280 (##sys#print6281 (string-append "[debug] running " (##sys#number->string c)6282 " finalizer(s) ("6283 (##sys#number->string6284 (##core#inline "C_i_live_finalizer_count"))6285 " live, "6286 (##sys#number->string6287 (##core#inline "C_i_allocated_finalizer_count"))6288 " allocated) ...\n")6289 #f ##sys#standard-error))6290 (do ([i 0 (fx+ i 1)])6291 ((fx>= i c))6292 (let ([i2 (fx+ 1 (fx* i 2))])6293 (handle-exceptions ex6294 (##sys#show-exception-warning ex "in finalizer" #f)6295 ((##sys#slot ##sys#pending-finalizers (fx+ i2 1))6296 (##sys#slot ##sys#pending-finalizers i2)) ) ))6297 (vector-fill! ##sys#pending-finalizers (##core#undefined))6298 (##sys#setislot ##sys#pending-finalizers 0 0)6299 (set! working-thread #f)))6300 (state) ; Got here due to interrupt; continue w/o error6301 ((eq? working-thread ##sys#current-thread)6302 (##sys#signal-hook6303 #:error '##sys#run-pending-finalizers6304 "re-entry from finalizer thread (maybe (gc #t) was called from a finalizer)"))6305 (else6306 ;; Give finalizer thread a change to run6307 (##sys#thread-yield!)))6308 (cond ((not state))6309 ((procedure? state) (state))6310 (state (##sys#context-switch state) ) ) ) ))63116312(define force-finalizers (make-parameter #t))63136314(define (##sys#force-finalizers)6315 (let loop ()6316 (let ([n (##sys#gc)])6317 (cond ((fx> (##sys#slot ##sys#pending-finalizers 0) 0)6318 (##sys#run-pending-finalizers #f)6319 (loop) )6320 (else n) ) ) ))63216322(define (gc . arg)6323 (let ((a (and (pair? arg) (car arg))))6324 (if a6325 (##sys#force-finalizers)6326 (##sys#gc a)))))63276328;;; Auxilliary definitions for safe use in quasiquoted forms and evaluated code:63296330(define ##sys#list->vector list->vector)6331(define ##sys#list list)6332(define ##sys#length length)6333(define ##sys#cons cons)6334(define ##sys#append append)6335(define ##sys#vector vector)6336(define ##sys#apply apply)6337(define ##sys#values values)6338(define ##sys#equal? equal?)6339(define ##sys#car car)6340(define ##sys#cdr cdr)6341(define ##sys#pair? pair?)6342(define ##sys#vector? vector?)6343(define ##sys#vector->list vector->list)6344(define ##sys#vector-length vector-length)6345(define ##sys#vector-ref vector-ref)6346(define ##sys#>= >=)6347(define ##sys#= =)6348(define ##sys#+ +)6349(define ##sys#eq? eq?)6350(define ##sys#eqv? eqv?)6351(define ##sys#list? list?)6352(define ##sys#null? null?)6353(define ##sys#map-n map)63546355;;; We need this here so `location' works:63566357(define (##sys#make-locative obj index weak? loc)6358 (cond [(##sys#immediate? obj)6359 (##sys#signal-hook #:type-error loc "locative cannot refer to immediate object" obj) ]6360 [(or (vector? obj) (pair? obj))6361 (##sys#check-range index 0 (##sys#size obj) loc)6362 (##core#inline_allocate ("C_a_i_make_locative" 5) 0 obj index weak?) ]6363 #;[(symbol? obj)6364 (##sys#check-range index 0 1 loc)6365 (##core#inline_allocate ("C_a_i_make_locative" 5) 0 obj index weak?) ]6366 [(and (##core#inline "C_blockp" obj)6367 (##core#inline "C_bytevectorp" obj) )6368 (##sys#check-range index 0 (##sys#size obj) loc)6369 (##core#inline_allocate ("C_a_i_make_locative" 5) 2 obj index weak?) ]6370 [(##sys#generic-structure? obj)6371 (case (##sys#slot obj 0)6372 ((u8vector)6373 (let ([v (##sys#slot obj 1)])6374 (##sys#check-range index 0 (##sys#size v) loc)6375 (##core#inline_allocate ("C_a_i_make_locative" 5) 2 v index weak?)) )6376 ((s8vector)6377 (let ([v (##sys#slot obj 1)])6378 (##sys#check-range index 0 (##sys#size v) loc)6379 (##core#inline_allocate ("C_a_i_make_locative" 5) 3 v index weak?) ) )6380 ((u16vector)6381 (let ([v (##sys#slot obj 1)])6382 (##sys#check-range index 0 (##sys#size v) loc)6383 (##core#inline_allocate ("C_a_i_make_locative" 5) 4 v index weak?) ) )6384 ((s16vector)6385 (let ([v (##sys#slot obj 1)])6386 (##sys#check-range index 0 (##sys#size v) loc)6387 (##core#inline_allocate ("C_a_i_make_locative" 5) 5 v index weak?) ) )6388 ((u32vector)6389 (let ([v (##sys#slot obj 1)])6390 (##sys#check-range index 0 (##sys#size v) loc)6391 (##core#inline_allocate ("C_a_i_make_locative" 5) 6 v index weak?) ) )6392 ((s32vector)6393 (let ([v (##sys#slot obj 1)])6394 (##sys#check-range index 0 (##sys#size v) loc)6395 (##core#inline_allocate ("C_a_i_make_locative" 5) 7 v index weak?) ) )6396 ((u64vector)6397 (let ([v (##sys#slot obj 1)])6398 (##sys#check-range index 0 (##sys#size v) loc)6399 (##core#inline_allocate ("C_a_i_make_locative" 5) 8 v index weak?) ) )6400 ((s64vector)6401 (let ([v (##sys#slot obj 1)])6402 (##sys#check-range index 0 (##sys#size v) loc)6403 (##core#inline_allocate ("C_a_i_make_locative" 5) 9 v index weak?) ) )6404 ((f32vector)6405 (let ([v (##sys#slot obj 1)])6406 (##sys#check-range index 0 (##sys#size v) loc)6407 (##core#inline_allocate ("C_a_i_make_locative" 5) 10 v index weak?) ) )6408 ((f64vector)6409 (let ([v (##sys#slot obj 1)])6410 (##sys#check-range index 0 (##sys#size v) loc)6411 (##core#inline_allocate ("C_a_i_make_locative" 5) 11 v index weak?) ) )6412 ;;XXX pointer-vector currently not supported6413 (else6414 (##sys#check-range index 0 (fx- (##sys#size obj) 1) loc)6415 (##core#inline_allocate ("C_a_i_make_locative" 5) 0 obj (fx+ index 1) weak?) ) ) ]6416 [(string? obj)6417 (##sys#check-range index 0 (##sys#size obj) loc)6418 (##core#inline_allocate ("C_a_i_make_locative" 5) 1 obj index weak?) ]6419 [else6420 (##sys#signal-hook6421 #:type-error loc6422 "bad argument type - locative cannot refer to objects of this type"6423 obj) ] ) )642464256426;;; Property lists64276428(module chicken.plist6429 (get get-properties put! remprop! symbol-plist)64306431(import scheme)6432(import (only chicken.base getter-with-setter))6433(import chicken.internal.syntax)64346435(define (put! sym prop val)6436 (##sys#check-symbol sym 'put!)6437 (##core#inline_allocate ("C_a_i_putprop" 8) sym prop val) )64386439(define (get sym prop #!optional default)6440 (##sys#check-symbol sym 'get)6441 (##core#inline "C_i_getprop" sym prop default))64426443(define ##sys#put! put!)6444(define ##sys#get get)64456446(set! get (getter-with-setter get put!))64476448(define (remprop! sym prop)6449 (##sys#check-symbol sym 'remprop!)6450 (let loop ((plist (##sys#slot sym 2)) (ptl #f))6451 (and (not (null? plist))6452 (let* ((tl (##sys#slot plist 1))6453 (nxt (##sys#slot tl 1)))6454 (or (and (eq? (##sys#slot plist 0) prop)6455 (begin6456 (if ptl6457 (##sys#setslot ptl 1 nxt)6458 (##sys#setslot sym 2 nxt) )6459 #t ) )6460 (loop nxt tl) ) ) ) )6461 (when (null? (##sys#slot sym 2))6462 ;; This will only unpersist if symbol is also unbound6463 (##core#inline "C_i_unpersist_symbol" sym) ) )64646465(define symbol-plist6466 (getter-with-setter6467 (lambda (sym)6468 (##sys#check-symbol sym 'symbol-plist)6469 (##sys#slot sym 2) )6470 (lambda (sym lst)6471 (##sys#check-symbol sym 'symbol-plist)6472 (##sys#check-list lst 'symbol-plist/setter)6473 (if (##core#inline "C_i_fixnumevenp" (##core#inline "C_i_length" lst))6474 (##sys#setslot sym 2 lst)6475 (##sys#signal-hook6476 #:type-error "property-list must be of even length"6477 lst sym))6478 (if (null? lst)6479 (##core#inline "C_i_unpersist_symbol" sym)6480 (##core#inline "C_i_persist_symbol" sym)))6481 "(chicken.plist#symbol-plist sym)"))64826483(define (get-properties sym props)6484 (##sys#check-symbol sym 'get-properties)6485 (when (symbol? props)6486 (set! props (list props)) )6487 (##sys#check-list props 'get-properties)6488 (let loop ((plist (##sys#slot sym 2)))6489 (if (null? plist)6490 (values #f #f #f)6491 (let* ((prop (##sys#slot plist 0))6492 (tl (##sys#slot plist 1))6493 (nxt (##sys#slot tl 1)))6494 (if (memq prop props)6495 (values prop (##sys#slot tl 0) nxt)6496 (loop nxt) ) ) ) ) )64976498) ; chicken.plist649965006501;;; Print timing information (support for "time" macro):65026503(define (##sys#display-times info)6504 (define (pstr str) (##sys#print str #f ##sys#standard-error))6505 (define (pchr chr) (##sys#write-char-0 chr ##sys#standard-error))6506 (define (pnum num)6507 (##sys#print (if (zero? num) "0" (##sys#number->string num)) #f ##sys#standard-error))6508 (define (round-to x y) ; Convert to fp with y digits after the point6509 (/ (round (* x (expt 10 y))) (expt 10.0 y)))6510 (define (pmem bytes)6511 (cond ((> bytes (expt 1024 3))6512 (pnum (round-to (/ bytes (expt 1024 3)) 2)) (pstr " GiB"))6513 ((> bytes (expt 1024 2))6514 (pnum (round-to (/ bytes (expt 1024 2)) 2)) (pstr " MiB"))6515 ((> bytes 1024)6516 (pnum (round-to (/ bytes 1024) 2)) (pstr " KiB"))6517 (else (pnum bytes) (pstr " bytes"))))6518 (##sys#flush-output ##sys#standard-output)6519 (pnum (##sys#slot info 0))6520 (pstr "s CPU time")6521 (let ((gctime (##sys#slot info 1)))6522 (when (> gctime 0)6523 (pstr ", ")6524 (pnum gctime)6525 (pstr "s GC time (major)")))6526 (let ((mut (##sys#slot info 2))6527 (umut (##sys#slot info 3)))6528 (when (fx> mut 0)6529 (pstr ", ")6530 (pnum mut)6531 (pchr #\/)6532 (pnum umut)6533 (pstr " mutations (total/tracked)")))6534 (let ((minor (##sys#slot info 4))6535 (major (##sys#slot info 5)))6536 (when (or (fx> minor 0) (fx> major 0))6537 (pstr ", ")6538 (pnum major)6539 (pchr #\/)6540 (pnum minor)6541 (pstr " GCs (major/minor)")))6542 (let ((maximum-heap-usage (##sys#slot info 6)))6543 (pstr ", maximum live heap: ")6544 (pmem maximum-heap-usage))6545 (##sys#write-char-0 #\newline ##sys#standard-error)6546 (##sys#flush-output ##sys#standard-error))654765486549;;; Dump heap state to stderr:65506551(define ##sys#dump-heap-state (##core#primitive "C_dump_heap_state"))6552(define ##sys#filter-heap-objects (##core#primitive "C_filter_heap_objects"))655365546555;;; Platform configuration inquiry:65566557(module chicken.platform6558 (build-platform chicken-version6559 chicken-home ;; DEPRECATED6560 include-path6561 feature? features machine-byte-order machine-type6562 repository-path installation-repository6563 register-feature! unregister-feature!6564 software-type software-version return-to-host6565 system-config-directory system-cache-directory6566 )65676568(import scheme)6569(import chicken.fixnum chicken.foreign chicken.keyword chicken.process-context)6570(import chicken.internal.syntax)6571(import (only chicken.base make-parameter))65726573(define software-type6574 (let ((sym (string->symbol ((##core#primitive "C_software_type")))))6575 (lambda () sym)))65766577(define machine-type6578 (let ((sym (string->symbol ((##core#primitive "C_machine_type")))))6579 (lambda () sym)))65806581(define machine-byte-order6582 (let ((sym (string->symbol ((##core#primitive "C_machine_byte_order")))))6583 (lambda () sym)))65846585(define software-version6586 (let ((sym (string->symbol ((##core#primitive "C_software_version")))))6587 (lambda () sym)))65886589(define build-platform6590 (let ((sym (string->symbol ((##core#primitive "C_build_platform")))))6591 (lambda () sym)))65926593(define ##sys#windows-platform6594 (and (eq? 'windows (software-type))6595 ;; Still windows even if 'Linux-like'6596 (not (eq? 'cygwin (software-version)))))65976598(define (chicken-version #!optional full)6599 (define (get-config)6600 (let ((bp (build-platform))6601 (st (software-type))6602 (sv (software-version))6603 (mt (machine-type)))6604 (define (str x)6605 (if (eq? 'unknown x)6606 ""6607 (string-append (symbol->string x) "-")))6608 (string-append (str sv) (str st) (str bp) (##sys#symbol->string mt))))6609 (if full6610 (let ((spec (string-append6611 " " (number->string (foreign-value "C_WORD_SIZE" int)) "bit"6612 (if (feature? #:dload) " dload" "")6613 (if (feature? #:ptables) " ptables" "")6614 (if (feature? #:gchooks) " gchooks" "")6615 (if (feature? #:cross-chicken) " cross" ""))))6616 (string-append6617 "Version " ##sys#build-version6618 (if ##sys#build-branch (string-append " (" ##sys#build-branch ")") "")6619 (if ##sys#build-id (string-append " (rev " ##sys#build-id ")") "")6620 "\n"6621 (get-config)6622 (if (zero? (##sys#size spec))6623 ""6624 (string-append " [" spec " ]"))))6625 ##sys#build-version))66266627;;; Installation locations66286629(define-foreign-variable binary-version int "C_BINARY_VERSION")6630(define-foreign-variable installation-home c-string "C_INSTALL_SHARE_HOME")6631(define-foreign-variable install-egg-home c-string "C_INSTALL_EGG_HOME")66326633;; DEPRECATED6634(define (chicken-home) installation-home)66356636(define path-list-separator6637 (if ##sys#windows-platform #\; #\:))66386639(define ##sys#split-path6640 (let ((cache '(#f)))6641 (lambda (path)6642 (cond ((not path) '())6643 ((equal? path (car cache))6644 (cdr cache))6645 (else6646 (let* ((len (string-length path))6647 (lst (let loop ((start 0) (pos 0))6648 (cond ((fx>= pos len)6649 (if (fx= pos start)6650 '()6651 (list (substring path start pos))))6652 ((char=? (string-ref path pos)6653 path-list-separator)6654 (cons (substring path start pos)6655 (loop (fx+ pos 1)6656 (fx+ pos 1))))6657 (else6658 (loop start (fx+ pos 1)))))))6659 (set! cache (cons path lst))6660 lst))))))66616662(define repository-path6663 (make-parameter6664 (cond ((foreign-value "C_private_repository_path()" c-string)6665 => list)6666 ((get-environment-variable "CHICKEN_REPOSITORY_PATH")6667 => ##sys#split-path)6668 (install-egg-home6669 => list)6670 (else #f))6671 (lambda (new)6672 (and new6673 (begin6674 (##sys#check-list new 'repository-path)6675 (for-each (lambda (p) (##sys#check-string p 'repository-path)) new)6676 new)))))66776678(define installation-repository6679 (make-parameter6680 (or (foreign-value "C_private_repository_path()" c-string)6681 (get-environment-variable "CHICKEN_INSTALL_REPOSITORY")6682 install-egg-home)))66836684(define (chop-separator str)6685 (let ((len (fx- (string-length str) 1)))6686 (if (and (> len 0)6687 (memq (string-ref str len) '(#\\ #\/)))6688 (substring str 0 len)6689 str) ) )66906691(define ##sys#include-pathnames6692 (cond ((get-environment-variable "CHICKEN_INCLUDE_PATH")6693 => (lambda (p)6694 (map chop-separator (##sys#split-path p))))6695 (else (list installation-home))))66966697(define (include-path) ##sys#include-pathnames)669866996700;;; Feature identifiers:67016702(define ->feature-id ; TODO: export this? It might be useful..6703 (let ()6704 (define (err . args)6705 (apply ##sys#signal-hook #:type-error "bad argument type - not a valid feature identifer" args))6706 (define (prefix s)6707 (if s (##sys#string-append s "-") ""))6708 (lambda (x)6709 (cond ((keyword? x) x)6710 ((string? x) (string->keyword x))6711 ((symbol? x) (string->keyword (##sys#symbol->string x)))6712 (else (err x))))))67136714(define ##sys#features6715 '(#:chicken6716 #:srfi-6 #:srfi-12 #:srfi-17 #:srfi-23 #:srfi-306717 #:srfi-39 #:srfi-62 #:srfi-88 #:full-numeric-tower))67186719;; Add system features:67206721(let ((check (lambda (f)6722 (unless (eq? 'unknown f)6723 (set! ##sys#features (cons (->feature-id f) ##sys#features))))))6724 (check (software-type))6725 (check (software-version))6726 (check (build-platform))6727 (check (machine-type))6728 (check (machine-byte-order)))67296730(when (foreign-value "HAVE_DLOAD" bool)6731 (set! ##sys#features (cons #:dload ##sys#features)))6732(when (foreign-value "HAVE_PTABLES" bool)6733 (set! ##sys#features (cons #:ptables ##sys#features)))6734(when (foreign-value "HAVE_GCHOOKS" bool)6735 (set! ##sys#features (cons #:gchooks ##sys#features)))6736(when (foreign-value "IS_CROSS_CHICKEN" bool)6737 (set! ##sys#features (cons #:cross-chicken ##sys#features)))67386739;; Register a feature to represent the word size (e.g., 32bit, 64bit)6740(set! ##sys#features6741 (cons (string->keyword6742 (string-append6743 (number->string (foreign-value "C_WORD_SIZE" int))6744 "bit"))6745 ##sys#features))67466747(set! ##sys#features6748 (let ((major (##sys#number->string (foreign-value "C_MAJOR_VERSION" int)))6749 (minor (##sys#number->string (foreign-value "C_MINOR_VERSION" int))))6750 (cons (->feature-id (string-append "chicken-" major))6751 (cons (->feature-id (string-append "chicken-" major "." minor))6752 ##sys#features))))67536754(define (register-feature! . fs)6755 (for-each6756 (lambda (f)6757 (let ((id (->feature-id f)))6758 (unless (memq id ##sys#features) (set! ##sys#features (cons id ##sys#features)))))6759 fs)6760 (##core#undefined))67616762(define (unregister-feature! . fs)6763 (let ((fs (map ->feature-id fs)))6764 (set! ##sys#features6765 (let loop ((ffs ##sys#features))6766 (if (null? ffs)6767 '()6768 (let ((f (##sys#slot ffs 0))6769 (r (##sys#slot ffs 1)))6770 (if (memq f fs)6771 (loop r)6772 (cons f (loop r)))))))6773 (##core#undefined)))67746775(define (features) ##sys#features)67766777(define (feature? . ids)6778 (let loop ((ids ids))6779 (or (null? ids)6780 (and (memq (->feature-id (##sys#slot ids 0)) ##sys#features)6781 (loop (##sys#slot ids 1))))))67826783(define return-to-host6784 (##core#primitive "C_return_to_host"))67856786(define (system-config-directory)6787 (or (get-environment-variable "XDG_CONFIG_HOME")6788 (if ##sys#windows-platform6789 (get-environment-variable "APPDATA")6790 (let ((home (get-environment-variable "HOME")))6791 (and home (string-append home "/.config"))))))67926793(define (system-cache-directory)6794 (or (get-environment-variable "XDG_CACHE_HOME")6795 (if ##sys#windows-platform6796 (or (get-environment-variable "LOCALAPPDATA")6797 (get-environment-variable "APPDATA"))6798 (let ((home (get-environment-variable "HOME")))6799 (and home (string-append home "/.cache"))))))68006801) ; chicken.platform