~ chicken-core (master) /library.scm
Trap1;;;; library.scm - R5RS/R7RS 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#vector-resize ##sys#default-parameter-vector33 setter-tag34 ##sys#print-exit ##sys#r7rs-exn-handlers35 ##sys#format-here-doc-warning36 exit-in-progress cleanup-before-exit chicken.base#cleanup-tasks37 maximal-string-length find-ratio-between find-ratio38 make-complex flonum->ratnum ratnum39 +maximum-allowed-exponent+ mantexp->dbl ldexp ldexp*40 round-quotient41 fllog1+ ##sys#sign ##sys#atanh ##sys#internal-atanh42 ##sys#sign-bit ##sys#tanh43 ##sys#string->compnum ##sys#internal-gcd)44 (not inline chicken.base#sleep-hook ##sys#change-directory-hook45 ##sys#user-read-hook ##sys#error-hook ##sys#signal-hook ##sys#signal-hook/errno46 ##sys#default-read-info-hook ##sys#infix-list-hook47 ##sys#sharp-number-hook ##sys#user-print-hook48 ##sys#user-interrupt-hook ##sys#windows-platform49 ##sys#resume-thread-on-event ##sys#suspend-thread-on-event50 ##sys#schedule ##sys#features)51 (foreign-declare #<<EOF52#include <errno.h>53#include <float.h>5455#ifdef HAVE_SYSEXITS_H56# include <sysexits.h>57#endif5859#ifndef EX_SOFTWARE60# define EX_SOFTWARE 7061#endif6263#define C_close_file(p) C_mk_bool(C_fclose((C_FILEPTR)(C_port_file(p))) == 0)64#define C_a_f64peek(ptr, c, b, i) C_flonum(ptr, ((double *)C_data_pointer(b))[ C_unfix(i) ])65#define C_fetch_c_strlen(b, i) C_fix(strlen((C_char *)C_block_item(b, C_unfix(i))))66#define C_asciiz_strlen(str) C_fix(strlen(C_c_string(str)))67#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)68#define C_free_mptr(p, i) (C_free((void *)C_block_item(p, C_unfix(i))), C_SCHEME_UNDEFINED)69#define C_free_sptr(p, i) (C_free((void *)(((C_char **)C_block_item(p, 0))[ C_unfix(i) ])), C_SCHEME_UNDEFINED)7071#define C_a_get_current_seconds(ptr, c, dummy) C_int64_to_num(ptr, time(NULL))72#define C_peek_c_string_at(ptr, i) ((C_char *)(((C_char **)ptr)[ i ]))7374#define C_flush_all_files(dummy) (C_fflush(NULL), C_SCHEME_UNDEFINED)7576static C_word77fast_read_line_from_file(C_word str, C_word start, C_word port, C_word size) {78 int n = C_unfix(size);79 int i;80 int c;81 int p = C_unfix(start);82 char *buf = C_c_string(str) + p;83 C_FILEPTR fp = C_port_file(port);8485 if ((c = C_getc(fp)) == EOF) {86 if (ferror(fp)) {87 clearerr(fp);88 if(p) return start;89 return C_fix(-1);90 } else { /* feof (fp) */91 if(p) return start;92 return C_SCHEME_END_OF_FILE;93 }94 }9596 C_ungetc(c, fp);9798 for (i = 0; i < n; i++) {99 c = C_getc(fp);100101 if(c == EOF && ferror(fp)) {102 clearerr(fp);103 return C_fix(-(i + 1) + p);104 }105106 switch (c) {107 case '\r': if ((c = C_getc(fp)) != '\n') C_ungetc(c, fp);108 case EOF: clearerr(fp);109 case '\n': return C_fix(i + p);110 }111 buf[i] = c;112 }113 if(p) return start;114 return C_SCHEME_FALSE;115}116117static C_word118fast_read_string_from_file(C_word dest, C_word port, C_word len, C_word pos)119{120 size_t m;121 int n = C_unfix (len);122 C_char * buf = C_c_string(dest) + C_unfix(pos);123 C_FILEPTR fp = C_port_file (port);124125 if(feof(fp)) return C_SCHEME_END_OF_FILE;126127 m = fread (buf, sizeof (char), n, fp);128129 if (m < n) {130 if (ferror(fp)) /* Report to Scheme, which may retry, so clear errors */131 clearerr(fp);132 else if (feof(fp) && 0 == m) /* eof but m > 0? Return data first, below */133 return C_SCHEME_END_OF_FILE; /* Calling again will get us here */134 }135136 return C_fix (m);137}138139static C_word140shallow_equal(C_word x, C_word y)141{142 /* assumes x and y are non-immediate */143 int i, len = C_header_size(x);144145 if(C_header_size(y) != len) return C_SCHEME_FALSE;146 else return C_mk_bool(!C_memcmp((void *)x, (void *)y, len * sizeof(C_word)));147}148149static C_word150signal_debug_event(C_word mode, C_word msg, C_word args)151{152 C_DEBUG_INFO cell;153 C_word av[ 3 ];154 cell.enabled = 1;155 cell.event = C_DEBUG_SIGNAL;156 cell.loc = "";157 cell.val = "";158 av[ 0 ] = mode;159 av[ 1 ] = msg;160 av[ 2 ] = args;161 C_debugger(&cell, 3, av);162 return C_SCHEME_UNDEFINED;163}164165static C_word C_i_sleep_until_interrupt(C_word secs)166{167 while(C_i_process_sleep(secs) == C_fix(-1) && errno == EINTR);168 return C_SCHEME_UNDEFINED;169}170171#ifdef NO_DLOAD2172# define HAVE_DLOAD 0173#else174# define HAVE_DLOAD 1175#endif176177#ifdef C_ENABLE_PTABLES178# define HAVE_PTABLES 1179#else180# define HAVE_PTABLES 0181#endif182183#ifdef C_GC_HOOKS184# define HAVE_GCHOOKS 1185#else186# define HAVE_GCHOOKS 0187#endif188189#if defined(C_CROSS_CHICKEN) && C_CROSS_CHICKEN190# define IS_CROSS_CHICKEN 1191#else192# define IS_CROSS_CHICKEN 0193#endif194EOF195) )196197;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;198;; NOTE: Modules defined here will typically exclude syntax199;; definitions, those are handled by expand.scm or modules.scm.200;; Handwritten import libraries (or a special-case module in201;; modules.scm for scheme) contain the value exports merged with202;; syntactic exports. The upshot of this is that any module that203;; refers to another module defined *earlier* in this file cannot use204;; macros from the earlier module!205;;206;; We get around this problem by using the "chicken.internal.syntax"207;; module, which is baked in and exports *every* available core macro.208;; See modules.scm, expand.scm and chicken-syntax.scm for details.209;;210;; NOTE #2: The module "scheme" is a legacy artifact, with CHICKEN211;; 6 "scheme" being just an alias for "scheme.r5rs", and "scheme.base"212;; is what used to be the standard Scheme module. We use it only213;; to provide a prefix ("scheme#") for the exported toplevel214;; identifiers, which now represent what is in the "scheme.base"215;; standard module. Yes, this is somewhat confusing, but changing216;; all prefixes to use the "proper" name would cause too many217;; bootstrapping problems.218;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;219220;; Pre-declaration of scheme, so it can be used later on. We only use221;; scheme macros and core language forms in here, to avoid a cyclic222;; dependency on itself. All actual definitions are set! below.223;; Also, this declaration is incomplete: the module itself is defined224;; as a primitive module due to syntax exports, which are missing225;; here. See modules.scm for the full definition.226(module scheme227 (;; [syntax]228 ;; We are reexporting these because otherwise the module here229 ;; will be inconsistent with the built-in one, and be void of230 ;; syntax definitions, causing problems below.231 begin and case cond define define-syntax delay do lambda232 if let let* let-syntax letrec letrec-syntax or233 quasiquote quote set! syntax-rules234235 not boolean? eq? eqv? equal? pair? boolean=? symbol=?236 cons car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar237 cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr238 caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar239 cddddr set-car! set-cdr!240 null? list? list length list-tail list-ref append reverse memq memv241 member assq assv assoc symbol? symbol->string string->symbol number?242 integer? exact? real? complex? inexact? rational? zero? odd? even?243 positive? negative? max min + - * / = > < >= <= quotient remainder244 exact-integer?245 modulo gcd lcm abs floor ceiling truncate round rationalize246 exact->inexact inexact->exact exp log expt sqrt247 sin cos tan asin acos atan248 number->string string->number char? char=? char>? char<? char>=?249 char<=? char-ci=? char-ci<? char-ci>? char-ci>=? char-ci<=?250 char-alphabetic? char-whitespace? char-numeric? char-upper-case?251 char-lower-case? char-upcase char-downcase252 char->integer integer->char253 string? string=? string>? string<? string>=? string<=? string-ci=?254 string-ci<? string-ci>? string-ci>=? string-ci<=? make-string255 string-length string-ref string-set! string-append string-copy string-copy!256 string->list list->string substring string-fill! vector? make-vector257 vector-ref vector-set! string vector vector-length vector->list258 list->vector vector-fill! procedure? map for-each apply force259 call-with-current-continuation call/cc input-port? output-port?260 current-input-port current-output-port call-with-input-file261 call-with-output-file open-input-file open-output-file262 close-input-port close-output-port263 read read-char peek-char write display write-char newline264 eof-object? with-input-from-file with-output-to-file265 char-ready? imag-part real-part make-rectangular make-polar angle266 magnitude numerator denominator values call-with-values dynamic-wind267268 open-input-string open-output-string open-input-bytevector269 open-output-bytevector get-output-string get-output-bytevector270 features make-list port? call-with-port peek-u8 make-parameter271 string-map vector-map string-for-each vector-for-each u8-ready?272 make-list list-set! write-string eof-object list-copy273 string->vector vector->string textual-port? binary-port?274 input-port-open? output-port-open? floor/ truncate/275 exact inexact floor-remainder floor-quotient close-port276277 char-foldcase string-foldcase string-upcase string-downcase278279 ;; The following procedures are overwritten in eval.scm:280 eval interaction-environment null-environment281 scheme-report-environment load)282283(import chicken.internal.syntax) ;; See note above284285;;; Operations on booleans:286287(define (not x) (##core#inline "C_i_not" x))288(define (boolean? x) (##core#inline "C_booleanp" x))289290291;;; Equivalence predicates:292293(define (eq? x y) (##core#inline "C_eqp" x y))294(define (eqv? x y) (##core#inline "C_i_eqvp" x y))295(define (equal? x y) (##core#inline "C_i_equalp" x y))296297(define (boolean=? x y . more)298 (##sys#check-boolean x 'boolean=?)299 (##sys#check-boolean y 'boolean=?)300 (let loop ((bs more) (f (eq? x y)))301 (if (null? bs)302 f303 (let ((b (##sys#slot bs 0)))304 (##sys#check-boolean b 'boolean=?)305 (loop (##sys#slot bs 1)306 (and f (eq? b y)))))))307308(define (symbol=? x y . more)309 (##sys#check-symbol x 'symbol=?)310 (##sys#check-symbol y 'symbol=?)311 (let loop ((bs more) (f (eq? x y)))312 (if (null? bs)313 f314 (let ((b (##sys#slot bs 0)))315 (##sys#check-symbol b 'symbol=?)316 (loop (##sys#slot bs 1)317 (and f (eq? b y)))))))318319320;;; Pairs and lists:321322(define (pair? x) (##core#inline "C_i_pairp" x))323(define (cons x y) (##core#inline_allocate ("C_a_i_cons" 3) x y))324(define (car x) (##core#inline "C_i_car" x))325(define (cdr x) (##core#inline "C_i_cdr" x))326327(define (set-car! x y) (##core#inline "C_i_set_car" x y))328(define (set-cdr! x y) (##core#inline "C_i_set_cdr" x y))329(define (cadr x) (##core#inline "C_i_cadr" x))330(define (caddr x) (##core#inline "C_i_caddr" x))331(define (cadddr x) (##core#inline "C_i_cadddr" x))332(define (cddddr x) (##core#inline "C_i_cddddr" x))333334(define (caar x) (##core#inline "C_i_caar" x))335(define (cdar x) (##core#inline "C_i_cdar" x))336(define (cddr x) (##core#inline "C_i_cddr" x))337(define (caaar x) (car (car (car x))))338(define (caadr x) (car (##core#inline "C_i_cadr" x)))339(define (cadar x) (##core#inline "C_i_cadr" (car x)))340(define (cdaar x) (cdr (car (car x))))341(define (cdadr x) (cdr (##core#inline "C_i_cadr" x)))342(define (cddar x) (cdr (cdr (car x))))343(define (cdddr x) (cdr (cdr (cdr x))))344(define (caaaar x) (car (car (car (car x)))))345(define (caaadr x) (car (car (##core#inline "C_i_cadr" x))))346(define (caadar x) (car (##core#inline "C_i_cadr" (car x))))347(define (caaddr x) (car (##core#inline "C_i_caddr" x)))348(define (cadaar x) (##core#inline "C_i_cadr" (car (car x))))349(define (cadadr x) (##core#inline "C_i_cadr" (##core#inline "C_i_cadr" x)))350(define (caddar x) (##core#inline "C_i_caddr" (car x)))351(define (cdaaar x) (cdr (car (car (car x)))))352(define (cdaadr x) (cdr (car (##core#inline "C_i_cadr" x))))353(define (cdadar x) (cdr (##core#inline "C_i_cadr" (car x))))354(define (cdaddr x) (cdr (##core#inline "C_i_caddr" x)))355(define (cddaar x) (cdr (cdr (car (car x)))))356(define (cddadr x) (cdr (cdr (##core#inline "C_i_cadr" x))))357(define (cdddar x) (cdr (cdr (cdr (car x)))))358359(define (null? x) (eq? x '()))360(define (list . lst) lst)361(define (length lst) (##core#inline "C_i_length" lst))362(define (list-tail lst i) (##core#inline "C_i_list_tail" lst i))363(define (list-ref lst i) (##core#inline "C_i_list_ref" lst i))364365(define append)366367(define (reverse lst0)368 (let loop ((lst lst0) (rest '()))369 (cond ((eq? lst '()) rest)370 ((pair? lst)371 (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest)) )372 (else (##sys#error-not-a-proper-list lst0 'reverse)) ) ))373374(define (memq x lst) (##core#inline "C_i_memq" x lst))375(define (memv x lst) (##core#inline "C_i_memv" x lst))376377(define (member x lst #!optional eq)378 (if eq379 (let loop ((lst lst))380 (and (pair? lst)381 (if (eq x (##sys#slot lst 0))382 lst383 (loop (##sys#slot lst 1)))))384 (##core#inline "C_i_member" x lst)))385386(define (assq x lst) (##core#inline "C_i_assq" x lst))387(define (assv x lst) (##core#inline "C_i_assv" x lst))388389(define (assoc x lst #!optional eq)390 (if eq391 (let loop ((lst lst))392 (and (pair? lst)393 (if (eq x (car (##sys#slot lst 0)))394 (car lst)395 (loop (##sys#slot lst 1)))))396 (##core#inline "C_i_assoc" x lst)))397398(define (list? x) (##core#inline "C_i_listp" x))399400;;; Strings:401402(define make-string)403404(define (string? x) (##core#inline "C_i_stringp" x))405(define (string-length s) (##core#inline "C_i_string_length" s))406(define (string-ref s i) (##core#inline "C_i_string_ref" s i))407(define (string-set! s i c) (##core#inline "C_i_string_set" s i c))408409(define (string=? x y . more)410 (let loop ((s y) (ss more) (f (##core#inline "C_i_string_equal_p" x y)))411 (if (null? ss)412 f413 (let ((s2 (##sys#slot ss 0)))414 (##sys#check-string s2 'string=?)415 (loop s2 (##sys#slot ss 1)416 (and f (##core#inline "C_i_string_equal_p" s s2)))))))417418(define (string-ci=? x y . more)419 (let loop ((s y) (ss more) (f (##core#inline "C_i_string_ci_equal_p" x y)))420 (if (null? ss)421 f422 (let ((s2 (##sys#slot ss 0)))423 (##sys#check-string s2 'string-ci=?)424 (loop s2 (##sys#slot ss 1)425 (and f (##core#inline "C_i_string_ci_equal_p" s s2)))))))426427(define string->list)428(define list->string)429(define string-copy)430(define string-copy!)431(define substring)432(define string-fill!)433434(define string<?)435(define string>?)436(define string<=?)437(define string>=?)438439(define string-ci<?)440(define string-ci>?)441(define string-ci<=?)442(define string-ci>=?)443444(define string)445(define string-append)446447(define open-input-string)448(define open-output-string)449(define open-input-bytevector)450(define open-output-bytevector)451(define get-output-string)452(define get-output-bytevector)453(define features)454(define make-list)455(define port?)456(define call-with-port)457(define close-port)458(define peek-u8)459(define string-map)460(define vector-map)461(define string-for-each)462(define vector-for-each)463(define make-list)464(define list-set!)465(define write-string)466(define eof-object)467(define list-copy)468(define string->vector)469(define vector->string)470(define input-port-open?)471(define output-port-open?)472(define floor/)473(define truncate/)474(define exact)475(define inexact)476(define floor-remainder)477(define floor-quotient)478(define make-parameter)479480;; Complex numbers481(define make-rectangular)482(define make-polar)483(define real-part)484(define imag-part)485(define angle)486(define magnitude)487488;; Rational numbers489(define numerator)490(define denominator)491(define inexact->exact)492(define (exact->inexact x)493 (##core#inline_allocate ("C_a_i_exact_to_inexact" 12) x))494495;; Numerical operations496(define (abs x) (##core#inline_allocate ("C_s_a_i_abs" 7) x))497(define + (##core#primitive "C_plus"))498(define - (##core#primitive "C_minus"))499(define * (##core#primitive "C_times"))500(define /)501(define floor)502(define ceiling)503(define truncate)504(define round)505(define rationalize)506507(define (quotient a b) (##core#inline_allocate ("C_s_a_i_quotient" 5) a b))508(define (remainder a b) (##core#inline_allocate ("C_s_a_i_remainder" 5) a b))509(define (modulo a b) (##core#inline_allocate ("C_s_a_i_modulo" 5) a b))510511(define (even? n) (##core#inline "C_i_evenp" n))512(define (odd? n) (##core#inline "C_i_oddp" n))513514(define max)515(define min)516(define exp)517(define log)518(define sin)519(define cos)520(define tan)521(define asin)522(define acos)523(define atan)524525(define sqrt)526(define expt)527(define gcd)528(define lcm)529530(define = (##core#primitive "C_nequalp"))531(define > (##core#primitive "C_greaterp"))532(define < (##core#primitive "C_lessp"))533(define >= (##core#primitive "C_greater_or_equal_p"))534(define <= (##core#primitive "C_less_or_equal_p"))535(define (number? x) (##core#inline "C_i_numberp" x))536(define complex? number?)537(define (real? x) (##core#inline "C_i_realp" x))538(define (rational? n) (##core#inline "C_i_rationalp" n))539(define (integer? x) (##core#inline "C_i_integerp" x))540(define (exact? x) (##core#inline "C_i_exactp" x))541(define (inexact? x) (##core#inline "C_i_inexactp" x))542(define (zero? n) (##core#inline "C_i_zerop" n))543(define (positive? n) (##core#inline "C_i_positivep" n))544(define (negative? n) (##core#inline "C_i_negativep" n))545(define (exact-integer? x) (##core#inline "C_i_exact_integerp" x))546547(define number->string (##core#primitive "C_number_to_string"))548(define string->number)549550551;;; Symbols:552553(define (symbol? x) (##core#inline "C_i_symbolp" x))554(define symbol->string)555(define string->symbol)556557;;; Vectors:558559(define (vector? x) (##core#inline "C_i_vectorp" x))560(define (vector-length v) (##core#inline "C_i_vector_length" v))561(define (vector-ref v i) (##core#inline "C_i_vector_ref" v i))562(define (vector-set! v i x) (##core#inline "C_i_vector_set" v i x))563(define make-vector)564(define list->vector)565(define vector->list)566(define vector)567(define vector-fill!)568569;;; Characters:570571(define (char? x) (##core#inline "C_charp" x))572573(define (char->integer c)574 (##sys#check-char c 'char->integer)575 (##core#inline "C_fix" (##core#inline "C_character_code" c)) )576577(define (##sys#check-char-code n loc)578 (if (or (##core#inline "C_fixnum_lessp" n 0)579 (##core#inline "C_fixnum_greaterp" n #x10ffff))580 (##sys#signal-hook581 #:domain-error loc "character code is out of valid range" n)582 n))583584(define-inline (fast-i->c n)585 (##core#inline "C_make_character" (##core#inline "C_unfix" n)) )586587(define (integer->char n)588 (##sys#check-fixnum n 'integer->char)589 (##sys#check-char-code n 'integer->char)590 (fast-i->c n))591592(define (char=? c1 c2 . more)593 (##sys#check-char c1 'char=?)594 (##sys#check-char c2 'char=?)595 (let loop ((c c2) (cs more)596 (f (##core#inline "C_u_i_char_equalp" c1 c2)))597 (if (null? cs)598 f599 (let ((c2 (##sys#slot cs 0)))600 (##sys#check-char c2 'char=?)601 (loop c2 (##sys#slot cs 1)602 (and f (##core#inline "C_u_i_char_equalp" c c2)))))))603604(define (char>? c1 c2 . more)605 (##sys#check-char c1 'char>?)606 (##sys#check-char c2 'char>?)607 (let loop ((c c2) (cs more)608 (f (##core#inline "C_u_i_char_greaterp" c1 c2)))609 (if (null? cs)610 f611 (let ((c2 (##sys#slot cs 0)))612 (##sys#check-char c2 'char>?)613 (loop c2 (##sys#slot cs 1)614 (and f (##core#inline "C_u_i_char_greaterp" c c2)))))))615616(define (char<? c1 c2 . more)617 (##sys#check-char c1 'char<?)618 (##sys#check-char c2 'char<?)619 (let loop ((c c2) (cs more)620 (f (##core#inline "C_u_i_char_lessp" c1 c2)))621 (if (null? cs)622 f623 (let ((c2 (##sys#slot cs 0)))624 (##sys#check-char c2 'char<?)625 (loop c2 (##sys#slot cs 1)626 (and f (##core#inline "C_u_i_char_lessp" c c2)))))))627628(define (char>=? c1 c2 . more)629 (##sys#check-char c1 'char>=?)630 (##sys#check-char c2 'char>=?)631 (let loop ((c c2) (cs more)632 (f (##core#inline "C_u_i_char_greater_or_equal_p" c1 c2)))633 (if (null? cs)634 f635 (let ((c2 (##sys#slot cs 0)))636 (##sys#check-char c2 'char>=?)637 (loop c2 (##sys#slot cs 1)638 (and f (##core#inline "C_u_i_char_greater_or_equal_p" c c2)))))))639640(define (char<=? c1 c2 . more)641 (##sys#check-char c1 'char<=?)642 (##sys#check-char c2 'char<=?)643 (let loop ((c c2) (cs more)644 (f (##core#inline "C_u_i_char_less_or_equal_p" c1 c2)))645 (if (null? cs)646 f647 (let ((c2 (##sys#slot cs 0)))648 (##sys#check-char c2 'char<=?)649 (loop c2 (##sys#slot cs 1)650 (and f (##core#inline "C_u_i_char_less_or_equal_p" c c2)))))))651652(define (char-upcase c)653 (##sys#check-char c 'char-upcase)654 (##core#inline "C_u_i_char_upcase" c))655656(define (char-downcase c)657 (##sys#check-char c 'char-downcase)658 (##core#inline "C_u_i_char_downcase" c))659660(define char-ci=?)661(define char-ci>?)662(define char-ci<?)663(define char-ci>=?)664(define char-ci<=?)665666(define (char-upper-case? c)667 (##sys#check-char c 'char-upper-case?)668 (##core#inline "C_u_i_char_upper_casep" c) )669670(define (char-lower-case? c)671 (##sys#check-char c 'char-lower-case?)672 (##core#inline "C_u_i_char_lower_casep" c) )673674(define (char-numeric? c)675 (##sys#check-char c 'char-numeric?)676 (##core#inline "C_u_i_char_numericp" c) )677678(define (char-whitespace? c)679 (##sys#check-char c 'char-whitespace?)680 (##core#inline "C_u_i_char_whitespacep" c) )681682(define (char-alphabetic? c)683 (##sys#check-char c 'char-alphabetic?)684 (##core#inline "C_u_i_char_alphabeticp" c) )685686(define (scheme.char#digit-value c)687 (##sys#check-char c 'digit-value)688 (let ((n (##core#inline "C_u_i_digit_value" c)))689 (and (not (eq? n 0))690 (##core#inline "C_fixnum_difference" n 1))))691692;; case folding and conversion693694(define (char-foldcase c)695 (##sys#check-char c 'char-foldcase)696 (##core#inline "C_utf_char_foldcase" c))697698(define (string-foldcase str)699 (##sys#check-string str 'string-foldcase)700 (let* ((bv (##sys#slot str 0))701 (n (##core#inline "C_fixnum_difference" (##sys#size bv) 1))702 (buf (##sys#make-bytevector (##core#inline "C_fixnum_times" n 2)))703 (len (##core#inline "C_utf_string_foldcase" bv buf n)))704 (##sys#buffer->string! buf len)))705706(define (string-downcase str)707 (##sys#check-string str 'string-downcase)708 (let* ((bv (##sys#slot str 0))709 (n (##core#inline "C_fixnum_difference" (##sys#size bv) 1))710 (buf (##sys#make-bytevector (##core#inline "C_fixnum_times" n 2)))711 (len (##core#inline "C_utf_string_downcase" bv buf n)))712 (##sys#buffer->string! buf len)))713714(define (string-upcase str)715 (##sys#check-string str 'string-upcase)716 (let* ((bv (##sys#slot str 0))717 (n (##core#inline "C_fixnum_difference" (##sys#size bv) 1))718 (buf (##sys#make-bytevector (##core#inline "C_fixnum_times" n 2)))719 (len (##core#inline "C_utf_string_upcase" bv buf n)))720 (##sys#buffer->string! buf len)))721722;;; Procedures:723724(define (procedure? x) (##core#inline "C_i_closurep" x))725(define apply (##core#primitive "C_apply"))726(define values (##core#primitive "C_values"))727(define call-with-values (##core#primitive "C_call_with_values"))728(define call-with-current-continuation)729(define call/cc)730731;;; Ports:732733(define (input-port? x)734 (and (##core#inline "C_blockp" x)735 (##core#inline "C_input_portp" x)))736737(define (output-port? x)738 (and (##core#inline "C_blockp" x)739 (##core#inline "C_output_portp" x)))740741(define (binary-port? port)742 (and (port? port)743 (eq? 'binary (##sys#slot port 14))))744745(define (textual-port? port)746 (and (port? port)747 (eq? 'textual (##sys#slot port 14))))748749(set! scheme#port?750 (lambda (x)751 (and (##core#inline "C_blockp" x)752 (##core#inline "C_portp" x))))753754(set! scheme#input-port-open?755 (lambda (p)756 (##sys#check-input-port p 'input-port-open?)757 (##core#inline "C_input_port_openp" p)))758759(set! scheme#output-port-open?760 (lambda (p)761 (##sys#check-output-port p 'output-port-open?)762 (##core#inline "C_output_port_openp" p)))763764(define current-input-port)765(define current-output-port)766(define open-input-file)767(define open-output-file)768(define close-input-port)769(define close-output-port)770(define call-with-input-file)771(define call-with-output-file)772(define with-input-from-file)773(define with-output-to-file)774775;;; Input:776777(define (eof-object? x) (##core#inline "C_eofp" x))778(define char-ready?)779(define u8-ready?)780(define read-char)781(define peek-char)782(define read)783784;;; Output:785786(define write-char)787(define newline)788(define write)789(define display)790791;;; Evaluation environments:792793;; All of the stuff below is overwritten with their "real"794;; implementations by chicken.eval (see eval.scm)795796(define (eval x . env)797 (##sys#error 'eval "`eval' is not defined - the `eval' unit was probably not linked with this executable"))798799(define (interaction-environment)800 (##sys#error 'interaction-environment "`interaction-environment' is not defined - the `eval' unit was probably not linked with this executable"))801802(define (scheme-report-environment n)803 (##sys#error 'scheme-report-environment "`scheme-report-environment' is not defined - the `eval' unit was probably not linked with this executable"))804805(define (null-environment)806 (##sys#error 'null-environment "`null-environment' is not defined - the `eval' unit was probably not linked with this executable"))807808(define (load filename . evaluator)809 (##sys#error 'load "`load' is not defined - the `eval' unit was probably not linked with this executable"))810811;; Other stuff:812813(define force)814(define for-each)815(define map)816(define dynamic-wind)817818) ; scheme819820(import scheme)821(import (only (scheme base) make-parameter open-output-string get-output-string))822823;; Pre-declaration of chicken.base, so it can be used later on. Much824;; like the "scheme" module, most declarations will be set! further825;; down in this file, mostly to avoid a cyclic dependency on itself.826;; The full definition (with macros) is in its own import library.827(module chicken.base828 (;; [syntax] and-let* case-lambda cut cute declare define-constant829 ;; define-inline define-record define-record-type830 ;; define-values delay-force fluid-let include831 ;; let-optionals let-values let*-values letrec*832 ;; letrec-values nth-value optional parameterize rec receive833 ;; require-library require-extension set!-values syntax unless when834 bignum? flonum? fixnum? ratnum? cplxnum? finite? infinite? nan?835 exact-integer-sqrt exact-integer-nth-root836837 port-closed? flush-output838 get-call-chain print print* add1 sub1 sleep839 current-error-port error void gensym print-call-chain840 char-name enable-warnings841 equal=? finite? foldl foldr getter-with-setter842 notice procedure-information setter signum string->uninterned-symbol843 subvector symbol-append vector-resize844 warning quotient&remainder quotient&modulo845 record-printer set-record-printer!846 make-promise promise?847 alist-ref alist-update alist-update! rassoc atom? butlast chop848 compress flatten intersperse join list-of? tail? constantly849 complement compose conjoin disjoin each flip identity o850851 case-sensitive keyword-style parentheses-synonyms symbol-escape852853 on-exit exit exit-handler implicit-exit-handler emergency-exit854 bwp-object? weak-cons weak-pair?)855856(import scheme chicken.internal.syntax)857858(define (fixnum? x) (##core#inline "C_fixnump" x))859(define (flonum? x) (##core#inline "C_i_flonump" x))860(define (bignum? x) (##core#inline "C_i_bignump" x))861(define (ratnum? x) (##core#inline "C_i_ratnump" x))862(define (cplxnum? x) (##core#inline "C_i_cplxnump" x))863(define exact-integer-sqrt)864(define exact-integer-nth-root)865866(define quotient&remainder (##core#primitive "C_quotient_and_remainder"))867;; Modulo's sign follows y (whereas remainder's sign follows x)868;; Inlining this is not much use: quotient&remainder is primitive869(define (quotient&modulo x y)870 (call-with-values (lambda () (quotient&remainder x y))871 (lambda (div rem)872 (if (positive? y)873 (if (negative? rem)874 (values div (+ rem y))875 (values div rem))876 (if (positive? rem)877 (values div (+ rem y))878 (values div rem))))))879880881(define (finite? x) (##core#inline "C_i_finitep" x))882(define (infinite? x) (##core#inline "C_i_infinitep" x))883(define (nan? x) (##core#inline "C_i_nanp" x))884885(define signum (##core#primitive "C_signum"))886887(define equal=?)888(define get-call-chain)889(define print-call-chain)890(define print)891(define print*)892(define (add1 n) (+ n 1))893(define (sub1 n) (- n 1))894(define current-error-port)895896(define (error . args)897 (if (pair? args)898 (apply ##sys#signal-hook #:error args)899 (##sys#signal-hook #:error #f)))900901(define (void . _) (##core#undefined))902903(define sleep)904905(define char-name)906(define enable-warnings)907; (define enable-notices)???908(define getter-with-setter)909(define procedure-information)910(define setter)911(define string->uninterned-symbol)912(define record-printer)913(define set-record-printer!)914915(define gensym)916917(define subvector)918(define vector-resize)919920(define symbol-append)921(define warning)922(define notice)923924(define port-closed?)925(define flush-output)926927;;; Promises:928929(define (promise? x)930 (##sys#structure? x 'promise))931932(define (##sys#make-promise proc)933 (##sys#make-structure 'promise proc))934935(define (make-promise obj)936 (if (promise? obj) obj937 (##sys#make-promise (lambda () obj))))938939;;; fast folds with correct argument order940941(define (foldl f z lst)942 (##sys#check-list lst 'foldl)943 (let loop ((lst lst) (z z))944 (if (not (pair? lst))945 z946 (loop (##sys#slot lst 1) (f z (##sys#slot lst 0))))))947948(define (foldr f z lst)949 (##sys#check-list lst 'foldr)950 (let loop ((lst lst))951 (if (not (pair? lst))952 z953 (f (##sys#slot lst 0) (loop (##sys#slot lst 1))))))954955;;; Exit:956957(define implicit-exit-handler)958(define exit-handler)959960(define chicken.base#cleanup-tasks '())961962(define (on-exit thunk)963 (set! cleanup-tasks (cons thunk chicken.base#cleanup-tasks)))964965(define (exit #!optional (code 0)) ; DEPRECATED966 ((exit-handler) code))967968(define (emergency-exit #!optional (code 0)) ; DEPRECATED (move to scheme.process-context)969 (##sys#check-fixnum code 'emergency-exit)970 (##core#inline "C_exit_runtime" code))971972;;; Parameters:973974(define case-sensitive)975(define keyword-style)976(define parentheses-synonyms)977(define symbol-escape)978979;;; Combinators:980981(define (identity x) x)982983(define (conjoin . preds)984 (lambda (x)985 (let loop ((preds preds))986 (or (null? preds)987 (and ((##sys#slot preds 0) x)988 (loop (##sys#slot preds 1)) ) ) ) ) )989990(define (disjoin . preds)991 (lambda (x)992 (let loop ((preds preds))993 (and (not (null? preds))994 (or ((##sys#slot preds 0) x)995 (loop (##sys#slot preds 1)) ) ) ) ) )996997(define (constantly . xs)998 (if (eq? 1 (length xs))999 (let ((x (car xs)))1000 (lambda _ x) )1001 (lambda _ (apply values xs)) ) )10021003(define (flip proc) (lambda (x y) (proc y x)))10041005(define complement1006 (lambda (p)1007 (lambda args (not (apply p args))) ) )10081009(define (compose . fns)1010 (define (rec f0 . fns)1011 (if (null? fns)1012 f01013 (lambda args1014 (call-with-values1015 (lambda () (apply (apply rec fns) args))1016 f0) ) ) )1017 (if (null? fns)1018 values1019 (apply rec fns) ) )10201021(define (o . fns)1022 (if (null? fns)1023 identity1024 (let loop ((fns fns))1025 (let ((h (##sys#slot fns 0))1026 (t (##sys#slot fns 1)) )1027 (if (null? t)1028 h1029 (lambda (x) (h ((loop t) x))))))))10301031(define (list-of? pred)1032 (lambda (lst)1033 (let loop ((lst lst))1034 (cond ((null? lst) #t)1035 ((not (pair? lst)) #f)1036 ((pred (##sys#slot lst 0)) (loop (##sys#slot lst 1)))1037 (else #f) ) ) ) )10381039(define (each . procs)1040 (cond ((null? procs) (lambda _ (##core#undefined)))1041 ((null? (##sys#slot procs 1)) (##sys#slot procs 0))1042 (else1043 (lambda args1044 (let loop ((procs procs))1045 (let ((h (##sys#slot procs 0))1046 (t (##sys#slot procs 1)) )1047 (if (null? t)1048 (apply h args)1049 (begin1050 (apply h args)1051 (loop t) ) ) ) ) ) ) ) )105210531054;;; Weak pairs:1055(define (bwp-object? x) (##core#inline "C_bwpp" x))1056(define (weak-cons x y) (##core#inline_allocate ("C_a_i_weak_cons" 3) x y))1057(define (weak-pair? x) (##core#inline "C_i_weak_pairp" x))10581059;;; List operators:10601061(define (atom? x) (##core#inline "C_i_not_pair_p" x))10621063(define (tail? x y)1064 (##sys#check-list y 'tail?)1065 (let loop ((y y))1066 (cond ((##core#inline "C_eqp" x y) #t)1067 ((and (##core#inline "C_blockp" y)1068 (##core#inline "C_pairp" y))1069 (loop (##sys#slot y 1)))1070 (else #f))))10711072(define intersperse1073 (lambda (lst x)1074 (let loop ((ns lst))1075 (if (##core#inline "C_eqp" ns '())1076 ns1077 (let ((tail (cdr ns)))1078 (if (##core#inline "C_eqp" tail '())1079 ns1080 (cons (##sys#slot ns 0) (cons x (loop tail))) ) ) ) ) ) )10811082(define (butlast lst)1083 (##sys#check-pair lst 'butlast)1084 (let loop ((lst lst))1085 (let ((next (##sys#slot lst 1)))1086 (if (and (##core#inline "C_blockp" next) (##core#inline "C_pairp" next))1087 (cons (##sys#slot lst 0) (loop next))1088 '() ) ) ) )10891090(define (flatten . lists0)1091 (let loop ((lists lists0) (rest '()))1092 (cond ((null? lists) rest)1093 (else1094 (let ((head (##sys#slot lists 0))1095 (tail (##sys#slot lists 1)) )1096 (if (list? head)1097 (loop head (loop tail rest))1098 (cons head (loop tail rest)) ) ) ) ) ) )10991100(define chop)11011102(define (join lsts . lst)1103 (let ((lst (if (pair? lst) (car lst) '())))1104 (##sys#check-list lst 'join)1105 (let loop ((lsts lsts))1106 (cond ((null? lsts) '())1107 ((not (pair? lsts))1108 (##sys#error-not-a-proper-list lsts) )1109 (else1110 (let ((l (##sys#slot lsts 0))1111 (r (##sys#slot lsts 1)) )1112 (if (null? r)1113 l1114 (##sys#append l lst (loop r)) ) ) ) ) ) ) )11151116(define compress1117 (lambda (blst lst)1118 (let ((msg "bad argument type - not a proper list"))1119 (##sys#check-list lst 'compress)1120 (let loop ((blst blst) (lst lst))1121 (cond ((null? blst) '())1122 ((not (pair? blst))1123 (##sys#signal-hook #:type-error 'compress msg blst) )1124 ((not (pair? lst))1125 (##sys#signal-hook #:type-error 'compress msg lst) )1126 ((##sys#slot blst 0)1127 (cons (##sys#slot lst 0) (loop (##sys#slot blst 1) (##sys#slot lst 1))))1128 (else (loop (##sys#slot blst 1) (##sys#slot lst 1))) ) ) ) ) )112911301131;;; Alists:11321133(define (alist-update! x y lst #!optional (cmp eqv?))1134 (let* ((aq (cond ((eq? eq? cmp) assq)1135 ((eq? eqv? cmp) assv)1136 ((eq? equal? cmp) assoc)1137 (else1138 (lambda (x lst)1139 (let loop ((lst lst))1140 (and (pair? lst)1141 (let ((a (##sys#slot lst 0)))1142 (if (and (pair? a) (cmp x (##sys#slot a 0)))1143 a1144 (loop (##sys#slot lst 1)) ) ) ) ) ) ) ) )1145 (item (aq x lst)) )1146 (if item1147 (begin1148 (##sys#setslot item 1 y)1149 lst)1150 (cons (cons x y) lst) ) ) )11511152(define (alist-update k v lst #!optional (cmp eqv?))1153 (let loop ((lst lst))1154 (cond ((null? lst)1155 (list (cons k v)))1156 ((not (pair? lst))1157 (error 'alist-update "bad argument type" lst))1158 (else1159 (let ((a (##sys#slot lst 0)))1160 (cond ((not (pair? a))1161 (error 'alist-update "bad argument type" a))1162 ((cmp k (##sys#slot a 0))1163 (cons (cons k v) (##sys#slot lst 1)))1164 (else1165 (cons (cons (##sys#slot a 0) (##sys#slot a 1))1166 (loop (##sys#slot lst 1))))))))))11671168(define (alist-ref x lst #!optional (cmp eqv?) (default #f))1169 (let* ((aq (cond ((eq? eq? cmp) assq)1170 ((eq? eqv? cmp) assv)1171 ((eq? equal? cmp) assoc)1172 (else1173 (lambda (x lst)1174 (let loop ((lst lst))1175 (cond1176 ((null? lst) #f)1177 ((pair? lst)1178 (let ((a (##sys#slot lst 0)))1179 (##sys#check-pair a 'alist-ref)1180 (if (cmp x (##sys#slot a 0))1181 a1182 (loop (##sys#slot lst 1)) ) ))1183 (else (error 'alist-ref "bad argument type" lst)) ) ) ) ) ) )1184 (item (aq x lst)) )1185 (if item1186 (##sys#slot item 1)1187 default) ) )11881189;; TODO: Make inlineable in C without "tst", to be more like assoc?1190(define (rassoc x lst . tst)1191 (##sys#check-list lst 'rassoc)1192 (let ((tst (if (pair? tst) (car tst) eqv?)))1193 (let loop ((l lst))1194 (and (pair? l)1195 (let ((a (##sys#slot l 0)))1196 (##sys#check-pair a 'rassoc)1197 (if (tst x (##sys#slot a 1))1198 a1199 (loop (##sys#slot l 1)) ) ) ) ) ) )12001201) ; chicken.base12021203(import chicken.base)12041205(define-constant output-string-initial-size 256)12061207(set! scheme#open-input-string1208 (lambda (string)1209 (##sys#check-string string 'open-input-string)1210 (let* ((port (##sys#make-port 1 ##sys#string-port-class "(string)" 'string))1211 (bv (##sys#slot string 0))1212 (len (##core#inline "C_fixnum_difference" (##sys#size bv) 1))1213 (bv2 (##sys#make-bytevector len)))1214 (##core#inline "C_copy_memory" bv2 bv len)1215 (##sys#setislot port 10 0)1216 (##sys#setislot port 11 len)1217 (##sys#setslot port 12 bv2)1218 port)))12191220(set! scheme#open-output-string1221 (lambda ()1222 (let ((port (##sys#make-port 2 ##sys#string-port-class "(string)" 'string)))1223 (##sys#setislot port 10 0)1224 (##sys#setislot port 11 output-string-initial-size)1225 (##sys#setslot port 12 (##sys#make-bytevector output-string-initial-size))1226 port)))12271228(set! scheme#get-output-string1229 (lambda (port)1230 (##sys#check-output-port port #f 'get-output-string)1231 (if (not (eq? 'string (##sys#slot port 7)))1232 (##sys#signal-hook1233 #:type-error 'get-output-string "argument is not a string-output-port" port)1234 (##sys#buffer->string (##sys#slot port 12) 0 (##sys#slot port 10)))))12351236(set! scheme#open-input-bytevector1237 (lambda (bv)1238 (let ((port (##sys#make-port 1 #f "(bytevector)" 'custom)))1239 (##sys#check-bytevector bv 'open-input-bytevector)1240 (##sys#setslot port 14 'binary)1241 (##sys#setslot1242 port1243 21244 (let ((index 0)1245 (bv-len (##sys#size bv)))1246 (vector (lambda (_) ; read-char1247 (if (eq? index bv-len)1248 #!eof1249 (let ((c (##core#inline "C_i_bytevector_ref" bv index)))1250 (set! index (##core#inline "C_fixnum_plus" index 1))1251 (fast-i->c c))))1252 (lambda (_) ; peek-char1253 (if (eq? index bv-len)1254 #!eof1255 (fast-i->c (##core#inline "C_i_bytevector_ref" bv index))))1256 #f ; write-char1257 #f ; write-bytevector1258 (lambda (_ _) ; close1259 (##sys#setislot port 8 #t))1260 #f ; flush-output1261 (lambda (_) #t) ; u8-ready?1262 (lambda (p n dest start) ; read-bytevector!1263 (let ((n2 (min n (##core#inline "C_fixnum_difference" bv-len index))))1264 (##core#inline "C_copy_memory_with_offset" dest bv start index n2)1265 (set! index (##core#inline "C_fixnum_plus" index n2))1266 n2))1267 #f ; read-line1268 #f ; read-buffered1269 (lambda (_) #t) ; char-ready?1270 )))1271 port)))12721273(set! scheme#open-output-bytevector1274 (lambda ()1275 (let ((port (##sys#make-port 2 #f "(bytevector)" 'custom))1276 (buffer (##sys#make-bytevector 256))1277 (index 0)1278 (size 256))1279 (define (add bv start end)1280 (let* ((len (##core#inline "C_fixnum_difference" end start))1281 (i2 (##core#inline "C_fixnum_plus" index len)))1282 (when (##core#inline "C_fixnum_greaterp" i2 size)1283 (let* ((sz2 (##core#inline "C_fixnum_plus" size i2))1284 (bv2 (##sys#make-bytevector sz2)))1285 (##core#inline "C_copy_memory_with_offset" bv2 buffer 0 0 index)1286 (set! size sz2)1287 (set! buffer bv2)))1288 (##core#inline "C_copy_memory_with_offset" buffer bv index start len)1289 (set! index i2)))1290 (define (getter)1291 (let ((bv (##sys#make-bytevector index)))1292 (##core#inline "C_copy_memory_with_offset" bv buffer 0 0 index)1293 bv))1294 (##sys#setslot port 9 getter)1295 (##sys#setslot port 14 'binary)1296 (##sys#setslot1297 port1298 21299 (vector #f ; read-char1300 #f ; peek-char1301 (lambda (p c) ; write-char1302 (let* ((s (string c))1303 (bv (##sys#slot s 0)))1304 (add bv 0 (##core#inline "C_fixnum_difference" (##sys#size bv) 1))))1305 (lambda (p bv start end) ; write-bytevector1306 (add bv start end))1307 (lambda (_ _) ; close1308 (##sys#setislot port 8 #t))1309 (lambda (_) #f) ; flush-output1310 #f ; u8-ready?1311 #f ; read-bytevector!1312 #f ; read-line1313 #f ; read-buffered1314 #f ; char-ready?1315 ))1316 port)))13171318(set! scheme#get-output-bytevector1319 (lambda (p)1320 (define (fail) (error 'get-output-bytevector "not an output-bytevector" p))1321 (##sys#check-output-port p 'get-output-bytevector)1322 (if (eq? (##sys#slot p 7) 'custom)1323 (let ((getter (##sys#slot p 9)))1324 (if (procedure? getter)1325 (getter)1326 (fail)))1327 (fail))))13281329(define-constant char-name-table-size 37)1330(define-constant read-line-buffer-initial-size 1024)1331(define-constant default-parameter-vector-size 16)1332(define maximal-string-length (- (foreign-value "C_HEADER_SIZE_MASK" unsigned-long) 1))13331334;;; Fixnum arithmetic:13351336(module chicken.fixnum *1337(import scheme)1338(import chicken.foreign)13391340(define most-positive-fixnum (foreign-value "C_MOST_POSITIVE_FIXNUM" int))1341(define most-negative-fixnum (foreign-value "C_MOST_NEGATIVE_FIXNUM" int))1342(define fixnum-bits (foreign-value "(C_WORD_SIZE - 1)" int))1343(define fixnum-precision (foreign-value "(C_WORD_SIZE - (1 + 1))" int))13441345(define (fx+ x y) (##core#inline "C_fixnum_plus" x y))1346(define (fx- x y) (##core#inline "C_fixnum_difference" x y))1347(define (fx* x y) (##core#inline "C_fixnum_times" x y))1348(define (fx= x y) (eq? x y))1349(define (fx> x y) (##core#inline "C_fixnum_greaterp" x y))1350(define (fx< x y) (##core#inline "C_fixnum_lessp" x y))1351(define (fx>= x y) (##core#inline "C_fixnum_greater_or_equal_p" x y))1352(define (fx<= x y) (##core#inline "C_fixnum_less_or_equal_p" x y))1353(define (fxmin x y) (##core#inline "C_i_fixnum_min" x y))1354(define (fxmax x y) (##core#inline "C_i_fixnum_max" x y))1355(define (fxneg x) (##core#inline "C_fixnum_negate" x))1356(define (fxand x y) (##core#inline "C_fixnum_and" x y))1357(define (fxior x y) (##core#inline "C_fixnum_or" x y))1358(define (fxxor x y) (##core#inline "C_fixnum_xor" x y))1359(define (fxnot x) (##core#inline "C_fixnum_not" x))1360(define (fxshl x y) (##core#inline "C_fixnum_shift_left" x y))1361(define (fxshr x y) (##core#inline "C_fixnum_shift_right" x y))1362(define (fxodd? x) (##core#inline "C_i_fixnumoddp" x))1363(define (fxeven? x) (##core#inline "C_i_fixnumevenp" x))1364(define (fxlen x) (##core#inline "C_i_fixnum_length" x))1365(define (fx/ x y) (##core#inline "C_fixnum_divide" x y) )1366(define (fxgcd x y) (##core#inline "C_i_fixnum_gcd" x y))1367(define (fxmod x y) (##core#inline "C_fixnum_modulo" x y) )1368(define (fxrem x y) (##core#inline "C_i_fixnum_remainder_checked" x y) )13691370;; Overflow-detecting versions of some of the above1371(define (fx+? x y) (##core#inline "C_i_o_fixnum_plus" x y) )1372(define (fx-? x y) (##core#inline "C_i_o_fixnum_difference" x y) )1373(define (fx*? x y) (##core#inline "C_i_o_fixnum_times" x y) )1374(define (fx/? x y) (##core#inline "C_i_o_fixnum_quotient" x y))13751376) ; chicken.fixnum13771378(import chicken.fixnum)137913801381;;; System routines:13821383(define (##sys#debug-mode?) (##core#inline "C_i_debug_modep"))13841385(define ##sys#warnings-enabled #t)1386(define ##sys#notices-enabled (##sys#debug-mode?))13871388(set! chicken.base#warning1389 (lambda (msg . args)1390 (when ##sys#warnings-enabled1391 (apply ##sys#signal-hook #:warning msg args))))13921393(set! chicken.base#notice1394 (lambda (msg . args)1395 (when (and ##sys#notices-enabled1396 ##sys#warnings-enabled)1397 (apply ##sys#signal-hook #:notice msg args))))13981399(set! chicken.base#enable-warnings1400 (lambda bool1401 (if (pair? bool)1402 (set! ##sys#warnings-enabled (car bool))1403 ##sys#warnings-enabled)))14041405(define ##sys#error error)1406(define ##sys#warn warning)1407(define ##sys#notice notice)14081409(define (##sys#error/errno err . args)1410 (if (pair? args)1411 (apply ##sys#signal-hook/errno #:error err #f args)1412 (##sys#signal-hook/errno #:error err #f)))14131414(define-foreign-variable strerror c-string "strerror(errno)")14151416(define ##sys#gc (##core#primitive "C_gc"))1417(define (##sys#setslot x i y) (##core#inline "C_i_setslot" x i y))1418(define (##sys#setislot x i y) (##core#inline "C_i_set_i_slot" x i y))1419(define ##sys#allocate-vector (##core#primitive "C_allocate_vector"))1420(define ##sys#allocate-bytevector (##core#primitive "C_allocate_bytevector"))1421(define ##sys#make-structure (##core#primitive "C_make_structure"))1422(define ##sys#ensure-heap-reserve (##core#primitive "C_ensure_heap_reserve"))1423(define ##sys#symbol-table-info (##core#primitive "C_get_symbol_table_info"))1424(define ##sys#memory-info (##core#primitive "C_get_memory_info"))14251426(define (##sys#start-timer)1427 (##sys#gc #t)1428 (##core#inline "C_start_timer"))14291430(define (##sys#stop-timer)1431 (let ((info ((##core#primitive "C_stop_timer"))))1432 ;; Run a major GC one more time to get memory usage information in1433 ;; case there was no major GC while the timer was running1434 (##sys#gc #t)1435 (##sys#setslot info 6 (##sys#slot ((##core#primitive "C_stop_timer")) 6))1436 info))14371438(define (##sys#immediate? x) (not (##core#inline "C_blockp" x)))1439(define (##sys#message str) (##core#inline "C_message" str))1440(define (##sys#byte x i) (##core#inline "C_subbyte" x i))1441(define ##sys#void void)1442(define ##sys#undefined-value (##core#undefined))1443(define (##sys#halt msg) (##core#inline "C_halt" msg))1444(define ##sys#become! (##core#primitive "C_become"))1445(define (##sys#block-ref x i) (##core#inline "C_i_block_ref" x i))1446(define ##sys#apply-values (##core#primitive "C_apply_values"))1447(define ##sys#copy-closure (##core#primitive "C_copy_closure"))14481449(define (##sys#block-set! x i y)1450 (when (or (not (##core#inline "C_blockp" x))1451 (and (##core#inline "C_specialp" x) (fx= i 0))1452 (##core#inline "C_byteblockp" x) )1453 (##sys#signal-hook '#:type-error '##sys#block-set! "slot not accessible" x) )1454 (##sys#check-range i 0 (##sys#size x) '##sys#block-set!)1455 (##sys#setslot x i y) )14561457(module chicken.time1458 ;; NOTE: We don't emit the import lib. Due to syntax exports, it has1459 ;; to be a hardcoded primitive module.1460 ;;1461 ;; [syntax] time1462 (cpu-time1463 current-process-milliseconds current-seconds)14641465(import scheme)1466(import (only chicken.module reexport))14671468(define (current-process-milliseconds)1469 (##core#inline_allocate ("C_a_i_current_process_milliseconds" 7) #f))14701471(define (current-seconds)1472 (##core#inline_allocate ("C_a_get_current_seconds" 7) #f))14731474(define cpu-time1475 (let () ;; ((buf (vector #f #f))) Disabled for now: vector is defined below!1476 (lambda ()1477 (let ((buf (vector #f #f)))1478 ;; should be thread-safe as no context-switch will occur after1479 ;; function entry and `buf' contents will have been extracted1480 ;; before `values' gets called.1481 (##core#inline_allocate ("C_a_i_cpu_time" 8) buf)1482 (values (##sys#slot buf 0) (##sys#slot buf 1)) )) ))14831484) ; chicken.time14851486(define (##sys#check-structure x y . loc)1487 (if (pair? loc)1488 (##core#inline "C_i_check_structure_2" x y (car loc))1489 (##core#inline "C_i_check_structure" x y) ) )14901491;; DEPRECATED1492(define (##sys#check-blob x . loc)1493 (if (pair? loc)1494 (##core#inline "C_i_check_bytevector_2" x (car loc))1495 (##core#inline "C_i_check_bytevector" x) ) )14961497(define ##sys#check-bytevector ##sys#check-blob)14981499(define (##sys#check-pair x . loc)1500 (if (pair? loc)1501 (##core#inline "C_i_check_pair_2" x (car loc))1502 (##core#inline "C_i_check_pair" x) ) )15031504(define (##sys#check-list x . loc)1505 (if (pair? loc)1506 (##core#inline "C_i_check_list_2" x (car loc))1507 (##core#inline "C_i_check_list" x) ) )15081509(define (##sys#check-string x . loc)1510 (if (pair? loc)1511 (##core#inline "C_i_check_string_2" x (car loc))1512 (##core#inline "C_i_check_string" x) ) )15131514(define (##sys#check-number x . loc)1515 (if (pair? loc)1516 (##core#inline "C_i_check_number_2" x (car loc))1517 (##core#inline "C_i_check_number" x) ) )15181519(define (##sys#check-fixnum x . loc)1520 (if (pair? loc)1521 (##core#inline "C_i_check_fixnum_2" x (car loc))1522 (##core#inline "C_i_check_fixnum" x) ) )15231524(define (##sys#check-bytevector x . loc)1525 (if (pair? loc)1526 (##core#inline "C_i_check_bytevector_2" x (car loc))1527 (##core#inline "C_i_check_bytevector" x) ) )15281529(define (##sys#check-inexact x . loc)1530 (if (pair? loc)1531 (##core#inline "C_i_check_inexact_2" x (car loc))1532 (##core#inline "C_i_check_inexact" x) ) )15331534(define (##sys#check-symbol x . loc)1535 (if (pair? loc)1536 (##core#inline "C_i_check_symbol_2" x (car loc))1537 (##core#inline "C_i_check_symbol" x) ) )15381539(define (##sys#check-keyword x . loc)1540 (if (pair? loc)1541 (##core#inline "C_i_check_keyword_2" x (car loc))1542 (##core#inline "C_i_check_keyword" x) ) )15431544(define (##sys#check-vector x . loc)1545 (if (pair? loc)1546 (##core#inline "C_i_check_vector_2" x (car loc))1547 (##core#inline "C_i_check_vector" x) ) )15481549(define (##sys#check-char x . loc)1550 (if (pair? loc)1551 (##core#inline "C_i_check_char_2" x (car loc))1552 (##core#inline "C_i_check_char" x) ) )15531554(define (##sys#check-boolean x . loc)1555 (if (pair? loc)1556 (##core#inline "C_i_check_boolean_2" x (car loc))1557 (##core#inline "C_i_check_boolean" x) ) )15581559(define (##sys#check-locative x . loc)1560 (if (pair? loc)1561 (##core#inline "C_i_check_locative_2" x (car loc))1562 (##core#inline "C_i_check_locative" x) ) )15631564(define (##sys#check-integer x . loc)1565 (unless (##core#inline "C_i_integerp" x)1566 (##sys#error-bad-integer x (and (pair? loc) (car loc))) ) )15671568(define (##sys#check-exact-integer x . loc)1569 (unless (##core#inline "C_i_exact_integerp" x)1570 (##sys#error-bad-exact-integer x (and (pair? loc) (car loc))) ) )15711572(define (##sys#check-exact-uinteger x . loc)1573 (when (or (not (##core#inline "C_i_exact_integerp" x))1574 (##core#inline "C_i_integer_negativep" x))1575 (##sys#error-bad-exact-uinteger x (and (pair? loc) (car loc))) ) )15761577(define (##sys#check-real x . loc)1578 (unless (##core#inline "C_i_realp" x)1579 (##sys#error-bad-real x (and (pair? loc) (car loc))) ) )15801581(define (##sys#check-range i from to . loc)1582 (if (pair? loc)1583 (##core#inline "C_i_check_range_2" i from to (car loc))1584 (##core#inline "C_i_check_range" i from to) ) )15851586(define (##sys#check-range/including i from to . loc)1587 (if (pair? loc)1588 (##core#inline "C_i_check_range_including_2" i from to (car loc))1589 (##core#inline "C_i_check_range_including" i from to) ) )15901591(define (##sys#check-special ptr . loc)1592 (unless (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr))1593 (##sys#signal-hook #:type-error (and (pair? loc) (car loc)) "bad argument type - not a pointer-like object" ptr) ) )15941595(define (##sys#check-closure x . loc)1596 (if (pair? loc)1597 (##core#inline "C_i_check_closure_2" x (car loc))1598 (##core#inline "C_i_check_closure" x) ) )15991600(set! scheme#force1601 (lambda (obj)1602 (if (##sys#structure? obj 'promise)1603 (let lp ((promise obj)1604 (forward #f))1605 (let ((val (##sys#slot promise 1)))1606 (cond ((null? val) (##sys#values))1607 ((pair? val) (apply ##sys#values val))1608 ((procedure? val)1609 (when forward (##sys#setslot forward 1 promise))1610 (let ((results (##sys#call-with-values val ##sys#list)))1611 (cond ((not (procedure? (##sys#slot promise 1)))1612 (lp promise forward)) ; in case of reentrance1613 ((and (not (null? results)) (null? (cdr results))1614 (##sys#structure? (##sys#slot results 0) 'promise))1615 (let ((result0 (##sys#slot results 0)))1616 (##sys#setslot promise 1 (##sys#slot result0 1))1617 (lp promise result0)))1618 (else1619 (##sys#setslot promise 1 results)1620 (apply ##sys#values results)))))1621 ((##sys#structure? val 'promise)1622 (lp val forward)))))1623 obj)))162416251626;;; Dynamic Load16271628(define ##sys#dload (##core#primitive "C_dload"))1629(define ##sys#set-dlopen-flags! (##core#primitive "C_set_dlopen_flags"))16301631(define (##sys#error-not-a-proper-list arg #!optional loc)1632 (##sys#error-hook1633 (foreign-value "C_NOT_A_PROPER_LIST_ERROR" int) loc arg))16341635(define (##sys#error-bad-number arg #!optional loc)1636 (##sys#error-hook1637 (foreign-value "C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR" int) loc arg))16381639(define (##sys#error-bad-integer arg #!optional loc)1640 (##sys#error-hook1641 (foreign-value "C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR" int) loc arg))16421643(define (##sys#error-bad-exact-integer arg #!optional loc)1644 (##sys#error-hook1645 (foreign-value "C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR" int) loc arg))16461647(define (##sys#error-bad-exact-uinteger arg #!optional loc)1648 (##sys#error-hook1649 (foreign-value "C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR" int) loc arg))16501651(define (##sys#error-bad-inexact arg #!optional loc)1652 (##sys#error-hook1653 (foreign-value "C_CANT_REPRESENT_INEXACT_ERROR" int) loc arg))16541655(define (##sys#error-bad-real arg #!optional loc)1656 (##sys#error-hook1657 (foreign-value "C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR" int) loc arg))16581659(define (##sys#error-bad-base arg #!optional loc)1660 (##sys#error-hook1661 (foreign-value "C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR" int) loc arg))16621663(set! scheme#append1664 (lambda lsts1665 (if (eq? lsts '())1666 lsts1667 (let loop ((lsts lsts))1668 (if (eq? (##sys#slot lsts 1) '())1669 (##sys#slot lsts 0)1670 (let copy ((node (##sys#slot lsts 0)))1671 (cond ((eq? node '()) (loop (##sys#slot lsts 1)))1672 ((pair? node)1673 (cons (##sys#slot node 0) (copy (##sys#slot node 1))) )1674 (else1675 (##sys#error-not-a-proper-list1676 (##sys#slot lsts 0) 'append)) ) )))) ) )16771678(define (##sys#fast-reverse lst0)1679 (let loop ((lst lst0) (rest '()))1680 (if (pair? lst)1681 (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest))1682 rest)))168316841685;;; Strings:16861687(define (##sys#make-bytevector size #!optional (fill 0))1688 (##sys#allocate-bytevector size fill))16891690(define (##sys#make-string size #!optional (fill #\space))1691 (let* ((count (##core#inline "C_utf_bytes" fill))1692 (n (fx* count size))1693 (bv (##sys#allocate-bytevector (fx+ n 1) 0)))1694 (##core#inline "C_utf_fill" bv fill)1695 (##core#inline_allocate ("C_a_ustring" 5) bv size)))16961697(define (##sys#buffer->string! buf len)1698 (##core#inline "C_utf_set_bv_size" buf len)1699 (##core#inline_allocate ("C_a_ustring" 5) buf1700 (##core#inline "C_utf_range_length" buf 0 len)))17011702(define (##sys#buffer->string buf start len)1703 (let ((bv (##sys#make-bytevector (fx+ len 1))))1704 (##core#inline "C_copy_memory_with_offset" bv buf 0 start len)1705 (##core#inline_allocate ("C_a_ustring" 5) bv1706 (##core#inline "C_utf_range_length" bv 0 len))))17071708(define (##sys#utf-decoder buf start len k)1709 (k buf start len))17101711(define (##sys#utf-encoder buf start len k)1712 (k buf start len))17131714(define (##sys#utf-scanner state byte)1715 (if state1716 (if (fx> state 1)1717 (fx- state 1)1718 #f)1719 (let ((n (##core#inline "C_utf_bytes_needed" byte)))1720 (if (eq? n 1)1721 #f1722 (fx- n 1)))))17231724(define (##sys#latin-decoder bv start len k)1725 (let* ((buf (##sys#make-bytevector (fx* len 2)))1726 (n (##core#inline "C_latin_to_utf" bv buf start len)))1727 (k buf 0 n)))17281729(define (##sys#latin-encoder bv start len k)1730 (let* ((buf (##sys#make-bytevector (fx+ len 1)))1731 (n (##core#inline "C_utf_to_latin" bv buf start len)))1732 (k buf 0 n)))17331734(define (##sys#latin-scanner state byte) #f)17351736(define (##sys#binary-decoder bv start len k)1737 (k bv start len) )17381739(define (##sys#binary-encoder bv start len k)1740 (k bv start len) )17411742(define (##sys#binary-scanner state byte) #f)17431744;; invokes k with encoding and decoding procedures1745(define (##sys#encoding-hook enc k)1746 (case enc1747 ((binary) (k ##sys#binary-decoder ##sys#binary-encoder ##sys#binary-scanner))1748 ((utf-8) (k ##sys#utf-decoder ##sys#utf-encoder ##sys#utf-scanner))1749 ((latin-1) (k ##sys#latin-decoder ##sys#latin-encoder ##sys#latin-scanner))1750 (else (##sys#signal-hook #:type-error #f "invalid file port encoding" enc))))17511752(define (##sys#register-encoding names dec enc scan)1753 (let ((old ##sys#encoding-hook))1754 (set! ##sys#encoding-hook1755 (lambda (enc k)1756 (if (or (eq? enc names)1757 (and (pair? names) (memq enc names)))1758 (k dec enc scan)1759 (old enc k))))))17601761;; decode buffer and create string1762(define (##sys#buffer->string/encoding buf start len enc)1763 (##sys#encoding-hook1764 enc1765 (lambda (decoder _ _) (decoder buf start len ##sys#buffer->string))))17661767;; encode buffer into bytevector1768(define (##sys#encode-buffer bv start len enc k)1769 (##sys#encoding-hook1770 enc1771 (lambda (_ encoder _) (encoder bv start len k))))17721773;; decode buffer into bytevector1774(define (##sys#decode-buffer bv start len enc k)1775 (##sys#encoding-hook1776 enc1777 (lambda (decoder _ _) (decoder bv start len k))))17781779;; encode a single character into bytevector, return number of bytes1780(define (##sys#encode-char c bv enc)1781 (##sys#encoding-hook1782 enc1783 (lambda (_ encoder _)1784 (let* ((bv1 (##sys#make-bytevector 4))1785 (n (##core#inline "C_utf_insert" bv1 0 c)))1786 (encoder bv1 0 n1787 (lambda (buf start len)1788 (##core#inline "C_copy_memory_with_offset" bv buf 0 start len)1789 len))))))17901791(define (##sys#decode-char bv enc start)1792 (##sys#decode-buffer1793 bv start (##sys#size bv) enc1794 (lambda (buf start _)1795 (##core#inline "C_utf_decode" buf start))))17961797;; how many extra bytes are needed for a complete codepoint?1798(define (##sys#scan-read-ahead enc byte)1799 (##sys#encoding-hook1800 enc1801 (lambda (_ _ scan) (scan #f byte))))18021803;; read char from port with encoding, scanning minimal number of bytes ahead1804(define (##sys#read-char/encoding p enc k)1805 (##sys#encoding-hook1806 enc1807 (lambda (dec _ scan)1808 (let ((buf (##sys#make-bytevector 5))1809 (rbv! (##sys#slot (##sys#slot p 2) 7))) ; read-bytevector!1810 (let loop ((state #f) (i 0))1811 (let ((rn (rbv! p 1 buf i)))1812 (if (eq? 0 rn)1813 (if (eq? i 0)1814 #!eof1815 (##sys#signal-hook #:file-error 'read-char "incomplete character sequence while decoding" buf i))1816 (let ((s2 (scan state (##core#inline "C_subbyte" buf i))))1817 (if s21818 (loop s2 (fx+ i 1))1819 (k buf 0 (fx+ i 1) dec))))))))))18201821(set! scheme#make-string1822 (lambda (size . fill)1823 (##sys#check-fixnum size 'make-string)1824 (when (fx< size 0)1825 (##sys#signal-hook #:bounds-error 'make-string "size is negative" size))1826 (##sys#make-string1827 size1828 (if (null? fill)1829 #\space1830 (let ((c (car fill)))1831 (##sys#check-char c 'make-string)1832 c ) ) ) ) )18331834(set! scheme#string->list1835 (lambda (s #!optional start end)1836 (##sys#check-string s 'string->list)1837 (let ((len (##sys#slot s 1)))1838 (if start1839 (##sys#check-range/including start 0 len 'string->list)1840 (set! start 0))1841 (if end1842 (##sys#check-range/including end 0 len 'string->list)1843 (set! end len))1844 (let loop ((i (fx- end 1)) (ls '()))1845 (if (fx< i start)1846 ls1847 (loop (fx- i 1)1848 (cons (string-ref s i) ls)) ) ) )))18491850(define ##sys#string->list string->list)18511852(set! scheme#list->string1853 (lambda (lst0)1854 (if (not (list? lst0))1855 (##sys#error-not-a-proper-list lst0 'list->string)1856 (let* ((len (##core#inline "C_utf_list_size" lst0))1857 (bv (##sys#make-bytevector (fx+ 1 len))))1858 (let loop ((i 0)1859 (p 0)1860 (lst lst0))1861 (if (not (pair? lst))1862 (##core#inline_allocate ("C_a_ustring" 5) bv i)1863 (let ((c (##sys#slot lst 0)))1864 (##sys#check-char c 'list->string)1865 (##core#inline "C_utf_insert" bv p c)1866 (loop (fx+ i 1)1867 (fx+ p (##core#inline "C_utf_bytes" c))1868 (##sys#slot lst 1)))))))))18691870(define ##sys#list->string list->string)18711872(define (##sys#reverse-list->string l)1873 (let* ((sz (##core#inline "C_utf_list_size" l))1874 (bv (##sys#make-bytevector (fx+ sz 1))))1875 (let loop ((p sz) (l l) (n 0))1876 (cond ((null? l)1877 (##core#inline_allocate ("C_a_ustring" 5) bv n))1878 ((pair? l)1879 (let ((c (##sys#slot l 0)))1880 (##sys#check-char c 'reverse-list->string)1881 (let* ((bs (##core#inline "C_utf_bytes" c))1882 (p2 (fx- p bs)))1883 (##core#inline "C_utf_insert" bv p2 c)1884 (loop p2 (##sys#slot l 1) (fx+ n 1)))))1885 (else (##sys#error-not-a-proper-list l 'reverse-list->string) ) ))))18861887(set! scheme#string-fill!1888 (lambda (s c #!optional start end)1889 (##sys#check-string s 'string-fill!)1890 (##sys#check-char c 'string-fill!)1891 (let ((len (string-length s)))1892 (cond (start (##sys#check-range start 0 len 'string-fill!)1893 (if end1894 (##sys#check-range end 0 len 'string-fill!)1895 (set! end len)))1896 (else1897 (set! start 0)1898 (set! end len))))1899 (let* ((bv (##sys#slot s 0))1900 (bvlen (##sys#size bv))1901 (count (fxmax 0 (fx- end start)))1902 (code (char->integer c)))1903 (if (and (eq? (fx- bvlen 1) (##sys#slot s 1))1904 (fx< code 128))1905 (##core#inline "C_fill_bytevector" bv code start count)1906 (do ((i start (fx+ i 1)))1907 ((fx>= i end))1908 (string-set! s i c))))))19091910(set! scheme#string-copy1911 (lambda (s #!optional start end)1912 (##sys#check-string s 'string-copy)1913 (let ((len (string-length s))1914 (start1 0))1915 (when start1916 (##sys#check-range/including start 0 len 'string-copy)1917 (set! start1 start))1918 (if end1919 (##sys#check-range/including end 0 len 'string-copy)1920 (set! end len))1921 (let* ((bv (##sys#slot (if start (##sys#substring s start1 end) s) 0))1922 (len (##sys#size bv))1923 (n (fx- end start1))1924 (bv2 (##sys#make-bytevector len)) )1925 (##core#inline "C_copy_memory" bv2 bv len)1926 (##core#inline_allocate ("C_a_ustring" 5) bv2 n)))))19271928(set! scheme#string-copy!1929 (lambda (to at from #!optional start end)1930 (##sys#check-string to 'string-copy!)1931 (##sys#check-string from 'string-copy!)1932 (let ((tlen (string-length to))1933 (flen (string-length from))1934 (d (fx- end start)))1935 (##sys#check-range at 0 tlen 'string-copy!)1936 (if start1937 (begin1938 (##sys#check-range/including start 0 flen 'string-copy!)1939 (if end1940 (##sys#check-range/including end 0 flen 'string-copy!)1941 (set! end flen)))1942 (set! start 0))1943 (if (and (eq? to from) (fx< start at))1944 (do ((at (fx- (fx+ at d) 1) (fx- at 1))1945 (i (fx- end 1) (fx- i 1)))1946 ((fx< i start))1947 (string-set! to at (string-ref from i)))1948 (do ((at at (fx+ at 1))1949 (i start (fx+ i 1)))1950 ((fx>= i end))1951 (string-set! to at (string-ref from i)))))))19521953(define (##sys#substring s start end)1954 (let* ((n (##core#inline "C_utf_range" s start end))1955 (bv (##sys#make-bytevector (fx+ n 1)))1956 (str (##core#inline_allocate ("C_a_ustring" 5) bv (fx- end start))))1957 (##core#inline "C_utf_copy" s str start end 0)1958 str ) )19591960(set! scheme#substring1961 (lambda (s start . end)1962 (##sys#check-string s 'substring)1963 (##sys#check-fixnum start 'substring)1964 (let ((end (if (pair? end)1965 (let ((end (car end)))1966 (##sys#check-fixnum end 'substring)1967 end)1968 (string-length s) ) ) )1969 (let ((len (string-length s)))1970 (if (and (fx<= start end)1971 (fx>= start 0)1972 (fx<= end len) )1973 (##sys#substring s start end)1974 (##sys#error-hook1975 (foreign-value "C_OUT_OF_BOUNDS_ERROR" int)1976 'substring s start) ) ) )))19771978(let ((compare1979 (lambda (s1 s2 more loc cmp)1980 (##sys#check-string s1 loc)1981 (##sys#check-string s2 loc)1982 (let* ((len1 (string-length s1))1983 (len2 (string-length s2))1984 (c (##core#inline "C_utf_compare"1985 s1 s2 0 01986 (if (fx< len1 len2) len1 len2))))1987 (let loop ((s s2)1988 (len len2)1989 (ss more)1990 (f (cmp c len1 len2)))1991 (and f1992 (or (null? ss)1993 (let* ((s2 (##sys#slot ss 0))1994 (len2 (string-length s2))1995 (c (##core#inline "C_utf_compare"1996 s s2 0 01997 (if (fx< len len2) len len2))))1998 (loop s2 len2 (##sys#slot ss 1)1999 (cmp c len len2))))))))))2000 (set! scheme#string<? (lambda (s1 s2 . more)2001 (compare2002 s1 s2 more 'string<?2003 (lambda (cmp len1 len2)2004 (or (fx< cmp 0)2005 (and (fx< len1 len2)2006 (eq? cmp 0) ) ) ) ) ) )2007 (set! scheme#string>? (lambda (s1 s2 . more)2008 (compare2009 s1 s2 more 'string>?2010 (lambda (cmp len1 len2)2011 (or (fx> cmp 0)2012 (and (fx> len1 len2)2013 (eq? cmp 0) ) ) ) ) ) )2014 (set! scheme#string<=? (lambda (s1 s2 . more)2015 (compare2016 s1 s2 more 'string<=?2017 (lambda (cmp len1 len2)2018 (if (eq? cmp 0)2019 (fx<= len1 len2)2020 (fx< cmp 0) ) ) ) ) )2021 (set! scheme#string>=? (lambda (s1 s2 . more)2022 (compare2023 s1 s2 more 'string>=?2024 (lambda (cmp len1 len2)2025 (if (eq? cmp 0)2026 (fx>= len1 len2)2027 (fx> cmp 0) ) ) ) ) ) )20282029(let ((compare2030 (lambda (s1 s2 more loc cmp)2031 (##sys#check-string s1 loc)2032 (##sys#check-string s2 loc)2033 (let* ((len1 (string-length s1))2034 (len2 (string-length s2))2035 (c (##core#inline "C_utf_compare_ci"2036 s1 s2 0 0 len1 len2)))2037 (let loop ((s s2)2038 (len len2)2039 (ss more)2040 (f (cmp c)))2041 (and f2042 (or (null? ss)2043 (let* ((s2 (##sys#slot ss 0))2044 (len2 (string-length s2))2045 (c (##core#inline "C_utf_compare_ci"2046 s s2 0 0 len len2)))2047 (loop s2 len2 (##sys#slot ss 1)2048 (cmp c))))))))))2049 (set! scheme#string-ci<? (lambda (s1 s2 . more)2050 (compare2051 s1 s2 more 'string-ci<?2052 (cut fx< <> 0))))2053 (set! scheme#string-ci>? (lambda (s1 s2 . more)2054 (compare2055 s1 s2 more 'string-ci>?2056 (cut fx> <> 0) ) ) )2057 (set! scheme#string-ci<=? (lambda (s1 s2 . more)2058 (compare2059 s1 s2 more 'string-ci<=?2060 (cut fx<= <> 0) ) ) )2061 (set! scheme#string-ci>=? (lambda (s1 s2 . more)2062 (compare2063 s1 s2 more 'string-ci>=?2064 (cut fx>= <> 0) ) ) ) )20652066(define (##sys#string-append x y)2067 (let* ((bv1 (##sys#slot x 0))2068 (bv2 (##sys#slot y 0))2069 (s1 (fx- (##sys#size bv1) 1))2070 (s2 (fx- (##sys#size bv2) 1))2071 (z (##sys#make-bytevector (fx+ s1 (fx+ s2 1)) 0)))2072 (##core#inline "C_copy_memory_with_offset" z bv1 0 0 s1)2073 (##core#inline "C_copy_memory_with_offset" z bv2 s1 0 s2)2074 (##core#inline_allocate ("C_a_ustring" 5) z2075 (fx+ (##sys#slot x 1) (##sys#slot y 1)))))20762077(set! scheme#string-append2078 (lambda all2079 (let ((snew #f)2080 (slen 0))2081 (let loop ((strs all) (n 0) (ul 0))2082 (cond ((eq? strs '())2083 (set! snew (##sys#make-bytevector (fx+ n 1) 0))2084 (set! slen ul))2085 (else2086 (let ((s (##sys#slot strs 0)))2087 (##sys#check-string s 'string-append)2088 (let* ((bv (##sys#slot s 0))2089 (len (fx- (##sys#size bv) 1))2090 (ulen (##sys#slot s 1)))2091 (loop (##sys#slot strs 1) (fx+ n len) (fx+ ul ulen))2092 (##core#inline "C_copy_memory_with_offset" snew bv n 0 len) ) ) ) ) )2093 (##core#inline_allocate ("C_a_ustring" 5) snew slen))))20942095(set! scheme#string2096 (let ([list->string list->string])2097 (lambda chars (list->string chars)) ) )20982099;; legacy procedure, used in some eggs, should be removed one day...2100(define (##sys#char->utf8-string c)2101 (scheme#string c))21022103(set! chicken.base#chop2104 (lambda (lst n)2105 (##sys#check-fixnum n 'chop)2106 (when (fx<= n 0) (##sys#error 'chop "invalid numeric argument" n))2107 (let ((len (length lst)))2108 (let loop ((lst lst) (i len))2109 (cond ((null? lst) '())2110 ((fx< i n) (list lst))2111 (else2112 (do ((hd '() (cons (##sys#slot tl 0) hd))2113 (tl lst (##sys#slot tl 1))2114 (c n (fx- c 1)) )2115 ((fx= c 0)2116 (cons (reverse hd) (loop tl (fx- i n))) ) ) ) ) ) ) ) )21172118;;; Numeric routines:2119;; Abbreviations of paper and book titles used in comments are:2120;; [Knuth] Donald E. Knuth, "The Art of Computer Programming", Volume 22121;; [MpNT] Tiplea at al., "MpNT: A Multi-Precision Number Theory Package"2122;; [MCA] Richard P. Brent & Paul Zimmermann, "Modern Computer Arithmetic"21232124(module chicken.flonum *2125(import scheme)2126(import chicken.foreign)2127(import (only chicken.base flonum?))2128(import chicken.internal.syntax)21292130(define maximum-flonum (foreign-value "DBL_MAX" double))2131(define minimum-flonum (foreign-value "DBL_MIN" double))2132(define flonum-radix (foreign-value "FLT_RADIX" int))2133(define flonum-epsilon (foreign-value "DBL_EPSILON" double))2134(define flonum-precision (foreign-value "DBL_MANT_DIG" int))2135(define flonum-decimal-precision (foreign-value "DBL_DIG" int))2136(define flonum-maximum-exponent (foreign-value "DBL_MAX_EXP" int))2137(define flonum-minimum-exponent (foreign-value "DBL_MIN_EXP" int))2138(define flonum-maximum-decimal-exponent (foreign-value "DBL_MAX_10_EXP" int))2139(define flonum-minimum-decimal-exponent (foreign-value "DBL_MIN_10_EXP" int))21402141(define-inline (fp-check-flonum x loc)2142 (unless (flonum? x)2143 (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int) loc x) ) )21442145(define-inline (fp-check-flonums x y loc)2146 (unless (and (flonum? x) (flonum? y))2147 (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int) loc x y) ) )21482149(define (fp+ x y)2150 (fp-check-flonums x y 'fp+)2151 (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y) )21522153(define (fp- x y)2154 (fp-check-flonums x y 'fp-)2155 (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y) )21562157(define (fp* x y)2158 (fp-check-flonums x y 'fp*)2159 (##core#inline_allocate ("C_a_i_flonum_times" 4) x y) )21602161(define (fp/ x y)2162 (fp-check-flonums x y 'fp/)2163 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y) )21642165(define (fp*+ x y z)2166 (unless (and (flonum? x) (flonum? y) (flonum? z))2167 (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int)2168 'fp*+ x y z) )2169 (##core#inline_allocate ("C_a_i_flonum_multiply_add" 4) x y z) )21702171(define (fpgcd x y)2172 (fp-check-flonums x y 'fpgcd)2173 (##core#inline_allocate ("C_a_i_flonum_gcd" 4) x y))21742175(define (fp/? x y) ; undocumented2176 (fp-check-flonums x y 'fp/?)2177 (##core#inline_allocate ("C_a_i_flonum_quotient_checked" 4) x y) )21782179(define (fp= x y)2180 (fp-check-flonums x y 'fp=)2181 (##core#inline "C_flonum_equalp" x y) )21822183(define (fp> x y)2184 (fp-check-flonums x y 'fp>)2185 (##core#inline "C_flonum_greaterp" x y) )21862187(define (fp< x y)2188 (fp-check-flonums x y 'fp<)2189 (##core#inline "C_flonum_lessp" x y) )21902191(define (fp>= x y)2192 (fp-check-flonums x y 'fp>=)2193 (##core#inline "C_flonum_greater_or_equal_p" x y) )21942195(define (fp<= x y)2196 (fp-check-flonums x y 'fp<=)2197 (##core#inline "C_flonum_less_or_equal_p" x y) )21982199(define (fpneg x)2200 (fp-check-flonum x 'fpneg)2201 (##core#inline_allocate ("C_a_i_flonum_negate" 4) x) )22022203(define (fpmax x y)2204 (fp-check-flonums x y 'fpmax)2205 (##core#inline "C_i_flonum_max" x y) )22062207(define (fpmin x y)2208 (fp-check-flonums x y 'fpmin)2209 (##core#inline "C_i_flonum_min" x y) )22102211(define (fpfloor x)2212 (fp-check-flonum x 'fpfloor)2213 (##core#inline_allocate ("C_a_i_flonum_floor" 4) x))22142215(define (fptruncate x)2216 (fp-check-flonum x 'fptruncate)2217 (##core#inline_allocate ("C_a_i_flonum_truncate" 4) x))22182219(define (fpround x)2220 (fp-check-flonum x 'fpround)2221 (##core#inline_allocate ("C_a_i_flonum_round" 4) x))22222223(define (fpceiling x)2224 (fp-check-flonum x 'fpceiling)2225 (##core#inline_allocate ("C_a_i_flonum_ceiling" 4) x))22262227(define (fpsin x)2228 (fp-check-flonum x 'fpsin)2229 (##core#inline_allocate ("C_a_i_flonum_sin" 4) x))22302231(define (fpcos x)2232 (fp-check-flonum x 'fpcos)2233 (##core#inline_allocate ("C_a_i_flonum_cos" 4) x))22342235(define (fptan x)2236 (fp-check-flonum x 'fptan)2237 (##core#inline_allocate ("C_a_i_flonum_tan" 4) x))22382239(define (fpasin x)2240 (fp-check-flonum x 'fpasin)2241 (##core#inline_allocate ("C_a_i_flonum_asin" 4) x))22422243(define (fpacos x)2244 (fp-check-flonum x 'fpacos)2245 (##core#inline_allocate ("C_a_i_flonum_acos" 4) x))22462247(define (fpatan x)2248 (fp-check-flonum x 'fpatan)2249 (##core#inline_allocate ("C_a_i_flonum_atan" 4) x))22502251(define (fpatan2 x y)2252 (fp-check-flonums x y 'fpatan2)2253 (##core#inline_allocate ("C_a_i_flonum_atan2" 4) x y))22542255(define (fpsinh x)2256 (fp-check-flonum x 'fpsinh)2257 (##core#inline_allocate ("C_a_i_flonum_sinh" 4) x))22582259(define (fpcosh x)2260 (fp-check-flonum x 'fpcosh)2261 (##core#inline_allocate ("C_a_i_flonum_cosh" 4) x))22622263(define (fptanh x)2264 (fp-check-flonum x 'fptanh)2265 (##core#inline_allocate ("C_a_i_flonum_tanh" 4) x))22662267(define (fpasinh x)2268 (fp-check-flonum x 'fpasinh)2269 (##core#inline_allocate ("C_a_i_flonum_asinh" 4) x))22702271(define (fpacosh x)2272 (fp-check-flonum x 'fpacosh)2273 (##core#inline_allocate ("C_a_i_flonum_acosh" 4) x))22742275(define (fpatanh x)2276 (fp-check-flonum x 'fpatanh)2277 (##core#inline_allocate ("C_a_i_flonum_atanh" 4) x))22782279(define (fpexp x)2280 (fp-check-flonum x 'fpexp)2281 (##core#inline_allocate ("C_a_i_flonum_exp" 4) x))22822283(define (fpexpt x y)2284 (fp-check-flonums x y 'fpexpt)2285 (##core#inline_allocate ("C_a_i_flonum_expt" 4) x y))22862287(define (fplog x)2288 (fp-check-flonum x 'fplog)2289 (##core#inline_allocate ("C_a_i_flonum_log" 4) x))22902291(define (fpsqrt x)2292 (fp-check-flonum x 'fpsqrt)2293 (##core#inline_allocate ("C_a_i_flonum_sqrt" 4) x))22942295(define (fpabs x)2296 (fp-check-flonum x 'fpabs)2297 (##core#inline_allocate ("C_a_i_flonum_abs" 4) x))22982299(define (fpinteger? x)2300 (fp-check-flonum x 'fpinteger?)2301 (##core#inline "C_u_i_fpintegerp" x))23022303(define (flonum-print-precision #!optional prec)2304 (let ((prev (##core#inline "C_get_print_precision")))2305 (when prec2306 (##sys#check-fixnum prec 'flonum-print-precision)2307 (##core#inline "C_set_print_precision" prec))2308 prev)))23092310(import chicken.flonum)23112312(define-inline (integer-negate x)2313 (##core#inline_allocate ("C_s_a_u_i_integer_negate" 5) x))23142315;;; Complex numbers23162317(define-inline (%cplxnum-real c) (##core#inline "C_u_i_cplxnum_real" c))2318(define-inline (%cplxnum-imag c) (##core#inline "C_u_i_cplxnum_imag" c))23192320(define (make-complex r i)2321 (if (eq? i 0)2322 r2323 (##core#inline_allocate ("C_a_i_cplxnum" 3)2324 (if (inexact? i) (exact->inexact r) r)2325 (if (inexact? r) (exact->inexact i) i)) ) )23262327(set! scheme#make-rectangular2328 (lambda (r i)2329 (##sys#check-real r 'make-rectangular)2330 (##sys#check-real i 'make-rectangular)2331 (make-complex r i) ))23322333(set! scheme#make-polar2334 (lambda (r phi)2335 (##sys#check-real r 'make-polar)2336 (##sys#check-real phi 'make-polar)2337 (let ((fphi (exact->inexact phi)))2338 (make-complex2339 (* r (##core#inline_allocate ("C_a_i_cos" 4) fphi))2340 (* r (##core#inline_allocate ("C_a_i_sin" 4) fphi))) ) ))23412342(set! scheme#real-part2343 (lambda (x)2344 (cond ((cplxnum? x) (%cplxnum-real x))2345 ((number? x) x)2346 (else (##sys#error-bad-number x 'real-part)) )))23472348(set! scheme#imag-part2349 (lambda (x)2350 (cond ((cplxnum? x) (%cplxnum-imag x))2351 ((number? x) 0)2352 (else (##sys#error-bad-number x 'imag-part)) )))23532354(set! scheme#angle2355 (lambda (n)2356 (##sys#check-number n 'angle)2357 (##core#inline_allocate ("C_a_i_atan2" 4)2358 (exact->inexact (imag-part n))2359 (exact->inexact (real-part n))) ))23602361(set! scheme#magnitude2362 (lambda (x)2363 (cond ((cplxnum? x)2364 (let ((r (%cplxnum-real x))2365 (i (%cplxnum-imag x)) )2366 (sqrt (+ (* r r) (* i i))) ))2367 ((number? x) (abs x))2368 (else (##sys#error-bad-number x 'magnitude))) ))23692370;;; Rational numbers23712372(define-inline (%ratnum-numerator r) (##core#inline "C_u_i_ratnum_num" r))2373(define-inline (%ratnum-denominator r) (##core#inline "C_u_i_ratnum_denom" r))2374(define-inline (%make-ratnum n d) (##core#inline_allocate ("C_a_i_ratnum" 3) n d))23752376(define (ratnum m n)2377 (cond2378 ((eq? n 1) m)2379 ((eq? n -1) (integer-negate m))2380 ((negative? n)2381 (%make-ratnum (integer-negate m) (integer-negate n)))2382 (else (%make-ratnum m n))))23832384(set! scheme#numerator2385 (lambda (n)2386 (cond ((##core#inline "C_i_exact_integerp" n) n)2387 ((##core#inline "C_i_flonump" n)2388 (cond ((not (finite? n)) (##sys#error-bad-inexact n 'numerator))2389 ((##core#inline "C_u_i_fpintegerp" n) n)2390 (else (exact->inexact (numerator (inexact->exact n))))))2391 ((ratnum? n) (%ratnum-numerator n))2392 (else (##sys#signal-hook2393 #:type-error 'numerator2394 "bad argument type - not a rational number" n) ) )))239523962397(set! scheme#denominator2398 (lambda (n)2399 (cond ((##core#inline "C_i_exact_integerp" n) 1)2400 ((##core#inline "C_i_flonump" n)2401 (cond ((not (finite? n)) (##sys#error-bad-inexact n 'denominator))2402 ((##core#inline "C_u_i_fpintegerp" n) 1.0)2403 (else (exact->inexact (denominator (inexact->exact n))))))2404 ((ratnum? n) (%ratnum-denominator n))2405 (else (##sys#signal-hook2406 #:type-error 'numerator2407 "bad argument type - not a rational number" n) ) )))240824092410(define (##sys#extended-signum x)2411 (cond2412 ((ratnum? x) (##core#inline "C_u_i_integer_signum" (%ratnum-numerator x)))2413 ((cplxnum? x) (make-polar 1 (angle x)))2414 (else (##sys#error-bad-number x 'signum))))24152416(define-inline (%flo->int x)2417 (##core#inline_allocate ("C_s_a_u_i_flo_to_int" 5) x))24182419(define (flonum->ratnum x)2420 ;; Try to multiply by two until we reach an integer2421 (define (float-fraction-length x)2422 (do ((x x (fp* x 2.0))2423 (i 0 (fx+ i 1)))2424 ((##core#inline "C_u_i_fpintegerp" x) i)))24252426 (define (deliver y d)2427 (let* ((q (##sys#integer-power 2 (float-fraction-length y)))2428 (scaled-y (* y (exact->inexact q))))2429 (if (finite? scaled-y) ; Shouldn't this always be true?2430 (##sys#/-2 (##sys#/-2 (%flo->int scaled-y) q) d)2431 (##sys#error-bad-inexact x 'inexact->exact))))24322433 (if (and (fp< x 1.0) ; Watch out for denormalized numbers2434 (fp> x -1.0)) ; XXX: Needs a test, it seems pointless2435 (deliver (* x (expt 2.0 flonum-precision))2436 ;; Can be bignum (is on 32-bit), so must wait until after init.2437 ;; We shouldn't need to calculate this every single time, tho..2438 (##sys#integer-power 2 flonum-precision))2439 (deliver x 1)))24402441(set! scheme#inexact->exact2442 (lambda (x)2443 (cond ((exact? x) x)2444 ((##core#inline "C_i_flonump" x)2445 (cond ((##core#inline "C_u_i_fpintegerp" x) (%flo->int x))2446 ((##core#inline "C_u_i_flonum_finitep" x) (flonum->ratnum x))2447 (else (##sys#error-bad-inexact x 'inexact->exact))))2448 ((cplxnum? x)2449 (make-complex (inexact->exact (%cplxnum-real x))2450 (inexact->exact (%cplxnum-imag x))))2451 (else (##sys#error-bad-number x 'inexact->exact)) )))245224532454;;; Bitwise operations:24552456;; From SRFI-3324572458(module chicken.bitwise *2459(import scheme)2460(define bitwise-and (##core#primitive "C_bitwise_and"))2461(define bitwise-ior (##core#primitive "C_bitwise_ior"))2462(define bitwise-xor (##core#primitive "C_bitwise_xor"))2463(define (bitwise-not n) (##core#inline_allocate ("C_s_a_i_bitwise_not" 5) n))2464(define (bit->boolean n i) (##core#inline "C_i_bit_to_bool" n i)) ; DEPRECATED2465;; XXX NOT YET! Reintroduce at a later time. See #1385:2466;; (define (bit-set? i n) (##core#inline "C_i_bit_setp" i n))2467(define (integer-length x) (##core#inline "C_i_integer_length" x))2468(define (arithmetic-shift n m)2469 (##core#inline_allocate ("C_s_a_i_arithmetic_shift" 5) n m))24702471) ; chicken.bitwise24722473(import chicken.bitwise)24742475;;; Basic arithmetic:24762477(define-inline (%integer-gcd a b)2478 (##core#inline_allocate ("C_s_a_u_i_integer_gcd" 5) a b))24792480(set! scheme#/2481 (lambda (arg1 . args)2482 (if (null? args)2483 (##sys#/-2 1 arg1)2484 (let loop ((args (##sys#slot args 1))2485 (x (##sys#/-2 arg1 (##sys#slot args 0))))2486 (if (null? args)2487 x2488 (loop (##sys#slot args 1)2489 (##sys#/-2 x (##sys#slot args 0))) ) ) ) ))24902491(define-inline (%integer-quotient a b)2492 (##core#inline_allocate ("C_s_a_u_i_integer_quotient" 5) a b))24932494(define (##sys#/-2 x y)2495 (when (eq? y 0)2496 (##sys#error-hook (foreign-value "C_DIVISION_BY_ZERO_ERROR" int) '/ x y))2497 (cond ((eq? x 0) 0)2498 ((and (##core#inline "C_i_exact_integerp" x)2499 (##core#inline "C_i_exact_integerp" y))2500 (let ((g (%integer-gcd x y)))2501 (ratnum (%integer-quotient x g) (%integer-quotient y g))))2502 ;; Compnum *must* be checked first2503 ((or (cplxnum? x) (cplxnum? y))2504 (if (cplxnum? y)2505 (let* ((a (real-part x)) (b (imag-part x))2506 (c (real-part y)) (d (imag-part y))2507 (r (+ (* c c) (* d d)))2508 (x (##sys#/-2 (+ (* a c) (* b d)) r))2509 (y (##sys#/-2 (- (* b c) (* a d)) r)) )2510 (make-complex x y) )2511 (let* ((a (real-part x)) (b (imag-part x))2512 (xu (##sys#/-2 a y))2513 (yu (##sys#/-2 b y)))2514 (make-complex xu yu))))2515 ((or (##core#inline "C_i_flonump" x) (##core#inline "C_i_flonump" y))2516 ;; This may be incorrect when one is a ratnum consisting of bignums2517 (fp/ (exact->inexact x) (exact->inexact y)))2518 ((ratnum? x)2519 (if (ratnum? y)2520 ;; a/b / c/d = a*d / b*c [generic]2521 ;; = ((a / g1) * (d / g2) * sign(a)) / abs((b / g2) * (c / g1))2522 ;; With g1 = gcd(a, c) and g2 = gcd(b, d) [Knuth, 4.5.1 ex. 4]2523 (let* ((a (%ratnum-numerator x)) (b (%ratnum-denominator x))2524 (c (%ratnum-numerator y)) (d (%ratnum-denominator y))2525 (g1 (%integer-gcd a c))2526 (g2 (%integer-gcd b d)))2527 (ratnum (* (quotient a g1) (quotient d g2))2528 (* (quotient b g2) (quotient c g1))))2529 ;; a/b / c/d = a*d / b*c [with d = 1]2530 ;; = ((a / g) * sign(a)) / abs(b * (c / g))2531 ;; With g = gcd(a, c) and c = y [Knuth, 4.5.1 ex. 4]2532 (let* ((a (%ratnum-numerator x))2533 (g (##sys#internal-gcd '/ a y))2534 (num (quotient a g))2535 (denom (* (%ratnum-denominator x) (quotient y g))))2536 (if (##core#inline "C_i_flonump" denom)2537 (##sys#/-2 num denom)2538 (ratnum num denom)))))2539 ((ratnum? y)2540 ;; a/b / c/d = a*d / b*c [with b = 1]2541 ;; = ((a / g1) * d * sign(a)) / abs(c / g1)2542 ;; With g1 = gcd(a, c) and a = x [Knuth, 4.5.1 ex. 4]2543 (let* ((c (%ratnum-numerator y))2544 (g (##sys#internal-gcd '/ x c))2545 (num (* (quotient x g) (%ratnum-denominator y)))2546 (denom (quotient c g)))2547 (if (##core#inline "C_i_flonump" denom)2548 (##sys#/-2 num denom)2549 (ratnum num denom))))2550 ((not (number? x)) (##sys#error-bad-number x '/))2551 (else (##sys#error-bad-number y '/))) )25522553(set! scheme#floor2554 (lambda (x)2555 (cond ((##core#inline "C_i_exact_integerp" x) x)2556 ((##core#inline "C_i_flonump" x) (fpfloor x))2557 ;; (floor x) = greatest integer <= x2558 ((ratnum? x) (let* ((n (%ratnum-numerator x))2559 (q (quotient n (%ratnum-denominator x))))2560 (if (>= n 0) q (- q 1))))2561 (else (##sys#error-bad-real x 'floor)) )))25622563(set! scheme#ceiling2564 (lambda (x)2565 (cond ((##core#inline "C_i_exact_integerp" x) x)2566 ((##core#inline "C_i_flonump" x) (fpceiling x))2567 ;; (ceiling x) = smallest integer >= x2568 ((ratnum? x) (let* ((n (%ratnum-numerator x))2569 (q (quotient n (%ratnum-denominator x))))2570 (if (>= n 0) (+ q 1) q)))2571 (else (##sys#error-bad-real x 'ceiling)) )))25722573(set! scheme#truncate2574 (lambda (x)2575 (cond ((##core#inline "C_i_exact_integerp" x) x)2576 ((##core#inline "C_i_flonump" x) (fptruncate x))2577 ;; (rational-truncate x) = integer of largest magnitude <= (abs x)2578 ((ratnum? x) (quotient (%ratnum-numerator x)2579 (%ratnum-denominator x)))2580 (else (##sys#error-bad-real x 'truncate)) )))25812582(set! scheme#round2583 (lambda (x)2584 (cond ((##core#inline "C_i_exact_integerp" x) x)2585 ((##core#inline "C_i_flonump" x)2586 (##core#inline_allocate ("C_a_i_flonum_round_proper" 4) x))2587 ((ratnum? x)2588 (let* ((x+1/2 (+ x (%make-ratnum 1 2)))2589 (r (floor x+1/2)))2590 (if (and (= r x+1/2) (odd? r)) (- r 1) r)))2591 (else (##sys#error-bad-real x 'round)) )))25922593(define (find-ratio-between x y)2594 (define (sr x y)2595 (let ((fx (inexact->exact (floor x)))2596 (fy (inexact->exact (floor y))))2597 (cond ((not (< fx x)) (list fx 1))2598 ((= fx fy)2599 (let ((rat (sr (##sys#/-2 1 (- y fy))2600 (##sys#/-2 1 (- x fx)))))2601 (list (+ (cadr rat) (* fx (car rat)))2602 (car rat))))2603 (else (list (+ 1 fx) 1)))))2604 (cond ((< y x) (find-ratio-between y x))2605 ((not (< x y)) (list x 1))2606 ((positive? x) (sr x y))2607 ((negative? y) (let ((rat (sr (- y) (- x))))2608 (list (- (car rat)) (cadr rat))))2609 (else '(0 1))))26102611(define (find-ratio x e) (find-ratio-between (- x e) (+ x e)))26122613(set! scheme#rationalize2614 (lambda (x e)2615 (let ((result (apply ##sys#/-2 (find-ratio x e))))2616 (if (or (inexact? x) (inexact? e))2617 (exact->inexact result)2618 result)) ))26192620(set! scheme#max2621 (lambda (x1 . xs)2622 (##sys#check-number x1 'max)2623 (let loop ((i (##core#inline "C_i_flonump" x1))2624 (m x1)2625 (xs xs)2626 (n (##core#inline "C_i_nanp" x1)))2627 (if (null? xs)2628 (if i (exact->inexact m) m)2629 (let* ((h (##sys#slot xs 0))2630 (_ (##sys#check-number h 'max))2631 (f (##core#inline "C_i_flonump" h))2632 (nxt (##sys#slot xs 1)))2633 (cond ((##core#inline "C_i_nanp" h) (loop i m nxt n))2634 (n (loop (or i f) h nxt #f))2635 ((> h m) (loop (or i f) h nxt #f))2636 (else (loop (or i f) m nxt n))))))))26372638(set! scheme#min2639 (lambda (x1 . xs)2640 (##sys#check-number x1 'min)2641 (let loop ((i (##core#inline "C_i_flonump" x1))2642 (m x1)2643 (xs xs)2644 (n (##core#inline "C_i_nanp" x1)))2645 (if (null? xs)2646 (if i (exact->inexact m) m)2647 (let* ((h (##sys#slot xs 0))2648 (_ (##sys#check-number h 'min))2649 (f (##core#inline "C_i_flonump" h))2650 (nxt (##sys#slot xs 1)))2651 (cond ((##core#inline "C_i_nanp" h) (loop i m nxt n))2652 (n (loop (or i f) h nxt #f))2653 ((< h m) (loop (or i f) h nxt #f))2654 (else (loop (or i f) m nxt n))))))))26552656(set! scheme#exp2657 (lambda (n)2658 (##sys#check-number n 'exp)2659 (if (cplxnum? n)2660 (* (##core#inline_allocate ("C_a_i_exp" 4)2661 (exact->inexact (%cplxnum-real n)))2662 (let ((p (%cplxnum-imag n)))2663 (make-complex2664 (##core#inline_allocate ("C_a_i_cos" 4) (exact->inexact p))2665 (##core#inline_allocate ("C_a_i_sin" 4) (exact->inexact p)) ) ) )2666 (##core#inline_allocate ("C_a_i_flonum_exp" 4) (exact->inexact n)) ) ))26672668(define (##sys#log-1 x) ; log_e(x)2669 (cond2670 ((eq? x 0) ; Exact zero? That's undefined2671 (##sys#signal-hook #:arithmetic-error 'log "log of exact 0 is undefined" x))2672 ;; avoid calling inexact->exact on X here (to avoid overflow?)2673 ((or (cplxnum? x) (negative? x)) ; General case2674 (+ (##sys#log-1 (magnitude x))2675 (* (make-complex 0 1) (angle x))))2676 (else ; Real number case (< already ensured the argument type is a number)2677 (##core#inline_allocate ("C_a_i_log" 4) (exact->inexact x)))))26782679(set! scheme#log2680 (lambda (a #!optional b)2681 (if b (##sys#/-2 (##sys#log-1 a) (##sys#log-1 b)) (##sys#log-1 a))))26822683(set! scheme#sin2684 (lambda (n)2685 (##sys#check-number n 'sin)2686 (if (cplxnum? n)2687 (let ((in (* +i n)))2688 (##sys#/-2 (- (exp in) (exp (- in))) +2i))2689 (##core#inline_allocate ("C_a_i_sin" 4) (exact->inexact n)) ) ))26902691(set! scheme#cos2692 (lambda (n)2693 (##sys#check-number n 'cos)2694 (if (cplxnum? n)2695 (let ((in (* +i n)))2696 (##sys#/-2 (+ (exp in) (exp (- in))) 2) )2697 (##core#inline_allocate ("C_a_i_cos" 4) (exact->inexact n)) ) ))26982699(define (##sys#tanh z)2700 (let* ((x (real-part z))2701 (y (imag-part z))2702 (tanh-overflow-treshold (/ (fpasinh maximum-flonum) 2))2703 (tanh-overflow-low-treshold (/ (fpasinh maximum-flonum) 4))2704 (ax (abs x)))2705 (cond2706 ((eqv? z 0) 0)2707 ((> ax tanh-overflow-treshold)2708 (if (real? z)2709 (* 1.0 (##sys#sign-bit x))2710 (make-rectangular (* 1.0 (##sys#sign-bit x))2711 (* 0.0 (##sys#sign-bit y)))))2712 ((> ax tanh-overflow-low-treshold)2713 (if (real? z)2714 (* 1.0 (##sys#sign-bit x))2715 (let ((y*2 (* y 2.0))2716 (cosh-x*2 (fpcosh (* 2.0 x))))2717 (cond2718 ((finite? y*2)2719 (make-rectangular (* 1.0 (##sys#sign-bit x))2720 (/ (sin y*2)2721 cosh-x*2)))2722 ((finite? y)2723 (make-rectangular (* 1.0 (##sys#sign-bit x))2724 (/ (* 2.0 (sin y) (cos y))2725 cosh-x*2)))2726 (else (make-rectangular (* 1.0 (##sys#sign-bit sign x))2727 (* 0.0 (##sys#sign-bit sign y))))))))2728 (else2729 (let* ((t (tan y))2730 (beta (+ 1.0 (* t t)))2731 (s (if (eqv? x 0)2732 0.0 ; Avoid divide-by-exact-zero errors2733 (fpsinh x)))2734 (rho (sqrt (+ 1.0 (* s s)))))2735 (if (infinite? t)2736 (make-rectangular (/ rho s) (/ t))2737 (let ((ret (if (real? z)2738 (* beta rho s)2739 (make-rectangular (* beta rho s)2740 t))))2741 (/ ret (+ 1.0 (* beta (* s s)))))))))))2742274327442745(set! scheme#tan2746 (lambda (n)2747 (##sys#check-number n 'tan)2748 (if (cplxnum? n)2749 (* -i (##sys#tanh (* +i n))) ; Kahan's version2750 (##core#inline_allocate ("C_a_i_tan" 4) (exact->inexact n)) ) ))27512752(define (##sys#conjugate z)2753 (make-rectangular (real-part z) (- (imag-part z))))27542755;; General case: sin^{-1}(z) = -i\ln(iz + \sqrt{1-z^2})2756(set! scheme#asin2757 (lambda (n)2758 (##sys#check-number n 'asin)2759 (cond ((and (##core#inline "C_i_flonump" n) (fp>= n -1.0) (fp<= n 1.0))2760 (##core#inline_allocate ("C_a_i_asin" 4) n))2761 ((and (##core#inline "C_fixnump" n) (fx>= n -1) (fx<= n 1))2762 (##core#inline_allocate ("C_a_i_asin" 4)2763 (##core#inline_allocate2764 ("C_a_i_fix_to_flo" 4) n)))2765 ;; General definition can return compnums2766 (else2767 (cond2768 ;; These should fall out of the algorithm below,2769 ;; but inexactness-promotion rules end up generating2770 ;; a NaN somewhere.2771 ;;2772 ;; These are the special cases -inf.0+0.0i and2773 ;; +inf.0+0.0i from Gambit. Since Gambit has mixed exactness numbers,2774 ;; this doesn't copy -inf.0+0i and +inf.0+0i. Basically, unsigned2775 ;; zero is approached counterclockwise, and signed zero from the2776 ;; side with that sign. So unsigned zero approches from the bottom2777 ;; and matches -0.0, which is probably not what we want.2778 ((eqv? n +inf.0) 1.5707963267948966+inf.0i)2779 ((eqv? n -inf.0) -1.5707963267948966+inf.0i)2780 (else2781 (let* ((x (real-part n))2782 (s:1-n (sqrt (- 1 n)))2783 (s:1+n (sqrt (+ 1 n)))2784 (ipart (imag-part (* (##sys#conjugate s:1-n)2785 s:1+n))))2786 (make-rectangular (atan x (real-part (* s:1-n s:1+n)))2787 (if (and (exact? ipart) (zero? ipart))2788 02789 (fpasinh ipart))))))))))27902791;; General case:2792;; cos^{-1}(z) = 1/2\pi + i\ln(iz + \sqrt{1-z^2}) = 1/2\pi - sin^{-1}(z) = sin(1) - sin(z)2793(set! scheme#acos2794 (let ((asin1 (##core#inline_allocate ("C_a_i_asin" 4) 1)))2795 (lambda (n)2796 (##sys#check-number n 'acos)2797 (cond ((and (##core#inline "C_i_flonump" n) (fp>= n -1.0) (fp<= n 1.0))2798 (##core#inline_allocate ("C_a_i_acos" 4) n))2799 ((and (##core#inline "C_fixnump" n) (fx>= n -1) (fx<= n 1))2800 (##core#inline_allocate ("C_a_i_acos" 4)2801 (##core#inline_allocate2802 ("C_a_i_fix_to_flo" 4) n)))2803 ;; General definition can return compnums2804 (else2805 (let* ((s:1-n (sqrt (- 1 n)))2806 (s:1+n (sqrt (+ 1 n)))2807 (x (* 2 (atan (real-part s:1-n) (real-part s:1+n))))2808 (w (imag-part (* (##sys#conjugate s:1+n)2809 s:1-n)))2810 (y (if (eq? w 0)2811 02812 (fpasinh w))))2813 (make-rectangular x y)))))))28142815;;; Start Kahan's atan (with modifications from Gambit)28162817(define fllog1+2818 (foreign-lambda double "log1p" double))28192820(define (##sys#sign-bit x)2821 (cond2822 ((eq? x 0) +1)2823 ((eqv? x +0.0) +1.0)2824 ((eqv? x -0.0) -1.0)2825 (else (signum x))))28262827(define (##sys#internal-atanh z)2828 (let* ((z (* (##sys#sign-bit (real-part z)) (##sys#conjugate z)))2829 (x (real-part z))2830 (y (imag-part z))2831 (theta (/ (sqrt maximum-flonum) 4))2832 (rho (/ theta))2833 (fl-pi/2 1.57079632679489661923132169163975144)2834 (fl-pi/4 0.785398163397448309615660845819875721))2835 (cond2836 ((or (> x theta) (> (abs y) theta))2837 (make-rectangular (real-part (/ z))2838 (* fl-pi/2 (##sys#sign-bit y))))2839 ((and (= x 1.0) (zero? y))2840 (make-rectangular +inf.02841 (* (##sys#sign-bit y) fl-pi/4)))2842 ((= x 1.0)2843 (let ((absy (abs y)))2844 (make-rectangular (log (/ (sqrt (sqrt (+ 4.0 (* y y))))2845 (sqrt absy)))2846 (* (/ (+ fl-pi/22847 (atan absy 2.0))2848 2.0)2849 (##sys#sign-bit y)))))2850 (else2851 (let ((y^2 (* y y)))2852 (make-rectangular (cond2853 ((eqv? x 0) 0)2854 (else2855 (/ (fllog1+ (/ (* 4.0 x)2856 (+ (* (- 1.0 x) (- 1.0 x))2857 y^2)))2858 4.0)))2859 (/ (angle (+ (* (- 1.0 x) (+ 1.0 x))2860 (- y^2)2861 (make-rectangular2862 0.02863 (* 2.0 y))))2864 2.0)))))))28652866(define (##sys#atanh z)2867 (cond2868 ((eqv? z 0) 0)2869 ((and (real? z) (eqv? (abs z) 1))2870 (error 'atanh "atanh has a singularity at 1 and -1"))2871 ((and (real? z) (< -1.0 z 1.0))2872 (fpatanh (exact->inexact z)))2873 (else (* (##sys#sign-bit (real-part z)) (##sys#conjugate (##sys#internal-atanh z))))))28742875(set! scheme#atan2876 (lambda (n #!optional b)2877 (##sys#check-number n 'atan)2878 (cond ((cplxnum? n)2879 (if b2880 (##sys#error-bad-real n 'atan)2881 (* -i (##sys#atanh (* +i n)))))2882 (b2883 (##core#inline_allocate2884 ("C_a_i_atan2" 4) (exact->inexact n) (exact->inexact b)))2885 (else2886 (##core#inline_allocate2887 ("C_a_i_atan" 4) (exact->inexact n))) ) ))28882889;;; End kahan algorithm28902891;; This is "Karatsuba Square Root" as described by Paul Zimmermann,2892;; which is 3/2K(n) + O(n log n) for an input of 2n words, where K(n)2893;; is the number of operations performed by Karatsuba multiplication.2894(define (##sys#exact-integer-sqrt a)2895 ;; Because we assume a3b+a2 >= b^2/4, we must check a few edge cases:2896 (if (and (fixnum? a) (fx<= a 4))2897 (case a2898 ((0 1) (values a 0))2899 ((2) (values 1 1))2900 ((3) (values 1 2))2901 ((4) (values 2 0))2902 (else (error "this should never happen")))2903 (let*-values2904 (((len/4) (fxshr (fx+ (integer-length a) 1) 2))2905 ((len/2) (fxshl len/4 1))2906 ((s^ r^) (##sys#exact-integer-sqrt2907 (arithmetic-shift a (fxneg len/2))))2908 ((mask) (- (arithmetic-shift 1 len/4) 1))2909 ((a0) (bitwise-and a mask))2910 ((a1) (bitwise-and (arithmetic-shift a (fxneg len/4)) mask))2911 ((q u) ((##core#primitive "C_u_integer_quotient_and_remainder")2912 (+ (arithmetic-shift r^ len/4) a1)2913 (arithmetic-shift s^ 1)))2914 ((s) (+ (arithmetic-shift s^ len/4) q))2915 ((r) (+ (arithmetic-shift u len/4) (- a0 (* q q)))))2916 (if (negative? r)2917 (values (- s 1)2918 (- (+ r (arithmetic-shift s 1)) 1))2919 (values s r)))))29202921(set! scheme#exact-integer-sqrt2922 (lambda (x)2923 (##sys#check-exact-uinteger x 'exact-integer-sqrt)2924 (##sys#exact-integer-sqrt x)))29252926;; Complex square root according to Kahan's algorithm.29272928(define logb (foreign-lambda double "logb" double))2929(define (ldexp* x k)2930 (if (inexact? x)2931 (ldexp x k)2932 (* x (expt 2 k))))29332934(define (##sys#cssqs z)2935 (let* ((x (real-part z))2936 (y (imag-part z))2937 (x^2 (* x x))2938 (y^2 (* y y))2939 (rho (+ x^2 y^2)))2940 (if (and (or (nan? rho) (infinite? rho))2941 (or (infinite? x) (infinite? y)))2942 (values +inf.0 0)2943 (let ((underflowed? (or (< x^2 minimum-flonum)2944 (< y^2 minimum-flonum)))2945 (overflowed? (or (infinite? rho)2946 (infinite? x^2)2947 (infinite? y^2))))2948 (if (or overflowed?2949 (and underflowed? (< rho (/ minimum-flonum2950 flonum-epsilon))))2951 (let* ((k (logb (inexact (max (abs x) (abs y)))))2952 (x* (ldexp* x (- k)))2953 (y* (ldexp* y (- k))))2954 (values (+ (* x* x*) (* y* y*)) k))2955 (values rho 0))))))29562957(define (##sys#csqrt z)2958 (define (even*? k)2959 (and (integer? k) (even? k)))2960 (define (odd*? k)2961 (and (integer? k) (odd? k)))2962 (let*-values (((x) (real-part z))2963 ((y) (imag-part z))2964 ((rho k) (##sys#cssqs z))2965 ((rho) (if (not (nan? x))2966 (+ (ldexp* (abs x) (- k))2967 (sqrt rho))2968 rho))2969 ((rho) (if (even*? k)2970 (+ rho rho)2971 rho))2972 ((k) (if (odd*? k)2973 (/ (- k 1) 2)2974 (- (/ k 2) 1)))2975 ((rho) (ldexp* (sqrt rho) k))2976 ((zeta) rho)2977 ((eta) y)2978 ((eta) (if (and (not (zero? rho)) (not (infinite? eta)))2979 (/ eta rho 2.0)2980 eta)))2981 (if (and (not (zero? rho)) (negative? x))2982 (make-rectangular (abs eta) (* rho (##sys#sign-bit y)))2983 (make-rectangular zeta eta))))29842985;; This procedure is so large because it tries very hard to compute2986;; exact results if at all possible.2987(define (##sys#sqrt/loc loc n)2988 (cond ((cplxnum? n) ; Must be checked before we call "negative?"2989 (##sys#csqrt n))2990 ((negative? n)2991 (make-complex .0 (##core#inline_allocate2992 ("C_a_i_sqrt" 4) (exact->inexact (- n)))))2993 ((##core#inline "C_i_exact_integerp" n)2994 (receive (s^2 r) (##sys#exact-integer-sqrt n)2995 (if (eq? 0 r)2996 s^22997 (##core#inline_allocate ("C_a_i_sqrt" 4) (exact->inexact n)))))2998 ((ratnum? n) ; Try to compute exact sqrt (we already know n is positive)2999 (receive (ns^2 nr) (##sys#exact-integer-sqrt (%ratnum-numerator n))3000 (if (eq? nr 0)3001 (receive (ds^2 dr)3002 (##sys#exact-integer-sqrt (%ratnum-denominator n))3003 (if (eq? dr 0)3004 (##sys#/-2 ns^2 ds^2)3005 (##sys#sqrt/loc loc (exact->inexact n))))3006 (##sys#sqrt/loc loc (exact->inexact n)))))3007 (else (##core#inline_allocate ("C_a_i_sqrt" 4) (exact->inexact n)))))30083009(set! scheme#sqrt (lambda (x) (##sys#sqrt/loc 'sqrt x)))30103011;; XXX These are bad bad bad definitions; very inefficient.3012;; But to improve it we would need to provide another implementation3013;; of the quotient procedure which floors instead of truncates.3014(define scheme#truncate/ quotient&remainder)30153016(define (scheme#floor/ x y)3017 (receive (div rem) (quotient&remainder x y)3018 (if (positive? y)3019 (if (negative? rem)3020 (values (- div 1) (+ rem y))3021 (values div rem))3022 (if (positive? rem)3023 (values (- div 1) (+ rem y))3024 (values div rem)))))30253026(define (scheme#floor-remainder x y)3027 (receive (div rem) (scheme#floor/ x y) rem))30283029(define (scheme#floor-quotient x y)3030 (receive (div rem) (scheme#floor/ x y) div))30313032(define (scheme#square n) (* n n))30333034(set! chicken.base#exact-integer-nth-root3035 (lambda (k n)3036 (##sys#check-exact-uinteger k 'exact-integer-nth-root)3037 (##sys#check-exact-uinteger n 'exact-integer-nth-root)3038 (##sys#exact-integer-nth-root/loc 'exact-integer-nth-root k n)))30393040;; Generalized Newton's algorithm for positive integers, with a little help3041;; from Wikipedia ;) https://en.wikipedia.org/wiki/Nth_root_algorithm3042(define (##sys#exact-integer-nth-root/loc loc k n)3043 (if (or (eq? 0 k) (eq? 1 k) (eq? 1 n)) ; Maybe call exact-integer-sqrt on n=2?3044 (values k 0)3045 (let ((len (integer-length k)))3046 (if (< len n) ; Idea from Gambit: 2^{len-1} <= k < 2^{len}3047 (values 1 (- k 1)) ; Since x >= 2, we know x^{n} can't exist3048 ;; Set initial guess to (at least) 2^ceil(ceil(log2(k))/n)3049 (let* ((shift-amount (inexact->exact (ceiling (/ (fx+ len 1) n))))3050 (g0 (arithmetic-shift 1 shift-amount))3051 (n-1 (- n 1)))3052 (let lp ((g0 g0)3053 (g1 (quotient3054 (+ (* n-1 g0)3055 (quotient k (##sys#integer-power g0 n-1)))3056 n)))3057 (if (< g1 g0)3058 (lp g1 (quotient3059 (+ (* n-1 g1)3060 (quotient k (##sys#integer-power g1 n-1)))3061 n))3062 (values g0 (- k (##sys#integer-power g0 n))))))))))30633064(define (##sys#integer-power base e)3065 (define (square x) (* x x))3066 (if (negative? e)3067 (##sys#/-2 1 (##sys#integer-power base (integer-negate e)))3068 (let lp ((res 1) (e2 e))3069 (cond3070 ((eq? e2 0) res)3071 ((even? e2) ; recursion is faster than iteration here3072 (* res (square (lp 1 (arithmetic-shift e2 -1)))))3073 (else3074 (lp (* res base) (- e2 1)))))))30753076(set! scheme#expt3077 (lambda (a b)3078 (define (log-expt a b)3079 (exp (* b (##sys#log-1 a))))3080 (define (slow-expt a b)3081 (if (eq? 0 a)3082 (##sys#signal-hook3083 #:arithmetic-error 'expt3084 "exponent of exact 0 with complex argument is undefined" a b)3085 (exp (* b (##sys#log-1 a)))))3086 (cond ((not (number? a)) (##sys#error-bad-number a 'expt))3087 ((not (number? b)) (##sys#error-bad-number b 'expt))3088 ((and (ratnum? a) (not (inexact? b)))3089 ;; (n*d)^b = n^b * d^b = n^b * x^{-b} | x = 1/b3090 ;; Hopefully faster than integer-power3091 (* (expt (%ratnum-numerator a) b)3092 (expt (%ratnum-denominator a) (- b))))3093 ((ratnum? b)3094 ;; x^{a/b} = (x^{1/b})^a3095 (cond3096 ((##core#inline "C_i_exact_integerp" a)3097 (if (negative? a)3098 (log-expt (exact->inexact a) (exact->inexact b))3099 (receive (ds^n r)3100 (##sys#exact-integer-nth-root/loc3101 'expt a (%ratnum-denominator b))3102 (if (eq? r 0)3103 (##sys#integer-power ds^n (%ratnum-numerator b))3104 (##core#inline_allocate ("C_a_i_flonum_expt" 4)3105 (exact->inexact a)3106 (exact->inexact b))))))3107 ((##core#inline "C_i_flonump" a)3108 (log-expt a (exact->inexact b)))3109 (else (slow-expt a b))))3110 ((or (cplxnum? b) (and (cplxnum? a) (not (integer? b))))3111 (slow-expt a b))3112 ((and (##core#inline "C_i_flonump" b)3113 (not (##core#inline "C_u_i_fpintegerp" b)))3114 (if (negative? a)3115 (log-expt (exact->inexact a) (exact->inexact b))3116 (##core#inline_allocate3117 ("C_a_i_flonum_expt" 4) (exact->inexact a) b)))3118 ((##core#inline "C_i_flonump" a)3119 (##core#inline_allocate ("C_a_i_flonum_expt" 4) a (exact->inexact b)))3120 ;; this doesn't work that well, yet...3121 ;; (XXX: What does this mean? why not? I do know this is ugly... :P)3122 (else (if (or (inexact? a) (inexact? b))3123 (exact->inexact (##sys#integer-power a (inexact->exact b)))3124 (##sys#integer-power a b)))) ))31253126;; Useful for sane error messages3127(define (##sys#internal-gcd loc a b)3128 (cond ((##core#inline "C_i_exact_integerp" a)3129 (cond ((##core#inline "C_i_exact_integerp" b)3130 (%integer-gcd a b))3131 ((and (##core#inline "C_i_flonump" b)3132 (##core#inline "C_u_i_fpintegerp" b))3133 (exact->inexact (%integer-gcd a (inexact->exact b))))3134 (else (##sys#error-bad-integer b loc))))3135 ((and (##core#inline "C_i_flonump" a)3136 (##core#inline "C_u_i_fpintegerp" a))3137 (cond ((##core#inline "C_i_flonump" b)3138 (##core#inline_allocate ("C_a_i_flonum_gcd" 4) a b))3139 ((##core#inline "C_i_exact_integerp" b)3140 (exact->inexact (%integer-gcd (inexact->exact a) b)))3141 (else (##sys#error-bad-integer b loc))))3142 (else (##sys#error-bad-integer a loc))))3143;; For compat reasons, we define this3144(define (##sys#gcd a b) (##sys#internal-gcd 'gcd a b))31453146(set! scheme#gcd3147 (lambda ns3148 (if (eq? ns '())3149 03150 (let loop ((head (##sys#slot ns 0))3151 (next (##sys#slot ns 1)))3152 (if (null? next)3153 (if (integer? head) (abs head) (##sys#error-bad-integer head 'gcd))3154 (let ((n2 (##sys#slot next 0)))3155 (loop (##sys#internal-gcd 'gcd head n2)3156 (##sys#slot next 1)) ) ) ) ) ))31573158(define (##sys#lcm x y)3159 (let ((gcd (##sys#internal-gcd 'lcm x y))) ; Ensure better error message3160 (abs (quotient (* x y) gcd) ) ) )31613162(set! scheme#lcm3163 (lambda ns3164 (if (null? ns)3165 13166 (let loop ((head (##sys#slot ns 0))3167 (next (##sys#slot ns 1)))3168 (if (null? next)3169 (if (integer? head) (abs head) (##sys#error-bad-integer head 'lcm))3170 (let* ((n2 (##sys#slot next 0))3171 (gcd (##sys#internal-gcd 'lcm head n2)))3172 (loop (quotient (* head n2) gcd)3173 (##sys#slot next 1)) ) ) ) ) ))31743175;; This simple enough idea is from3176;; http://www.numberworld.org/y-cruncher/internals/radix-conversion.html3177(define (##sys#integer->string/recursive n base expected-string-size)3178 (let*-values (((halfsize) (fxshr (fx+ expected-string-size 1) 1))3179 ((b^M/2) (##sys#integer-power base halfsize))3180 ((hi lo) ((##core#primitive "C_u_integer_quotient_and_remainder")3181 n b^M/2))3182 ((strhi) (number->string hi base))3183 ((strlo) (number->string (abs lo) base)))3184 (string-append strhi3185 ;; Fix up any leading zeroes that were stripped from strlo3186 (make-string (fx- halfsize (string-length strlo)) #\0)3187 strlo)))31883189(define ##sys#extended-number->string3190 (let ((string-append string-append))3191 (lambda (n base)3192 (cond3193 ((ratnum? n)3194 (string-append (number->string (%ratnum-numerator n) base)3195 "/"3196 (number->string (%ratnum-denominator n) base)))3197 ((cplxnum? n) (let ((r (%cplxnum-real n))3198 (i (%cplxnum-imag n)) )3199 (string-append3200 (number->string r base)3201 ;; The infinities and NaN always print their sign3202 (if (and (finite? i) (>= i 0) (not (eqv? i -0.0))) "+" "")3203 (number->string i base) "i") ))3204 (else (##sys#error-bad-number n 'number->string))) ) ) )32053206(define ##sys#number->string number->string) ; for printer32073208;; We try to prevent memory exhaustion attacks by limiting the3209;; maximum exponent value. Perhaps this should be a parameter?3210(define-constant +maximum-allowed-exponent+ 10000)32113212;; From "Easy Accurate Reading and Writing of Floating-Point Numbers"3213;; by Aubrey Jaffer.3214(define (mantexp->dbl mant point)3215 (if (not (negative? point))3216 (exact->inexact (* mant (##sys#integer-power 10 point)))3217 (let* ((scl (##sys#integer-power 10 (abs point)))3218 (bex (fx- (fx- (integer-length mant)3219 (integer-length scl))3220 flonum-precision)))3221 (if (fx< bex 0)3222 (let* ((num (arithmetic-shift mant (fxneg bex)))3223 (quo (round-quotient num scl)))3224 (cond ((> (integer-length quo) flonum-precision)3225 ;; Too many bits of quotient; readjust3226 (set! bex (fx+ 1 bex))3227 (set! quo (round-quotient num (* scl 2)))))3228 (ldexp (exact->inexact quo) bex))3229 ;; Fall back to exact calculation in extreme cases3230 (exact->inexact (* mant (##sys#integer-power 10 point)))))))32313232(define ldexp (foreign-lambda double "ldexp" double int))32333234;; Should we export this?3235(define (round-quotient n d)3236 (let ((q (%integer-quotient n d)))3237 (if ((if (even? q) > >=) (* (abs (remainder n d)) 2) (abs d))3238 (+ q (if (eqv? (negative? n) (negative? d)) 1 -1))3239 q)))32403241(define (##sys#string->compnum radix str offset exactness)3242 ;; Flipped when a sign is encountered (for inexact numbers only)3243 (define negative #f)3244 ;; Go inexact unless exact was requested (with #e prefix)3245 (define (go-inexact! neg?)3246 (unless (eq? exactness 'e)3247 (set! exactness 'i)3248 (set! negative (or negative neg?))))3249 (define (safe-exponent value e allow-inexact? neg?)3250 (and e (cond3251 ((not value) 0)3252 ((> e +maximum-allowed-exponent+)3253 (and allow-inexact?3254 (eq? exactness 'i)3255 (cond ((zero? value) (if neg? -0.0 0.0))3256 ((> value 0.0) +inf.0)3257 (else -inf.0))))3258 ((< e (fxneg +maximum-allowed-exponent+))3259 (and allow-inexact? (eq? exactness 'i) (if neg? -0.0 +0.0)))3260 ((and allow-inexact? (eq? exactness 'i))3261 (let ((r (mantexp->dbl value e)))3262 (if (and neg? (zero? r)) -0.0 r)))3263 (else (* value (##sys#integer-power 10 e))))))3264 (define (make-nan)3265 ;; Return fresh NaNs, so eqv? returns #f on two read NaNs. This3266 ;; is not mandated by the standard, but compatible with earlier3267 ;; CHICKENs and it just makes more sense.3268 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) 0.0 0.0))3269 (let* ((len (string-length str))3270 (0..r (fast-i->c (fx+ (char->integer #\0) (fx- radix 1))))3271 (a..r (fast-i->c (fx+ (char->integer #\a) (fx- radix 11))))3272 (A..r (fast-i->c (fx+ (char->integer #\A) (fx- radix 11))))3273 ;; Ugly flag which we need (note that "exactness" is mutated too!)3274 ;; Since there is (almost) no backtracking we can do this.3275 (seen-hashes? #f)3276 ;; All these procedures return #f or an object consed onto an end3277 ;; position. If the cdr is false, that's the end of the string.3278 ;; If just #f is returned, the string contains invalid number syntax.3279 (scan-digits3280 (lambda (start cplx?)3281 (let lp ((i start)3282 ;; Drop is true when the last read character is3283 ;; an "i" while reading the second part of a3284 ;; rectangular complex number literal *and* the3285 ;; radix is 19 or above. In that case, we back3286 ;; up one character to ensure we don't consume3287 ;; the trailing "i", which we otherwise would.3288 (drop? #f))3289 (if (fx= i len)3290 (and (fx> i start)3291 (if drop?3292 (cons (sub1 i) (sub1 i))3293 (cons i #f)))3294 (let ((c (string-ref str i)))3295 (if (fx<= radix 10)3296 (if (and (char>=? c #\0) (char<=? c 0..r))3297 (lp (fx+ i 1) #f)3298 (and (fx> i start) (cons i i)))3299 (if (or (and (char>=? c #\0) (char<=? c #\9))3300 (and (char>=? c #\a) (char<=? c a..r))3301 (and (char>=? c #\A) (char<=? c A..r)))3302 (lp (fx+ i 1)3303 (and cplx? (fx>= radix 19)3304 (or (char=? c #\i)3305 (char=? c #\I))))3306 (and (fx> i start)3307 (if (and drop? (not (char=? c #\/))) ;; Fractional numbers are an exception - the i may only come after the slash3308 (cons (sub1 i) (sub1 i))3309 (cons i i))))))))))3310 (scan-hashes3311 (lambda (start)3312 (let lp ((i start))3313 (if (fx= i len)3314 (and (fx> i start) (cons i #f))3315 (let ((c (string-ref str i)))3316 (if (eq? c #\#)3317 (lp (fx+ i 1))3318 (and (fx> i start) (cons i i))))))))3319 (scan-digits+hashes3320 (lambda (start neg? cplx? all-hashes-ok?)3321 (let* ((digits (and (not seen-hashes?) (scan-digits start cplx?)))3322 (hashes (if digits3323 (and (cdr digits) (scan-hashes (cdr digits)))3324 (and all-hashes-ok? (scan-hashes start))))3325 (end (or hashes digits)))3326 (and-let* ((end)3327 (num (##core#inline_allocate3328 ("C_s_a_i_digits_to_integer" 6)3329 str start (car end) radix neg?)))3330 (when hashes ; Eeewww. Feeling dirty yet?3331 (set! seen-hashes? #t)3332 (go-inexact! neg?))3333 (cons num (cdr end))))))3334 (scan-exponent3335 (lambda (start)3336 (and (fx< start len)3337 (let ((sign (case (string-ref str start)3338 ((#\+) 'pos) ((#\-) 'neg) (else #f))))3339 (and-let* ((start (if sign (fx+ start 1) start))3340 (end (scan-digits start #f)))3341 (cons (##core#inline_allocate3342 ("C_s_a_i_digits_to_integer" 6)3343 str start (car end) radix (eq? sign 'neg))3344 (cdr end)))))))3345 (scan-decimal-tail ; The part after the decimal dot3346 (lambda (start neg? decimal-head)3347 (and (fx< start len)3348 (let* ((tail (scan-digits+hashes start neg? #f decimal-head))3349 (next (if tail (cdr tail) start)))3350 (and (or decimal-head (not next)3351 (fx> next start)) ; Don't allow empty "."3352 (case (and next (string-ref str next))3353 ((#\e #\s #\f #\d #\l3354 #\E #\S #\F #\D #\L)3355 (and-let* (((fx> len next))3356 (ee (scan-exponent (fx+ next 1)))3357 (e (car ee))3358 (val (if tail3359 (let* ((num (or (car tail) 0))3360 (te (fx- e (fx- (cdr tail) start)))3361 (h (if decimal-head3362 (safe-exponent decimal-head (- e te) #f neg?)3363 0)))3364 (safe-exponent (+ h num) te #t neg?))3365 (safe-exponent decimal-head e #t neg?))))3366 (cons val (cdr ee))))3367 (else (cons (if tail3368 (let* ((last (or next len))3369 (te (fx- start last))3370 (num (or (car tail) 0))3371 (h (if decimal-head3372 (safe-exponent decimal-head (- te) #f neg?)3373 0)))3374 (safe-exponent (+ h num) te #t neg?))3375 ;; NOTE: May convert to inexact or +inf.0 etc, so this is not a no-op3376 (safe-exponent decimal-head 0 #t neg?))3377 next))))))))3378 (scan-ureal3379 (lambda (start neg? cplx?)3380 (if (and (fx> len (fx+ start 1)) (eq? radix 10)3381 (eq? (string-ref str start) #\.))3382 (begin3383 (go-inexact! neg?)3384 (scan-decimal-tail (fx+ start 1) neg? #f))3385 (and-let* ((end (scan-digits+hashes start neg? cplx? #f)))3386 (case (and (cdr end) (string-ref str (cdr end)))3387 ((#\.)3388 (go-inexact! neg?)3389 (and (eq? radix 10)3390 (if (fx> len (fx+ (cdr end) 1))3391 (scan-decimal-tail (fx+ (cdr end) 1) neg? (car end))3392 (if (and neg? (eq? exactness 'i) (zero? (car end)))3393 (cons -0.0 #f)3394 (cons (car end) #f)))))3395 ((#\e #\s #\f #\d #\l3396 #\E #\S #\F #\D #\L)3397 (go-inexact! neg?)3398 (and-let* (((eq? radix 10))3399 ((fx> len (cdr end)))3400 (ee (scan-exponent (fx+ (cdr end) 1)))3401 (num (car end))3402 (val (safe-exponent num (car ee) #t neg?)))3403 (cons val (cdr ee))))3404 ((#\/)3405 (set! seen-hashes? #f) ; Reset flag for denominator3406 (and-let* (((fx> len (cdr end)))3407 (d (scan-digits+hashes (fx+ (cdr end) 1) #f cplx? #f))3408 (num (car end))3409 (denom (car d)))3410 (if (not (eq? denom 0))3411 (cons (##sys#/-2 num denom) (cdr d))3412 ;; Hacky: keep around an inexact until we decide we3413 ;; *really* need exact values, then fail at the end.3414 (and (not (eq? exactness 'e))3415 (case (signum num)3416 ((-1) (cons -inf.0 (cdr d)))3417 ((0) (cons (make-nan) (cdr d)))3418 ((+1) (cons +inf.0 (cdr d))))))))3419 (else end))))))3420 (scan-real3421 (lambda (start cplx?)3422 (and (fx< start len)3423 (let* ((sign (case (string-ref str start)3424 ((#\+) 'pos) ((#\-) 'neg) (else #f)))3425 (next (if sign (fx+ start 1) start)))3426 (and (fx< next len)3427 (case (string-ref str next)3428 ((#\i #\I)3429 (or (and sign3430 (cond3431 ((and (fx= (fx+ next 1) len) ; [+-]i3432 ;; Reject bare "+i" in higher radixes where this would be ambiguous3433 (or cplx?3434 (fx< radix 19)))3435 (cons (if (eq? sign 'neg) -1 1) next))3436 ((and (fx<= (fx+ next 5) len)3437 (string-ci=? (substring str next (fx+ next 5)) "inf.0"))3438 (go-inexact! (eq? sign 'neg))3439 (cons (if (eq? sign 'neg) -inf.0 +inf.0)3440 (and (fx< (fx+ next 5) len)3441 (fx+ next 5))))3442 (else #f)))3443 (scan-ureal next (eq? sign 'neg) cplx?)))3444 ((#\n #\N)3445 (or (and sign3446 (fx<= (fx+ next 5) len)3447 (string-ci=? (substring str next (fx+ next 5)) "nan.0")3448 (begin (go-inexact! (eq? sign 'neg))3449 (cons (make-nan)3450 (and (fx< (fx+ next 5) len)3451 (fx+ next 5)))))3452 (scan-ureal next (eq? sign 'neg) cplx?)))3453 (else (scan-ureal next (eq? sign 'neg) cplx?))))))))3454 (number (and-let* ((r1 (scan-real offset #f)))3455 (let ((nf (and r1 (zero? (car r1)) negative)))3456 (case (and (cdr r1) (string-ref str (cdr r1)))3457 ((#f) (car r1))3458 ((#\i #\I) (and (fx= len (fx+ (cdr r1) 1))3459 (let ((c (string-ref str offset)))3460 (or (eq? c #\+)3461 (eq? c #\-)))3462 (make-rectangular 0 (if nf (- (car r1)) (car r1)))))3463 ((#\+ #\-)3464 (set! seen-hashes? #f) ; Reset flag for imaginary part3465 (set! negative #f)3466 (and-let* ((r2 (scan-real (cdr r1) #t))3467 ((cdr r2))3468 ((fx= len (fx+ (cdr r2) 1)))3469 ((or (eq? (string-ref str (cdr r2)) #\i)3470 (eq? (string-ref str (cdr r2)) #\I))))3471 (make-rectangular3472 (car r1)3473 (let ((n2 (if (and (exact? (car r2)) (eq? exactness 'i))3474 (exact->inexact (car r2))3475 (car r2))))3476 (if (and negative (>= n2 0) (not (eqv? n2 -0.0)))3477 (- n2)3478 n2)))))3479 ((#\@)3480 (set! seen-hashes? #f) ; Reset flag for angle3481 (and-let* ((r2 (scan-real (fx+ (cdr r1) 1) #f))3482 ((not (cdr r2))))3483 (make-polar (car r1) (car r2))))3484 (else #f))))))3485 (and number (if (eq? exactness 'i)3486 (exact->inexact number)3487 (and (finite? number) number)))))34883489(set! scheme#string->number3490 (lambda (str #!optional (base 10))3491 (##sys#check-string str 'string->number)3492 (unless (and (##core#inline "C_fixnump" base)3493 (fx< 1 base) (fx< base 37)) ; We only have 0-9 and the alphabet!3494 (##sys#error-bad-base base 'string->number))3495 (let scan-prefix ((i 0)3496 (exness #f)3497 (radix #f)3498 (len (string-length str)))3499 (if (and (fx< (fx+ i 2) len) (eq? (string-ref str i) #\#))3500 (case (string-ref str (fx+ i 1))3501 ((#\i #\I) (and (not exness) (scan-prefix (fx+ i 2) 'i radix len)))3502 ((#\e #\E) (and (not exness) (scan-prefix (fx+ i 2) 'e radix len)))3503 ((#\b #\B) (and (not radix) (scan-prefix (fx+ i 2) exness 2 len)))3504 ((#\o #\O) (and (not radix) (scan-prefix (fx+ i 2) exness 8 len)))3505 ((#\d #\D) (and (not radix) (scan-prefix (fx+ i 2) exness 10 len)))3506 ((#\x #\X) (and (not radix) (scan-prefix (fx+ i 2) exness 16 len)))3507 (else #f))3508 (##sys#string->compnum (or radix base) str i exness)))))35093510(define (##sys#string->number str #!optional (radix 10) exactness)3511 (##sys#string->compnum radix str 0 exactness))35123513(define ##sys#fixnum->string (##core#primitive "C_fixnum_to_string"))3514(define ##sys#flonum->string (##core#primitive "C_flonum_to_string"))3515(define ##sys#integer->string (##core#primitive "C_integer_to_string"))3516(define ##sys#number->string number->string)35173518(set! chicken.base#equal=?3519 (lambda (x y)3520 (define (compare-slots x y start)3521 (let ((l1 (##sys#size x))3522 (l2 (##sys#size y)))3523 (and (eq? l1 l2)3524 (or (fx<= l1 start)3525 (let ((l1n (fx- l1 1)))3526 (let loop ((i start))3527 (if (fx= i l1n)3528 (walk (##sys#slot x i) (##sys#slot y i)) ; tailcall3529 (and (walk (##sys#slot x i) (##sys#slot y i))3530 (loop (fx+ i 1))))))))))3531 (define (walk x y)3532 (cond ((eq? x y))3533 ((number? x)3534 (if (number? y)3535 (= x y)3536 (eq? x y)))3537 ((not (##core#inline "C_blockp" x)) #f)3538 ((not (##core#inline "C_blockp" y)) #f)3539 ((not (##core#inline "C_sametypep" x y)) #f)3540 ((##core#inline "C_specialp" x)3541 (and (##core#inline "C_specialp" y)3542 (if (##core#inline "C_closurep" x)3543 (##core#inline "shallow_equal" x y)3544 (compare-slots x y 1))))3545 ((##core#inline "C_stringp" x)3546 (walk (##sys#slot x 0) (##sys#slot y 0)))3547 ((##core#inline "C_byteblockp" x)3548 (and (##core#inline "C_byteblockp" y)3549 (let ((s1 (##sys#size x)))3550 (and (eq? s1 (##sys#size y))3551 (##core#inline "C_bv_compare" x y s1)))))3552 (else3553 (let ((s1 (##sys#size x)))3554 (and (eq? s1 (##sys#size y))3555 (compare-slots x y 0))))))3556 (walk x y) ))355735583559;;; Symbols:35603561(define ##sys#snafu '##sys#fnord)3562(define ##sys#intern-symbol (##core#primitive "C_string_to_symbol"))3563(define ##sys#intern-keyword (##core#primitive "C_string_to_keyword"))3564(define ##sys#make-symbol (##core#primitive "C_make_symbol"))3565(define (##sys#interned-symbol? x) (##core#inline "C_lookup_symbol" x))35663567(define (##sys#string->symbol-name s)3568 (let* ((bv (##sys#slot s 0))3569 (len (##sys#size bv))3570 (s2 (##sys#make-bytevector len)))3571 (##core#inline "C_copy_bytevector" bv s2 len)))35723573(define (##sys#symbol->string/shared s)3574 (let* ((bv (##sys#slot s 1))3575 (count (##core#inline "C_utf_length" bv)))3576 (##core#inline_allocate ("C_a_ustring" 5)3577 bv3578 count)))35793580(define (##sys#symbol->string s)3581 (let* ((bv (##sys#slot s 1))3582 (len (##sys#size bv))3583 (s2 (##sys#make-bytevector len))3584 (count (##core#inline "C_utf_length" bv)))3585 (##core#inline_allocate ("C_a_ustring" 5)3586 (##core#inline "C_copy_bytevector" bv s2 len)3587 count)))35883589(define (##sys#string->symbol str)3590 (##sys#intern-symbol (##sys#string->symbol-name str) ))35913592(set! scheme#symbol->string3593 (lambda (s)3594 (##sys#check-symbol s 'symbol->string)3595 (##sys#symbol->string s) ) )35963597(set! scheme#string->symbol3598 (lambda (str)3599 (##sys#check-string str 'string->symbol)3600 (##sys#string->symbol str)))36013602(set! chicken.base#string->uninterned-symbol3603 (lambda (str)3604 (##sys#check-string str 'string->uninterned-symbol)3605 (##sys#make-symbol (##sys#string->symbol-name str))))36063607(set! chicken.base#gensym3608 (let ((counter -1))3609 (lambda str-or-sym3610 (let ((err (lambda (prefix) (##sys#signal-hook #:type-error 'gensym "argument is not a string or symbol" prefix))))3611 (set! counter (fx+ counter 1))3612 (##sys#make-symbol3613 (##sys#string->symbol-name3614 (##sys#string-append3615 (if (eq? str-or-sym '())3616 "g"3617 (let ((prefix (car str-or-sym)))3618 (or (and (##core#inline "C_blockp" prefix)3619 (cond ((##core#inline "C_stringp" prefix) prefix)3620 ((##core#inline "C_symbolp" prefix) (##sys#symbol->string/shared prefix))3621 (else (err prefix))))3622 (err prefix) ) ) )3623 (##sys#number->string counter) ) ) ) ) ) ) )36243625(set! chicken.base#symbol-append3626 (let ((string-append string-append))3627 (lambda ss3628 (##sys#string->symbol3629 (apply3630 string-append3631 (map (lambda (s)3632 (##sys#check-symbol s 'symbol-append)3633 (##sys#symbol->string/shared s))3634 ss))))))36353636;;; Keywords:36373638(module chicken.keyword3639 (keyword? get-keyword keyword->string string->keyword)36403641(import scheme)3642(import chicken.fixnum)36433644(define (keyword? x) (##core#inline "C_i_keywordp" x) )36453646(define string->keyword3647 (let ([string string] )3648 (lambda (s)3649 (##sys#check-string s 'string->keyword)3650 (##sys#intern-keyword (##sys#string->symbol-name s) ) ) ))36513652(define keyword->string3653 (let ([keyword? keyword?])3654 (lambda (kw)3655 (if (keyword? kw)3656 (##sys#symbol->string kw)3657 (##sys#signal-hook #:type-error 'keyword->string "bad argument type - not a keyword" kw) ) ) ) )36583659(define get-keyword3660 (let ((tag (list 'tag)))3661 (lambda (key args #!optional thunk)3662 (##sys#check-keyword key 'get-keyword)3663 (##sys#check-list args 'get-keyword)3664 (let ((r (##core#inline "C_i_get_keyword" key args tag)))3665 (if (eq? r tag) ; not found3666 (and thunk (thunk))3667 r)))))36683669(define ##sys#get-keyword get-keyword))36703671(import chicken.keyword)367236733674;;; bytevectors:36753676(define (##sys#bytevector->list v)3677 (let ((n (##sys#size v)))3678 (let loop ((i (fx- n 1)) (lst '()))3679 (if (fx< i 0)3680 lst3681 (loop (fx- i 1)3682 (cons (##core#inline "C_subbyte" v i) lst))))))36833684(define (##sys#list->bytevector lst0)3685 (let* ((n (length lst0))3686 (bv (##sys#make-bytevector n)))3687 (let loop ((lst lst0) (i 0))3688 (if (null? lst)3689 bv3690 (let ((b (car lst)))3691 (if (##core#inline "C_fixnump" b)3692 (##core#inline "C_setsubbyte" bv i b)3693 (##sys#signal-hook #:type-error "can not convert list to bytevector" lst0))3694 (loop (cdr lst) (fx+ i 1)))))))36953696(module chicken.bytevector3697 (bytevector? bytevector=? bytevector-length3698 make-bytevector bytevector bytevector-u8-ref3699 bytevector-u8-set! bytevector-copy bytevector-copy!3700 bytevector-append utf8->string string->utf83701 latin1->string string->latin1 bytes->string)37023703(import scheme (chicken foreign))37043705(define (make-bytevector size #!optional fill)3706 (##sys#check-fixnum size 'make-bytevector)3707 (if fill (##sys#check-fixnum fill 'make-bytevector))3708 (##sys#make-bytevector size fill) )37093710(define (bytevector? x)3711 (##core#inline "C_i_bytevectorp" x) )37123713(define (bytevector-length bv)3714 (##sys#check-bytevector bv 'bytevector-length)3715 (##sys#size bv) )37163717(define (bytevector-u8-ref bv i)3718 (##core#inline "C_i_bytevector_ref" bv i))37193720(define (bytevector-u8-set! bv i b)3721 (##core#inline "C_i_bytevector_set" bv i b))37223723(define (string->utf8 s)3724 (##sys#check-string s 'string->utf8)3725 (let* ((sbv (##sys#slot s 0))3726 (n (##core#inline "C_fixnum_difference" (##sys#size sbv) 1))3727 (bv (##sys#make-bytevector n)) )3728 (##core#inline "C_copy_memory" bv sbv n)3729 bv) )37303731(define (utf8->string bv #!optional (start 0) end)3732 (##sys#check-bytevector bv 'utf8->string)3733 (let* ((n (##sys#size bv))3734 (to (or end n)))3735 (##sys#check-range/including start 0 n 'utf8->string)3736 (if end3737 (##sys#check-range/including end 0 n 'utf8->string))3738 (let ((count (##core#inline "C_utf_validate" bv n start to)))3739 (if (not count)3740 (##sys#error-hook (foreign-value "C_DECODING_ERROR" int) 'utf8->string bv))3741 (let* ((len (##core#inline "C_fixnum_difference" to start))3742 (dest (##sys#make-bytevector (##core#inline "C_fixnum_plus" len 1))))3743 (##core#inline "C_copy_memory_with_offset" dest bv 0 start len)3744 (##core#inline_allocate ("C_a_ustring" 5) dest count)))))37453746(define (bytes->string bv #!optional (start 0) end)3747 (##sys#check-bytevector bv 'bytes->string)3748 (let* ((n (##sys#size bv))3749 (to (or end n)))3750 (##sys#check-range/including start 0 n 'bytes->string)3751 (if end3752 (##sys#check-range/including end 0 n 'bytes->string))3753 (##sys#buffer->string bv start (##core#inline "C_fixnum_difference" to start))))37543755(define (string->latin1 s)3756 (##sys#check-string s 'string->latin1)3757 (let* ((sbv (##sys#slot s 0))3758 (len (##sys#slot s 1))3759 (blen (##core#inline "C_fixnum_difference" (##sys#size sbv) 1))3760 (bv (##sys#make-bytevector len)) )3761 (##core#inline "C_utf_to_latin" sbv bv 0 blen)3762 bv))37633764(define (latin1->string bv)3765 (##sys#check-bytevector bv 'latin1->string)3766 (let* ((len (##sys#size bv))3767 (buf (##sys#make-bytevector (##core#inline "C_fixnum_times" len 2)))3768 (n (##core#inline "C_latin_to_utf" bv buf 0 len)))3769 (##sys#buffer->string! buf n)))37703771(define (bytevector=? b1 b2)3772 (##sys#check-bytevector b1 'bytevector=?)3773 (##sys#check-bytevector b2 'bytevector=?)3774 (let ((n (##sys#size b1)))3775 (and (eq? (##sys#size b2) n)3776 (##core#inline "C_bv_compare" b1 b2 n))))37773778(define (bytevector . args)3779 (let* ((n (length args))3780 (bv (##sys#make-bytevector n)))3781 (let loop ((args args) (i 0))3782 (cond ((null? args) bv)3783 (else3784 (let ((b (car args)))3785 (##sys#check-fixnum b 'bytevector)3786 (##core#inline "C_setsubbyte" bv i b)3787 (loop (cdr args) (##core#inline "C_fixnum_plus" i 1))))))))37883789(define (bytevector-copy bv #!optional (start 0) end)3790 (##sys#check-bytevector bv 'bytevector-copy)3791 (let* ((n (##sys#size bv))3792 (to (or end n)))3793 (if end3794 (##sys#check-range/including end 0 n 'bytevector->copy))3795 (cond ((and (eq? n 0) (eq? start 0) (eq? 0 to))3796 (##sys#make-bytevector 0))3797 (else3798 (##sys#check-range/including start 0 n 'bytevector->copy)3799 (let* ((n2 (##core#inline "C_fixnum_difference" to start))3800 (v2 (##sys#make-bytevector n2)))3801 (##core#inline "C_copy_memory_with_offset" v2 bv 0 start n2)3802 v2)))))38033804(define (bytevector-copy! bv1 at bv2 #!optional (start 0) end)3805 (##sys#check-bytevector bv1 'bytevector-copy!)3806 (##sys#check-bytevector bv2 'bytevector-copy!)3807 (let* ((n1 (##sys#size bv1))3808 (n2 (##sys#size bv2))3809 (to (or end n2))3810 (nc (##core#inline "C_fixnum_difference" to start)))3811 (cond ((and (eq? n2 0) (eq? nc 0) (eq? start 0)) (##core#undefined))3812 (else3813 (##sys#check-range/including start 0 n2 'bytevector->copy!)3814 (##sys#check-range/including at 0 n1 'bytevector->copy!)3815 (##sys#check-range/including (##core#inline "C_fixnum_plus" at nc)3816 0 n1 'bytevector->copy!)3817 (##core#inline "C_copy_memory_with_offset" bv1 bv2 at start nc)))))38183819(define (bytevector-append . bvs)3820 (let loop ((lst bvs) (len 0))3821 (if (null? lst)3822 (let ((bv (##sys#make-bytevector len)))3823 (let loop ((lst bvs) (i 0))3824 (if (null? lst)3825 bv3826 (let* ((bv1 (car lst))3827 (n (##sys#size bv1)))3828 (##core#inline "C_copy_memory_with_offset" bv bv1 i 0 n)3829 (loop (cdr lst) (##core#inline "C_fixnum_plus" i n))))))3830 (let ((bv (car lst)))3831 (##sys#check-bytevector bv 'bytevector-append)3832 (loop (cdr lst) (##core#inline "C_fixnum_plus" len (##sys#size bv)))))))38333834) ; chicken.bytevector383538363837;;; Vectors:3838(set! scheme#make-vector3839 (lambda (size . fill)3840 (##sys#check-fixnum size 'make-vector)3841 (when (fx< size 0) (##sys#error 'make-vector "size is negative" size))3842 (##sys#allocate-vector3843 size3844 (if (null? fill)3845 (##core#undefined)3846 (car fill) ))))38473848(define ##sys#make-vector make-vector)38493850(set! scheme#list->vector3851 (lambda (lst0)3852 (if (not (list? lst0))3853 (##sys#error-not-a-proper-list lst0 'list->vector)3854 (let* ([len (length lst0)]3855 [v (##sys#make-vector len)] )3856 (let loop ([lst lst0]3857 [i 0])3858 (if (null? lst)3859 v3860 (begin3861 (##sys#setslot v i (##sys#slot lst 0))3862 (loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) ) )))38633864(set! scheme#vector->list3865 (lambda (v #!optional start end)3866 (##sys#check-vector v 'vector->list)3867 (let ((len (##sys#size v)))3868 (if start3869 (##sys#check-range/including start 0 len 'vector->list)3870 (set! start 0))3871 (if end3872 (##sys#check-range/including end 0 len 'vector->list)3873 (set! end len))3874 (let loop ((i start))3875 (if (fx>= i end)3876 '()3877 (cons (##sys#slot v i)3878 (loop (fx+ i 1)) ) ) ) ) ))38793880(set! scheme#vector (lambda xs (list->vector xs) ))38813882(set! scheme#vector-fill!3883 (lambda (v x #!optional start end)3884 (##sys#check-vector v 'vector-fill!)3885 (let ((len (##sys#size v)))3886 (if start3887 (##sys#check-range/including start 0 len 'vector-fill!)3888 (set! start 0))3889 (if end3890 (##sys#check-range/including end 0 len 'vector-fill!)3891 (set! end len))3892 (do ((i start (fx+ i 1)))3893 ((fx>= i end))3894 (##sys#setslot v i x) ) ) ))38953896(define (scheme#vector-copy v #!optional start end)3897 (##sys#check-vector v 'vector-copy)3898 (let ((copy (lambda (v start end)3899 (let* ((len (##sys#size v)))3900 (##sys#check-range/including start 0 end 'vector-copy)3901 (##sys#check-range/including end start len 'vector-copy)3902 (let ((vec (##sys#make-vector (fx- end start))))3903 (do ((ti 0 (fx+ ti 1))3904 (fi start (fx+ fi 1)))3905 ((fx>= fi end) vec)3906 (##sys#setslot vec ti (##sys#slot v fi))))))))3907 (if end3908 (copy v start end)3909 (copy v (or start 0) (##sys#size v)))))39103911(define (scheme#vector-copy! to at from #!optional start end)3912 (##sys#check-vector to 'vector-copy!)3913 (##sys#check-vector from 'vector-copy!)3914 (let ((copy! (lambda (to at from start end)3915 (let* ((tlen (##sys#size to))3916 (flen (##sys#size from))3917 (d (fx- end start)))3918 (##sys#check-range/including at 0 tlen 'vector-copy!)3919 (##sys#check-range/including start 0 end 'vector-copy!)3920 (##sys#check-range/including end start flen 'vector-copy!)3921 (##sys#check-range/including d 0 (fx- tlen at) 'vector-copy!)3922 (if (and (eq? to from) (fx< start at))3923 (do ((fi (fx- end 1) (fx- fi 1))3924 (ti (fx- (fx+ at d) 1) (fx- ti 1)))3925 ((fx< fi start))3926 (##sys#setslot to ti (##sys#slot from fi)))3927 (do ((fi start (fx+ fi 1))3928 (ti at (fx+ ti 1)))3929 ((fx= fi end))3930 (##sys#setslot to ti (##sys#slot from fi))))))))3931 (if end3932 (copy! to at from start end)3933 (copy! to at from (or start 0) (##sys#size from)))))39343935(define (scheme#vector-append . vs)3936 (##sys#for-each (cut ##sys#check-vector <> 'vector-append) vs)3937 (let* ((lens (map ##sys#size vs))3938 (vec (##sys#make-vector (foldl fx+ 0 lens))))3939 (do ((vs vs (cdr vs))3940 (lens lens (cdr lens))3941 (i 0 (fx+ i (car lens))))3942 ((null? vs) vec)3943 (scheme#vector-copy! vec i (car vs) 0 (car lens)))))39443945(set! chicken.base#subvector3946 (lambda (v i #!optional j)3947 (##sys#check-vector v 'subvector)3948 (let* ((len (##sys#size v))3949 (j (or j len))3950 (len2 (fx- j i)))3951 (##sys#check-range/including i 0 len 'subvector)3952 (##sys#check-range/including j 0 len 'subvector)3953 (let ((v2 (make-vector len2)))3954 (do ((k 0 (fx+ k 1)))3955 ((fx>= k len2) v2)3956 (##sys#setslot v2 k (##sys#slot v (fx+ k i))))))))39573958(set! chicken.base#vector-resize3959 (lambda (v n #!optional init)3960 (##sys#check-vector v 'vector-resize)3961 (##sys#check-fixnum n 'vector-resize)3962 (##sys#vector-resize v n init)))39633964(define (##sys#vector-resize v n init)3965 (let ((v2 (##sys#make-vector n init))3966 (len (min (##sys#size v) n)) )3967 (do ((i 0 (fx+ i 1)))3968 ((fx>= i len) v2)3969 (##sys#setslot v2 i (##sys#slot v i)) ) ) )39703971;;; Characters:39723973(set! scheme#char-ci=?3974 (lambda (x y . more)3975 (##sys#check-char x 'char-ci=?)3976 (##sys#check-char y 'char-ci=?)3977 (let ((c2 (##core#inline "C_utf_char_foldcase" y)))3978 (let loop ((c c2) (cs more)3979 (f (eq? (##core#inline "C_utf_char_foldcase" x) c2)))3980 (if (null? cs)3981 f3982 (let ((c2 (##sys#slot cs 0)))3983 (##sys#check-char c2 'char-ci=?)3984 (let ((c2 ((##core#inline "C_utf_char_foldcase" c2))))3985 (loop c2 (##sys#slot cs 1)3986 (and f (eq? c c2))))))))))39873988(set! scheme#char-ci>?3989 (lambda (x y . more)3990 (##sys#check-char x 'char-ci>?)3991 (##sys#check-char y 'char-ci>?)3992 (let ((c2 (##core#inline "C_utf_char_foldcase" y)))3993 (let loop ((c c2) (cs more)3994 (f (##core#inline "C_u_i_char_greaterp"3995 (##core#inline "C_utf_char_foldcase" x)3996 c2)))3997 (if (null? cs)3998 f3999 (let ((c2 (##sys#slot cs 0)))4000 (##sys#check-char c2 'char-ci>?)4001 (let ((c2 ((##core#inline "C_utf_char_foldcase" c2))))4002 (loop c2 (##sys#slot cs 1)4003 (and f (##core#inline "C_u_i_char_greaterp" c c2))))))))))40044005(set! scheme#char-ci<?4006 (lambda (x y . more)4007 (##sys#check-char x 'char-ci<?)4008 (##sys#check-char y 'char-ci<?)4009 (let ((c2 (##core#inline "C_utf_char_foldcase" y)))4010 (let loop ((c c2) (cs more)4011 (f (##core#inline "C_u_i_char_lessp"4012 (##core#inline "C_utf_char_foldcase" x)4013 c2)))4014 (if (null? cs)4015 f4016 (let ((c2 (##sys#slot cs 0)))4017 (##sys#check-char c2 'char-ci<?)4018 (let ((c2 ((##core#inline "C_utf_char_foldcase" c2))))4019 (loop c2 (##sys#slot cs 1)4020 (and f (##core#inline "C_u_i_char_lessp" c c2))))))))))40214022(set! scheme#char-ci>=?4023 (lambda (x y . more)4024 (##sys#check-char x 'char-ci>=?)4025 (##sys#check-char y 'char-ci>=?)4026 (let ((c2 (##core#inline "C_utf_char_foldcase" y)))4027 (let loop ((c c2) (cs more)4028 (f (##core#inline "C_u_i_char_greater_or_equal_p"4029 (##core#inline "C_utf_char_foldcase" x)4030 c2)))4031 (if (null? cs)4032 f4033 (let ((c2 (##sys#slot cs 0)))4034 (##sys#check-char c2 'char-ci>=?)4035 (let ((c2 ((##core#inline "C_utf_char_foldcase" c2))))4036 (loop c2 (##sys#slot cs 1)4037 (and f (##core#inline "C_u_i_char_greater_or_equal_p" c c2))))))))))40384039(set! scheme#char-ci<=?4040 (lambda (x y . more)4041 (##sys#check-char x 'char-ci<=?)4042 (##sys#check-char y 'char-ci<=?)4043 (let ((c2 (##core#inline "C_utf_char_foldcase" y)))4044 (let loop ((c c2) (cs more)4045 (f (##core#inline "C_u_i_char_less_or_equal_p"4046 (##core#inline "C_utf_char_foldcase" x)4047 c2)))4048 (if (null? cs)4049 f4050 (let ((c2 (##sys#slot cs 0)))4051 (##sys#check-char c2 'char-ci<=?)4052 (let ((c2 ((##core#inline "C_utf_char_foldcase" c2))))4053 (loop c2 (##sys#slot cs 1)4054 (and f (##core#inline "C_u_i_char_less_or_equal_p" c c2))))))))))40554056(set! chicken.base#char-name4057 (let ((chars-to-names (make-vector char-name-table-size '()))4058 (names-to-chars '()))4059 (define (lookup-char c)4060 (let* ((code (char->integer c))4061 (key (##core#inline "C_fixnum_modulo" code char-name-table-size)) )4062 (let loop ((b (##sys#slot chars-to-names key)))4063 (and (pair? b)4064 (let ((a (##sys#slot b 0)))4065 (if (eq? (##sys#slot a 0) c)4066 a4067 (loop (##sys#slot b 1)) ) ) ) ) ) )4068 (lambda (x #!optional (chr #:none))4069 (cond ((char? x)4070 (and-let* ((a (lookup-char x)))4071 (case chr4072 ((#:none)4073 (##sys#slot a 1) )4074 ((#f)4075 (##sys#setslot a 0 #f)4076 (##sys#setslot (assq (##sys#slot a 1) names-to-chars) 0 #f)4077 (##core#undefined))4078 (else4079 (##sys#signal-hook #:type-error 'char-name4080 "expected second boolean argument" chr) ))))4081 ((symbol? x)4082 (let ((a (assq x names-to-chars)))4083 (case chr4084 ((#:none) (and a (##sys#slot a 1)))4085 ((#f)4086 (when a4087 (##sys#setslot a 0 #f)4088 (##sys#setslot (lookup-char (##sys#slot a 1)) 0 #f))4089 (##core#undefined))4090 (else4091 (##sys#check-char chr 'char-name)4092 (when (fx< (##sys#size (##sys#slot x 1)) 2)4093 (##sys#signal-hook #:type-error 'char-name "invalid character name" x) )4094 (let ((a (lookup-char chr)))4095 (if a4096 (let ((b (assq x names-to-chars)))4097 (##sys#setslot a 1 x)4098 (if b4099 (##sys#setislot b 1 chr)4100 (set! names-to-chars (cons (cons x chr) names-to-chars)) ) )4101 (let ((key (##core#inline "C_fixnum_modulo" (char->integer chr)4102 char-name-table-size)))4103 (set! names-to-chars (cons (cons x chr) names-to-chars))4104 (##sys#setslot4105 chars-to-names key4106 (cons (cons chr x) (##sys#slot chars-to-names key))) ) ) ) ))))4107 (else (##sys#signal-hook #:type-error 'char-name "invalid argument type" x))))))41084109;; TODO: Use the character names here in the next release? Or just4110;; use the numbers everywhere, for clarity?4111(char-name 'space #\space)4112(char-name 'tab #\tab)4113(char-name 'linefeed #\linefeed)4114(char-name 'newline #\newline)4115(char-name 'vtab (integer->char 11))4116(char-name 'delete (integer->char 127))4117(char-name 'esc (integer->char 27))4118(char-name 'escape (integer->char 27))4119(char-name 'alarm (integer->char 7))4120(char-name 'nul (integer->char 0))4121(char-name 'null (integer->char 0))4122(char-name 'return #\return)4123(char-name 'page (integer->char 12))4124(char-name 'backspace (integer->char 8))412541264127;;; Procedures:41284129(define ##sys#call-with-current-continuation (##core#primitive "C_call_cc"))4130(define ##sys#call-with-cthulhu (##core#primitive "C_call_with_cthulhu"))4131(define ##sys#call-with-values call-with-values)41324133(define (##sys#for-each p lst0)4134 (let loop ((lst lst0))4135 (cond ((eq? lst '()) (##core#undefined))4136 ((pair? lst)4137 (p (##sys#slot lst 0))4138 (loop (##sys#slot lst 1)) )4139 (else (##sys#error-not-a-proper-list lst0 'for-each)) ) ))41404141(define (##sys#map p lst0)4142 (let loop ((lst lst0))4143 (cond ((eq? lst '()) lst)4144 ((pair? lst)4145 (cons (p (##sys#slot lst 0)) (loop (##sys#slot lst 1))) )4146 (else (##sys#error-not-a-proper-list lst0 'map)) ) ))41474148(letrec ((mapsafe4149 (lambda (p lsts loc)4150 (call-with-current-continuation4151 (lambda (empty)4152 (let lp ((lsts lsts))4153 (if (eq? lsts '())4154 lsts4155 (let ((item (##sys#slot lsts 0)))4156 (cond ((eq? item '()) (empty '()))4157 ((pair? item)4158 (cons (p item) (lp (##sys#slot lsts 1))))4159 (else (##sys#error-not-a-proper-list item loc)))))))))))41604161 (set! scheme#for-each4162 (lambda (fn lst1 . lsts)4163 (if (null? lsts)4164 (##sys#for-each fn lst1)4165 (let loop ((all (cons lst1 lsts)))4166 (let* ((first (##sys#slot all 0))4167 (safe-args (mapsafe (lambda (x) (car x)) all 'for-each))) ; ensure inlining4168 (when (pair? safe-args)4169 (apply fn safe-args)4170 (loop (mapsafe (lambda (x) (cdr x)) all 'for-each))))))))41714172 (set! scheme#map4173 (lambda (fn lst1 . lsts)4174 (if (null? lsts)4175 (##sys#map fn lst1)4176 (let loop ((all (cons lst1 lsts)))4177 (let* ((first (##sys#slot all 0))4178 (safe-args (mapsafe (lambda (x) (car x)) all 'map)))4179 (if (pair? safe-args)4180 (cons (apply fn safe-args)4181 (loop (mapsafe (lambda (x) (cdr x)) all 'map)))4182 '())))))))418341844185;;; dynamic-wind:4186;4187; (taken more or less directly from SLIB)4188;4189; This implementation is relatively costly: we have to shadow call/cc4190; with a new version that unwinds suspended thunks, but for this to4191; happen the return-values of the escaping procedure have to be saved4192; temporarily in a list. Since call/cc is very efficient under this4193; implementation, and because allocation of memory that is to be4194; garbage soon has also quite low overhead, the performance-penalty4195; might be acceptable (ctak needs about 4 times longer).41964197(define ##sys#dynamic-winds '())41984199(set! scheme#dynamic-wind4200 (lambda (before thunk after)4201 (before)4202 (set! ##sys#dynamic-winds (cons (cons before after) ##sys#dynamic-winds))4203 (##sys#call-with-values4204 thunk4205 (lambda results4206 (set! ##sys#dynamic-winds (##sys#slot ##sys#dynamic-winds 1))4207 (after)4208 (apply ##sys#values results) ) ) ))42094210(define ##sys#dynamic-wind dynamic-wind)42114212(set! scheme#call-with-current-continuation4213 (lambda (proc)4214 (let ((winds ##sys#dynamic-winds))4215 (##sys#call-with-current-continuation4216 (lambda (cont)4217 (define (continuation . results)4218 (unless (eq? ##sys#dynamic-winds winds)4219 (##sys#dynamic-unwind winds (fx- (length ##sys#dynamic-winds) (length winds))) )4220 (apply cont results) )4221 (proc continuation) ))) ))42224223(set! scheme#call/cc call-with-current-continuation)42244225(define (##sys#dynamic-unwind winds n)4226 (cond [(eq? ##sys#dynamic-winds winds)]4227 [(fx< n 0)4228 (##sys#dynamic-unwind (##sys#slot winds 1) (fx+ n 1))4229 ((##sys#slot (##sys#slot winds 0) 0))4230 (set! ##sys#dynamic-winds winds) ]4231 [else4232 (let ([after (##sys#slot (##sys#slot ##sys#dynamic-winds 0) 1)])4233 (set! ##sys#dynamic-winds (##sys#slot ##sys#dynamic-winds 1))4234 (after)4235 (##sys#dynamic-unwind winds (fx- n 1)) ) ] ) )423642374238;;; Ports:42394240(set! chicken.base#port-closed?4241 (lambda (p)4242 (##sys#check-port p 'port-closed?)4243 (eq? (##sys#slot p 8) 0)))42444245;;; Custom ports:42464247;;; Port layout:4248;4249; 0: file ptr (special)4250; 1: direction (fixnum, 1 = input)4251; 2: class (vector of procedures)4252; 3: name (string)4253; 4: row (fixnum)4254; 5: col (fixnum)4255; 6: EOF (bool)4256; 7: type ('stream | 'custom | 'string | 'socket)4257; 8: closed (fixnum)4258; 9: data4259; 10-12: reserved, port class specific4260; 13: case sensitive? (boolean)4261; 14: mode ('textual | 'binary)4262; 15: reserved (encoding)4263;4264; Port-class:4265;4266; 0: (read-char PORT) -> CHAR | EOF4267; 1: (peek-char PORT) -> CHAR | EOF4268; 2: (write-char PORT CHAR)4269; 3: (write-bytevector PORT BYTEVECTOR START END)4270; 4: (close PORT DIRECTION)4271; 5: (flush-output PORT)4272; 6: (u8-ready? PORT) -> BOOL4273; 7: (read-bytevector! PORT COUNT BYTEVECTOR START) -> COUNT'4274; 8: (read-line PORT LIMIT) -> STRING | EOF4275; 9: (read-buffered PORT) -> STRING4276; [10: (char-ready? PORT) -> BOOL (optional)]42774278(define (##sys#make-port i/o class name type)4279 (let ((port (##core#inline_allocate ("C_a_i_port" 17))))4280 (##sys#setislot port 1 i/o)4281 (##sys#setslot port 2 class)4282 (##sys#setslot port 3 name)4283 (##sys#setislot port 4 1)4284 (##sys#setislot port 5 0)4285 (##sys#setislot port 6 #f)4286 (##sys#setslot port 7 type)4287 (##sys#setslot port 8 i/o)4288 (##sys#setislot port 10 #f)4289 (##sys#setislot port 13 #t)4290 (##sys#setislot port 14 'textual) ; default, only used for R7RS port predicates4291 (##sys#setslot port 15 'utf-8)4292 port) )42934294;;; Stream ports:4295; Input port slots:4296; 10: peek buffer4297; 12: Static buffer for read-line, allocated on-demand42984299(define ##sys#stream-port-class4300 (vector (lambda (p) ; read-char4301 (let loop ()4302 (let ((peeked (##sys#slot p 10)))4303 (cond (peeked4304 (##sys#setislot p 10 #f)4305 (##sys#decode-char peeked (##sys#slot p 15) 0))4306 ((eq? 'utf-8 (##sys#slot p 15)) ; fast path4307 (let ((c (##core#inline "C_read_char" p)))4308 (if (eq? -1 c)4309 (let ((err (##sys#update-errno)))4310 (if (eq? err (foreign-value "EINTR" int))4311 (##sys#dispatch-interrupt loop)4312 (##sys#signal-hook/errno4313 #:file-error err 'read-char4314 (##sys#string-append "cannot read from port - " strerror)4315 p)))4316 c)))4317 (else (##sys#read-char/encoding4318 p (##sys#slot p 15)4319 (lambda (buf start len dec)4320 (dec buf start len4321 (lambda (buf start len)4322 (##core#inline "C_utf_decode" buf start))))))))))4323 (lambda (p) ; peek-char4324 (let ((pb (##sys#slot p 10))4325 (enc (##sys#slot p 15)))4326 (if pb4327 (##sys#decode-char pb enc 0)4328 (##sys#read-char/encoding4329 p enc4330 (lambda (buf start len dec)4331 (let ((pb (##sys#make-bytevector len 1)))4332 (##core#inline "C_copy_memory_with_offset" pb buf 0 start len)4333 (##sys#setslot p 10 pb)4334 (dec buf start len4335 (lambda (buf start _)4336 (##core#inline "C_utf_decode" buf start)))))))))4337 (lambda (p c) ; write-char4338 (let ((enc (##sys#slot p 15)))4339 (if (eq? enc 'utf-8) ;; fast path4340 (##core#inline "C_display_char" p c)4341 (let* ((bv (##sys#make-bytevector 4))4342 (n (##core#inline "C_utf_insert" bv 0 c)))4343 ((##sys#slot (##sys#slot p 2) 3) p bv 0 n))))) ; write-bytevector4344 (lambda (p bv from to) ; write-bytevector4345 (##sys#encode-buffer4346 bv from (fx- to from) (##sys#slot p 15)4347 (lambda (bv start len)4348 (##core#inline "C_display_string" p bv start len))))4349 (lambda (p d) ; close4350 (let loop ()4351 (unless (##core#inline "C_close_file" p)4352 (if (eq? err (foreign-value "EINTR" int))4353 (##sys#dispatch-interrupt loop)4354 (##sys#signal-hook/errno4355 #:file-error (##sys#update-errno) 'close-output-port4356 (##sys#string-append "error while closing port - " strerror)4357 p)))))4358 (lambda (p) ; flush-output4359 (let loop ()4360 (unless (##core#inline "C_flush_output" p)4361 (let ((err (##sys#update-errno)))4362 (if (eq? err (foreign-value "EINTR" int))4363 (##sys#dispatch-interrupt loop)4364 (##sys#signal-hook/errno4365 #:file-error err 'flush-output-port4366 (##sys#string-append "error while flushing output port - " strerror)4367 p))))))4368 (lambda (p) ; u8-ready?4369 (or (##sys#slot p 10)4370 (##core#inline "C_char_ready_p" p) ))4371 (lambda (p n dest start) ; read-bytevector!4372 (let ((pb (##sys#slot p 10))4373 (nc 0))4374 (when pb4375 (set! nc (##sys#size pb))4376 (##core#inline "C_copy_memory_with_offset" dest pb start 0 nc)4377 (set! start (fx+ start nc))4378 (set! n (fx- n nc))4379 (##sys#setislot p 10 #f))4380 ;;XXX "n" below always true?4381 (let loop ((rem (or n (fx- (##sys#size dest) start)))4382 (act nc)4383 (start start))4384 (let ((len (##core#inline "fast_read_string_from_file" dest p rem start)))4385 (cond ((eof-object? len) ; EOF returns 0 bytes read4386 act)4387 ((fx< len 0)4388 (let ((err (##sys#update-errno)))4389 (if (eq? err (foreign-value "EINTR" int))4390 (##sys#dispatch-interrupt4391 (lambda () (loop rem act start)))4392 (##sys#signal-hook/errno4393 #:file-error err 'read-bytevector!4394 (##sys#string-append "cannot read from port - " strerror)4395 p n dest start))))4396 ((fx< len rem)4397 (loop (fx- rem len) (fx+ act len) (fx+ start len)))4398 (else (fx+ act len) ) ) ))))4399 (lambda (p rlimit) ; read-line4400 (when rlimit (##sys#check-fixnum rlimit 'read-line))4401 (let ((sblen read-line-buffer-initial-size)4402 (pb (##sys#slot p 10))4403 (buffer (##sys#slot p 12))4404 (bpos 0))4405 (unless buffer4406 (set! buffer (##sys#make-bytevector sblen))4407 (##sys#setslot p 12 buffer))4408 (when pb4409 (set! bpos (##sys#size pb))4410 (##core#inline "C_copy_memory_with_offset" buffer pb 0 0 bpos)4411 (##sys#setislot p 10 #f))4412 (let loop ([len sblen]4413 [limit (or rlimit maximal-string-length)]4414 [buffer buffer]4415 [result ""]4416 [f #f])4417 (let* ((nlimit (fxmin limit len))4418 (n (##core#inline "fast_read_line_from_file" buffer bpos4419 p nlimit)))4420 (set! bpos 0)4421 (cond ((eof-object? n) (if f result #!eof))4422 ((not n)4423 (let ((prev (##sys#buffer->string/encoding buffer 0 nlimit4424 (##sys#slot p 15))))4425 (if (fx< limit len)4426 (##sys#string-append result prev)4427 (loop (fx* len 2)4428 (fx- limit len)4429 (##sys#make-bytevector (fx* len 2))4430 (##sys#string-append result prev)4431 #t)) ) )4432 ((fx< n 0)4433 (let ((err (##sys#update-errno)))4434 (if (eq? err (foreign-value "EINTR" int))4435 (let ((n (fx- (fxneg n) 1)))4436 (##sys#dispatch-interrupt4437 (lambda ()4438 (loop len limit buffer4439 (##sys#string-append4440 result4441 (##sys#buffer->string/encoding buffer 0 n (##sys#slot p 15)))4442 #t))))4443 (##sys#signal-hook/errno4444 #:file-error err 'read-line4445 (##sys#string-append "cannot read from port - " strerror)4446 p rlimit))))4447 (f (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))4448 (##sys#string-append result4449 (##sys#buffer->string/encoding buffer 0 n (##sys#slot p 15))))4450 (else4451 (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))4452 (##sys#buffer->string/encoding buffer 0 n (##sys#slot p 15))))))))4453 #f ; read-buffered4454 (lambda (p) ; char-ready? (effectively u8-ready?)4455 (or (##sys#slot p 10)4456 (##core#inline "C_char_ready_p" p) ))4457 ) )44584459(define ##sys#open-file-port (##core#primitive "C_open_file_port"))44604461(define ##sys#standard-input (##sys#make-port 1 ##sys#stream-port-class "(stdin)" 'stream))4462(define ##sys#standard-output (##sys#make-port 2 ##sys#stream-port-class "(stdout)" 'stream))4463(define ##sys#standard-error (##sys#make-port 2 ##sys#stream-port-class "(stderr)" 'stream))44644465(##sys#open-file-port ##sys#standard-input 0 #f)4466(##sys#open-file-port ##sys#standard-output 1 #f)4467(##sys#open-file-port ##sys#standard-error 2 #f)44684469(define (##sys#check-input-port x open . loc)4470 (if (pair? loc)4471 (##core#inline "C_i_check_port_2" x 1 open (car loc))4472 (##core#inline "C_i_check_port" x 1 open)))44734474(define (##sys#check-output-port x open . loc)4475 (if (pair? loc)4476 (##core#inline "C_i_check_port_2" x 2 open (car loc))4477 (##core#inline "C_i_check_port" x 2 open)))44784479(define (##sys#check-port x . loc)4480 (if (pair? loc)4481 (##core#inline "C_i_check_port_2" x 0 #f (car loc))4482 (##core#inline "C_i_check_port" x 0 #f) ) )44834484(define (##sys#check-open-port x . loc)4485 (if (pair? loc)4486 (##core#inline "C_i_check_port_2" x 0 #t (car loc))4487 (##core#inline "C_i_check_port" x 0 #t) ) )44884489(set! scheme#current-input-port4490 (lambda args4491 (if (null? args)4492 ##sys#standard-input4493 (let ((p (car args)))4494 (##sys#check-input-port p 'current-input-port)4495 (let-optionals (cdr args) ((convert? #t) (set? #t))4496 (when set? (set! ##sys#standard-input p)))4497 p) ) ))44984499(set! scheme#current-output-port4500 (lambda args4501 (if (null? args)4502 ##sys#standard-output4503 (let ((p (car args)))4504 (##sys#check-output-port p 'current-output-port)4505 (let-optionals (cdr args) ((convert? #t) (set? #t))4506 (when set? (set! ##sys#standard-output p)))4507 p) ) ))45084509(set! chicken.base#current-error-port4510 (lambda args4511 (if (null? args)4512 ##sys#standard-error4513 (let ((p (car args)))4514 (##sys#check-output-port p 'current-error-port)4515 (let-optionals (cdr args) ((convert? #t) (set? #t))4516 (when set? (set! ##sys#standard-error p)))4517 p))))45184519(define (##sys#tty-port? port)4520 (and (not (zero? (##sys#peek-unsigned-integer port 0)))4521 (##core#inline "C_tty_portp" port) ) )45224523(define (##sys#port-data port) (##sys#slot port 9))4524(define (##sys#set-port-data! port data) (##sys#setslot port 9 data))45254526(define ##sys#default-file-encoding)45274528(let ()4529 (define (open name inp modes loc)4530 (##sys#check-string name loc)4531 (let ((fmode (if inp "r" "w"))4532 (bmode "")4533 (enc (##sys#default-file-encoding)))4534 (do ((modes modes (##sys#slot modes 1)))4535 ((null? modes))4536 (let ((o (##sys#slot modes 0)))4537 (case o4538 ((#:binary binary)4539 (set! bmode "b")4540 (set! enc 'binary))4541 ((#:text text) (set! bmode ""))4542 ((#:utf-8 utf-8)4543 (set! enc 'utf-8))4544 ((#:latin-1 latin-1 #:iso-8859-1 iso-8859-1)4545 (set! enc 'latin-1))4546 ((#:unix #:nl unix nl)4547 (set! bmode "b"))4548 ((#:crnl crnl)4549 (set! bmode ""))4550 ((#:append append)4551 (if inp4552 (##sys#error loc "cannot use append mode with input file")4553 (set! fmode "a") ) )4554 (else (##sys#error loc "invalid file option" o)) ) ) )4555 (let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class name 'stream)))4556 (##sys#setslot port 15 enc)4557 (unless (##sys#open-file-port port name (##sys#string-append fmode bmode))4558 (##sys#signal-hook/errno #:file-error (##sys#update-errno) loc4559 (##sys#string-append "cannot open file - " strerror)4560 name))4561 port) ) )45624563 (define (close port inp loc)4564 (if inp4565 (##sys#check-input-port port loc)4566 (##sys#check-output-port port loc))4567 ; repeated closing is ignored4568 (let ((direction (if inp 1 2)))4569 (when (##core#inline "C_port_openp" port direction)4570 (##sys#setislot port 8 (fxand (##sys#slot port 8) (fxnot direction)))4571 ((##sys#slot (##sys#slot port 2) 4) port direction)4572 (##core#undefined))))45734574 (set! scheme#open-input-file (lambda (name . mode) (open name #t mode 'open-input-file)))4575 (set! scheme#open-output-file (lambda (name . mode) (open name #f mode 'open-output-file)))4576 (set! scheme#close-input-port (lambda (port) (close port #t 'close-input-port)))4577 (set! scheme#close-output-port (lambda (port) (close port #f 'close-output-port))))45784579(set! scheme#call-with-input-file4580 (let ((open-input-file open-input-file)4581 (close-input-port close-input-port) )4582 (lambda (name p . mode)4583 (let ((f (apply open-input-file name mode)))4584 (##sys#call-with-values4585 (lambda () (p f))4586 (lambda results4587 (close-input-port f)4588 (apply ##sys#values results) ) ) ) ) ) )45894590(set! scheme#call-with-output-file4591 (let ((open-output-file open-output-file)4592 (close-output-port close-output-port) )4593 (lambda (name p . mode)4594 (let ((f (apply open-output-file name mode)))4595 (##sys#call-with-values4596 (lambda () (p f))4597 (lambda results4598 (close-output-port f)4599 (apply ##sys#values results) ) ) ) ) ) )46004601(set! scheme#with-input-from-file4602 (let ((open-input-file open-input-file)4603 (close-input-port close-input-port) )4604 (lambda (str thunk . mode)4605 (let ((file (apply open-input-file str mode)))4606 (fluid-let ((##sys#standard-input file))4607 (##sys#call-with-values thunk4608 (lambda results4609 (close-input-port file)4610 (apply ##sys#values results) ) ) ) ) ) ) )46114612(set! scheme#with-output-to-file4613 (let ((open-output-file open-output-file)4614 (close-output-port close-output-port) )4615 (lambda (str thunk . mode)4616 (let ((file (apply open-output-file str mode)))4617 (fluid-let ((##sys#standard-output file))4618 (##sys#call-with-values thunk4619 (lambda results4620 (close-output-port file)4621 (apply ##sys#values results) ) ) ) ) ) ) )46224623(define (##sys#file-exists? name file? dir? loc)4624 (case (##core#inline "C_i_file_exists_p" (##sys#make-c-string name loc) file? dir?)4625 ((#f) #f)4626 ((#t) #t)4627 (else4628 (##sys#signal-hook4629 #:file-error loc "system error while trying to access file"4630 name))))46314632(define (##sys#flush-output port)4633 ((##sys#slot (##sys#slot port 2) 5) port) ; flush-output4634 (##core#undefined) )46354636(set! chicken.base#flush-output4637 (lambda (#!optional (port ##sys#standard-output))4638 (##sys#check-output-port port #t 'flush-output)4639 (##sys#flush-output port)))46404641(define (##sys#port-line port)4642 (and (##core#inline "C_input_portp" port)4643 (##sys#slot port 4) ) )46444645;;; Decorate procedure with arbitrary data4646;4647; warning: may modify proc, if it already has a suitable decoration!46484649(define (##sys#decorate-lambda proc pred decorator)4650 (let ((len (##sys#size proc)))4651 (let loop ((i (fx- len 1)))4652 (cond ((zero? i)4653 (let ((p2 (make-vector (fx+ len 1))))4654 (do ((i 1 (fx+ i 1)))4655 ((fx>= i len)4656 (##core#inline "C_vector_to_closure" p2)4657 (##core#inline "C_copy_pointer" proc p2)4658 (decorator p2 i) )4659 (##sys#setslot p2 i (##sys#slot proc i)) ) ) )4660 (else4661 (let ((x (##sys#slot proc i)))4662 (if (pred x)4663 (decorator proc i)4664 (loop (fx- i 1)) ) ) ) ) ) ) )46654666(define (##sys#lambda-decoration proc pred)4667 (let loop ((i (fx- (##sys#size proc) 1)))4668 (and (fx> i 0)4669 (let ((x (##sys#slot proc i)))4670 (if (pred x)4671 x4672 (loop (fx- i 1)) ) ) ) ) )467346744675;;; Create lambda-info object46764677(define (##sys#make-lambda-info str)4678 (let* ((bv (##sys#slot str 0))4679 (sz (fx- (##sys#size bv) 1))4680 (info (##sys#make-bytevector sz)))4681 (##core#inline "C_copy_memory" info bv sz)4682 (##core#inline "C_bytevector_to_lambdainfo" info)4683 info) )468446854686;;; Function debug info:46874688(define (##sys#lambda-info? x)4689 (and (not (##sys#immediate? x)) (##core#inline "C_lambdainfop" x)))46904691(define (##sys#lambda-info proc)4692 (##sys#lambda-decoration proc ##sys#lambda-info?))46934694(define (##sys#lambda-info->string info)4695 (let* ((sz (##sys#size info))4696 (bv (##sys#make-bytevector (fx+ sz 1))) )4697 (##core#inline "C_copy_memory" bv info sz)4698 (##core#inline_allocate ("C_a_ustring" 5) bv4699 (##core#inline "C_utf_length" bv))))47004701(set! chicken.base#procedure-information4702 (lambda (x)4703 (##sys#check-closure x 'procedure-information)4704 (and-let* ((info (##sys#lambda-info x)))4705 (##sys#read (scheme#open-input-string (##sys#lambda-info->string info)) #f) ) ) )470647074708;;; SRFI-1747094710(define setter-tag (vector 'setter))47114712(define-inline (setter? x)4713 (and (pair? x) (eq? setter-tag (##sys#slot x 0))) )47144715(set! chicken.base#setter4716 (##sys#decorate-lambda4717 (lambda (proc)4718 (or (and-let* (((procedure? proc))4719 (d (##sys#lambda-decoration proc setter?)) )4720 (##sys#slot d 1) )4721 (##sys#error 'setter "no setter defined" proc) ) )4722 setter?4723 (lambda (proc i)4724 (##sys#setslot4725 proc i4726 (cons4727 setter-tag4728 (lambda (get set)4729 (if (procedure? get)4730 (let ((get2 (##sys#decorate-lambda4731 get4732 setter?4733 (lambda (proc i) (##sys#setslot proc i (cons setter-tag set)) proc))))4734 (if (eq? get get2)4735 get4736 (##sys#become! (list (cons get get2))) ) )4737 (error "can not set setter of non-procedure" get) ) ) ) )4738 proc) ) )47394740(define ##sys#setter setter)47414742(set! chicken.base#getter-with-setter4743 (lambda (get set #!optional info)4744 (##sys#check-closure get 'getter-with-setter)4745 (##sys#check-closure set 'getter-with-setter)4746 (let ((getdec (cond (info4747 (##sys#check-string info 'getter-with-setter)4748 (##sys#make-lambda-info info))4749 (else (##sys#lambda-info get))))4750 (p1 (##sys#decorate-lambda4751 (##sys#copy-closure get)4752 setter?4753 (lambda (proc i)4754 (##sys#setslot proc i (cons setter-tag set))4755 proc))))4756 (if getdec4757 (##sys#decorate-lambda4758 p14759 ##sys#lambda-info?4760 (lambda (p i)4761 (##sys#setslot p i getdec)4762 p))4763 p1))))47644765(set! scheme#car (getter-with-setter scheme#car set-car!))4766(set! scheme#cdr (getter-with-setter scheme#cdr set-cdr!))4767(set! scheme#caar (getter-with-setter scheme#caar (lambda (x y) (set-car! (car x) y))))4768(set! scheme#cadr (getter-with-setter scheme#cadr (lambda (x y) (set-car! (cdr x) y))))4769(set! scheme#cdar (getter-with-setter scheme#cdar (lambda (x y) (set-cdr! (car x) y))))4770(set! scheme#cddr (getter-with-setter scheme#cddr (lambda (x y) (set-cdr! (cdr x) y))))4771(set! scheme#caaar (getter-with-setter scheme#caaar (lambda (x y) (set-car! (caar x) y))))4772(set! scheme#caadr (getter-with-setter scheme#caadr (lambda (x y) (set-car! (cadr x) y))))4773(set! scheme#cadar (getter-with-setter scheme#cadar (lambda (x y) (set-car! (cdar x) y))))4774(set! scheme#caddr (getter-with-setter scheme#caddr (lambda (x y) (set-car! (cddr x) y))))4775(set! scheme#cdaar (getter-with-setter scheme#cdaar (lambda (x y) (set-cdr! (caar x) y))))4776(set! scheme#cdadr (getter-with-setter scheme#cdadr (lambda (x y) (set-cdr! (cadr x) y))))4777(set! scheme#cddar (getter-with-setter scheme#cddar (lambda (x y) (set-cdr! (cdar x) y))))4778(set! scheme#cdddr (getter-with-setter scheme#cdddr (lambda (x y) (set-cdr! (cddr x) y))))4779(set! scheme#string-ref (getter-with-setter scheme#string-ref string-set!))4780(set! scheme#vector-ref (getter-with-setter scheme#vector-ref vector-set!))47814782(set! scheme#list-ref4783 (getter-with-setter4784 scheme#list-ref4785 (lambda (x i y) (set-car! (list-tail x i) y))))47864787(set! chicken.bytevector#bytevector-u8-ref4788 (getter-with-setter chicken.bytevector#bytevector-u8-ref4789 chicken.bytevector#bytevector-u8-set!4790 "(chicken.bytevector#bytevector-u8-ref v i)"))479147924793;;; Parameters:47944795(define ##sys#default-parameter-vector (##sys#make-vector default-parameter-vector-size))4796(define ##sys#current-parameter-vector '#())47974798(set! scheme#make-parameter4799 (let ((count 0))4800 (lambda (init #!optional (guard (lambda (x) x)))4801 (let* ((val (guard init))4802 (i count)4803 (assign (lambda (val n convert? set?)4804 (when (fx>= i n)4805 (set! ##sys#current-parameter-vector4806 (##sys#vector-resize4807 ##sys#current-parameter-vector4808 (fx+ i 1)4809 ##sys#snafu) ) )4810 (let ((val (if convert? (guard val) val)))4811 (when set?4812 (##sys#setslot ##sys#current-parameter-vector i val))4813 val))))48144815 (set! count (fx+ count 1))4816 (when (fx>= i (##sys#size ##sys#default-parameter-vector))4817 (set! ##sys#default-parameter-vector4818 (##sys#vector-resize4819 ##sys#default-parameter-vector4820 (fx+ i 1)4821 (##core#undefined)) ) )4822 (##sys#setslot ##sys#default-parameter-vector i val)4823 (getter-with-setter4824 (lambda args4825 (let ((n (##sys#size ##sys#current-parameter-vector)))4826 (cond ((pair? args)4827 (let-optionals (cdr args) ((convert? #t)4828 (set? #t))4829 (assign (car args) n convert? set?)))4830 ((fx>= i n)4831 (##sys#slot ##sys#default-parameter-vector i) )4832 (else4833 (let ((val (##sys#slot ##sys#current-parameter-vector i)))4834 (if (eq? val ##sys#snafu)4835 (##sys#slot ##sys#default-parameter-vector i)4836 val) ) ) ) ) )4837 (lambda (val)4838 (let ((n (##sys#size ##sys#current-parameter-vector)))4839 (assign val n #f #t))))))))484048414842;;; Input:48434844(set! scheme#char-ready?4845 (lambda (#!optional (port ##sys#standard-input))4846 (##sys#check-input-port port #t 'char-ready?)4847 (let ((class (##sys#slot port 2)))4848 ;; check size - for backwards compatibility we still allow missing method4849 ((if (fx> (##sys#size class) 10)4850 (##sys#slot class 10) ; char-ready?4851 (##sys#slot class 6)) ; u8-ready?4852 port))))48534854(set! scheme#u8-ready?4855 (lambda (#!optional (port ##sys#standard-input))4856 (##sys#check-input-port port #t 'u8-ready?)4857 ((##sys#slot (##sys#slot port 2) 6) port) )) ; u8-ready?48584859(set! scheme#read-char4860 (lambda (#!optional (port ##sys#standard-input))4861 (##sys#check-input-port port #t 'read-char)4862 (##sys#read-char-0 port) ))48634864(define (##sys#read-char-0 p)4865 (let ([c (if (##sys#slot p 6)4866 (begin4867 (##sys#setislot p 6 #f)4868 #!eof)4869 ((##sys#slot (##sys#slot p 2) 0) p) ) ] ) ; read-char4870 (cond [(eq? c #\newline)4871 (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))4872 (##sys#setislot p 5 0) ]4873 [(not (##core#inline "C_eofp" c))4874 (##sys#setislot p 5 (fx+ (##sys#slot p 5) 1)) ] )4875 c) )48764877(define (##sys#read-char/port port)4878 (##sys#check-input-port port #t 'read-char)4879 (##sys#read-char-0 port) )48804881(define (##sys#peek-char-0 p)4882 (if (##sys#slot p 6)4883 #!eof4884 (let ((c ((##sys#slot (##sys#slot p 2) 1) p))) ; peek-char4885 (when (##core#inline "C_eofp" c)4886 (##sys#setislot p 6 #t) )4887 c) ) )48884889(set! scheme#peek-char4890 (lambda (#!optional (port ##sys#standard-input))4891 (##sys#check-input-port port #t 'peek-char)4892 (##sys#peek-char-0 port) ))48934894(set! scheme#read4895 (lambda (#!optional (port ##sys#standard-input))4896 (##sys#check-input-port port #t 'read)4897 (##sys#read port ##sys#default-read-info-hook) ))48984899(define ##sys#default-read-info-hook #f)4900(define ##sys#read-error-with-line-number #f)4901(define (##sys#read-prompt-hook) #f) ; just here so that srfi-18 works without eval4902(define (##sys#infix-list-hook lst) lst)49034904(set! ##sys#default-file-encoding (make-parameter 'utf-8))49054906(define (##sys#sharp-number-hook port n)4907 (##sys#read-error port "invalid `#...' read syntax" n) )49084909(set! chicken.base#case-sensitive (make-parameter #t))4910(set! chicken.base#parentheses-synonyms (make-parameter #t))4911(set! chicken.base#symbol-escape (make-parameter #t))49124913(set! chicken.base#keyword-style4914 (make-parameter #:suffix (lambda (x) (when x (##sys#check-keyword x 'keyword-style)) x)))49154916(define ##sys#current-read-table (make-parameter (##sys#make-structure 'read-table '() '() '())))49174918(define ##sys#read-warning4919 (let ([string-append string-append])4920 (lambda (port msg . args)4921 (apply4922 ##sys#warn4923 (let ((ln (##sys#port-line port)))4924 (if (and ##sys#read-error-with-line-number ln)4925 (string-append "(line " (##sys#number->string ln) ") " msg)4926 msg) )4927 args) ) ) )49284929(define ##sys#read-error4930 (let ([string-append string-append] )4931 (lambda (port msg . args)4932 (apply4933 ##sys#signal-hook4934 #:syntax-error4935 (let ((ln (##sys#port-line port)))4936 (if (and ##sys#read-error-with-line-number ln)4937 (string-append "(line " (##sys#number->string ln) ") " msg)4938 msg) )4939 args) ) ) )49404941(define ##sys#read4942 (let ((string-append string-append)4943 (keyword-style keyword-style)4944 (parentheses-synonyms parentheses-synonyms)4945 (case-sensitive case-sensitive)4946 (symbol-escape symbol-escape)4947 (integer->char integer->char)4948 (current-read-table ##sys#current-read-table))4949 (lambda (port infohandler)4950 (let ((csp (and (case-sensitive) (##sys#slot port 13)))4951 (ksp (keyword-style))4952 (psp (parentheses-synonyms))4953 (sep (symbol-escape))4954 (crt (current-read-table))4955 (warn #f)4956 (shared '())4957 ; set below - needs more state to make a decision4958 (terminating-characters '(#\, #\; #\( #\) #\' #\" #\[ #\] #\{ #\}))4959 (reserved-characters #f) )49604961 (define (container c)4962 (##sys#read-error port "unexpected list terminator" c) )49634964 (define (info class data val)4965 (if infohandler4966 (infohandler class data val)4967 data) )49684969 (define (skip-to-eol)4970 (let skip ((c (##sys#read-char-0 port)))4971 (if (and (not (##core#inline "C_eofp" c)) (not (eq? #\newline c)))4972 (skip (##sys#read-char-0 port)) ) ) )49734974 (define (reserved-character c)4975 (##sys#read-char-0 port)4976 (##sys#read-error port "reserved character" c) )49774978 (define (read-unreserved-char-0 port)4979 (let ((c (##sys#read-char-0 port)))4980 (if (memq c reserved-characters)4981 (reserved-character c)4982 c) ) )49834984 (define (register-shared! n thunk)4985 (set! shared (cons (cons n thunk) shared)))49864987 (define (unthunk o fail)4988 (let ((v (o)))4989 (cond ((not (procedure? v)) v)4990 ((eq? v o)4991 (fail "self-referential datum"))4992 (else4993 (unthunk v fail)))))49944995 ;; Fills holes in `o` destructively.4996 (define (unthunkify! o fail)4997 (let loop! ((o o))4998 (cond ((pair? o)4999 (if (not (procedure? (car o)))5000 (loop! (car o))5001 (set-car! o (unthunk (car o) fail)))5002 (if (not (procedure? (cdr o)))5003 (loop! (cdr o))5004 (set-cdr! o (unthunk (cdr o) fail))))5005 ((vector? o)5006 (let ((len (##sys#size o)))5007 (do ((i 0 (fx+ i 1)))5008 ((eq? i len))5009 (let ((v (##sys#slot o i)))5010 (if (not (procedure? v))5011 (loop! v)5012 (##sys#setslot o i (unthunk v fail))))))))))50135014 (define (readrec)50155016 (define (r-spaces)5017 (let loop ([c (##sys#peek-char-0 port)])5018 (cond ((##core#inline "C_eofp" c))5019 ((eq? #\; c)5020 (skip-to-eol)5021 (loop (##sys#peek-char-0 port)) )5022 ((char-whitespace? c)5023 (##sys#read-char-0 port)5024 (loop (##sys#peek-char-0 port)) ) ) ) )50255026 (define (r-usequence u n base)5027 (let loop ((seq '()) (n n))5028 (if (eq? n 0)5029 (let* ((str (##sys#reverse-list->string seq))5030 (n (string->number str base)))5031 (or n5032 (##sys#read-error5033 port5034 (string-append5035 "invalid escape-sequence '\\" u str "\'")) ) )5036 (let ((x (##sys#read-char-0 port)))5037 (if (or (eof-object? x) (char=? #\" x))5038 (##sys#read-error port "unterminated string constant")5039 (loop (cons x seq) (fx- n 1)) ) ) ) ) )50405041 (define (r-xsequence delim)5042 (define (parse seq)5043 (let* ((str (##sys#reverse-list->string seq))5044 (n (string->number str 16)))5045 (or n5046 (##sys#read-error port5047 (string-append "invalid escape-sequence '\\x"5048 str ";\'")))))5049 (define (complain)5050 (set! warn "unterminated hexadecimal escape sequence"))5051 (define (abort)5052 (##sys#read-error port "unterminated hexadecimal escape sequence") )5053 (let loop ((seq '()))5054 (let ((x (##sys#peek-char-0 port)))5055 (cond ((eof-object? x) (abort))5056 ((eq? delim x)5057 (let ((n (parse seq)))5058 (if (fx> n #x1ffff)5059 (abort)5060 (begin (complain) n))))5061 ((eq? #\; x)5062 (##sys#read-char-0 port)5063 (parse seq))5064 ((or (and (char>=? x #\0) (char<=? x #\9))5065 (and (char>=? x #\a) (char<=? x #\f))5066 (and (char>=? x #\A) (char<=? x #\F)))5067 (loop (cons (##sys#read-char-0 port) seq)))5068 (else5069 (let ((n (parse seq)))5070 (if (fx> n #x1ffff)5071 (abort)5072 (begin (complain) n))))))))50735074 (define (r-string term)5075 (let loop ((c (##sys#read-char-0 port)) (lst '()))5076 (cond ((##core#inline "C_eofp" c)5077 (##sys#read-error port "unterminated string") )5078 ((eq? #\\ c)5079 (set! c (##sys#read-char-0 port))5080 (case c5081 ((#\t) (loop (##sys#read-char-0 port) (cons #\tab lst)))5082 ((#\r) (loop (##sys#read-char-0 port) (cons #\return lst)))5083 ((#\b) (loop (##sys#read-char-0 port) (cons #\backspace lst)))5084 ((#\n) (loop (##sys#read-char-0 port) (cons #\newline lst)))5085 ((#\a) (loop (##sys#read-char-0 port) (cons (integer->char 7) lst)))5086 ((#\v) (loop (##sys#read-char-0 port) (cons (integer->char 11) lst)))5087 ((#\f) (loop (##sys#read-char-0 port) (cons (integer->char 12) lst)))5088 ((#\x)5089 (let ((ch (integer->char (r-xsequence term))))5090 (loop (##sys#read-char-0 port) (cons ch lst)) ) )5091 ((#\u)5092 (let ((n (r-usequence "u" 4 16)))5093 (loop (##sys#read-char-0 port)5094 (cons (integer->char n) lst)) ) )5095 ((#\U)5096 (let ((n (r-usequence "U" 8 16)))5097 (loop (##sys#read-char-0 port)5098 (cons (integer->char n) lst)) ))5099 ((#\\ #\' #\" #\|)5100 (loop (##sys#read-char-0 port) (cons c lst)))5101 ((#\newline #\return #\space #\tab)5102 ;; Read "escaped" <intraline ws>* <nl> <intraline ws>*5103 (let eat-ws ((c c) (nl? #f))5104 (case c5105 ((#\space #\tab)5106 (eat-ws (##sys#read-char-0 port) nl?))5107 ((#\return)5108 (if nl?5109 (loop c lst)5110 (let ((nc (##sys#read-char-0 port)))5111 (if (eq? nc #\newline) ; collapse \r\n5112 (eat-ws (##sys#read-char-0 port) #t)5113 (eat-ws nc #t)))))5114 ((#\newline)5115 (if nl?5116 (loop c lst)5117 (eat-ws (##sys#read-char-0 port) #t)))5118 (else5119 (unless nl?5120 (##sys#read-warning5121 port5122 "escaped whitespace, but no newline - collapsing anyway"))5123 (loop c lst)))))5124 (else5125 (cond ((##core#inline "C_eofp" c)5126 (##sys#read-error port "unterminated string"))5127 ((and (char-numeric? c)5128 (char>=? c #\0)5129 (char<=? c #\7))5130 (let ((ch (integer->char5131 (fx+ (fx* (fx- (char->integer c) 48) 64)5132 (r-usequence "" 2 8)))))5133 (loop (##sys#read-char-0 port) (cons ch lst)) ))5134 (else5135 (##sys#read-warning5136 port5137 "undefined escape sequence in string - probably forgot backslash"5138 c)5139 (loop (##sys#read-char-0 port) (cons c lst))) ) )))5140 ((eq? term c) (##sys#reverse-list->string lst))5141 (else (loop (##sys#read-char-0 port) (cons c lst))) ) ))51425143 (define (r-list start end)5144 (if (eq? (##sys#read-char-0 port) start)5145 (let ((first #f)5146 (ln0 #f)5147 (outer-container container) )5148 (define (starting-line msg)5149 (if (and ln0 ##sys#read-error-with-line-number)5150 (string-append5151 msg ", starting in line "5152 (##sys#number->string ln0))5153 msg))5154 (##sys#call-with-current-continuation5155 (lambda (return)5156 (set! container5157 (lambda (c)5158 (if (eq? c end)5159 (return #f)5160 (##sys#read-error5161 port5162 (starting-line "list-terminator mismatch")5163 c end) ) ) )5164 (let loop ([last '()])5165 (r-spaces)5166 (unless first (set! ln0 (##sys#port-line port)))5167 (let ([c (##sys#peek-char-0 port)])5168 (cond ((##core#inline "C_eofp" c)5169 (##sys#read-error5170 port5171 (starting-line "unterminated list") ) )5172 ((eq? c end)5173 (##sys#read-char-0 port) )5174 ((eq? c #\.)5175 (##sys#read-char-0 port)5176 (let ((c2 (##sys#peek-char-0 port)))5177 (cond ((or (char-whitespace? c2)5178 (eq? c2 #\()5179 (eq? c2 #\))5180 (eq? c2 #\")5181 (eq? c2 #\;) )5182 (unless (pair? last)5183 (##sys#read-error port "invalid use of `.'") )5184 (r-spaces)5185 (##sys#setslot last 1 (readrec))5186 (r-spaces)5187 (unless (eq? (##sys#read-char-0 port) end)5188 (##sys#read-error5189 port5190 (starting-line "missing list terminator")5191 end)))5192 (else5193 (r-xtoken5194 (lambda (tok kw)5195 (let* ((tok (##sys#string-append "." tok))5196 (val5197 (cond ((and (string=? tok ".:")5198 (eq? ksp #:suffix))5199 ;; Edge case: r-xtoken sees5200 ;; a bare ":" and sets kw to #f5201 (build-keyword "."))5202 (kw (build-keyword tok))5203 ((and (char-numeric? c2)5204 (##sys#string->number tok)))5205 (else (build-symbol tok))))5206 (node (cons val '())))5207 (if first5208 (##sys#setslot last 1 node)5209 (set! first node) )5210 (loop node))))))))5211 (else5212 (let ([node (cons (readrec) '())])5213 (if first5214 (##sys#setslot last 1 node)5215 (set! first node) )5216 (loop node) ) ) ) ) ) ) )5217 (set! container outer-container)5218 (if first5219 (info 'list-info (##sys#infix-list-hook first) ln0)5220 '() ) )5221 (##sys#read-error port "missing token" start) ) )52225223 (define (r-vector)5224 (let ((lst (r-list #\( #\))))5225 (if (list? lst)5226 (##sys#list->vector lst)5227 (##sys#read-error port "invalid vector syntax" lst) ) ) )52285229 (define (r-number radix exactness)5230 (r-xtoken5231 (lambda (tok kw)5232 (cond (kw5233 (let ((s (build-keyword tok)))5234 (info 'symbol-info s (##sys#port-line port)) ))5235 ((string=? tok ".")5236 (##sys#read-error port "invalid use of `.'"))5237 ((and (fx> (string-length tok) 0) (char=? (string-ref tok 0) #\#))5238 (##sys#read-error port "unexpected prefix in number syntax" tok))5239 ((##sys#string->number tok (or radix 10) exactness))5240 (radix (##sys#read-error port "illegal number syntax" tok))5241 (else (build-symbol tok)) ) ) ))52425243 (define (r-number-with-exactness radix)5244 (cond [(eq? #\# (##sys#peek-char-0 port))5245 (##sys#read-char-0 port)5246 (let ([c2 (##sys#read-char-0 port)])5247 (cond [(eof-object? c2)5248 (##sys#read-error port "unexpected end of numeric literal")]5249 [(char=? c2 #\i) (r-number radix 'i)]5250 [(char=? c2 #\e) (r-number radix 'e)]5251 [else5252 (##sys#read-error5253 port5254 "illegal number syntax - invalid exactness prefix" c2)] ) ) ]5255 [else (r-number radix #f)] ) )52565257 (define (r-number-with-radix exactness)5258 (cond [(eq? #\# (##sys#peek-char-0 port))5259 (##sys#read-char-0 port)5260 (let ([c2 (##sys#read-char-0 port)])5261 (cond [(eof-object? c2) (##sys#read-error port "unexpected end of numeric literal")]5262 [(char=? c2 #\x) (r-number 16 exactness)]5263 [(char=? c2 #\d) (r-number 10 exactness)]5264 [(char=? c2 #\o) (r-number 8 exactness)]5265 [(char=? c2 #\b) (r-number 2 exactness)]5266 [else (##sys#read-error port "illegal number syntax - invalid radix" c2)] ) ) ]5267 [else (r-number 10 exactness)] ) )52685269 (define (r-token)5270 (let loop ((c (##sys#peek-char-0 port)) (lst '()))5271 (cond ((or (eof-object? c)5272 (char-whitespace? c)5273 (memq c terminating-characters) )5274 (##sys#reverse-list->string lst) )5275 ((char=? c #\x00)5276 (##sys#read-error port "attempt to read expression from something that looks like binary data"))5277 (else5278 (read-unreserved-char-0 port)5279 (loop (##sys#peek-char-0 port)5280 (cons (if csp5281 c5282 (##core#inline "C_utf_char_foldcase" c) )5283 lst) ) ) ) ) )52845285 (define (r-digits)5286 (let loop ((c (##sys#peek-char-0 port)) (lst '()))5287 (cond ((or (eof-object? c) (not (char-numeric? c)))5288 (##sys#reverse-list->string lst) )5289 (else5290 (##sys#read-char-0 port)5291 (loop (##sys#peek-char-0 port) (cons c lst)) ) ) ) )52925293 (define (r-symbol)5294 (r-xtoken5295 (lambda (str kw)5296 (let ((s (if kw (build-keyword str) (build-symbol str))))5297 (info 'symbol-info s (##sys#port-line port)) ) )))52985299 (define (r-xtoken k)5300 (define pkw ; check for prefix keyword immediately5301 (and (eq? ksp #:prefix)5302 (eq? #\: (##sys#peek-char-0 port))5303 (begin (##sys#read-char-0 port) #t)))5304 (let loop ((lst '()) (skw #f) (qtd #f))5305 (let ((c (##sys#peek-char-0 port)))5306 (cond ((or (eof-object? c)5307 (char-whitespace? c)5308 (memq c terminating-characters))5309 ;; The various cases here cover:5310 ;; - Nonempty keywords formed with colon in the ksp position5311 ;; - Empty keywords formed explicitly with vbar quotes5312 ;; - Bare colon, which should always be a symbol5313 (cond ((and skw (eq? ksp #:suffix) (or qtd (not (null? (cdr lst)))))5314 (k (##sys#reverse-list->string (cdr lst)) #t))5315 ((and pkw (or qtd (not (null? lst))))5316 (k (##sys#reverse-list->string lst) #t))5317 ((and pkw (not qtd) (null? lst))5318 (k ":" #f))5319 (else5320 (k (##sys#reverse-list->string lst) #f))))5321 ((memq c reserved-characters)5322 (reserved-character c))5323 (else5324 (let ((c (##sys#read-char-0 port)))5325 (case c5326 ((#\|)5327 (let ((part (r-string #\|)))5328 (loop (append (##sys#fast-reverse (##sys#string->list part)) lst)5329 #f #t)))5330 ((#\newline)5331 (##sys#read-warning5332 port "escaped symbol syntax spans multiple lines"5333 (##sys#reverse-list->string lst))5334 (loop (cons #\newline lst) #f qtd))5335 ((#\:)5336 (loop (cons #\: lst) #t qtd))5337 ((#\\)5338 (let ((c (##sys#read-char-0 port)))5339 (if (eof-object? c)5340 (##sys#read-error5341 port5342 "unexpected end of file while reading escaped character")5343 (loop (cons c lst) #f qtd))))5344 (else5345 (loop5346 (cons (if csp5347 c5348 (##core#inline "C_utf_char_foldcase" c))5349 lst)5350 #f qtd)))))))))53515352 (define (r-char)5353 ;; Code contributed by Alex Shinn5354 (let* ([c (##sys#peek-char-0 port)]5355 [tk (r-token)]5356 [len (string-length tk)])5357 (cond [(fx> len 1)5358 (cond [(and (or (char=? #\x c) (char=? #\u c) (char=? #\U c))5359 (##sys#string->number (##sys#substring tk 1 len) 16) )5360 => (lambda (n) (integer->char n)) ]5361 [(and-let* ((c0 (char->integer (string-ref tk 0)))5362 ((fx<= #xC0 c0)) ((fx<= c0 #xF7))5363 (n0 (fxand (fxshr c0 4) 3))5364 (n (fx+ 2 (fxand (fxior n0 (fxshr n0 1)) (fx- n0 1))))5365 ((fx= len n))5366 (res (fx+ (fxshl (fxand c0 (fx- (fxshl 1 (fx- 8 n)) 1))5367 6)5368 (fxand (char->integer5369 (string-ref tk 1))5370 #b111111))))5371 (cond ((fx>= n 3)5372 (set! res (fx+ (fxshl res 6)5373 (fxand5374 (char->integer5375 (string-ref tk 2))5376 #b111111)))5377 (if (fx= n 4)5378 (set! res (fx+ (fxshl res 6)5379 (fxand (char->integer5380 (string-ref tk 3))5381 #b111111))))))5382 (integer->char res))]5383 [(char-name (##sys#string->symbol tk))]5384 [else (##sys#read-error port "unknown named character" tk)] ) ]5385 [(memq c terminating-characters) (##sys#read-char-0 port)]5386 [else c] ) ) )53875388 (define (r-comment)5389 (let loop ((i 0))5390 (let ((c (##sys#read-char-0 port)))5391 (case c5392 ((#\|) (if (eq? #\# (##sys#read-char-0 port))5393 (if (not (eq? i 0))5394 (loop (fx- i 1)) )5395 (loop i) ) )5396 ((#\#) (loop (if (eq? #\| (##sys#read-char-0 port))5397 (fx+ i 1)5398 i) ) )5399 (else (if (eof-object? c)5400 (##sys#read-error port "unterminated block-comment")5401 (loop i) ) ) ) ) ) )54025403 (define (r-ext-symbol)5404 (let ((tok (r-token)))5405 (build-symbol (string-append "##" tok))))54065407 (define (r-quote q)5408 (let ((ln (##sys#port-line port)))5409 (info 'list-info (list q (readrec)) ln)))54105411 (define (build-symbol tok)5412 (##sys#string->symbol tok) )54135414 (define (build-keyword tok)5415 (##sys#intern-keyword (##sys#string->symbol-name tok)))54165417 ;; now have the state to make a decision.5418 (set! reserved-characters5419 (append (if (not psp) '(#\[ #\] #\{ #\}) '())5420 (if (not sep) '(#\|) '())))5421 (r-spaces)5422 (let* ((c (##sys#peek-char-0 port))5423 (srst (##sys#slot crt 1))5424 (h (and (not (eof-object? c))5425 (assq c srst))))5426 (if (and h (##sys#slot h 1))5427 ;; then handled by read-table entry5428 (##sys#call-with-values5429 (lambda () ((##sys#slot h 1) c port))5430 (lambda xs (if (null? xs) (readrec) (car xs))))5431 ;; otherwise chicken extended r5rs syntax5432 (case c5433 ((#\')5434 (##sys#read-char-0 port)5435 (r-quote 'quote))5436 ((#\`)5437 (##sys#read-char-0 port)5438 (r-quote 'quasiquote))5439 ((#\,)5440 (##sys#read-char-0 port)5441 (cond ((eq? (##sys#peek-char-0 port) #\@)5442 (##sys#read-char-0 port)5443 (r-quote 'unquote-splicing))5444 (else (r-quote 'unquote))))5445 ((#\#)5446 (##sys#read-char-0 port)5447 (let ((dchar (##sys#peek-char-0 port)))5448 (cond5449 ((eof-object? dchar)5450 (##sys#read-error5451 port "unexpected end of input after reading #-sign"))5452 ((char-numeric? dchar)5453 (let* ((n (string->number (r-digits)))5454 (dchar2 (##sys#peek-char-0 port))5455 (spdrst (##sys#slot crt 3)))5456 (cond ((eof-object? dchar2)5457 (##sys#read-error5458 port "unexpected end of input after reading"5459 c n))5460 ;; #<num>=...5461 ((eq? #\= dchar2)5462 (##sys#read-char-0 port)5463 (letrec ((datum (begin5464 (register-shared! n (lambda () datum))5465 (readrec))))5466 datum))5467 ;; #<num>#5468 ((eq? #\# dchar2)5469 (##sys#read-char-0 port)5470 (cond ((assq n shared) => cdr)5471 (else (##sys#read-error port "undefined datum" n))))5472 ;; #<num> handled by parameterized # read-table entry?5473 ((and (char? dchar2)5474 (let ((a (assq dchar2 spdrst)))5475 (and a (##sys#slot a 1) a))) =>5476 (lambda (h)5477 (##sys#call-with-values5478 (lambda () ((##sys#slot h 1) dchar2 port n))5479 (lambda xs (if (null? xs) (readrec) (car xs))))))5480 ;; #<num>5481 ((or (eq? dchar2 #\)) (char-whitespace? dchar2))5482 (##sys#sharp-number-hook port n))5483 (else (##sys#read-char-0 port) ; Consume it first5484 (##sys#read-error5485 port5486 "invalid parameterized read syntax"5487 c n dchar2) ) ) ))5488 (else (let* ((sdrst (##sys#slot crt 2))5489 (h (assq dchar sdrst)))5490 (if (and h (##sys#slot h 1))5491 ;; then handled by # read-table entry5492 (##sys#call-with-values5493 (lambda () ((##sys#slot h 1) dchar port))5494 (lambda xs (if (null? xs) (readrec) (car xs))))5495 ;; otherwise chicken extended R7RS syntax5496 (case (char-downcase dchar)5497 ((#\x) (##sys#read-char-0 port) (r-number-with-exactness 16))5498 ((#\d) (##sys#read-char-0 port) (r-number-with-exactness 10))5499 ((#\o) (##sys#read-char-0 port) (r-number-with-exactness 8))5500 ((#\b) (##sys#read-char-0 port) (r-number-with-exactness 2))5501 ((#\i) (##sys#read-char-0 port) (r-number-with-radix 'i))5502 ((#\e) (##sys#read-char-0 port) (r-number-with-radix 'e))5503 ((#\() (r-vector))5504 ((#\\) (##sys#read-char-0 port) (r-char))5505 ((#\|)5506 (##sys#read-char-0 port)5507 (r-comment) (readrec) )5508 ((#\#)5509 (##sys#read-char-0 port)5510 (r-ext-symbol) )5511 ((#\;)5512 (##sys#read-char-0 port)5513 (readrec) (readrec) )5514 ((#\`)5515 (##sys#read-char-0 port)5516 (r-quote 'quasisyntax))5517 ((#\$)5518 (##sys#read-char-0 port)5519 ;; HACK: reuse r-quote to add line number info5520 (r-quote 'location))5521 ((#\:)5522 (##sys#read-char-0 port)5523 (let ((c (##sys#peek-char-0 port)))5524 (fluid-let ((ksp #f))5525 (r-xtoken5526 (lambda (str kw)5527 (if (and (eq? 0 (string-length str))5528 (not (char=? c #\|)))5529 (##sys#read-error port "empty keyword")5530 (build-keyword str)))))))5531 ((#\+)5532 (##sys#read-char-0 port)5533 (let* ((ln (##sys#port-line port))5534 (tst (readrec)))5535 (info 'list-info5536 (list 'cond-expand (list tst (readrec)) '(else))5537 ln)))5538 ((#\!)5539 (##sys#read-char-0 port)5540 (let ((c (##sys#peek-char-0 port)))5541 (cond ((and (char? c)5542 (or (char-whitespace? c) (char=? #\/ c)))5543 (skip-to-eol)5544 (readrec) )5545 (else5546 (let ([tok (r-token)])5547 (cond ((string=? "eof" tok) #!eof)5548 ((string=? "bwp" tok) #!bwp)5549 ((string=? "fold-case" tok)5550 (set! csp #f)5551 (##sys#setislot port 13 csp)5552 (readrec))5553 ((string=? "no-fold-case" tok)5554 (set! csp #t)5555 (##sys#setislot port 13 csp)5556 (readrec))5557 ((member tok '("optional" "rest" "key"))5558 (build-symbol (##sys#string-append "#!" tok)) )5559 (else5560 (let ((a (assq (string->symbol tok) ##sys#read-marks)))5561 (if a5562 ((##sys#slot a 1) port)5563 (##sys#read-error5564 port5565 "invalid `#!' token" tok) ) ) ) ) ) ) ) ) )5566 (else5567 (##sys#call-with-values (lambda () (##sys#user-read-hook dchar port))5568 (lambda xs (if (null? xs) (readrec) (car xs)))) ) ) ) )) ) ) )5569 ((#\() (r-list #\( #\)))5570 ((#\)) (##sys#read-char-0 port) (container c))5571 ((#\") (##sys#read-char-0 port) (r-string #\"))5572 ((#\.) (r-number #f #f))5573 ((#\- #\+) (r-number #f #f))5574 (else5575 (cond [(eof-object? c) c]5576 [(char-numeric? c) (r-number #f #f)]5577 ((memq c reserved-characters)5578 (reserved-character c))5579 (else5580 (case c5581 ((#\[) (r-list #\[ #\]))5582 ((#\{) (r-list #\{ #\}))5583 ((#\] #\}) (##sys#read-char-0 port) (container c))5584 (else (r-symbol) ) ) ) ) ) ) ) ) )55855586 (let ((x (readrec)))5587 (when warn (##sys#read-warning port warn))5588 (when (pair? shared)5589 (unthunkify! x (lambda a (apply ##sys#read-error p a))))5590 x)))))55915592;;; Hooks for user-defined read-syntax:5593;5594; - Redefine this to handle new read-syntaxes. If 'char' doesn't match5595; your character then call the previous handler.5596; - Don't forget to read 'char', it's only peeked at this point.55975598(define (##sys#user-read-hook char port)5599 (define (fail item) (##sys#read-error port "invalid sharp-sign read syntax" item))5600 (case char5601 ((#\f #\t #\u)5602 (let ((sym (##sys#read port ##sys#default-read-info-hook)))5603 (if (not (symbol? sym))5604 (fail char)5605 (case sym5606 ((t true) #t)5607 ((f false) #f)5608 ((u8)5609 ;; u8vectors, srfi-4 handles this already via read-hook but we reimplement it5610 ;; here in case srfi-4 is not loaded5611 (let ((d (##sys#read-numvector-data port)))5612 (if (or (null? d) (pair? d))5613 (##sys#list->bytevector (##sys#canonicalize-number-list! d))5614 ;; reuse already created bytevector5615 (##core#inline "C_chop_bv" (##sys#slot d 0)))))5616 (else (fail sym))))))5617 (else (fail char))))56185619;; returns a (potentially large) list of numbers (bytes) in5620;; order. ignores whitespace.5621(define (##sys#read-hex-literal port) ;; { 00ff11 ff } => #u8(0 255 17 255)5622 (define (hex c)5623 (cond ((and (char>=? c #\a) (char<=? c #\f)) (fx- (char->integer c) 87)) ;; (- (char->integer #\a) 10)5624 ((and (char>=? c #\A) (char<=? c #\F)) (fx- (char->integer c) 55)) ;; (- (char->integer #\A) 10)5625 ((and (char>=? c #\0) (char<=? c #\9)) (fx- (char->integer c) 48)) ;; (char->integer #\0)5626 (else (##sys#read-error port "invalid hex-code in bytecode literal" c))))56275628 (unless (eq? #\{ (##sys#read-char-0 port)) (##sys#read-error port "internal error"))5629 (let ((first #f))5630 (let loop ((h #f) (last #f))5631 (let ((c (##sys#read-char-0 port)))5632 (cond ((eof-object? c)5633 (##sys#read-error port "unexpected end of hex bytevector literal"))5634 ((char=? #\} c)5635 (if h5636 (##sys#read-error port "odd-numbered hex bytevector literal")5637 (or first '())))5638 ((char-whitespace? c)5639 (if h5640 (##sys#read-error port "odd-numbered hex bytevector literal")5641 (loop #f last)))5642 (h5643 (let ((node (cons (fxior (fxshl h 4) (hex c)) '())))5644 (if first5645 (##sys#setslot last 1 node)5646 (set! first node))5647 (loop #f node)))5648 (else (loop (hex c) last)))))))56495650(define (##sys#read-numvector-data port)5651 (let ((c (##sys#peek-char-0 port)))5652 (case c5653 ((#\( #\") (##sys#read port ##sys#default-read-info-hook))5654 ((#\{) (##sys#read-hex-literal port))5655 (else (##sys#read-error port "invalid numeric vector syntax" c)))))56565657(define (##sys#canonicalize-number-list! lst1)5658 (let loop ((lst lst1) (prev #f))5659 (if (and (##core#inline "C_blockp" lst)5660 (##core#inline "C_pairp" lst))5661 (let retry ((x (##sys#slot lst 0)))5662 (cond ((char? x) (retry (string x)))5663 ((null? x)5664 (if prev5665 (##sys#setslot prev 1 (##sys#slot lst 1))5666 (set! lst1 (##sys#slot lst 1)))5667 (loop (##sys#slot lst 1) prev))5668 ((list? x)5669 (let ((lst (##sys#append x (##sys#slot lst 1))))5670 (if prev5671 (##sys#setslot prev 1 lst)5672 (set! lst1 lst))5673 (loop lst prev)))5674 ((string? x) (retry (chicken.bytevector#string->utf8 x)))5675 ((and (##core#inline "C_blockp" x)5676 (##sys#bytevector? x))5677 (retry (##sys#bytevector->list x)))5678 ((##sys#srfi-4-vector? x) (retry (##sys#slot x 1)))5679 (else (loop (##sys#slot lst 1) lst))))5680 lst1)))56815682;;; Table for specially-handled read-syntax:5683;5684; - entries should be #f or a 256-element vector containing procedures5685; - each procedure is called with two arguments, a char (peeked) and a5686; port, and should return an expression56875688(define ##sys#read-marks '()) ; TODO move to read-syntax module568956905691;;; Output:56925693(define (##sys#write-char-0 c p)5694 ((##sys#slot (##sys#slot p 2) 2) p c)5695 (##core#undefined))56965697(define (##sys#write-char/port c port)5698 (##sys#check-output-port port #t 'write-char)5699 (##sys#check-char c 'write-char)5700 (##sys#write-char-0 c port) )57015702(set! scheme#write-char5703 (lambda (c #!optional (port ##sys#standard-output))5704 (##sys#check-char c 'write-char)5705 (##sys#check-output-port port #t 'write-char)5706 (##sys#write-char-0 c port) ))57075708(set! scheme#newline5709 (lambda (#!optional (port ##sys#standard-output))5710 (##sys#write-char/port #\newline port) ))57115712(set! scheme#write5713 (lambda (x #!optional (port ##sys#standard-output))5714 (##sys#check-output-port port #t 'write)5715 (##sys#print x #t port) ))57165717(set! scheme#display5718 (lambda (x #!optional (port ##sys#standard-output))5719 (##sys#check-output-port port #t 'display)5720 (##sys#print x #f port) ))57215722(define-inline (*print-each lst)5723 (for-each (cut ##sys#print <> #f ##sys#standard-output) lst) )57245725(set! chicken.base#print5726 (lambda args5727 (##sys#check-output-port ##sys#standard-output #t 'print)5728 (*print-each args)5729 (##sys#write-char-0 #\newline ##sys#standard-output)))57305731(set! chicken.base#print*5732 (lambda args5733 (##sys#check-output-port ##sys#standard-output #t 'print)5734 (*print-each args)5735 (##sys#flush-output ##sys#standard-output)))57365737(define ##sys#current-print-length (make-parameter 0))5738(define ##sys#print-length-limit (make-parameter #f))5739(define ##sys#print-exit (make-parameter #f))57405741(define ##sys#print5742 (let ((case-sensitive case-sensitive)5743 (symbol-escape symbol-escape)5744 (keyword-style keyword-style))5745 (lambda (x readable port)5746 (##sys#check-output-port port #t #f)5747 (let ((csp (case-sensitive))5748 (ksp (keyword-style))5749 (sep (symbol-escape))5750 (length-limit (##sys#print-length-limit))5751 (special-characters '(#\( #\) #\, #\[ #\] #\{ #\} #\' #\" #\; #\ #\` #\| #\\)) )57525753 (define (outstr port str)5754 (if length-limit5755 (let* ((len (string-length str))5756 (cpp0 (##sys#current-print-length))5757 (cpl (fx+ cpp0 len)) )5758 (if (fx> cpl length-limit)5759 (let ((n (fx- length-limit cpp0)))5760 (when (fx> n 0) (outstr0 port (##sys#substring str 0 n)))5761 (outstr0 port "...")5762 ((##sys#print-exit) (##core#undefined)))5763 (outstr0 port str) )5764 (##sys#current-print-length cpl) )5765 (outstr0 port str) ) )57665767 (define (outstr0 port str)5768 (let ((bv (##sys#slot str 0)))5769 ((##sys#slot (##sys#slot port 2) 3) port bv 0 (fx- (##sys#size bv) 1)))) ; write-bytevector57705771 (define (outchr port chr)5772 (when length-limit5773 (let ((cpp0 (##sys#current-print-length)))5774 (##sys#current-print-length (fx+ cpp0 1))5775 (when (fx> cpp0 length-limit)5776 (outstr0 port "...")5777 ((##sys#print-exit) (##core#undefined)))))5778 ((##sys#slot (##sys#slot port 2) 2) port chr)) ; write-char57795780 (define (specialchar? chr)5781 (let ([c (char->integer chr)])5782 (or (fx<= c 32)5783 (memq chr special-characters) ) ) )57845785 (define (outsym port sym)5786 (let ((str (##sys#symbol->string/shared sym)))5787 (if (or (not sep) (not readable) (sym-is-readable? str))5788 (outstr port str)5789 (outreadablesym port str))))57905791 (define (outreadablesym port str)5792 (let ((len (string-length str)))5793 (outchr port #\|)5794 (let loop ((i 0))5795 (if (fx>= i len)5796 (outchr port #\|)5797 (let ((c (string-ref str i)))5798 (cond ((or (char<? c #\space) (char>? c #\~))5799 (outstr port "\\x")5800 (let ((n (char->integer c)))5801 (outstr port (##sys#number->string n 16))5802 (outchr port #\;)5803 (loop (fx+ i 1))))5804 (else5805 (when (or (eq? c #\|) (eq? c #\\)) (outchr port #\\))5806 (outchr port c)5807 (loop (fx+ i 1)) ) ) ) ) )))58085809 (define (sym-is-readable? str)5810 (let ((len (string-length str)))5811 (cond ((eq? len 0) #f)5812 ((eq? len 1)5813 (let ((c (string-ref str 0)))5814 (cond ((or (eq? #\# c) (eq? #\. c)) #f)5815 ((specialchar? c) #f)5816 ((char-numeric? c) #f)5817 (else #t))))5818 (else5819 (let loop ((i (fx- len 1)))5820 (if (eq? i 0)5821 (let ((c (string-ref str 0)))5822 (cond ((char-numeric? c) #f)5823 ((or (eq? c #\+) (eq? c #\-))5824 (or (fx= len 1)5825 (not (char-numeric? (string-ref str 1)))))5826 ((eq? c #\.)5827 (and (fx> len 1)5828 (not (char-numeric? (string-ref str 1)))))5829 ((eq? c #\:) #f)5830 ((and (eq? c #\#)5831 ;; Not a qualified symbol?5832 (not (and (fx> len 2)5833 (eq? (string-ref str 1) #\#)5834 (not (eq? (string-ref str 2) #\#)))))5835 (member str '("#!rest" "#!key" "#!optional"5836 "#!fold-case" "#!no-fold-case")))5837 ((specialchar? c) #f)5838 (else #t) ) )5839 (let ((c (string-ref str i)))5840 (and (or csp (not (char-upper-case? c)))5841 (not (specialchar? c))5842 (or (not (eq? c #\:))5843 (fx< i (fx- len 1)))5844 (loop (fx- i 1)) ) ) ) ) ) ) ) )58455846 (let out ([x x])5847 (cond ((eq? x '()) (outstr port "()"))5848 ((eq? x #t) (outstr port "#t"))5849 ((eq? x #f) (outstr port "#f"))5850 ((##core#inline "C_eofp" x) (outstr port "#!eof"))5851 ((##core#inline "C_undefinedp" x) (outstr port "#<unspecified>"))5852 ((##core#inline "C_bwpp" x) (outstr port "#!bwp"))5853 ((##core#inline "C_charp" x)5854 (cond [readable5855 (outstr port "#\\")5856 (let ([code (char->integer x)])5857 (cond [(char-name x)5858 => (lambda (cn)5859 (outstr port (##sys#symbol->string/shared cn)) ) ]5860 [(or (fx< code 32) (fx> code #x1ffff))5861 (outchr port #\x)5862 (outstr port (##sys#number->string code 16)) ]5863 [else (outchr port x)] ) ) ]5864 [else (outchr port x)] ) )5865 ((##core#inline "C_fixnump" x) (outstr port (##sys#number->string x)))5866 ((##core#inline "C_unboundvaluep" x) (outstr port "#<unbound value>"))5867 ((not (##core#inline "C_blockp" x)) (outstr port "#<invalid immediate object>"))5868 ((##core#inline "C_forwardedp" x) (outstr port "#<invalid forwarded object>"))5869 ((##core#inline "C_i_keywordp" x)5870 ;; Force portable #: style for readable output5871 (case (and (not readable) ksp)5872 ((#:prefix)5873 (outchr port #\:)5874 (outsym port x))5875 ((#:suffix)5876 (outsym port x)5877 (outchr port #\:))5878 (else5879 (outstr port "#:")5880 (outsym port x))))5881 ((##core#inline "C_i_symbolp" x) (outsym port x))5882 ((number? x) (outstr port (##sys#number->string x)))5883 ((##core#inline "C_anypointerp" x) (outstr port (##sys#pointer->string x)))5884 ((##core#inline "C_stringp" x)5885 (cond (readable5886 (outchr port #\")5887 (do ((i 0 (fx+ i 1))5888 (c (string-length x) (fx- c 1)) )5889 ((eq? c 0)5890 (outchr port #\") )5891 (let ((chr (char->integer (string-ref x i))))5892 (case chr5893 ((34) (outstr port "\\\""))5894 ((92) (outstr port "\\\\"))5895 (else5896 (cond ((or (fx< chr 32)5897 (fx= chr #x1ffff))5898 (outchr port #\\)5899 (case chr5900 ((7) (outchr port #\a))5901 ((8) (outchr port #\b))5902 ((9) (outchr port #\t))5903 ((10) (outchr port #\n))5904 ((11) (outchr port #\v))5905 ((12) (outchr port #\f))5906 ((13) (outchr port #\r))5907 (else5908 (outchr port #\x)5909 (when (fx< chr 16) (outchr port #\0))5910 (outstr port (##sys#number->string chr 16))5911 (outchr port #\;) ) ) )5912 (else (outchr port (##core#inline "C_fix_to_char" chr)) ) ) ) ) ) ) )5913 (else (outstr port x)) ) )5914 ((##core#inline "C_pairp" x)5915 (outchr port #\()5916 (out (##sys#slot x 0))5917 (do ((x (##sys#slot x 1) (##sys#slot x 1)))5918 ((or (not (##core#inline "C_blockp" x)) (not (##core#inline "C_pairp" x)))5919 (if (not (eq? x '()))5920 (begin5921 (outstr port " . ")5922 (out x) ) )5923 (outchr port #\)) )5924 (outchr port #\space)5925 (out (##sys#slot x 0)) ) )5926 ((##core#inline "C_bytevectorp" x)5927 (outstr port "#u8")5928 (out (##sys#bytevector->list x)))5929 ((##core#inline "C_structurep" x) (##sys#user-print-hook x readable port))5930 ((##core#inline "C_closurep" x) (outstr port (##sys#procedure->string x)))5931 ((##core#inline "C_locativep" x) (outstr port "#<locative>"))5932 ((##core#inline "C_lambdainfop" x)5933 (outstr port "#<lambda info ")5934 (outstr port (##sys#lambda-info->string x))5935 (outchr port #\>) )5936 ((##core#inline "C_portp" x)5937 (case (##sys#slot x 1)5938 ((1) (outstr port "#<input port \""))5939 ((2) (outstr port "#<output port \""))5940 (else (outstr port "#<port \"")))5941 (outstr port (##sys#slot x 3))5942 (outstr port "\">") )5943 ((##core#inline "C_vectorp" x)5944 (let ((n (##sys#size x)))5945 (cond ((eq? 0 n)5946 (outstr port "#()") )5947 (else5948 (outstr port "#(")5949 (out (##sys#slot x 0))5950 (do ((i 1 (fx+ i 1))5951 (c (fx- n 1) (fx- c 1)) )5952 ((eq? c 0)5953 (outchr port #\)) )5954 (outchr port #\space)5955 (out (##sys#slot x i)) ) ) ) ) )5956 (else (##sys#error "unprintable block object encountered")))))5957 (##core#undefined))))59585959(define ##sys#procedure->string5960 (let ((string-append string-append))5961 (lambda (x)5962 (let ((info (##sys#lambda-info x)))5963 (if info5964 (string-append "#<procedure " (##sys#lambda-info->string info) ">")5965 "#<procedure>") ) ) ) )59665967(define ##sys#record-printers '())59685969(set! chicken.base#record-printer5970 (lambda (type)5971 (let ((a (assq type ##sys#record-printers)))5972 (and a (cdr a)))))59735974(set! chicken.base#set-record-printer!5975 (lambda (type proc)5976 (##sys#check-closure proc 'set-record-printer!)5977 (let ((a (assq type ##sys#record-printers)))5978 (if a5979 (##sys#setslot a 1 proc)5980 (set! ##sys#record-printers (cons (cons type proc) ##sys#record-printers)))5981 (##core#undefined))))59825983;; OBSOLETE can be removed after bootstrapping5984(set! ##sys#register-record-printer chicken.base#set-record-printer!)59855986(set! chicken.base#record-printer5987 (getter-with-setter record-printer set-record-printer!))59885989(define (##sys#user-print-hook x readable port)5990 (let* ((type (##sys#slot x 0))5991 (a (assq type ##sys#record-printers))5992 (name (if (vector? type) (##sys#slot type 0) type)))5993 (cond (a (handle-exceptions ex5994 (begin5995 (##sys#print "#<Error in printer of record type `" #f port)5996 (##sys#print name #f port)5997 (if (##sys#structure? ex 'condition)5998 (and-let* ((a (member '(exn . message) (##sys#slot ex 2))))5999 (##sys#print "': " #f port)6000 (##sys#print (cadr a) #f port)6001 (##sys#write-char-0 #\> port))6002 (##sys#print "'>" #f port)))6003 ((##sys#slot a 1) x port)))6004 (else6005 (##sys#print "#<" #f port)6006 (##sys#print name #f port)6007 (case type6008 ((condition)6009 (##sys#print ": " #f port)6010 (##sys#print (##sys#slot x 1) #f port) )6011 ((thread)6012 (##sys#print ": " #f port)6013 (##sys#print (##sys#slot x 6) #f port) ) )6014 (##sys#write-char-0 #\> port) ) ) ) )60156016(define ##sys#with-print-length-limit6017 (let ([call-with-current-continuation call-with-current-continuation])6018 (lambda (limit thunk)6019 (call-with-current-continuation6020 (lambda (return)6021 (parameterize ((##sys#print-length-limit limit)6022 (##sys#print-exit return)6023 (##sys#current-print-length 0))6024 (thunk)))))))602560266027;;; String ports:6028;6029; - Port-slots:6030;6031; Input:6032;6033; 10: position (in bytes)6034; 11: len6035; 12: input bytevector6036;6037; Output:6038;6039; 10: position (in bytes)6040; 11: limit6041; 12: output bytevector60426043(define ##sys#string-port-class6044 (letrec ((check6045 (lambda (p n)6046 (let* ((position (##sys#slot p 10))6047 (limit (##sys#slot p 11))6048 (output (##sys#slot p 12))6049 (limit2 (fx+ position n)))6050 (when (fx>= limit2 limit)6051 (when (fx>= limit2 maximal-string-length)6052 (##sys#error "string buffer full" p) )6053 (let* ([limit3 (fxmin maximal-string-length (fx+ limit limit))]6054 [buf (##sys#make-bytevector limit3)] )6055 (##core#inline "C_copy_memory_with_offset" buf output 0 0 position)6056 (##sys#setslot p 12 buf)6057 (##sys#setislot p 11 limit3)6058 (check p n) ) ) ) ) ) )6059 (vector6060 (lambda (p) ; read-char6061 (let ((position (##sys#slot p 10))6062 (input (##sys#slot p 12))6063 (len (##sys#slot p 11)))6064 (if (fx>= position len)6065 #!eof6066 (let ((c (##core#inline "C_utf_decode" input position)))6067 (##sys#setislot p 106068 (##core#inline "C_utf_advance" input position))6069 c))))6070 (lambda (p) ; peek-char6071 (let ((position (##sys#slot p 10))6072 (input (##sys#slot p 12))6073 (len (##sys#slot p 11)))6074 (if (fx>= position len)6075 #!eof6076 (##core#inline "C_utf_decode" input position))))6077 (lambda (p c) ; write-char6078 (check p 1)6079 (let ([position (##sys#slot p 10)]6080 [output (##sys#slot p 12)] )6081 (##sys#setislot p 10 (##core#inline "C_utf_insert" output position c))))6082 (lambda (p bv from to) ; write-bytevector6083 (let ((len (fx- to from)))6084 (check p len)6085 (let* ((position (##sys#slot p 10))6086 (output (##sys#slot p 12)))6087 (##core#inline "C_copy_memory_with_offset" output bv position from len)6088 (##sys#setislot p 10 (fx+ position len)) ) ) )6089 void ; close6090 (lambda (p) #f) ; flush-output6091 (lambda (p) #t) ; u8-ready?6092 (lambda (p n dest start) ; read-bytevector!6093 (let* ((pos (##sys#slot p 10))6094 (input (##sys#slot p 12))6095 (n2 (fx- (##sys#slot p 11) pos)))6096 (when (or (not n) (fx> n n2)) (set! n n2))6097 (##core#inline "C_copy_memory_with_offset" dest input start pos n)6098 (##sys#setislot p 10 (fx+ pos n))6099 n))6100 (lambda (p limit) ; read-line6101 (let* ((pos (##sys#slot p 10))6102 (size (##sys#slot p 11))6103 (buf (##sys#slot p 12))6104 (end (if limit (fx+ pos limit) size)))6105 (if (fx>= pos size)6106 #!eof6107 (receive (next line full-line?)6108 (##sys#scan-buffer-line6109 buf (if (fx> end size) size end) pos6110 (lambda (pos) (values #f pos #f) ) )6111 ;; Update row & column position6112 (if full-line?6113 (begin6114 (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))6115 (##sys#setislot p 5 0))6116 (##sys#setislot p 5 (fx+ (##sys#slot p 5) (string-length line))))6117 (##sys#setislot p 10 next)6118 line) ) ) )6119 (lambda (p) ; read-buffered6120 (let ((pos (##sys#slot p 10))6121 (buf (##sys#slot p 12))6122 (len (##sys#slot p 11)) )6123 (if (fx>= pos len)6124 ""6125 (let* ((rest (fx- len pos))6126 (buffered (##sys#buffer->string buf pos rest)))6127 (##sys#setislot p 10 len)6128 buffered))))6129 (lambda (p) #t) ; char-ready?6130 )))61316132;; Invokes the eos handler when EOS is reached to get more data.6133;; The eos-handler is responsible for stopping, either when EOF is hit or6134;; a user-supplied limit is reached (ie, it's indistinguishable from EOF)6135(define (##sys#scan-buffer-line buf limit start-pos eos-handler #!optional enc)6136 (let* ((hold 1024)6137 (dpos 0)6138 (line (##sys#make-bytevector hold)))6139 (define (grow)6140 (let* ((h2 (fx* hold 2))6141 (l2 (##sys#make-bytevector h2)))6142 (##core#inline "C_copy_memory" l2 line dpos)6143 (set! line l2)6144 (set! hold h2)))6145 (define (conc buf from to)6146 (let ((len (fx- to from)))6147 (when (fx>= (fx+ dpos len) hold) (grow))6148 (##core#inline "C_copy_memory_with_offset" line buf dpos from len)6149 (set! dpos (fx+ dpos len))))6150 (define (conc1 b)6151 (when (fx>= (fx+ dpos 1) hold) (grow))6152 (##core#inline "C_setsubbyte" line dpos b)6153 (set! dpos (fx+ dpos 1)))6154 (define (getline)6155 (if enc6156 (##sys#buffer->string/encoding line 0 dpos enc)6157 (##sys#buffer->string line 0 dpos)))6158 (let loop ((buf buf)6159 (offset start-pos)6160 (pos start-pos)6161 (limit limit))6162 (cond ((fx= pos limit)6163 (conc buf offset pos)6164 (receive (buf offset limit) (eos-handler pos)6165 (if buf6166 (loop buf offset offset limit)6167 (values offset (getline) #f))))6168 (else6169 (let ((c (##core#inline "C_subbyte" buf pos)))6170 (cond ((eq? c 10)6171 (conc buf offset pos)6172 (values (fx+ pos 1) (getline) #t))6173 ((and (eq? c 13) ; \r\n -> drop \r from string6174 (fx> limit (fx+ pos 1))6175 (eq? (##core#inline "C_subbyte" buf (fx+ pos 1)) 10))6176 (conc buf offset pos)6177 (values (fx+ pos 2) (getline) #t))6178 ((and (eq? c 13) ; Edge case (#568): \r{read}[\n|xyz]6179 (fx= limit (fx+ pos 1)))6180 (conc buf offset pos)6181 (receive (buf offset limit) (eos-handler pos)6182 (if buf6183 (if (eq? (##core#inline "C_subbyte" buf offset) 10)6184 (values (fx+ offset 1) (getline) #t)6185 ;; "Restore" \r we didn't copy, loop w/ new string6186 (begin6187 (conc1 13)6188 (loop buf offset offset limit)))6189 (values (fx+ offset 1) (getline) #t))))6190 ((eq? c 13)6191 (conc buf offset pos)6192 (values (fx+ pos 1) (getline) #t))6193 (else (loop buf offset (fx+ pos 1) limit)) ) ) ) ) )))61946195(define ##sys#print-to-string6196 (let ([get-output-string get-output-string]6197 [open-output-string open-output-string] )6198 (lambda (xs)6199 (let ([out (open-output-string)])6200 (for-each (lambda (x) (##sys#print x #f out)) xs)6201 (get-output-string out) ) ) ) )62026203(define ##sys#pointer->string6204 (let ((string-append string-append))6205 (lambda (x)6206 (if (##core#inline "C_taggedpointerp" x)6207 (string-append6208 "#<tagged pointer "6209 (##sys#print-to-string6210 (let ((tag (##sys#slot x 1)))6211 (list (if (pair? tag) (car tag) tag) ) ) )6212 " "6213 (##sys#number->string (##sys#pointer->address x) 16)6214 ">")6215 (string-append "#<pointer 0x" (##sys#number->string (##sys#pointer->address x) 16) ">") ) ) ) )621662176218;;; Access backtrace:62196220(define-constant +trace-buffer-entry-slot-count+ 5)62216222(set! chicken.base#get-call-chain6223 (let ((extract6224 (foreign-lambda* nonnull-c-string ((scheme-object x)) "C_return((C_char *)x);")))6225 (lambda (#!optional (start 0) (thread ##sys#current-thread))6226 (let* ((tbl (foreign-value "C_trace_buffer_size" int))6227 ;; 5 slots: "raw" location (for compiled code), "cooked" location (for interpreted code), cooked1, cooked2, thread6228 (c +trace-buffer-entry-slot-count+)6229 (vec (##sys#make-vector (fx* c tbl) #f))6230 (r (##core#inline "C_fetch_trace" start vec))6231 (n (if (fixnum? r) r (fx* c tbl)))6232 (t-id (and thread (##sys#slot thread 14))))6233 (let loop ((i 0))6234 (if (fx>= i n)6235 '()6236 (let ((t (##sys#slot vec (fx+ i 4)))) ; thread id6237 (if (or (not t) (not thread) (eq? t-id t))6238 (cons (vector6239 (or (##sys#slot vec (fx+ i 1)) ; cooked_location6240 (extract (##sys#slot vec i))) ; raw_location6241 (##sys#slot vec (fx+ i 2)) ; cooked16242 (##sys#slot vec (fx+ i 3))) ; cooked26243 (loop (fx+ i c)))6244 (loop (fx+ i c))))))))))62456246(define (##sys#really-print-call-chain port chain header)6247 (when (pair? chain)6248 (##sys#print header #f port)6249 (for-each6250 (lambda (info)6251 (let* ((more1 (##sys#slot info 1)) ; cooked1 (expr/form)6252 (more2 (##sys#slot info 2)) ; cooked2 (cntr/frameinfo)6253 (fi (##sys#structure? more2 'frameinfo)))6254 (##sys#print "\n\t" #f port)6255 (##sys#print (##sys#slot info 0) #f port) ; raw (mode)6256 (##sys#print "\t " #f port)6257 (when (and more2 (if fi (##sys#slot more2 1)))6258 (##sys#write-char-0 #\[ port)6259 (##sys#print6260 (if fi6261 (##sys#slot more2 1) ; cntr6262 more2)6263 #f port)6264 (##sys#print "] " #f port))6265 (when more16266 (##sys#with-print-length-limit6267 1006268 (lambda ()6269 (##sys#print more1 #t port))))))6270 chain)6271 (##sys#print "\t<--\n" #f port)))62726273(set! chicken.base#print-call-chain6274 (lambda (#!optional (port ##sys#standard-output) (start 0)6275 (thread ##sys#current-thread)6276 (header "\n\tCall history:\n"))6277 (##sys#check-output-port port #t 'print-call-chain)6278 (##sys#check-fixnum start 'print-call-chain)6279 (##sys#check-string header 'print-call-chain)6280 (##sys#really-print-call-chain port (get-call-chain start thread) header)))628162826283;;; Interrupt handling:62846285(define (##sys#user-interrupt-hook)6286 (define (break) (##sys#signal-hook #:user-interrupt #f))6287 (if (eq? ##sys#current-thread ##sys#primordial-thread)6288 (break)6289 (##sys#setslot ##sys#primordial-thread 1 break) ) )629062916292;;; Default handlers62936294(define-foreign-variable _ex_software int "EX_SOFTWARE")62956296(define exit-in-progress #f)62976298(define (cleanup-before-exit)6299 (set! exit-in-progress #t)6300 (##core#inline "C_flush_all_files" #f)6301 (when (##core#inline "C_i_dump_heap_on_exitp")6302 (##sys#print "\n" #f ##sys#standard-error)6303 (##sys#dump-heap-state))6304 (when (##core#inline "C_i_profilingp")6305 (##core#inline "C_i_dump_statistical_profile"))6306 (let loop ()6307 (let ((tasks chicken.base#cleanup-tasks))6308 (set! chicken.base#cleanup-tasks '())6309 (unless (null? tasks)6310 (for-each (lambda (t) (t)) tasks)6311 (loop))))6312 (when (fx> (##sys#slot ##sys#pending-finalizers 0) 0)6313 (##sys#run-pending-finalizers #f))6314 (when (fx> (##core#inline "C_i_live_finalizer_count") 0)6315 (when (##sys#debug-mode?)6316 (##sys#print "[debug] forcing finalizers...\n" #f ##sys#standard-error))6317 (when (chicken.gc#force-finalizers)6318 (##sys#force-finalizers))))63196320(set! chicken.base#exit-handler6321 (make-parameter6322 (lambda (#!optional (code 0))6323 (##sys#check-fixnum code)6324 (cond (exit-in-progress6325 (##sys#warn "\"exit\" called while processing on-exit tasks"))6326 (else6327 (cleanup-before-exit)6328 (##core#inline "C_exit_runtime" code))))))63296330(set! chicken.base#implicit-exit-handler6331 (make-parameter6332 (lambda ()6333 (cleanup-before-exit))))63346335(define ##sys#reset-handler ; Exposed by chicken.repl6336 (make-parameter6337 (lambda ()6338 ((exit-handler) _ex_software))))63396340(define (##sys#dbg-hook . args)6341 (##core#inline "C_dbg_hook" #f)6342 (##core#undefined))634363446345;;; Condition handling:63466347(module chicken.condition6348 ;; NOTE: We don't emit the import lib. Due to syntax exports, it6349 ;; has to be a hardcoded primitive module.6350 (abort signal current-exception-handler6351 print-error-message with-exception-handler63526353 ;; [syntax] condition-case handle-exceptions63546355 ;; Condition object manipulation6356 make-property-condition make-composite-condition6357 condition condition? condition->list condition-predicate6358 condition-property-accessor get-condition-property)63596360(import scheme chicken.base chicken.fixnum chicken.foreign)6361(import chicken.internal.syntax)6362(import (only (scheme base) make-parameter open-output-string get-output-string))63636364(define (##sys#signal-hook/errno mode errno msg . args)6365 (##core#inline "C_dbg_hook" #f)6366 (##core#inline "signal_debug_event" mode msg args)6367 (case mode6368 [(#:user-interrupt)6369 (abort6370 (##sys#make-structure6371 'condition6372 '(user-interrupt)6373 '() ) ) ]6374 [(#:warning #:notice)6375 (##sys#print6376 (if (eq? mode #:warning) "\nWarning: " "\nNote: ")6377 #f ##sys#standard-error)6378 (##sys#print msg #f ##sys#standard-error)6379 (if (or (null? args) (fx> (length args) 1))6380 (##sys#write-char-0 #\newline ##sys#standard-error)6381 (##sys#print ": " #f ##sys#standard-error))6382 (for-each6383 (lambda (x)6384 (##sys#with-print-length-limit6385 4006386 (lambda ()6387 (##sys#print x #t ##sys#standard-error)6388 (##sys#write-char-0 #\newline ##sys#standard-error))))6389 args)6390 (##sys#flush-output ##sys#standard-error)]6391 (else6392 (when (and (symbol? msg) (null? args))6393 (set! msg (symbol->string msg)))6394 (let* ([hasloc (and (or (not msg) (symbol? msg)) (pair? args))]6395 [loc (and hasloc msg)]6396 [msg (if hasloc (##sys#slot args 0) msg)]6397 [args (if hasloc (##sys#slot args 1) args)] )6398 (abort6399 (##sys#make-structure6400 'condition6401 (case mode6402 [(#:type-error) '(exn type)]6403 [(#:syntax-error) '(exn syntax)]6404 [(#:bounds-error) '(exn bounds)]6405 [(#:arithmetic-error) '(exn arithmetic)]6406 [(#:file-error) '(exn i/o file)]6407 [(#:runtime-error) '(exn runtime)]6408 [(#:process-error) '(exn process)]6409 [(#:network-error) '(exn i/o net)]6410 [(#:network-timeout-error) '(exn i/o net timeout)]6411 [(#:limit-error) '(exn runtime limit)]6412 [(#:arity-error) '(exn arity)]6413 [(#:access-error) '(exn access)]6414 [(#:domain-error) '(exn domain)]6415 ((#:memory-error) '(exn memory))6416 [else '(exn)] )6417 (let ((props6418 (list '(exn . message) msg6419 '(exn . arguments) args6420 '(exn . call-chain) (get-call-chain)6421 '(exn . location) loc)))6422 (if errno6423 (cons '(exn . errno) (cons errno props))6424 props))))))))64256426(define (##sys#signal-hook mode msg . args)6427 (if (pair? args)6428 (apply ##sys#signal-hook/errno mode #f msg args)6429 (##sys#signal-hook/errno mode #f msg)))64306431(define ##sys#posix-error6432 (let ((string-append string-append))6433 (lambda (type loc msg . args)6434 (apply ##sys#signal-hook/errno6435 type (##sys#update-errno) loc6436 (string-append msg " - " strerror) args))))64376438(define (abort x)6439 (let ((h (car ##sys#current-exception-handler)))6440 (set! ##sys#current-exception-handler (cdr ##sys#current-exception-handler))6441 (h x)6442 (abort6443 (##sys#make-structure6444 'condition6445 '(exn)6446 (list '(exn . message) "exception handler returned"6447 '(exn . arguments) '()6448 '(exn . location) #f) ) ) ) )64496450(define (signal x)6451 (let ((h (car ##sys#current-exception-handler)))6452 (set! ##sys#current-exception-handler (cdr ##sys#current-exception-handler))6453 (h x) ) )64546455(define ##sys#error-handler6456 (make-parameter6457 (let ((string-append string-append))6458 (lambda (msg . args)6459 (##sys#error-handler (lambda args (##core#inline "C_halt" "error in error")))6460 (cond ((not (foreign-value "C_gui_mode" bool))6461 (##sys#print "\nError" #f ##sys#standard-error)6462 (when msg6463 (##sys#print ": " #f ##sys#standard-error)6464 (##sys#print msg #f ##sys#standard-error))6465 (##sys#with-print-length-limit6466 4006467 (lambda ()6468 (cond [(fx= 1 (length args))6469 (##sys#print ": " #f ##sys#standard-error)6470 (##sys#print (##sys#slot args 0) #t ##sys#standard-error)]6471 [else6472 (##sys#for-each6473 (lambda (x)6474 (##sys#print #\newline #f ##sys#standard-error)6475 (##sys#print x #t ##sys#standard-error))6476 args)])))6477 (##sys#print #\newline #f ##sys#standard-error)6478 (print-call-chain ##sys#standard-error)6479 (##core#inline "C_halt" #f))6480 (else6481 (let ((out (open-output-string)))6482 (when msg (##sys#print msg #f out))6483 (##sys#print #\newline #f out)6484 (##sys#for-each (lambda (x) (##sys#print x #t out) (##sys#print #\newline #f out)) args)6485 (##core#inline "C_halt" (get-output-string out)))))))))648664876488(define ##sys#last-exception #f) ; used in csi for ,exn command64896490(define ##sys#current-exception-handler6491 ;; Exception-handler for the primordial thread:6492 (let ((string-append string-append))6493 (define (h c)6494 (when (##sys#structure? c 'condition)6495 (set! ##sys#last-exception c)6496 (let ((kinds (##sys#slot c 1)))6497 (cond ((memq 'exn kinds)6498 (let* ((props (##sys#slot c 2))6499 (msga (member '(exn . message) props))6500 (argsa (member '(exn . arguments) props))6501 (loca (member '(exn . location) props)) )6502 (apply6503 (##sys#error-handler)6504 (if msga6505 (let ((msg (cadr msga))6506 (loc (and loca (cadr loca))) )6507 (if (and loc (symbol? loc))6508 (string-append6509 "(" (##sys#symbol->string/shared loc) ") "6510 (cond ((symbol? msg) (##sys#slot msg 1))6511 ((string? msg) msg)6512 (else "") ) ) ; Hm...6513 msg) )6514 "<exn: has no `message' property>")6515 (if argsa6516 (cadr argsa)6517 '() ) )6518 ;; in case error-handler returns, which shouldn't happen:6519 ((##sys#reset-handler)) ) )6520 ((eq? 'user-interrupt (##sys#slot kinds 0))6521 (##sys#print "\n*** user interrupt ***\n" #f ##sys#standard-error)6522 ((##sys#reset-handler)) )6523 ((eq? 'uncaught-exception (##sys#slot kinds 0))6524 ((##sys#error-handler)6525 "uncaught exception"6526 (cadr (member '(uncaught-exception . reason) (##sys#slot c 2))) )6527 ((##sys#reset-handler)) ) ) ) )6528 (abort6529 (##sys#make-structure6530 'condition6531 '(uncaught-exception)6532 (list '(uncaught-exception . reason) c)) ))6533 (let ((eh (list h)))6534 (##sys#setslot eh 1 eh)6535 eh)))65366537(define (with-exception-handler handler thunk)6538 (let ((old ##sys#current-exception-handler))6539 (##sys#dynamic-wind6540 (lambda ()6541 (set! ##sys#current-exception-handler (cons handler old)))6542 thunk6543 (lambda ()6544 (set! ##sys#current-exception-handler old)) ) ) )65456546(define (current-exception-handler . args)6547 (if (null? args)6548 (car ##sys#current-exception-handler)6549 (let ((proc (car args)))6550 (##sys#check-closure proc 'current-exception-handler)6551 (let-optionals (cdr args) ((convert? #t) (set? #t))6552 (when set? (set-car! ##sys#current-exception-handler proc)))6553 proc)))65546555;;; Condition object manipulation65566557(define (prop-list->kind-prefixed-prop-list loc kind plist)6558 (let loop ((props plist))6559 (cond ((null? props) '())6560 ((or (not (pair? props)) (not (pair? (cdr props))))6561 (##sys#signal-hook6562 #:type-error loc "argument is not an even property list" plist))6563 (else (cons (cons kind (car props))6564 (cons (cadr props)6565 (loop (cddr props))))))))65666567(define (make-property-condition kind . props)6568 (##sys#make-structure6569 'condition (list kind)6570 (prop-list->kind-prefixed-prop-list6571 'make-property-condition kind props)))65726573(define (make-composite-condition c1 . conds)6574 (let ([conds (cons c1 conds)])6575 (for-each (lambda (c) (##sys#check-structure c 'condition 'make-composite-condition)) conds)6576 (##sys#make-structure6577 'condition6578 (apply ##sys#append (map (lambda (c) (##sys#slot c 1)) conds))6579 (apply ##sys#append (map (lambda (c) (##sys#slot c 2)) conds)) ) ) )65806581(define (condition arg1 . args)6582 (let* ((args (cons arg1 args))6583 (keys (apply ##sys#append6584 (map (lambda (c)6585 (prop-list->kind-prefixed-prop-list6586 'condition (car c) (cdr c)))6587 args))))6588 (##sys#make-structure 'condition (map car args) keys)))65896590(define (condition? x) (##sys#structure? x 'condition))65916592(define (condition->list x)6593 (unless (condition? x)6594 (##sys#signal-hook6595 #:type-error 'condition->list6596 "argument is not a condition object" x))6597 (map (lambda (k)6598 (cons k (let loop ((props (##sys#slot x 2)))6599 (cond ((null? props) '())6600 ((eq? (caar props) k)6601 (cons (cdar props)6602 (cons (cadr props)6603 (loop (cddr props)))))6604 (else6605 (loop (cddr props)))))))6606 (##sys#slot x 1)))66076608(define (condition-predicate kind)6609 (lambda (c)6610 (and (condition? c)6611 (if (memv kind (##sys#slot c 1)) #t #f)) ) )66126613(define (condition-property-accessor kind prop . err-def)6614 (let ((err? (null? err-def))6615 (k+p (cons kind prop)) )6616 (lambda (c)6617 (##sys#check-structure c 'condition)6618 (and (memv kind (##sys#slot c 1))6619 (let ([a (member k+p (##sys#slot c 2))])6620 (cond [a (cadr a)]6621 [err? (##sys#signal-hook6622 #:type-error 'condition-property-accessor6623 "condition has no such property" prop) ]6624 [else (car err-def)] ) ) ) ) ) )66256626(define get-condition-property6627 (lambda (c kind prop . err-def)6628 ((apply condition-property-accessor kind prop err-def) c)))662966306631;;; Convenient error printing:66326633(define print-error-message6634 (let* ((display display)6635 (newline newline)6636 (write write)6637 (string-append string-append)6638 (errmsg (condition-property-accessor 'exn 'message #f))6639 (errloc (condition-property-accessor 'exn 'location #f))6640 (errargs (condition-property-accessor 'exn 'arguments #f))6641 (writeargs6642 (lambda (args port)6643 (##sys#for-each6644 (lambda (x)6645 (##sys#with-print-length-limit 80 (lambda () (write x port)))6646 (newline port) )6647 args) ) ) )6648 (lambda (ex . args)6649 (let-optionals args ((port ##sys#standard-output)6650 (header "Error"))6651 (##sys#check-output-port port #t 'print-error-message)6652 (newline port)6653 (display header port)6654 (cond ((and (not (##sys#immediate? ex)) (eq? 'condition (##sys#slot ex 0)))6655 (cond ((errmsg ex) =>6656 (lambda (msg)6657 (display ": " port)6658 (let ((loc (errloc ex)))6659 (when (and loc (symbol? loc))6660 (display (string-append "(" (##sys#symbol->string/shared loc) ") ") port) ) )6661 (display msg port) ) )6662 (else6663 (let ((kinds (##sys#slot ex 1)))6664 (if (equal? '(user-interrupt) kinds)6665 (display ": *** user interrupt ***" port)6666 (begin6667 (display ": <condition> " port)6668 (display (##sys#slot ex 1) port) ) ) ) ) )6669 (let ((args (errargs ex)))6670 (cond6671 ((not args))6672 ((fx= 1 (length args))6673 (display ": " port)6674 (writeargs args port))6675 (else6676 (newline port)6677 (writeargs args port)))))6678 ((string? ex)6679 (display ": " port)6680 (display ex port)6681 (newline port))6682 (else6683 (display ": uncaught exception: " port)6684 (writeargs (list ex) port) ) ) ) ) ) )668566866687;;; Show exception message and backtrace as warning6688;;; (used for threads and finalizers)66896690(define ##sys#show-exception-warning6691 (let ((print-error-message print-error-message)6692 (display display)6693 (write-char write-char)6694 (print-call-chain print-call-chain)6695 (open-output-string open-output-string)6696 (get-output-string get-output-string) )6697 (lambda (exn cause #!optional (thread ##sys#current-thread))6698 (when ##sys#warnings-enabled6699 (let ((o (open-output-string)))6700 (display "Warning" o)6701 (when thread6702 (display " (" o)6703 (display thread o)6704 (write-char #\) o))6705 (display ": " o)6706 (display cause o)6707 (print-error-message exn ##sys#standard-error (get-output-string o))6708 (print-call-chain ##sys#standard-error 0 thread) ) ))))670967106711;;; Error hook (called by runtime-system):67126713(define ##sys#error-hook6714 (let ([string-append string-append])6715 (lambda (code loc . args)6716 (case code6717 ((1) (let ([c (car args)]6718 [n (cadr args)]6719 [fn (caddr args)] )6720 (apply6721 ##sys#signal-hook6722 #:arity-error loc6723 (string-append "bad argument count - received " (##sys#number->string n) " but expected "6724 (##sys#number->string c) )6725 (if fn (list fn) '())) ) )6726 ((2) (let ([c (car args)]6727 [n (cadr args)]6728 [fn (caddr args)] )6729 (apply6730 ##sys#signal-hook6731 #:arity-error loc6732 (string-append "too few arguments - received " (##sys#number->string n) " but expected "6733 (##sys#number->string c) )6734 (if fn (list fn) '()))))6735 ((3) (apply ##sys#signal-hook #:type-error loc "bad argument type" args))6736 ((4) (apply ##sys#signal-hook #:runtime-error loc "unbound variable" args))6737 ((5) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a keyword" args))6738 ((6) (apply ##sys#signal-hook #:limit-error loc "out of memory" args))6739 ((7) (apply ##sys#signal-hook #:arithmetic-error loc "division by zero" args))6740 ((8) (apply ##sys#signal-hook #:bounds-error loc "out of range" args))6741 ((9) (apply ##sys#signal-hook #:type-error loc "call of non-procedure" args))6742 ((10) (apply ##sys#signal-hook #:arity-error loc "continuation cannot receive multiple values" args))6743 ((11) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a non-cyclic list" args))6744 ((12) (apply ##sys#signal-hook #:limit-error loc "recursion too deep" args))6745 ((13) (apply ##sys#signal-hook #:type-error loc "inexact number cannot be represented as an exact number" args))6746 ((14) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a proper list" args))6747 ((15) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" args))6748 ((16) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a number" args))6749 ((17) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a string" args))6750 ((18) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a pair" args))6751 ((19) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a list" args))6752 ((20) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a character" args))6753 ((21) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a vector" args))6754 ((22) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a symbol" args))6755 ((23) (apply ##sys#signal-hook #:limit-error loc "stack overflow" args))6756 ((24) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a structure of the required type" args))6757 ((25) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a bytevector" args))6758 ((26) (apply ##sys#signal-hook #:type-error loc "locative refers to reclaimed object" args))6759 ((27) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a block object" args))6760 ((28) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a number vector" args))6761 ((29) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an integer" args))6762 ((30) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an unsigned integer" args))6763 ((31) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a pointer" args))6764 ((32) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a tagged pointer" args))6765 ((33) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a flonum" args))6766 ((34) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a procedure" args))6767 ((35) (apply ##sys#signal-hook #:type-error loc "bad argument type - invalid base" args))6768 ((36) (apply ##sys#signal-hook #:limit-error loc "recursion too deep or circular data encountered" args))6769 ((37) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a boolean" args))6770 ((38) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a locative" args))6771 ((39) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a port" args))6772 ((40) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a port of the correct type" args))6773 ((41) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an input-port" args))6774 ((42) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an output-port" args))6775 ((43) (apply ##sys#signal-hook #:file-error loc "port already closed" args))6776 ((44) (apply ##sys#signal-hook #:type-error loc "cannot represent string with NUL bytes as C string" args))6777 ((45) (apply ##sys#signal-hook #:memory-error loc "segmentation violation" args))6778 ((46) (apply ##sys#signal-hook #:arithmetic-error loc "floating-point exception" args))6779 ((47) (apply ##sys#signal-hook #:runtime-error loc "illegal instruction" args))6780 ((48) (apply ##sys#signal-hook #:memory-error loc "bus error" args))6781 ((49) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an exact number" args))6782 ((50) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an inexact number" args))6783 ((51) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a real" args))6784 ((52) (apply ##sys#signal-hook #:type-error loc "bad argument type - complex number has no ordering" args))6785 ((53) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an exact integer" args))6786 ((54) (apply ##sys#signal-hook #:type-error loc "number does not fit in foreign type" args))6787 ((55) (apply ##sys#signal-hook #:type-error loc "cannot compute absolute value of complex number" args))6788 ((56) (let ((c (car args))6789 (n (cadr args))6790 (fn (caddr args)))6791 (apply6792 ##sys#signal-hook6793 #:bounds-error loc6794 (string-append "attempted rest argument access at index " (##sys#number->string n)6795 " but rest list length is " (##sys#number->string c) )6796 (if fn (list fn) '()))))6797 ((57) (apply ##sys#signal-hook #:type-error loc "string contains invalid UTF-8 sequence" args))6798 ((58) (apply ##sys#signal-hook #:type-error loc "string contains un-encodable character" args))6799 ((59) (apply ##sys#signal-hook #:type-error loc "bad argument type - numeric value exceeds range" args))6800 (else (apply ##sys#signal-hook #:runtime-error loc "unknown internal error" args)) ) ) ) )68016802) ; chicken.condition68036804(import chicken.condition)68056806;;; R7RS exceptions68076808(define (scheme#raise-continuable obj)6809 (let ((h (car ##sys#current-exception-handler)))6810 (dynamic-wind6811 (lambda ()6812 (set! ##sys#current-exception-handler (cdr ##sys#current-exception-handler)))6813 (lambda () (h obj))6814 (lambda ()6815 (set! ##sys#current-exception-handler (cons h ##sys#current-exception-handler))))))68166817(define scheme#error-object? condition?)6818(define scheme#error-object-message (condition-property-accessor 'exn 'message))6819(define scheme#error-object-irritants (condition-property-accessor 'exn 'arguments))68206821(define scheme#read-error?)6822(define scheme#file-error?)68236824(let ((exn? (condition-predicate 'exn))6825 (i/o? (condition-predicate 'i/o))6826 (file? (condition-predicate 'file))6827 (syntax? (condition-predicate 'syntax)))6828 (set! scheme#read-error?6829 (lambda (obj)6830 (and (exn? obj)6831 (or (i/o? obj) ; XXX Not fine-grained enough.6832 (syntax? obj)))))6833 (set! scheme#file-error?6834 (lambda (obj)6835 (and (exn? obj)6836 (file? obj)))))683768386839;;; Miscellaneous low-level routines:68406841(define (##sys#structure? x s) (##core#inline "C_i_structurep" x s))6842(define (##sys#generic-structure? x) (##core#inline "C_structurep" x))6843(define (##sys#slot x i) (##core#inline "C_slot" x i))6844(define (##sys#size x) (##core#inline "C_block_size" x))6845(define ##sys#make-pointer (##core#primitive "C_make_pointer"))6846(define ##sys#make-tagged-pointer (##core#primitive "C_make_tagged_pointer"))6847(define (##sys#pointer? x) (##core#inline "C_anypointerp" x))6848(define (##sys#set-pointer-address! ptr addr) (##core#inline "C_update_pointer" addr ptr))6849(define (##sys#bytevector? x) (##core#inline "C_i_bytevectorp" x))6850(define (##sys#string->pbytevector s) (##core#inline "C_string_to_pbytevector" s))6851(define (##sys#permanent? x) (##core#inline "C_permanentp" x))6852(define (##sys#block-address x) (##core#inline_allocate ("C_block_address" 6) x))6853(define (##sys#locative? x) (##core#inline "C_locativep" x))68546855(define (##sys#srfi-4-vector? x)6856 (or (##core#inline "C_i_srfi_4_vectorp" x)6857 (and (##core#inline "C_blockp" x)6858 (##core#inline "C_structurep" x)6859 (let ((t (##sys#slot x 0)))6860 (or (eq? t 'c64vector) (eq? t 'c128vector))))))68616862(define (##sys#null-pointer)6863 (let ([ptr (##sys#make-pointer)])6864 (##core#inline "C_update_pointer" 0 ptr)6865 ptr) )68666867(define (##sys#null-pointer? x)6868 (eq? 0 (##sys#pointer->address x)) )68696870(define (##sys#address->pointer addr)6871 (let ([ptr (##sys#make-pointer)])6872 (##core#inline "C_update_pointer" addr ptr)6873 ptr) )68746875(define (##sys#pointer->address ptr)6876 ;;XXX '6' is platform dependent!6877 (##core#inline_allocate ("C_a_unsigned_int_to_num" 6) (##sys#slot ptr 0)) )68786879(define (##sys#make-c-string str #!optional loc)6880 (let ((bv (##sys#slot str 0)))6881 (if (fx= (##core#inline "C_asciiz_strlen" bv) (fx- (##sys#size bv) 1))6882 bv6883 (##sys#error-hook (foreign-value "C_ASCIIZ_REPRESENTATION_ERROR" int)6884 loc str))) )68856886(define ##sys#peek-signed-integer (##core#primitive "C_peek_signed_integer"))6887(define ##sys#peek-unsigned-integer (##core#primitive "C_peek_unsigned_integer"))6888(define (##sys#peek-fixnum b i) (##core#inline "C_peek_fixnum" b i))6889(define (##sys#peek-byte ptr i) (##core#inline "C_peek_byte" ptr i))68906891(define (##sys#vector->structure! vec) (##core#inline "C_vector_to_structure" vec))68926893(define (##sys#peek-double b i)6894 (##core#inline_allocate ("C_a_f64peek" 4) b i))68956896(define (##sys#peek-c-string b i)6897 (and (not (##sys#null-pointer? b))6898 (##sys#peek-nonnull-c-string b i)))68996900(define (##sys#peek-nonnull-c-string b i)6901 (let* ([len (##core#inline "C_fetch_c_strlen" b i)]6902 [bv (##sys#make-bytevector (fx+ len 1) 0)] )6903 (##core#inline "C_peek_c_string" b i bv len)6904 (##sys#buffer->string! bv len)))69056906(define (##sys#peek-and-free-c-string b i)6907 (let ((str (##sys#peek-c-string b i)))6908 (##core#inline "C_free_mptr" b i)6909 str))69106911(define (##sys#peek-and-free-nonnull-c-string b i)6912 (let ((str (##sys#peek-nonnull-c-string b i)))6913 (##core#inline "C_free_mptr" b i)6914 str))69156916(define (##sys#poke-c-string b i s)6917 (##core#inline "C_poke_c_string" b i (##sys#make-c-string s) s) )69186919(define (##sys#poke-integer b i n) (##core#inline "C_poke_integer" b i n))6920(define (##sys#poke-double b i n) (##core#inline "C_poke_double" b i n))69216922(define ##sys#peek-c-string-list6923 (let ((fetch (foreign-lambda c-string "C_peek_c_string_at" c-pointer int)))6924 (lambda (ptr n)6925 (let loop ((i 0))6926 (if (and n (fx>= i n))6927 '()6928 (let ((s (fetch ptr i)))6929 (if s6930 (cons s (loop (fx+ i 1)))6931 '() ) ) ) ) ) ) )69326933(define ##sys#peek-and-free-c-string-list6934 (let ((fetch (foreign-lambda c-string "C_peek_c_string_at" c-pointer int))6935 (free (foreign-lambda void "C_free" c-pointer)))6936 (lambda (ptr n)6937 (let ((lst (let loop ((i 0))6938 (if (and n (fx>= i n))6939 '()6940 (let ((s (fetch ptr i)))6941 (cond (s6942 (##core#inline "C_free_sptr" ptr i)6943 (cons s (loop (fx+ i 1))) )6944 (else '() ) ) ) ) ) ) )6945 (free ptr)6946 lst) ) ) )69476948(define (##sys#vector->closure! vec addr)6949 (##core#inline "C_vector_to_closure" vec)6950 (##core#inline "C_update_pointer" addr vec) )69516952(define (##sys#symbol-has-toplevel-binding? s)6953 (##core#inline "C_boundp" s))69546955(define (##sys#block-pointer x)6956 (let ([ptr (##sys#make-pointer)])6957 (##core#inline "C_pointer_to_block" ptr x)6958 ptr) )695969606961;;; Support routines for foreign-function calling:69626963(define (##sys#foreign-char-argument x) (##core#inline "C_i_foreign_char_argumentp" x))6964(define (##sys#foreign-fixnum-argument x) (##core#inline "C_i_foreign_fixnum_argumentp" x))6965(define (##sys#foreign-flonum-argument x) (##core#inline "C_i_foreign_flonum_argumentp" x))6966(define (##sys#foreign-block-argument x) (##core#inline "C_i_foreign_block_argumentp" x))69676968(define (##sys#foreign-cplxnum-argument x)6969 (if (##core#inline "C_i_numberp" x)6970 (##core#inline_allocate ("C_a_i_exact_to_inexact" 12) x)6971 (##sys#signal-hook6972 #:type-error #f "bad argument type - not a complex number"6973 x)))69746975(define (##sys#foreign-struct-wrapper-argument t x)6976 (##core#inline "C_i_foreign_struct_wrapper_argumentp" t x))69776978(define (##sys#foreign-string-argument x) (##core#inline "C_i_foreign_string_argumentp" x))6979(define (##sys#foreign-symbol-argument x) (##core#inline "C_i_foreign_symbol_argumentp" x))6980(define (##sys#foreign-pointer-argument x) (##core#inline "C_i_foreign_pointer_argumentp" x))6981(define (##sys#foreign-tagged-pointer-argument x tx) (##core#inline "C_i_foreign_tagged_pointer_argumentp" x tx))69826983(define (##sys#foreign-ranged-integer-argument obj size)6984 (##core#inline "C_i_foreign_ranged_integer_argumentp" obj size))6985(define (##sys#foreign-unsigned-ranged-integer-argument obj size)6986 (##core#inline "C_i_foreign_unsigned_ranged_integer_argumentp" obj size))69876988(define (##sys#wrap-struct type rec)6989 (##sys#setslot rec 0 type)6990 rec)69916992;;; Low-level threading interface:69936994(define ##sys#default-thread-quantum 10000)69956996(define (##sys#default-exception-handler arg)6997 (##core#inline "C_halt" "internal error: default exception handler shouldn't be called!") )69986999(define (##sys#make-thread thunk state name q)7000 (##sys#make-structure7001 'thread7002 thunk ; #1 thunk7003 #f ; #2 result list7004 state ; #3 state7005 #f ; #4 block-timeout7006 (vector ; #5 state buffer7007 ##sys#dynamic-winds7008 ##sys#standard-input7009 ##sys#standard-output7010 ##sys#standard-error7011 (list ##sys#default-exception-handler)7012 (##sys#vector-resize ##sys#current-parameter-vector7013 (##sys#size ##sys#current-parameter-vector) #f) )7014 name ; #6 name7015 (##core#undefined) ; #7 end-exception7016 '() ; #8 owned mutexes7017 q ; #9 quantum7018 (##core#undefined) ; #10 specific7019 #f ; #11 block object (type depends on blocking type)7020 '() ; #12 recipients7021 #f ; #13 unblocked by timeout?7022 (cons #f #f))) ; #14 ID (just needs to be unique)70237024(define ##sys#primordial-thread7025 (##sys#make-thread #f 'running 'primordial ##sys#default-thread-quantum))70267027(define ##sys#current-thread ##sys#primordial-thread)70287029(define (##sys#make-mutex id owner)7030 (##sys#make-structure7031 'mutex7032 id ; #1 name7033 owner ; #2 thread or #f7034 '() ; #3 list of waiting threads7035 #f ; #4 abandoned7036 #f ; #5 locked7037 (##core#undefined) ) ) ; #6 specific70387039(define (##sys#schedule) ((##sys#slot ##sys#current-thread 1)))70407041(define (##sys#thread-yield!)7042 (##sys#call-with-current-continuation7043 (lambda (return)7044 (let ((ct ##sys#current-thread))7045 (##sys#setslot ct 1 (lambda () (return (##core#undefined))))7046 (##sys#schedule) ) ) ) )70477048(define (##sys#kill-other-threads thunk)7049 (thunk)) ; does nothing, will be modified by scheduler.scm70507051;; these two procedures should redefined in thread APIs (e.g. srfi-18):7052(define (##sys#resume-thread-on-event t) #f)70537054(define (##sys#suspend-thread-on-event t)7055 ;; wait until signal handler fires. If we are only waiting for a finalizer,7056 ;; then this will wait forever:7057 (##sys#sleep-until-interrupt))70587059(define (##sys#sleep-until-interrupt)7060 (##core#inline "C_i_sleep_until_interrupt" 100)7061 (##sys#dispatch-interrupt (lambda _ #f)))706270637064;;; event queues (for signals and finalizers)70657066(define (##sys#make-event-queue)7067 (##sys#make-structure 'event-queue7068 '() ; head7069 '() ; tail7070 #f)) ; suspended thread70717072(define (##sys#add-event-to-queue! q e)7073 (let ((h (##sys#slot q 1))7074 (t (##sys#slot q 2))7075 (item (cons e '())))7076 (if (null? h)7077 (##sys#setslot q 1 item)7078 (##sys#setslot t 1 item))7079 (##sys#setslot q 2 item)7080 (let ((st (##sys#slot q 3))) ; thread suspended?7081 (when st7082 (##sys#setslot q 3 #f)7083 (##sys#resume-thread-on-event st)))))70847085(define (##sys#get-next-event q)7086 (let ((st (##sys#slot q 3)))7087 (and (not st)7088 (let ((h (##sys#slot q 1)))7089 (and (not (null? h))7090 (let ((x (##sys#slot h 0))7091 (n (##sys#slot h 1)))7092 (##sys#setslot q 1 n)7093 (when (null? n) (##sys#setslot q 2 '()))7094 x))))))70957096(define (##sys#wait-for-next-event q)7097 (let ((st (##sys#slot q 3)))7098 (when st7099 (##sys#signal-hook #:runtime-error #f "event queue blocked" q))7100 (let again ()7101 (let ((h (##sys#slot q 1)))7102 (cond ((null? h)7103 (##sys#setslot q 3 ##sys#current-thread)7104 (##sys#suspend-thread-on-event ##sys#current-thread)7105 (again))7106 (else7107 (let ((x (##sys#slot h 0))7108 (n (##sys#slot h 1)))7109 (##sys#setslot q 1 n)7110 (when (null? n) (##sys#setslot q 2 '()))7111 x)))))))711271137114;;; Sleeping:71157116(define (chicken.base#sleep-hook n) ; modified by scheduler.scm7117 (##core#inline "C_i_process_sleep" n))71187119(set! chicken.base#sleep7120 (lambda (n)7121 (##sys#check-fixnum n 'sleep)7122 (chicken.base#sleep-hook n)7123 (##core#undefined)))712471257126;;; Interrupt-handling:71277128(define ##sys#context-switch (##core#primitive "C_context_switch"))71297130(define ##sys#signal-vector (make-vector 256 #f))71317132(define (##sys#interrupt-hook reason state)7133 (let loop ((reason reason))7134 (when reason7135 (let ((handler (##sys#slot ##sys#signal-vector reason)))7136 (when handler7137 (handler reason))7138 (loop (##core#inline "C_i_pending_interrupt" #f)))))7139 (cond ((fx> (##sys#slot ##sys#pending-finalizers 0) 0)7140 (##sys#run-pending-finalizers state) )7141 ((procedure? state) (state))7142 (else (##sys#context-switch state) ) ) )71437144(define (##sys#dispatch-interrupt k)7145 (##sys#interrupt-hook7146 (##core#inline "C_i_pending_interrupt" #f)7147 k))714871497150;;; Accessing "errno":71517152(define-foreign-variable _errno int "errno")71537154(define ##sys#update-errno)7155(define ##sys#errno)71567157(let ((n 0))7158 (set! ##sys#update-errno (lambda () (set! n _errno) n))7159 (set! ##sys#errno (lambda () n)))716071617162;;; Format error string for unterminated here-docs:71637164(define (##sys#format-here-doc-warning end)7165 (##sys#print-to-string `("unterminated here-doc string literal `" ,end "'")))71667167;;; Special string quoting syntax:71687169(set! ##sys#user-read-hook7170 (let ([old ##sys#user-read-hook]7171 [read read]7172 [display display] )7173 (define (readln port)7174 (let ([ln (open-output-string)])7175 (do ([c (##sys#read-char-0 port) (##sys#read-char-0 port)])7176 ((or (eof-object? c) (char=? #\newline c))7177 (if (eof-object? c) c (get-output-string ln)))7178 (##sys#write-char-0 c ln) ) ) )7179 (define (read-escaped-sexp port skip-brace?)7180 (when skip-brace? (##sys#read-char-0 port))7181 (let* ((form (read port)))7182 (when skip-brace?7183 (let loop ()7184 ;; Skips all characters until #\}7185 (let ([c (##sys#read-char-0 port)])7186 (cond [(eof-object? c)7187 (##sys#read-error port "unexpected end of file - unterminated `#{...}' item in `here' string literal") ]7188 [(not (char=? #\} c)) (loop)] ) ) ) )7189 form))7190 (lambda (char port)7191 (cond [(not (char=? #\< char)) (old char port)]7192 [else7193 (read-char port)7194 (case (##sys#peek-char-0 port)7195 [(#\<)7196 (##sys#read-char-0 port)7197 (let ([str (open-output-string)]7198 [end (readln port)]7199 [f #f] )7200 (let ((endlen (if (eof-object? end) 0 (string-length end))))7201 (cond7202 ((fx= endlen 0)7203 (##sys#read-warning7204 port "Missing tag after #<< here-doc token"))7205 ((or (char=? (string-ref end (fx- endlen 1)) #\space)7206 (char=? (string-ref end (fx- endlen 1)) #\tab))7207 (##sys#read-warning7208 port "Whitespace after #<< here-doc tag"))7209 ))7210 (do ([ln (readln port) (readln port)])7211 ((or (eof-object? ln) (string=? end ln))7212 (when (eof-object? ln)7213 (##sys#read-warning port7214 (##sys#format-here-doc-warning end)))7215 (get-output-string str) )7216 (if f7217 (##sys#write-char-0 #\newline str)7218 (set! f #t) )7219 (display ln str) ) ) ]7220 [(#\#)7221 (##sys#read-char-0 port)7222 (let ([end (readln port)]7223 [str (open-output-string)] )7224 (define (get/clear-str)7225 (let ((s (get-output-string str)))7226 (set! str (open-output-string))7227 s))72287229 (let ((endlen (if (eof-object? end) 0 (string-length end))))7230 (cond7231 ((fx= endlen 0)7232 (##sys#read-warning7233 port "Missing tag after #<# here-doc token"))7234 ((or (char=? (string-ref end (fx- endlen 1)) #\space)7235 (char=? (string-ref end (fx- endlen 1)) #\tab))7236 (##sys#read-warning7237 port "Whitespace after #<# here-doc tag"))7238 ))72397240 (let loop [(lst '())]7241 (let ([c (##sys#read-char-0 port)])7242 (case c7243 [(#\newline #!eof)7244 (let ([s (get/clear-str)])7245 (cond [(or (eof-object? c) (string=? end s))7246 (when (eof-object? c)7247 (##sys#read-warning7248 port (##sys#format-here-doc-warning end)))7249 `(##sys#print-to-string7250 ;;Can't just use `(list ,@lst) because of 126 argument apply limit7251 ,(let loop2 ((lst (cdr lst)) (next-string '()) (acc ''())) ; drop last newline7252 (cond ((null? lst)7253 `(cons ,(##sys#print-to-string next-string) ,acc))7254 ((or (string? (car lst)) (char? (car lst)))7255 (loop2 (cdr lst) (cons (car lst) next-string) acc))7256 (else7257 (loop2 (cdr lst)7258 '()7259 `(cons ,(car lst)7260 (cons ,(##sys#print-to-string next-string) ,acc))))))) ]7261 [else (loop (cons #\newline (cons s lst)))] ) ) ]7262 [(#\#)7263 (let ([c (##sys#peek-char-0 port)])7264 (case c7265 [(#\#)7266 (##sys#write-char-0 (##sys#read-char-0 port) str)7267 (loop lst) ]7268 [(#\{) (loop (cons (read-escaped-sexp port #t)7269 (cons (get/clear-str) lst) ) ) ]7270 [else (loop (cons (read-escaped-sexp port #f)7271 (cons (get/clear-str) lst) ) ) ] ) ) ]7272 [else7273 (##sys#write-char-0 c str)7274 (loop lst) ] ) ) ) ) ]7275 [else (##sys#read-error port "unreadable object")] ) ] ) ) ) )727672777278;;; Accessing process information (cwd, environ, etc.)72797280#>7281#if defined(_WIN32) && !defined(__CYGWIN__)7282#include <direct.h>72837284static C_word C_chdir(C_word str) {7285 return C_fix(_wchdir(C_utf16(str, 0)));7286}72877288static C_word C_curdir(C_word buf, C_word size) {7289 C_WCHAR *cwd = _wgetcwd((C_WCHAR *)C_c_string(buf), C_unfix(size));7290 if(cwd == NULL) return C_SCHEME_FALSE;7291 C_char *up = C_utf8(cwd);7292 C_char *p = up;7293 while(*p) {7294 *p = *p == '\\' ? '/' : *p;7295 ++p;7296 }7297 int len = C_strlen(up);7298 C_memcpy(cwd, up, len + 1);7299 return C_fix(len);7300}7301#else7302# define C_chdir(str) C_fix(chdir(C_c_string(str)))7303# define C_curdir(buf, size) (getcwd(C_c_string(buf), size) ? C_fix(strlen(C_c_string(buf))) : C_SCHEME_FALSE)7304#endif73057306<#73077308(module chicken.process-context7309 (argv argc+argv command-line-arguments7310 program-name executable-pathname7311 change-directory current-directory7312 get-environment-variable get-environment-variables7313 set-environment-variable! unset-environment-variable!)73147315(import scheme)7316(import chicken.base chicken.fixnum chicken.foreign)7317(import chicken.internal.syntax)7318(import (only (scheme base) make-parameter))73197320;;; Current directory access:73217322(define (change-directory name)7323 (##sys#check-string name 'change-directory)7324 (let ((sname (##sys#make-c-string name 'change-directory)))7325 (unless (fx= (##core#inline "C_chdir" sname) 0)7326 (##sys#signal-hook/errno #:file-error (##sys#update-errno) 'change-directory7327 (string-append "cannot change current directory - " strerror) name))7328 name))73297330(define (##sys#change-directory-hook dir) ; set! by posix for fd support7331 (change-directory dir))73327333(define current-directory7334 (getter-with-setter7335 (lambda ()7336 (let* ((buffer-size (foreign-value "C_MAX_PATH" size_t))7337 (buffer (##sys#make-bytevector buffer-size))7338 (len (##core#inline "C_curdir" buffer buffer-size)))7339 (unless ##sys#windows-platform ; FIXME need `cond-expand' here7340 (##sys#update-errno))7341 (if len7342 (##sys#buffer->string buffer 0 len)7343 (##sys#signal-hook/errno7344 #:file-error7345 (##sys#errno)7346 'current-directory "cannot retrieve current directory"))))7347 (lambda (dir)7348 (##sys#change-directory-hook dir))7349 "(chicken.process-context#current-directory)"))735073517352;;; Environment access:73537354(define _getenv7355 (foreign-lambda c-string "C_getenv" scheme-object))73567357(define (get-environment-variable var)7358 (_getenv (##sys#make-c-string var 'get-environment-variable)))73597360(define get-environment-entry7361 (foreign-lambda c-string* "C_getenventry" int))73627363(define (set-environment-variable! var val)7364 (##sys#check-string var 'set-environment-variable!)7365 (##core#inline "C_i_setenv"7366 (##sys#make-c-string var 'set-environment-variable!)7367 (and val7368 (begin7369 (##sys#check-string val 'set-environment-variable!)7370 (##sys#make-c-string val 'set-environment-variable!))))7371 (##core#undefined))73727373(define (unset-environment-variable! var)7374 (##sys#check-string var 'unset-environment-variable!)7375 (##core#inline "C_i_setenv"7376 (##sys#make-c-string var 'unset-environment-variable!)7377 #f)7378 (##core#undefined))73797380(define get-environment-variables7381 (lambda ()7382 (let loop ((i 0))7383 (let ((entry (get-environment-entry i)))7384 (if entry7385 (let scan ((j 0))7386 (if (char=? #\= (string-ref entry j))7387 (cons (cons (##sys#substring entry 0 j)7388 (##sys#substring entry (fx+ j 1) (string-length entry)))7389 (loop (fx+ i 1)))7390 (scan (fx+ j 1))))7391 '())))))739273937394;;; Command line handling73957396(define-foreign-variable main_argc int "C_main_argc")7397(define-foreign-variable main_argv c-pointer "C_main_argv")73987399(define executable-pathname7400 (foreign-lambda c-string* "C_executable_pathname"))74017402(define (argc+argv)7403 (##sys#values main_argc main_argv))74047405(define argv ; includes program name7406 (let ((cache #f)7407 (fetch-arg (foreign-lambda* c-string ((scheme-object i))7408 "C_return(C_main_argv[C_unfix(i)]);")))7409 (lambda ()7410 (unless cache7411 (set! cache (do ((i (fx- main_argc 1) (fx- i 1))7412 (v '() (cons (fetch-arg i) v)))7413 ((fx< i 0) v))))7414 cache)))74157416(define program-name7417 (make-parameter7418 (if (null? (argv))7419 "<unknown>" ; may happen if embedded in C application7420 (car (argv)))7421 (lambda (x)7422 (##sys#check-string x 'program-name)7423 x) ) )74247425(define command-line-arguments7426 (make-parameter7427 (let ((args (argv)))7428 (if (pair? args)7429 (let loop ((args (##sys#slot args 1))) ; Skip over program name (argv[0])7430 (if (null? args)7431 '()7432 (let ((arg (##sys#slot args 0))7433 (rest (##sys#slot args 1)) )7434 (cond7435 ((string=? "-:" arg) ; Consume first "empty" runtime options list, return rest7436 rest)74377438 ((and (fx>= (string-length arg) 3)7439 (string=? "-:" (##sys#substring arg 0 2)))7440 (loop rest))74417442 ;; First non-runtime option and everything following it is returned as-is7443 (else args) ) ) ) )7444 args) )7445 (lambda (x)7446 (##sys#check-list x 'command-line-arguments)7447 x) ) )74487449) ; chicken.process-context745074517452(module chicken.gc7453 (current-gc-milliseconds gc memory-statistics7454 set-finalizer! make-finalizer add-to-finalizer7455 set-gc-report! force-finalizers)74567457(import scheme)7458(import chicken.base chicken.fixnum chicken.foreign)7459(import chicken.internal.syntax)7460(import (only (scheme base) make-parameter))74617462;;; GC info:74637464(define (current-gc-milliseconds)7465 (##core#inline "C_i_accumulated_gc_time"))74667467(define (set-gc-report! flag)7468 (##core#inline "C_set_gc_report" flag))74697470;;; Memory info:74717472(define (memory-statistics)7473 (let* ((free (##sys#gc #t))7474 (info (##sys#memory-info))7475 (half-size (fx/ (##sys#slot info 0) 2)))7476 (vector half-size (fx- half-size free) (##sys#slot info 1))))74777478;;; Finalization:74797480(define-foreign-variable _max_pending_finalizers int "C_max_pending_finalizers")74817482(define ##sys#pending-finalizers7483 (##sys#make-vector (fx+ (fx* 2 _max_pending_finalizers) 1) (##core#undefined)) )74847485(##sys#setislot ##sys#pending-finalizers 0 0)74867487(define ##sys#set-finalizer! (##core#primitive "C_register_finalizer"))74887489(define ##sys#init-finalizer7490 (let ((string-append string-append))7491 (lambda (x y)7492 (when (fx>= (##core#inline "C_i_live_finalizer_count") _max_pending_finalizers)7493 (cond ((##core#inline "C_resize_pending_finalizers" (fx* 2 _max_pending_finalizers))7494 (set! ##sys#pending-finalizers7495 (##sys#vector-resize ##sys#pending-finalizers7496 (fx+ (fx* 2 _max_pending_finalizers) 1)7497 (##core#undefined)))7498 (when (##sys#debug-mode?)7499 (##sys#print7500 (string-append7501 "[debug] too many finalizers ("7502 (##sys#number->string7503 (##core#inline "C_i_live_finalizer_count"))7504 "), resized max finalizers to "7505 (##sys#number->string _max_pending_finalizers)7506 "\n")7507 #f ##sys#standard-error)))7508 (else7509 (when (##sys#debug-mode?)7510 (##sys#print7511 (string-append7512 "[debug] too many finalizers ("7513 (##core#inline "C_i_live_finalizer_count")7514 "), forcing ...\n")7515 #f ##sys#standard-error))7516 (##sys#force-finalizers) ) ) )7517 (##sys#set-finalizer! x y) ) ) )75187519(define set-finalizer! ##sys#init-finalizer)75207521(define finalizer-tag (vector 'finalizer))75227523(define (finalizer? x)7524 (and (pair? x) (eq? finalizer-tag (##sys#slot x 0))) )75257526(define (make-finalizer . objects)7527 (let ((q (##sys#make-event-queue)))7528 (define (handler o) (##sys#add-event-to-queue! q o))7529 (define (handle o) (##sys#init-finalizer o handler))7530 (for-each handle objects)7531 (##sys#decorate-lambda7532 (lambda (#!optional mode)7533 (if mode7534 (##sys#wait-for-next-event q)7535 (##sys#get-next-event q)))7536 finalizer?7537 (lambda (proc i)7538 (##sys#setslot proc i (cons finalizer-tag handle))7539 proc))))75407541(define (add-to-finalizer f . objects)7542 (let ((af (and (procedure? f)7543 (##sys#lambda-decoration f finalizer?))))7544 (unless af7545 (error 'add-to-finalizer "bad argument type - not a finalizer procedure"7546 f))7547 (for-each (cdr af) objects)))75487549(define ##sys#run-pending-finalizers7550 (let ((vector-fill! vector-fill!)7551 (string-append string-append)7552 (working-thread #f) )7553 (lambda (state)7554 (cond7555 ((not working-thread)7556 (set! working-thread ##sys#current-thread)7557 (let* ((c (##sys#slot ##sys#pending-finalizers 0)) )7558 (when (##sys#debug-mode?)7559 (##sys#print7560 (string-append "[debug] running " (##sys#number->string c)7561 " finalizer(s) ("7562 (##sys#number->string7563 (##core#inline "C_i_live_finalizer_count"))7564 " live, "7565 (##sys#number->string7566 (##core#inline "C_i_allocated_finalizer_count"))7567 " allocated) ...\n")7568 #f ##sys#standard-error))7569 (do ([i 0 (fx+ i 1)])7570 ((fx>= i c))7571 (let ([i2 (fx+ 1 (fx* i 2))])7572 (handle-exceptions ex7573 (##sys#show-exception-warning ex "in finalizer" #f)7574 ((##sys#slot ##sys#pending-finalizers (fx+ i2 1))7575 (##sys#slot ##sys#pending-finalizers i2)) ) ))7576 (vector-fill! ##sys#pending-finalizers (##core#undefined))7577 (##sys#setislot ##sys#pending-finalizers 0 0)7578 (set! working-thread #f)))7579 (state) ; Got here due to interrupt; continue w/o error7580 ((eq? working-thread ##sys#current-thread)7581 (##sys#signal-hook7582 #:error '##sys#run-pending-finalizers7583 "re-entry from finalizer thread (maybe (gc #t) was called from a finalizer)"))7584 (else7585 ;; Give finalizer thread a change to run7586 (##sys#thread-yield!)))7587 (cond ((not state))7588 ((procedure? state) (state))7589 (state (##sys#context-switch state) ) ) ) ))75907591(define force-finalizers (make-parameter #t))75927593(define (##sys#force-finalizers)7594 (let loop ()7595 (let ([n (##sys#gc)])7596 (cond ((fx> (##sys#slot ##sys#pending-finalizers 0) 0)7597 (##sys#run-pending-finalizers #f)7598 (loop) )7599 (else n) ) ) ))76007601(define (gc . arg)7602 (let ((a (and (pair? arg) (car arg))))7603 (if a7604 (##sys#force-finalizers)7605 (##sys#gc a)))))76067607;;; Auxilliary definitions for safe use in quasiquoted forms and evaluated code:76087609(define ##sys#list->vector list->vector)7610(define ##sys#list list)7611(define ##sys#length length)7612(define ##sys#cons cons)7613(define ##sys#append append)7614(define ##sys#vector vector)7615(define ##sys#apply apply)7616(define ##sys#values values)7617(define ##sys#equal? equal?)7618(define ##sys#car car)7619(define ##sys#cdr cdr)7620(define ##sys#pair? pair?)7621(define ##sys#vector? vector?)7622(define ##sys#vector->list vector->list)7623(define ##sys#vector-length vector-length)7624(define ##sys#vector-ref vector-ref)7625(define ##sys#>= >=)7626(define ##sys#= =)7627(define ##sys#+ +)7628(define ##sys#eq? eq?)7629(define ##sys#eqv? eqv?)7630(define ##sys#list? list?)7631(define ##sys#null? null?)7632(define ##sys#map-n map)76337634;;; We need this here so `location' works:76357636(define (##sys#make-locative obj index weak? loc)7637 (cond [(##sys#immediate? obj)7638 (##sys#signal-hook #:type-error loc "locative cannot refer to immediate object" obj) ]7639 [(or (vector? obj) (pair? obj))7640 (##sys#check-range index 0 (##sys#size obj) loc)7641 (##core#inline_allocate ("C_a_i_make_locative" 5) 0 obj index weak?) ]7642 [(and (##core#inline "C_blockp" obj)7643 (##core#inline "C_bytevectorp" obj) )7644 (##sys#check-range index 0 (##sys#size obj) loc)7645 (##core#inline_allocate ("C_a_i_make_locative" 5) 2 obj index weak?) ]7646 [(##sys#generic-structure? obj)7647 (case (##sys#slot obj 0)7648 ((u8vector)7649 (let ([v (##sys#slot obj 1)])7650 (##sys#check-range index 0 (##sys#size v) loc)7651 (##core#inline_allocate ("C_a_i_make_locative" 5) 2 v index weak?)) )7652 ((s8vector)7653 (let ([v (##sys#slot obj 1)])7654 (##sys#check-range index 0 (##sys#size v) loc)7655 (##core#inline_allocate ("C_a_i_make_locative" 5) 3 v index weak?) ) )7656 ((u16vector)7657 (let ([v (##sys#slot obj 1)])7658 (##sys#check-range index 0 (##sys#size v) loc)7659 (##core#inline_allocate ("C_a_i_make_locative" 5) 4 v index weak?) ) )7660 ((s16vector)7661 (let ([v (##sys#slot obj 1)])7662 (##sys#check-range index 0 (##sys#size v) loc)7663 (##core#inline_allocate ("C_a_i_make_locative" 5) 5 v index weak?) ) )7664 ((u32vector)7665 (let ([v (##sys#slot obj 1)])7666 (##sys#check-range index 0 (##sys#size v) loc)7667 (##core#inline_allocate ("C_a_i_make_locative" 5) 6 v index weak?) ) )7668 ((s32vector)7669 (let ([v (##sys#slot obj 1)])7670 (##sys#check-range index 0 (##sys#size v) loc)7671 (##core#inline_allocate ("C_a_i_make_locative" 5) 7 v index weak?) ) )7672 ((u64vector)7673 (let ([v (##sys#slot obj 1)])7674 (##sys#check-range index 0 (##sys#size v) loc)7675 (##core#inline_allocate ("C_a_i_make_locative" 5) 8 v index weak?) ) )7676 ((s64vector)7677 (let ([v (##sys#slot obj 1)])7678 (##sys#check-range index 0 (##sys#size v) loc)7679 (##core#inline_allocate ("C_a_i_make_locative" 5) 9 v index weak?) ) )7680 ((f32vector)7681 (let ([v (##sys#slot obj 1)])7682 (##sys#check-range index 0 (##sys#size v) loc)7683 (##core#inline_allocate ("C_a_i_make_locative" 5) 10 v index weak?) ) )7684 ((f64vector)7685 (let ([v (##sys#slot obj 1)])7686 (##sys#check-range index 0 (##sys#size v) loc)7687 (##core#inline_allocate ("C_a_i_make_locative" 5) 11 v index weak?) ) )7688 ;;XXX pointer-vector currently not supported7689 (else7690 (##sys#check-range index 0 (fx- (##sys#size obj) 1) loc)7691 (##core#inline_allocate ("C_a_i_make_locative" 5) 0 obj (fx+ index 1) weak?) ) ) ]7692 ((string? obj)7693 (let ((bv (##sys#slot obj 0))7694 (p (##core#inline "C_utf_position" obj index)))7695 (##sys#check-range index 0 (##sys#slot obj 1) loc)7696 (##core#inline_allocate ("C_a_i_make_locative" 5) 1 bv p weak?) ) )7697 [else7698 (##sys#signal-hook7699 #:type-error loc7700 "bad argument type - locative cannot refer to objects of this type"7701 obj) ] ) )770277037704;;; Property lists77057706(module chicken.plist7707 (get get-properties put! remprop! symbol-plist)77087709(import scheme)7710(import (only chicken.base getter-with-setter))7711(import chicken.internal.syntax)77127713(define (put! sym prop val)7714 (##sys#check-symbol sym 'put!)7715 (##core#inline_allocate ("C_a_i_putprop" 8) sym prop val) )77167717(define (get sym prop #!optional default)7718 (##sys#check-symbol sym 'get)7719 (##core#inline "C_i_getprop" sym prop default))77207721(define ##sys#put! put!)7722(define ##sys#get get)77237724(set! get (getter-with-setter get put!))77257726(define (remprop! sym prop)7727 (##sys#check-symbol sym 'remprop!)7728 (let loop ((plist (##sys#slot sym 2)) (ptl #f))7729 (and (not (null? plist))7730 (let* ((tl (##sys#slot plist 1))7731 (nxt (##sys#slot tl 1)))7732 (or (and (eq? (##sys#slot plist 0) prop)7733 (begin7734 (if ptl7735 (##sys#setslot ptl 1 nxt)7736 (##sys#setslot sym 2 nxt) )7737 #t ) )7738 (loop nxt tl) ) ) ) )7739 (when (null? (##sys#slot sym 2))7740 ;; This will only unpersist if symbol is also unbound7741 (##core#inline "C_i_unpersist_symbol" sym) ) )77427743(define symbol-plist7744 (getter-with-setter7745 (lambda (sym)7746 (##sys#check-symbol sym 'symbol-plist)7747 (##sys#slot sym 2) )7748 (lambda (sym lst)7749 (##sys#check-symbol sym 'symbol-plist)7750 (##sys#check-list lst 'symbol-plist/setter)7751 (if (##core#inline "C_i_fixnumevenp" (##core#inline "C_i_length" lst))7752 (##sys#setslot sym 2 lst)7753 (##sys#signal-hook7754 #:type-error "property-list must be of even length"7755 lst sym))7756 (if (null? lst)7757 (##core#inline "C_i_unpersist_symbol" sym)7758 (##core#inline "C_i_persist_symbol" sym)))7759 "(chicken.plist#symbol-plist sym)"))77607761(define (get-properties sym props)7762 (##sys#check-symbol sym 'get-properties)7763 (unless (pair? props)7764 (set! props (list props)) )7765 (let loop ((plist (##sys#slot sym 2)))7766 (if (null? plist)7767 (values #f #f #f)7768 (let* ((prop (##sys#slot plist 0))7769 (tl (##sys#slot plist 1))7770 (nxt (##sys#slot tl 1)))7771 (if (memq prop props)7772 (values prop (##sys#slot tl 0) nxt)7773 (loop nxt) ) ) ) ) )77747775) ; chicken.plist777677777778;;; Print timing information (support for "time" macro):77797780(define (##sys#display-times info)7781 (define (pstr str) (##sys#print str #f ##sys#standard-error))7782 (define (pchr chr) (##sys#write-char-0 chr ##sys#standard-error))7783 (define (pnum num)7784 (##sys#print (if (zero? num) "0" (##sys#number->string num)) #f ##sys#standard-error))7785 (define (round-to x y) ; Convert to fp with y digits after the point7786 (/ (round (* x (expt 10 y))) (expt 10.0 y)))7787 (define (pmem bytes)7788 (cond ((> bytes (expt 1024 3))7789 (pnum (round-to (/ bytes (expt 1024 3)) 2)) (pstr " GiB"))7790 ((> bytes (expt 1024 2))7791 (pnum (round-to (/ bytes (expt 1024 2)) 2)) (pstr " MiB"))7792 ((> bytes 1024)7793 (pnum (round-to (/ bytes 1024) 2)) (pstr " KiB"))7794 (else (pnum bytes) (pstr " bytes"))))7795 (##sys#flush-output ##sys#standard-output)7796 (pnum (##sys#slot info 0))7797 (pstr "s CPU time")7798 (let ((gctime (##sys#slot info 1)))7799 (when (> gctime 0)7800 (pstr ", ")7801 (pnum gctime)7802 (pstr "s GC time (major)")))7803 (let ((mut (##sys#slot info 2))7804 (umut (##sys#slot info 3)))7805 (when (fx> mut 0)7806 (pstr ", ")7807 (pnum mut)7808 (pchr #\/)7809 (pnum umut)7810 (pstr " mutations (total/tracked)")))7811 (let ((minor (##sys#slot info 4))7812 (major (##sys#slot info 5)))7813 (when (or (fx> minor 0) (fx> major 0))7814 (pstr ", ")7815 (pnum major)7816 (pchr #\/)7817 (pnum minor)7818 (pstr " GCs (major/minor)")))7819 (let ((maximum-heap-usage (##sys#slot info 6)))7820 (pstr ", maximum live heap: ")7821 (pmem maximum-heap-usage))7822 (##sys#write-char-0 #\newline ##sys#standard-error)7823 (##sys#flush-output ##sys#standard-error))782478257826;;; Dump heap state to stderr:78277828(define ##sys#dump-heap-state (##core#primitive "C_dump_heap_state"))7829(define ##sys#filter-heap-objects (##core#primitive "C_filter_heap_objects"))783078317832;;; Platform configuration inquiry:78337834(module chicken.platform7835 (build-platform chicken-version7836 feature? machine-byte-order machine-type7837 repository-path installation-repository7838 register-feature! unregister-feature! include-path7839 software-type software-version return-to-host7840 system-config-directory system-cache-directory7841 )78427843(import scheme)7844(import chicken.fixnum chicken.foreign chicken.keyword chicken.process-context)7845(import chicken.internal.syntax)7846(import (only (scheme base) make-parameter))78477848(define software-type7849 (let ((sym (string->symbol ((##core#primitive "C_software_type")))))7850 (lambda () sym)))78517852(define machine-type7853 (let ((sym (string->symbol ((##core#primitive "C_machine_type")))))7854 (lambda () sym)))78557856(define machine-byte-order7857 (let ((sym (string->symbol ((##core#primitive "C_machine_byte_order")))))7858 (lambda () sym)))78597860(define software-version7861 (let ((sym (string->symbol ((##core#primitive "C_software_version")))))7862 (lambda () sym)))78637864(define build-platform7865 (let ((sym (string->symbol ((##core#primitive "C_build_platform")))))7866 (lambda () sym)))78677868(define ##sys#windows-platform7869 (and (eq? 'windows (software-type))7870 ;; Still windows even if 'Linux-like'7871 (not (eq? 'cygwin (software-version)))))78727873(define (chicken-version #!optional full)7874 (define (get-config)7875 (let ((bp (build-platform))7876 (st (software-type))7877 (sv (software-version))7878 (mt (machine-type)))7879 (define (str x)7880 (if (eq? 'unknown x)7881 ""7882 (string-append (symbol->string x) "-")))7883 (string-append (str sv) (str st) (str bp) (##sys#symbol->string/shared mt))))7884 (if full7885 (let ((spec (string-append7886 " " (number->string (foreign-value "C_WORD_SIZE" int)) "bit"7887 (if (feature? #:dload) " dload" "")7888 (if (feature? #:ptables) " ptables" "")7889 (if (feature? #:gchooks) " gchooks" "")7890 (if (feature? #:cross-chicken) " cross" ""))))7891 (string-append7892 "Version " ##sys#build-version7893 (if ##sys#build-branch (string-append " (" ##sys#build-branch ")") "")7894 (if ##sys#build-id (string-append " (rev " ##sys#build-id ")") "")7895 "\n"7896 (get-config)7897 (if (zero? (string-length spec))7898 ""7899 (string-append " [" spec " ]"))))7900 ##sys#build-version))79017902;;; Installation locations79037904(define-foreign-variable binary-version int "C_BINARY_VERSION")7905(define-foreign-variable installation-home c-string "C_INSTALL_SHARE_HOME")7906(define-foreign-variable install-egg-home c-string "C_INSTALL_EGG_HOME")79077908(define (include-path #!optional new)7909 (when new7910 (##sys#check-list new 'include-path)7911 (set! ##sys#include-pathnames new))7912 ##sys#include-pathnames)79137914(define path-list-separator7915 (if ##sys#windows-platform #\; #\:))79167917(define ##sys#split-path7918 (let ((cache '(#f)))7919 (lambda (path)7920 (cond ((not path) '())7921 ((equal? path (car cache))7922 (cdr cache))7923 (else7924 (let* ((len (string-length path))7925 (lst (let loop ((start 0) (pos 0))7926 (cond ((fx>= pos len)7927 (if (fx= pos start)7928 '()7929 (list (substring path start pos))))7930 ((char=? (string-ref path pos)7931 path-list-separator)7932 (cons (substring path start pos)7933 (loop (fx+ pos 1)7934 (fx+ pos 1))))7935 (else7936 (loop start (fx+ pos 1)))))))7937 (set! cache (cons path lst))7938 lst))))))79397940(define repository-path7941 (make-parameter7942 (cond ((foreign-value "C_private_repository_path()" c-string)7943 => list)7944 ((get-environment-variable "CHICKEN_REPOSITORY_PATH")7945 => ##sys#split-path)7946 (install-egg-home7947 => list)7948 (else #f))7949 (lambda (new)7950 (and new7951 (begin7952 (##sys#check-list new 'repository-path)7953 (for-each (lambda (p) (##sys#check-string p 'repository-path)) new)7954 new)))))79557956(define installation-repository7957 (make-parameter7958 (or (foreign-value "C_private_repository_path()" c-string)7959 (get-environment-variable "CHICKEN_INSTALL_REPOSITORY")7960 install-egg-home)))79617962(define (chop-separator str)7963 (let ((len (fx- (string-length str) 1)))7964 (if (and (> len 0)7965 (memq (string-ref str len) '(#\\ #\/)))7966 (substring str 0 len)7967 str) ) )79687969(define ##sys#include-pathnames7970 (cond ((get-environment-variable "CHICKEN_INCLUDE_PATH")7971 => (lambda (p)7972 (map chop-separator (##sys#split-path p))))7973 (else (list installation-home))))797479757976;;; Feature identifiers:79777978(define ->feature-id ; TODO: export this? It might be useful..7979 (let ()7980 (define (err . args)7981 (apply ##sys#signal-hook #:type-error "bad argument type - not a valid feature identifer" args))7982 (define (prefix s)7983 (if s (##sys#string-append s "-") ""))7984 (lambda (x)7985 (cond ((keyword? x) x)7986 ((string? x) (string->keyword x))7987 ((symbol? x) (string->keyword (##sys#symbol->string/shared x)))7988 (else (err x))))))79897990(define ##sys#features7991 '(#:chicken7992 #:srfi-6 #:srfi-12 #:srfi-17 #:srfi-23 #:srfi-307993 #:exact-complex #:srfi-39 #:srfi-62 #:srfi-88 #:full-numeric-tower #:full-unicode))79947995;; Add system features:79967997;; all platforms we support have this7998(set! ##sys#features `(#:posix #:r7rs #:ieee-float #:ratios ,@##sys#features))79998000(let ((check (lambda (f)8001 (unless (eq? 'unknown f)8002 (set! ##sys#features (cons (->feature-id f) ##sys#features))))))8003 (check (software-type))8004 (check (software-version))8005 (check (build-platform))8006 (check (machine-type))8007 (check (machine-byte-order)))80088009(when (foreign-value "HAVE_DLOAD" bool)8010 (set! ##sys#features (cons #:dload ##sys#features)))8011(when (foreign-value "HAVE_PTABLES" bool)8012 (set! ##sys#features (cons #:ptables ##sys#features)))8013(when (foreign-value "HAVE_GCHOOKS" bool)8014 (set! ##sys#features (cons #:gchooks ##sys#features)))8015(when (foreign-value "IS_CROSS_CHICKEN" bool)8016 (set! ##sys#features (cons #:cross-chicken ##sys#features)))80178018;; Register a feature to represent the word size (e.g., 32bit, 64bit)8019(set! ##sys#features8020 (cons (string->keyword8021 (string-append8022 (number->string (foreign-value "C_WORD_SIZE" int))8023 "bit"))8024 ##sys#features))80258026(set! ##sys#features8027 (let ((major (##sys#number->string (foreign-value "C_MAJOR_VERSION" int)))8028 (minor (##sys#number->string (foreign-value "C_MINOR_VERSION" int))))8029 (cons (->feature-id (string-append "chicken-" major))8030 (cons (->feature-id (string-append "chicken-" major "." minor))8031 ##sys#features))))80328033(define (register-feature! . fs)8034 (for-each8035 (lambda (f)8036 (let ((id (->feature-id f)))8037 (unless (memq id ##sys#features) (set! ##sys#features (cons id ##sys#features)))))8038 fs)8039 (##core#undefined))80408041(define (unregister-feature! . fs)8042 (let ((fs (map ->feature-id fs)))8043 (set! ##sys#features8044 (let loop ((ffs ##sys#features))8045 (if (null? ffs)8046 '()8047 (let ((f (##sys#slot ffs 0))8048 (r (##sys#slot ffs 1)))8049 (if (memq f fs)8050 (loop r)8051 (cons f (loop r)))))))8052 (##core#undefined)))80538054(define (feature? . ids)8055 (let loop ((ids ids))8056 (or (null? ids)8057 (and (memq (->feature-id (##sys#slot ids 0)) ##sys#features)8058 (loop (##sys#slot ids 1))))))80598060(define return-to-host8061 (##core#primitive "C_return_to_host"))80628063(define (system-config-directory)8064 (or (get-environment-variable "XDG_CONFIG_HOME")8065 (if ##sys#windows-platform8066 (get-environment-variable "APPDATA")8067 (let ((home (get-environment-variable "HOME")))8068 (and home (string-append home "/.config"))))))80698070(define (system-cache-directory)8071 (or (get-environment-variable "XDG_CACHE_HOME")8072 (if ##sys#windows-platform8073 (or (get-environment-variable "LOCALAPPDATA")8074 (get-environment-variable "APPDATA"))8075 (let ((home (get-environment-variable "HOME")))8076 (and home (string-append home "/.cache"))))))80778078) ; chicken.platform80798080(set! scheme#features8081 (lambda ()8082 (map (lambda (s)8083 (##sys#string->symbol (##sys#symbol->string s)))8084 ##sys#features)))80858086(set! scheme#make-list8087 (lambda (n #!optional fill)8088 (##sys#check-integer n 'make-list)8089 (unless (fx>= n 0)8090 (error 'make-list "not a positive integer" n))8091 (do ((i n (fx- i 1))8092 (result '() (cons fill result)))8093 ((eq? i 0) result))))80948095(set! scheme#list-set!8096 (lambda (l n obj)8097 (##sys#check-integer n 'list-set!)8098 (unless (fx>= n 0)8099 (error 'list-set! "not a positive integer" n))8100 (do ((i n (fx- i 1))8101 (l l (cdr l)))8102 ((fx= i 0) (set-car! l obj))8103 (when (null? l)8104 (error 'list-set! "out of range")))))81058106;; TODO: Test if this is the quickest way to do this, or whether we8107;; should just cons recursively like our SRFI-1 implementation does.8108(set! scheme#list-copy8109 (lambda (lst)8110 (cond ((pair? lst)8111 (let lp ((res '())8112 (lst lst))8113 (if (pair? lst)8114 (lp (cons (car lst) res) (cdr lst))8115 (append (##sys#fast-reverse res) lst))))8116 (else lst))))81178118(set! scheme#string->vector8119 (lambda (s #!optional start end)8120 (##sys#check-string s 'string->vector)8121 (let ((s->v (lambda (s start end)8122 (let* ((len (##sys#slot s 1)))8123 (##sys#check-range/including start 0 end 'string->vector)8124 (##sys#check-range/including end start len 'string->vector)8125 (let ((v (##sys#make-vector (fx- end start))))8126 (do ((ti 0 (fx+ ti 1))8127 (fi start (fx+ fi 1)))8128 ((fx= fi end) v)8129 (##sys#setslot v ti (##core#inline "C_utf_subchar" s fi))))))))8130 (if end8131 (s->v s start end)8132 (s->v s (or start 0) (string-length s))))))81338134(set! scheme#vector->string8135 (lambda (v #!optional start end)8136 (##sys#check-vector v 'vector->string)8137 (let ((v->s (lambda (v start end)8138 (let ((len (##sys#size v)))8139 (##sys#check-range/including start 0 end 'vector->string)8140 (##sys#check-range/including end start len 'vector->string)8141 (let ((bv (##sys#make-bytevector (fx* (fx- end start) 4))))8142 (let loop ((i 0)8143 (p start))8144 (if (fx= p end)8145 (##sys#buffer->string! bv i)8146 (let ((c (##sys#slot v p)))8147 (##sys#check-char c 'vector->string)8148 (loop (##core#inline "C_utf_insert" bv i c)8149 (fx+ p 1))))))))))8150 (if end8151 (v->s v start end)8152 (v->s v (or start 0) (##sys#size v))))))81538154(set! scheme#string-map8155 (lambda (proc str . more)8156 (define (%string-map proc s)8157 (let* ((len (string-length s))8158 (ans (##sys#make-bytevector (fx* 4 len))))8159 (let loop ((i 0)8160 (j 0))8161 (if (fx>= j len)8162 (##sys#buffer->string! ans i)8163 (let ((r (proc (string-ref s j))))8164 (##sys#check-char r 'string-map)8165 (loop (##core#inline "C_utf_insert" ans i r)8166 (fx+ j 1)))))))8167 (if (null? more)8168 (%string-map proc str)8169 (let ((strs (cons str more)))8170 (##sys#check-closure proc 'string-map)8171 (##sys#for-each (cut ##sys#check-string <> 'string-map) strs)8172 (let* ((len (foldl fxmin most-positive-fixnum (map string-length strs)))8173 (str (##sys#make-string len)))8174 (do ((i 0 (fx+ i 1)))8175 ((fx= i len) str)8176 (string-set! str i (apply proc (map (cut string-ref <> i) strs)))))))))81778178(set! scheme#string-for-each8179 (lambda (proc str . more)8180 (define (%string-for-each proc s)8181 (let ((len (string-length s)))8182 (let lp ((i 0))8183 (if (fx< i len)8184 (begin (proc (string-ref s i))8185 (lp (fx+ i 1)))))))8186 (if (null? more)8187 (%string-for-each proc str)8188 (let ((strs (cons str more)))8189 (##sys#check-closure proc 'string-for-each)8190 (##sys#for-each (cut ##sys#check-string <> 'string-for-each) strs)8191 (let* ((len (foldl fxmin most-positive-fixnum (map string-length strs)))8192 (str (##sys#make-string len)))8193 (do ((i 0 (fx+ i 1)))8194 ((fx= i len))8195 (apply proc (map (cut string-ref <> i) strs))))))))81968197(set! scheme#vector-map8198 (lambda (proc v . more)8199 (cond ((null? more)8200 (##sys#check-closure proc 'vector-map)8201 (##sys#check-vector v 'vector-map)8202 (let* ((len (##sys#size v))8203 (vec (##sys#make-vector len)))8204 (do ((i 0 (fx+ i 1)))8205 ((fx= i len) vec)8206 (##sys#setslot vec i (proc (##sys#slot v i))))))8207 (else8208 (let ((vs (cons v more)))8209 (##sys#check-closure proc 'vector-map)8210 (##sys#for-each (cut ##sys#check-vector <> 'vector-map) vs)8211 (let* ((len (foldl fxmin most-positive-fixnum (map ##sys#size vs)))8212 (vec (##sys#make-vector len)))8213 (do ((i 0 (fx+ i 1)))8214 ((fx= i len) vec)8215 (##sys#setslot vec i (apply proc (map (cut vector-ref <> i) vs))))))))))82168217(set! scheme#vector-for-each8218 (lambda (proc v . more)8219 (cond ((null? more)8220 (##sys#check-closure proc 'vector-for-each)8221 (##sys#check-vector v 'vector-for-each)8222 (let ((len (##sys#size v)))8223 (do ((i 0 (fx+ i 1)))8224 ((fx= i len))8225 (proc (##sys#slot v i)))))8226 (else8227 (let ((vs (cons v more)))8228 (##sys#check-closure proc 'vector-for-each)8229 (##sys#for-each (cut ##sys#check-vector <> 'vector-for-each) vs)8230 (let* ((len (foldl fxmin most-positive-fixnum (map ##sys#size vs)))8231 (vec (##sys#make-vector len)))8232 (do ((i 0 (fx+ i 1)))8233 ((fx= i len) vec)8234 (apply proc (map (cut vector-ref <> i) vs)))))))))82358236(set! scheme#close-port8237 (lambda (port)8238 (##sys#check-port port 'close-port)8239 (when (##core#inline "C_port_openp" port 1)8240 ((##sys#slot (##sys#slot port 2) 4) port 1))8241 (when (##core#inline "C_port_openp" port 2)8242 ((##sys#slot (##sys#slot port 2) 4) port 2))8243 (##sys#setislot port 8 0)8244 (##core#undefined)))82458246(set! scheme#call-with-port8247 (lambda (port proc)8248 (receive ret8249 (proc port)8250 (scheme#close-port port)8251 (apply values ret))))82528253(set! scheme#eof-object (lambda () #!eof))82548255(set! scheme#peek-u88256 (lambda (#!optional (port ##sys#standard-input))8257 (let ((c (peek-char port)))8258 (if (eof-object? c)8259 c8260 (let ((d (char->integer c)))8261 (if (fx< d 256)8262 d8263 (let ((bv (##sys#make-bytevector 4)))8264 (##sys#encode-char c bv (##sys#slot port 15))8265 (##core#inline "C_subbyte" bv 0))))))))82668267(set! scheme#write-string8268 (lambda (s #!optional (port ##sys#standard-output) start end)8269 (##sys#check-string s 'write-string)8270 (##sys#check-output-port port #t 'write-string)8271 (if start8272 (##sys#check-fixnum start 'write-string)8273 (set! start 0))8274 (if end8275 (##sys#check-fixnum end 'write-string)8276 (set! end (string-length s)))8277 (let* ((part (if start (substring s start end) s))8278 (bv (##sys#slot part 0))8279 (len (fx- (##sys#size bv) 1)))8280 ((##sys#slot (##sys#slot port 2) 3) ; write-bytevector8281 port bv 0 len))))828282838284;; I/O82858286(module chicken.io8287 (read-list read-buffered read-byte read-line8288 read-lines read-string read-string! read-token8289 write-byte write-line write-bytevector read-bytevector8290 read-bytevector!)82918292(import scheme chicken.base chicken.fixnum)8293(import chicken.internal.syntax)8294(import (only (scheme base) open-output-string get-output-string))829582968297;;; Read expressions from file:82988299(define read-list8300 (let ((read read))8301 (lambda (#!optional (port ##sys#standard-input) (reader read) max)8302 (##sys#check-input-port port #t 'read-list)8303 (do ((x (reader port) (reader port))8304 (i 0 (fx+ i 1))8305 (xs '() (cons x xs)))8306 ((or (eof-object? x) (and max (fx>= i max)))8307 (##sys#fast-reverse xs))))))830883098310;;; Line I/O:83118312(define read-line8313 (let ()8314 (lambda args8315 (let* ([parg (pair? args)]8316 [p (if parg (car args) ##sys#standard-input)]8317 [limit (and parg (pair? (cdr args)) (cadr args))])8318 (##sys#check-input-port p #t 'read-line)8319 (cond ((##sys#slot (##sys#slot p 2) 8) => (lambda (rl) (rl p limit)))8320 (else8321 (let* ((buffer-len (if limit limit 256))8322 (buffer (##sys#make-string buffer-len)))8323 (let loop ([i 0])8324 (if (and limit (fx>= i limit))8325 (##sys#substring buffer 0 i)8326 (let ([c (##sys#read-char-0 p)])8327 (if (eof-object? c)8328 (if (fx= i 0)8329 c8330 (##sys#substring buffer 0 i) )8331 (case c8332 [(#\newline) (##sys#substring buffer 0 i)]8333 [(#\return)8334 (let ([c (peek-char p)])8335 (if (char=? c #\newline)8336 (begin (##sys#read-char-0 p)8337 (##sys#substring buffer 0 i))8338 (##sys#substring buffer 0 i) ) ) ]8339 [else8340 (when (fx>= i buffer-len)8341 (set! buffer8342 (##sys#string-append buffer (make-string buffer-len)))8343 (set! buffer-len (fx+ buffer-len buffer-len)) )8344 (string-set! buffer i c)8345 (loop (fx+ i 1)) ] ) ) ) ) ) ) ) ) ) ) ) )83468347(define read-lines8348 (lambda (#!optional (port ##sys#standard-input) max)8349 (##sys#check-input-port port #t 'read-lines)8350 (when max (##sys#check-fixnum max 'read-lines))8351 (let loop ((lns '())8352 (n (or max most-positive-fixnum)))8353 (if (eq? n 0)8354 (##sys#fast-reverse lns)8355 (let ((ln (read-line port)))8356 (if (eof-object? ln)8357 (##sys#fast-reverse lns)8358 (loop (cons ln lns) (fx- n 1))))))))83598360(define write-line8361 (lambda (str . port)8362 (let* ((p (if (##core#inline "C_eqp" port '())8363 ##sys#standard-output8364 (##sys#slot port 0) ) ))8365 (##sys#check-output-port p #t 'write-line)8366 (##sys#check-string str 'write-line)8367 (let ((bv (##sys#slot str 0)))8368 ((##sys#slot (##sys#slot p 2) 3) ; write-bytevector8369 p8370 bv8371 08372 (fx- (##sys#size bv) 1)))8373 (##sys#write-char-0 #\newline p))))837483758376;;; Extended I/O83778378(define (read-bytevector!/port n dest port start)8379 (if (eq? n 0)8380 08381 (let ((rdbvec (##sys#slot (##sys#slot port 2) 7))) ; read-bytevector!8382 (let loop ((start start) (n n) (m 0))8383 (let ((n2 (rdbvec port n dest start)))8384 (##sys#setislot port 5 ; update port-position8385 (fx+ (##sys#slot port 5) n2))8386 (cond ((eq? n2 0) m)8387 ((or (not n) (fx< n2 n))8388 (loop (fx+ start n2) (and n (fx- n n2)) (fx+ m n2)))8389 (else (fx+ n2 m))))))))83908391(define (read-string!/port n dest port start)8392 (let ((buf (##sys#make-bytevector (fx* n 4)))8393 (enc (##sys#slot port 15)))8394 (##sys#encoding-hook8395 enc8396 (lambda (decoder _ _)8397 (define (readb n buf port p)8398 (let ((bytes (read-bytevector!/port n buf port p)))8399 (if (eq? enc 'utf-8) ; fast path, avoid copying8400 bytes8401 (decoder buf p bytes8402 (lambda (dbuf start len)8403 (##core#inline "C_copy_memory_with_offset" buf dbuf p start len)8404 len)))))8405 (define (finish un bytes left)8406 (##core#inline "C_utf_overwrite" dest start un buf bytes)8407 (fx+ un left))8408 (let loop ((p 0) (n n) (un 0) (bn 0)) ; pos, count, codepoints, total bytes8409 (let ((bytes (readb n buf port p)))8410 (cond ((eq? bytes 0) (finish un bn 0))8411 ((eq? enc 'utf-8)8412 ;; read incomplete fragments8413 ;; FIXME: hardcoded, should be encoding-specific!8414 (let recount ((bytes bytes))8415 (let* ((fc (##core#inline "C_utf_fragment_counts" buf p bytes))8416 (full (fxshr fc 4))8417 (left (fxand fc 15))8418 (total (fx+ un full))8419 (tbytes (fx+ bn bytes))8420 (remain (fx- n full)))8421 (cond ((fx> left 0)8422 (let ((b2 (readb left buf port (fx+ p bytes))))8423 (if (fx< b2 left)8424 (finish total tbytes (fx+ left b2))8425 (recount (fx+ bytes b2)))))8426 ((eq? remain 0) (finish total tbytes 0))8427 (else (loop (fx+ p bytes) remain total tbytes))))))8428 (else8429 (loop (fx+ p bytes) (fx- n bytes)8430 (fx+ un bytes) (fx+ bn bytes))))))))))84318432(define (read-string! n dest #!optional (port ##sys#standard-input) (start 0))8433 (##sys#check-input-port port #t 'read-string!)8434 (##sys#check-string dest 'read-string!)8435 (when n (##sys#check-fixnum n 'read-string!))8436 (let ((dest-size (string-length dest)))8437 (unless (and n (fx<= (fx+ start n) dest-size))8438 (set! n (fx- dest-size start))))8439 (##sys#check-fixnum start 'read-string!)8440 (read-string!/port n dest port start))84418442(define (read-bytevector! dest #!optional (port ##sys#standard-input) (start 0) end)8443 (##sys#check-input-port port #t 'read-bytevector!)8444 (##sys#check-bytevector dest 'read-bytevector!)8445 (##sys#check-fixnum start 'read-bytevector!)8446 (when end (##sys#check-fixnum end 'read-bytevector!))8447 (let* ((size (##sys#size dest))8448 (n (fx- (or end size) start)))8449 (read-bytevector!/port n dest port start)))84508451(define read-string/port8452 (lambda (n p)8453 (cond ((eq? n 0) "") ; Don't attempt to peek (fd might not be ready)8454 ((eof-object? (##sys#peek-char-0 p)) #!eof)8455 (n (let* ((str (##sys#make-string n))8456 (n2 (read-string!/port n str p 0)))8457 (if (eq? n n2)8458 str8459 (##sys#substring str 0 n2))))8460 (else8461 (##sys#read-remaining8462 p8463 (lambda (buf len)8464 (##sys#buffer->string/encoding buf 0 len8465 (##sys#slot p 15))))))))84668467(define (##sys#read-remaining p k)8468 (let ((len 1024))8469 (let loop ((buf (##sys#make-bytevector len))8470 (bsize len)8471 (pos 0))8472 (let* ((nr (fx- (##sys#size buf) pos))8473 (n (read-bytevector!/port nr buf p pos)))8474 (cond ((eq? n nr)8475 (let* ((bsize2 (fx* bsize 2))8476 (buf2 (##sys#make-bytevector bsize2)))8477 (##core#inline "C_copy_memory" buf2 buf bsize)8478 (loop buf2 bsize2 (fx+ pos n))))8479 (else (k buf (fx+ n pos))))))))84808481(define read-bytevector/port8482 (lambda (n p)8483 (let* ((bv (##sys#make-bytevector n))8484 (n2 (read-bytevector!/port n bv p 0)))8485 (if (eq? n n2)8486 bv8487 (let ((bv2 (##sys#make-bytevector n2)))8488 (##core#inline "C_copy_memory" bv2 bv n2)8489 bv2)))))84908491(define (read-string #!optional n (port ##sys#standard-input))8492 (##sys#check-input-port port #t 'read-string)8493 (when n (##sys#check-fixnum n 'read-string))8494 (read-string/port n port))84958496(define (read-bytevector #!optional n (port ##sys#standard-input))8497 (##sys#check-input-port port #t 'read-bytevector)8498 (cond (n (##sys#check-fixnum n 'read-bytevector)8499 (let ((r (read-bytevector/port n port)))8500 (if (eq? (##sys#size r) 0)8501 #!eof8502 r)))8503 (else8504 (##sys#read-remaining8505 port8506 (lambda (buf len)8507 (if (eq? len 0)8508 #!eof8509 (let ((r (##sys#make-bytevector len)))8510 (##core#inline "C_copy_memory" r buf len)8511 r)))))))851285138514;; Make internal reader procedures available for use in srfi-4.scm:85158516(define chicken.io#read-string/port read-string/port)8517(define chicken.io#read-string!/port read-string!/port)8518(define chicken.io#read-bytevector/port read-bytevector/port)8519(define chicken.io#read-bytevector!/port read-bytevector!/port)85208521(define (##sys#read-buffered-bytes port)8522 (let ((rb (##sys#slot (##sys#slot port 2) 9))) ; read-buffered method8523 (if rb8524 (rb port)8525 "")))85268527(define (read-buffered #!optional (port ##sys#standard-input)) ; DEPRECATED8528 (##sys#check-input-port port #t 'read-buffered)8529 (##sys#read-buffered-bytes port))853085318532;;; read token of characters that satisfy a predicate85338534(define read-token8535 (lambda (pred . port)8536 (let ([port (optional port ##sys#standard-input)])8537 (##sys#check-input-port port #t 'read-token)8538 (let ([out (open-output-string)])8539 (let loop ()8540 (let ([c (##sys#peek-char-0 port)])8541 (if (and (not (eof-object? c)) (pred c))8542 (begin8543 (##sys#write-char-0 (##sys#read-char-0 port) out)8544 (loop) )8545 (get-output-string out) ) ) ) ) ) ) )854685478548;;; Binary I/O85498550(define (read-byte #!optional (port ##sys#standard-input))8551 (##sys#check-input-port port #t 'read-byte)8552 (let* ((bv (##sys#make-bytevector 1))8553 (n (read-bytevector!/port 1 bv port 0)))8554 (if (fx< n 1)8555 #!eof8556 (##core#inline "C_subbyte" bv 0))))85578558(define (write-byte byte #!optional (port ##sys#standard-output))8559 (##sys#check-fixnum byte 'write-byte)8560 (##sys#check-output-port port #t 'write-byte)8561 (let ((bv (##sys#make-bytevector 1 byte)))8562 ((##sys#slot (##sys#slot port 2) 3) ; write-bytevector8563 port bv 0 1)))85648565(define (write-bytevector bv #!optional (port ##sys#standard-output) (start 0)8566 end)8567 (##sys#check-bytevector bv 'write-bytevector)8568 (##sys#check-output-port port #t 'write-bytevector)8569 (##sys#check-fixnum start 'write-bytevector)8570 (let ((len (##sys#size bv)))8571 (##sys#check-range/including start 0 len 'write-bytevector)8572 (when end (##sys#check-range/including end 0 len 'write-bytevector))8573 (let ((end (if end (fxmin end len) len)))8574 ((##sys#slot (##sys#slot port 2) 3) ; write-bytevector8575 port bv start end))))85768577) ; module chicken.io