From bddb0b2b7e130d5766d695bc7e0da1e03605c112 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Mon, 11 Sep 2017 18:35:10 +0200 Subject: [PATCH] Add priliminary version of (chicken base) module This is a primitive module because it has several syntax exports. We first define the module containing mostly stub definitions which are set! further down in the file. This ensures we won't have to import the module into itself, which will result in strange/unexpected errors. There's one hack: at the end of library.scm, we define a few toplevel aliases for procedures that are supposed to be in the default macro namespace. Without this, we'd need (import-for-syntax chicken.base) in practically every low-level macro use. We will need to find out why this is needed, and take better control over what's available in the initial macro environment. --- README | 1 + c-platform.scm | 61 ++++--- chicken-syntax.scm | 289 ++++++++++++++++-------------- chicken.base.import.scm | 75 ++++++++ chicken.import.scm | 95 +++++----- defaults.make | 3 +- distribution/manifest | 2 + expand.scm | 10 +- library.scm | 447 +++++++++++++++++++++++++++------------------- modules.scm | 25 +-- tests/scrutiny-2.expected | 8 +- tests/scrutiny.expected | 16 +- types.db | 260 ++++++++++++++------------- 13 files changed, 751 insertions(+), 541 deletions(-) create mode 100644 chicken.base.import.scm diff --git a/README b/README index 6ee15437..54641e04 100644 --- a/README +++ b/README @@ -284,6 +284,7 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/ | |-- chicken | | `-- 9 | | |-- chicken.import.so + | | |-- chicken.base.import.so | | |-- chicken.bitwise.import.so | | |-- chicken.blob.import.so | | |-- chicken.compiler.user-pass.import.so diff --git a/c-platform.scm b/c-platform.scm index b01b6edb..a4e932fa 100644 --- a/c-platform.scm +++ b/c-platform.scm @@ -61,7 +61,7 @@ (bound-to-procedure ##sys#for-each ##sys#map ##sys#print ##sys#setter ##sys#setslot ##sys#dynamic-wind ##sys#call-with-values - ##sys#start-timer ##sys#stop-timer ##sys#gcd ##sys#lcm ##sys#make-promise ##sys#structure? ##sys#slot + ##sys#start-timer ##sys#stop-timer ##sys#gcd ##sys#lcm ##sys#structure? ##sys#slot ##sys#allocate-vector ##sys#list->vector ##sys#block-ref ##sys#block-set! ##sys#list ##sys#cons ##sys#append ##sys#vector ##sys#foreign-char-argument ##sys#foreign-fixnum-argument ##sys#foreign-flonum-argument ##sys#error ##sys#peek-c-string ##sys#peek-nonnull-c-string @@ -76,8 +76,8 @@ ##sys#profile-entry ##sys#profile-exit) ) ) ) (define default-units '(library eval)) -(define default-imports '(scheme chicken)) -(define default-syntax-imports '(scheme chicken)) +(define default-imports '(scheme chicken chicken.base)) +(define default-syntax-imports '(scheme chicken chicken.base)) (define words-per-flonum 4) @@ -134,7 +134,7 @@ char-lower-case? char-upper-case? char-upcase char-downcase string? string=? string>? string=? string<=? string-ci=? string-ci? string-ci<=? string-ci>=? string-append string->list list->string vector? vector->list list->vector string read - read-char substring string-fill! vector-fill! make-string make-vector open-input-file + read-char substring string-fill! vector-copy! vector-fill! make-string make-vector open-input-file open-output-file call-with-input-file call-with-output-file close-input-port close-output-port values call-with-values vector procedure? memq memv member assq assv assoc list-tail list-ref abs char-ready? peek-char list->string string->list @@ -153,16 +153,29 @@ fxrem fxshl fxshr fxxor))) (define-constant +extended-bindings+ - '(bignum? cplxnum? fixnum? flonum? ratnum? + '(chicken.base#bignum? chicken.base#cplxnum? chicken.base#fixnum? + chicken.base#flonum? chicken.base#ratnum? + chicken.base#add1 chicken.base#sub1 + chicken.base#nan? chicken.base#finite? chicken.base#infinite? + chicken.base#gensym + chicken.base#void chicken.base#print chicken.base#print* + chicken.base#error chicken.base#call/cc chicken.base#char-name + chicken.base#current-error-port + chicken.base#symbol-append chicken.base#foldl chicken.base#foldr + chicken.base#setter chicken.base#getter-with-setter + chicken.bitwise#integer-length chicken.bitwise#bitwise-and chicken.bitwise#bitwise-not chicken.bitwise#bitwise-ior chicken.bitwise#bitwise-xor chicken.bitwise#arithmetic-shift chicken.bitwise#bit->boolean - add1 sub1 exact-integer? nan? finite? infinite? - void flush-output print print* error call/cc chicken.blob#blob-size - identity chicken.blob#blob=? equal=? make-polar make-rectangular - real-part imag-part string->symbol symbol-append foldl foldr setter - current-error-port current-thread chicken.keyword#get-keyword + + chicken.blob#blob-size + chicken.blob#blob=? equal=? + + exact-integer? flush-output make-polar make-rectangular + real-part imag-part string->symbol current-thread + + chicken.keyword#get-keyword srfi-4#u8vector-length srfi-4#s8vector-length srfi-4#u16vector-length srfi-4#s16vector-length srfi-4#u32vector-length srfi-4#u64vector-length @@ -205,9 +218,9 @@ chicken.memory#pointer-u16-set! chicken.memory#pointer-s16-set! chicken.memory#pointer-u32-set! chicken.memory#pointer-s32-set! chicken.memory#pointer-f32-set! chicken.memory#pointer-f64-set! - chicken.data-structures#o chicken.string#substring-index chicken.string#substring-index-ci chicken.string#substring=? chicken.string#substring-ci=? + chicken.data-structures#identity chicken.data-structures#o chicken.data-structures#atom? chicken.data-structures#alist-ref chicken.data-structures#rassoc chicken.io#read-string chicken.format#format @@ -236,7 +249,7 @@ ##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#void ##sys#foreign-ranged-integer-argument ##sys#foreign-unsigned-ranged-integer-argument ##sys#peek-fixnum ##sys#setislot ##sys#poke-integer ##sys#permanent? ##sys#values ##sys#poke-double - ##sys#intern-symbol ##sys#make-symbol ##sys#null-pointer? ##sys#peek-byte + ##sys#intern-symbol ##sys#null-pointer? ##sys#peek-byte ##sys#file-exists? ##sys#substring-index ##sys#substring-index-ci ##sys#lcm ##sys#gcd)) (for-each @@ -268,8 +281,8 @@ (make-node '##core#inline_allocate (list aiop 36) (list (car callargs) (qnode 1)))))))) - (rewrite 'add1 8 (op1 "C_fixnum_increase" "C_u_fixnum_increase" "C_s_a_i_plus")) - (rewrite 'sub1 8 (op1 "C_fixnum_decrease" "C_u_fixnum_decrease" "C_s_a_i_minus"))) + (rewrite 'chicken.base#add1 8 (op1 "C_fixnum_increase" "C_u_fixnum_increase" "C_s_a_i_plus")) + (rewrite 'chicken.base#sub1 8 (op1 "C_fixnum_decrease" "C_u_fixnum_decrease" "C_s_a_i_minus"))) (let () (define (eqv?-id db classargs cont callargs) @@ -489,15 +502,15 @@ (rewrite 'rational? 2 1 "C_i_rationalp" #t) (rewrite 'real? 2 1 "C_i_realp" #t) (rewrite 'integer? 2 1 "C_i_integerp" #t) -(rewrite 'exact-integer? 2 1 "C_i_exact_integerp" #t) -(rewrite 'flonum? 2 1 "C_i_flonump" #t) -(rewrite 'fixnum? 2 1 "C_fixnump" #t) -(rewrite 'bignum? 2 1 "C_i_bignump" #t) -(rewrite 'cplxnum? 2 1 "C_i_cplxnump" #t) -(rewrite 'ratnum? 2 1 "C_i_ratnump" #t) -(rewrite 'nan? 2 1 "C_i_nanp" #f) -(rewrite 'finite? 2 1 "C_i_finitep" #f) -(rewrite 'infinite? 2 1 "C_i_infinitep" #f) +(rewrite 'chicken.base#exact-integer? 2 1 "C_i_exact_integerp" #t) +(rewrite 'chicken.base#flonum? 2 1 "C_i_flonump" #t) +(rewrite 'chicken.base#fixnum? 2 1 "C_fixnump" #t) +(rewrite 'chicken.base#bignum? 2 1 "C_i_bignump" #t) +(rewrite 'chicken.base#cplxnum? 2 1 "C_i_cplxnump" #t) +(rewrite 'chicken.base#ratnum? 2 1 "C_i_ratnump" #t) +(rewrite 'chicken.base#nan? 2 1 "C_i_nanp" #f) +(rewrite 'chicken.base#finite? 2 1 "C_i_finitep" #f) +(rewrite 'chicken.base#infinite? 2 1 "C_i_infinitep" #f) (rewrite 'chicken.flonum#fpinteger? 2 1 "C_u_i_fpintegerp" #f) (rewrite '##sys#pointer? 2 1 "C_anypointerp" #t) (rewrite 'pointer? 2 1 "C_i_safe_pointerp" #t) @@ -958,7 +971,7 @@ '##core#call (list #t) (list val cont (qnode #f)) ) ) ) ) ) ) ) ) ) ) ) ) (rewrite 'call-with-current-continuation 8 rewrite-call/cc) - (rewrite 'call/cc 8 rewrite-call/cc) ) + (rewrite 'chicken.base#call/cc 8 rewrite-call/cc) ) (define setter-map '((car . set-car!) diff --git a/chicken-syntax.scm b/chicken-syntax.scm index c951d467..740ac4ac 100644 --- a/chicken-syntax.scm +++ b/chicken-syntax.scm @@ -261,9 +261,9 @@ (##sys#macro-subset me0 ##sys#default-macro-environment))) -;;; Other non-standard macros: +;;; Non-standard macros that provide core/"base" functionality: -(define ##sys#chicken-macro-environment +(set! ##sys#chicken.base-macro-environment (let ((me0 (##sys#macro-environment))) (##sys#extend-macro-environment @@ -288,8 +288,8 @@ plain-name)) (slots (cddr x)) (%define (r 'define)) - (%setter (r 'setter)) - (%getter-with-setter (r 'getter-with-setter)) + (%setter (r 'chicken.base#setter)) + (%getter-with-setter (r 'chicken.base#getter-with-setter)) (slotnames (map (lambda (slot) (cond ((symbol? slot) slot) @@ -366,20 +366,6 @@ (##core#lambda ,vars ,@rest)) ) ) ) ) ))) (##sys#extend-macro-environment - 'time '() - (##sys#er-transformer - (lambda (form r c) - (let ((rvar (r 't))) - `(##core#begin - (##sys#start-timer) - (##sys#call-with-values - (##core#lambda () ,@(cdr form)) - (##core#lambda - ,rvar - (##sys#display-times (##sys#stop-timer)) - (##sys#apply ##sys#values ,rvar) ) ) ) ) ) ) ) - -(##sys#extend-macro-environment 'declare '() (##sys#er-transformer (lambda (form r c) @@ -400,49 +386,6 @@ `(##core#include ,(cadr form) ,##sys#current-source-filename)))) (##sys#extend-macro-environment - 'assert '() - (##sys#er-transformer - (let ((string-append string-append)) - (lambda (form r c) - (##sys#check-syntax 'assert form '#(_ 1)) - (let* ((exp (cadr form)) - (msg-and-args (cddr form)) - (msg (optional msg-and-args "assertion failed")) - (tmp (r 'tmp))) - (when (string? msg) - (and-let* ((ln (chicken.syntax#get-line-number form))) - (set! msg (string-append "(" ln ") " msg)))) - `(##core#let ((,tmp ,exp)) - (##core#if (##core#check ,tmp) - ,tmp - (##sys#error - ,msg - ,@(if (pair? msg-and-args) - (cdr msg-and-args) - `((##core#quote ,(chicken.syntax#strip-syntax exp)))))))))))) - -(##sys#extend-macro-environment - 'ensure - '() - (##sys#er-transformer - (lambda (form r c) - (##sys#check-syntax 'ensure form '#(_ 3)) - (let ((pred (cadr form)) - (exp (caddr form)) - (args (cdddr form)) - (tmp (r 'tmp))) - `(##core#let - ([,tmp ,exp]) - (##core#if (##core#check (,pred ,tmp)) - ,tmp - (##sys#signal-hook - #:type-error - ,@(if (pair? args) - args - `((##core#immutable (##core#quote "argument has incorrect type")) - ,tmp (##core#quote ,pred)) ) ) ) ) ) ) ) ) - -(##sys#extend-macro-environment 'fluid-let '() (##sys#er-transformer (lambda (form r c) @@ -475,33 +418,6 @@ (##core#undefined) ) ) ) ) ))) (##sys#extend-macro-environment - 'eval-when '() - (##sys#er-transformer - (lambda (form r compare) - (##sys#check-syntax 'eval-when form '#(_ 2)) - (let* ((situations (cadr form)) - (body `(##core#begin ,@(cddr form))) - (e #f) - (c #f) - (l #f)) - (let loop ((ss situations)) - (if (pair? ss) - (let ((s (car ss))) - (cond ((compare s 'eval) (set! e #t)) - ((compare s 'load) (set! l #t)) - ((compare s 'compile) (set! c #t)) - (else (##sys#error "invalid situation specifier" (car ss)))) - (loop (cdr ss))))) - (if (memq '#:compiling ##sys#features) - (cond ((and c l) `(##core#compiletimetoo ,body)) - (c `(##core#compiletimeonly ,body)) - (l body) - (else '(##core#undefined))) - (if e - body - '(##core#undefined))))))) - -(##sys#extend-macro-environment 'parameterize '() (##sys#er-transformer (lambda (form r c) @@ -739,42 +655,6 @@ `(##core#let ((,var ,(cadr b))) (##core#if ,var ,(fold bs2) #f) ) ) ] ) ) ) ) ) ) ) ) -(##sys#extend-macro-environment - 'select '() - (##sys#er-transformer - (lambda (form r c) - (##sys#check-syntax 'select form '(_ _ . _)) - (let ((exp (cadr form)) - (body (cddr form)) - (tmp (r 'tmp)) - (%else (r 'else)) - (%or (r 'or))) - `(##core#let - ((,tmp ,exp)) - ,(let expand ((clauses body) (else? #f)) - (cond ((null? clauses) - '(##core#undefined) ) - ((not (pair? clauses)) - (chicken.syntax#syntax-error 'select "invalid syntax" clauses)) - (else - (let ((clause (##sys#slot clauses 0)) - (rclauses (##sys#slot clauses 1)) ) - (##sys#check-syntax 'select clause '#(_ 1)) - (cond ((c %else (car clause)) - (expand rclauses #t) - `(##core#begin ,@(cdr clause)) ) - (else? - (##sys#notice - "non-`else' clause following `else' clause in `select'" - (chicken.syntax#strip-syntax clause)) - (expand rclauses #t) - '(##core#begin)) - (else - `(##core#if - (,%or ,@(map (lambda (x) `(##sys#eqv? ,tmp ,x)) - (car clause) ) ) - (##core#begin ,@(cdr clause)) - ,(expand rclauses #f) ) ) ) ) ) ) ) ) ) ) ) ) ;;; Optional argument handling: @@ -1106,7 +986,7 @@ (##sys#extend-macro-environment 'define-record-type - `((getter-with-setter . ,(##sys#primitive-alias 'getter-with-setter))) + `() (##sys#er-transformer (lambda (form r c) (##sys#check-syntax @@ -1124,7 +1004,7 @@ (pred (cadddr form)) (slots (cddddr form)) (%define (r 'define)) - (%getter-with-setter (r 'getter-with-setter)) + (%getter-with-setter (r 'chicken.base#getter-with-setter)) (vars (cdr conser)) (x (r 'x)) (y (r 'y)) @@ -1276,6 +1156,151 @@ ,(car head)) `(##core#letrec* ((,head ,@(cddr form))) ,head)))))) +;;; use + +(##sys#extend-macro-environment + 'use '() + (##sys#er-transformer + (lambda (x r c) + (##sys#check-syntax 'use x '(_ . #(_ 0))) + `(,(r 'require-extension) ,@(cdr x))))) + +(##sys#extend-macro-environment + 'require-extension + '() + (##sys#er-transformer + (lambda (x r c) + `(,(r 'import) ,@(cdr x))))) + +(##sys#macro-subset me0 ##sys#default-macro-environment))) + + +;;; Remaining non-standard macros: + +(set! ##sys#chicken-macro-environment + (let ((me0 (##sys#macro-environment))) + +(##sys#extend-macro-environment + 'time '() + (##sys#er-transformer + (lambda (form r c) + (let ((rvar (r 't))) + `(##core#begin + (##sys#start-timer) + (##sys#call-with-values + (##core#lambda () ,@(cdr form)) + (##core#lambda + ,rvar + (##sys#display-times (##sys#stop-timer)) + (##sys#apply ##sys#values ,rvar) ) ) ) ) ) ) ) + +(##sys#extend-macro-environment + 'assert '() + (##sys#er-transformer + (let ((string-append string-append)) + (lambda (form r c) + (##sys#check-syntax 'assert form '#(_ 1)) + (let* ((exp (cadr form)) + (msg-and-args (cddr form)) + (msg (optional msg-and-args "assertion failed")) + (tmp (r 'tmp))) + (when (string? msg) + (and-let* ((ln (chicken.syntax#get-line-number form))) + (set! msg (string-append "(" ln ") " msg)))) + `(##core#let ((,tmp ,exp)) + (##core#if (##core#check ,tmp) + ,tmp + (##sys#error + ,msg + ,@(if (pair? msg-and-args) + (cdr msg-and-args) + `((##core#quote ,(chicken.syntax#strip-syntax exp)))))))))))) + +(##sys#extend-macro-environment + 'ensure + '() + (##sys#er-transformer + (lambda (form r c) + (##sys#check-syntax 'ensure form '#(_ 3)) + (let ((pred (cadr form)) + (exp (caddr form)) + (args (cdddr form)) + (tmp (r 'tmp))) + `(##core#let + ([,tmp ,exp]) + (##core#if (##core#check (,pred ,tmp)) + ,tmp + (##sys#signal-hook + #:type-error + ,@(if (pair? args) + args + `((##core#immutable (##core#quote "argument has incorrect type")) + ,tmp (##core#quote ,pred)) ) ) ) ) ) ) ) ) + +(##sys#extend-macro-environment + 'eval-when '() + (##sys#er-transformer + (lambda (form r compare) + (##sys#check-syntax 'eval-when form '#(_ 2)) + (let* ((situations (cadr form)) + (body `(##core#begin ,@(cddr form))) + (e #f) + (c #f) + (l #f)) + (let loop ((ss situations)) + (if (pair? ss) + (let ((s (car ss))) + (cond ((compare s 'eval) (set! e #t)) + ((compare s 'load) (set! l #t)) + ((compare s 'compile) (set! c #t)) + (else (##sys#error "invalid situation specifier" (car ss)))) + (loop (cdr ss))))) + (if (memq '#:compiling ##sys#features) + (cond ((and c l) `(##core#compiletimetoo ,body)) + (c `(##core#compiletimeonly ,body)) + (l body) + (else '(##core#undefined))) + (if e + body + '(##core#undefined))))))) + +(##sys#extend-macro-environment + 'select '() + (##sys#er-transformer + (lambda (form r c) + (##sys#check-syntax 'select form '(_ _ . _)) + (let ((exp (cadr form)) + (body (cddr form)) + (tmp (r 'tmp)) + (%else (r 'else)) + (%or (r 'or))) + `(##core#let + ((,tmp ,exp)) + ,(let expand ((clauses body) (else? #f)) + (cond ((null? clauses) + '(##core#undefined) ) + ((not (pair? clauses)) + (chicken.syntax#syntax-error 'select "invalid syntax" clauses)) + (else + (let ((clause (##sys#slot clauses 0)) + (rclauses (##sys#slot clauses 1)) ) + (##sys#check-syntax 'select clause '#(_ 1)) + (cond ((c %else (car clause)) + (expand rclauses #t) + `(##core#begin ,@(cdr clause)) ) + (else? + (##sys#notice + "non-`else' clause following `else' clause in `select'" + (chicken.syntax#strip-syntax clause)) + (expand rclauses #t) + '(##core#begin)) + (else + `(##core#if + (,%or ,@(map (lambda (x) `(##sys#eqv? ,tmp ,x)) + (car clause) ) ) + (##core#begin ,@(cdr clause)) + ,(expand rclauses #f) ) ) ) ) ) ) ) ) ) ) ) ) + ;;; Definitions available at macroexpansion-time: @@ -1288,15 +1313,6 @@ (,(r 'define) ,@(cdr form)))))) -;;; use - -(##sys#extend-macro-environment - 'use '() - (##sys#er-transformer - (lambda (x r c) - (##sys#check-syntax 'use x '(_ . #(_ 0))) - `(,(r 'require-extension) ,@(cdr x))))) - (##sys#extend-macro-environment 'use-for-syntax '() (##sys#er-transformer @@ -1324,9 +1340,10 @@ ;; capture current macro env and add all the preceding ones as well -;; TODO: omit `chicken.{condition,type}-m-e' when plain "chicken" module goes away +;; TODO: omit `chicken.{base,condition,type}-m-e' when plain "chicken" module goes away (append ##sys#chicken.condition-macro-environment ##sys#chicken.type-macro-environment + ##sys#chicken.base-macro-environment (##sys#macro-subset me0 ##sys#default-macro-environment)))) ;; register features diff --git a/chicken.base.import.scm b/chicken.base.import.scm new file mode 100644 index 00000000..2f9118b3 --- /dev/null +++ b/chicken.base.import.scm @@ -0,0 +1,75 @@ +;;;; chicken.base.import.scm - import library for "chicken.base" module +; +; Copyright (c) 2017, The CHICKEN Team +; All rights reserved. +; +; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following +; conditions are met: +; +; Redistributions of source code must retain the above copyright notice, this list of conditions and the following +; disclaimer. +; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following +; disclaimer in the documentation and/or other materials provided with the distribution. +; Neither the name of the author nor the names of its contributors may be used to endorse or promote +; products derived from this software without specific prior written permission. +; +; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS +; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR +; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +; POSSIBILITY OF SUCH DAMAGE. + +(##sys#register-core-module + 'chicken.base + 'library + '((add1 . chicken.base#add1) + (bignum? . chicken.base#bignum?) + (call/cc . chicken.base#call/cc) + (char-name . chicken.base#char-name) + (cplxnum? . chicken.base#cplxnum?) + (current-error-port . chicken.base#current-error-port) + (enable-warnings . chicken.base#enable-warnings) + (equal=? . chicken.base#equal=?) + (error . chicken.base#error) + (exact-integer? . chicken.base#exact-integer?) + (exact-integer-sqrt . chicken.base#exact-integer-sqrt) + (exact-integer-nth-root . chicken.base#exact-integer-nth-root) + (finite? . chicken.base#finite?) + (fixnum? . chicken.base#fixnum?) + (flonum? . chicken.base#flonum?) + (foldl . chicken.base#foldl) + (foldr . chicken.base#foldr) + (gensym . chicken.base#gensym) + (get-call-chain . chicken.base#get-call-chain) + (getter-with-setter . chicken.base#getter-with-setter) + (infinite? . chicken.base#infinite?) + (make-parameter . chicken.base#make-parameter) + (make-promise . chicken.base#make-promise) + (nan? . chicken.base#nan?) + (notice . chicken.base#notice) + (print . chicken.base#print) + (print-call-chain . chicken.base#print-call-chain) + (print* . chicken.base#print*) + (procedure-information . chicken.base#procedure-information) + (promise? . chicken.base#promise?) + (quotient&modulo . chicken.base#quotient&modulo) + (quotient&remainder . chicken.base#quotient&remainder) + (ratnum? . chicken.base#ratnum?) + (setter . chicken.base#setter) + (signum . chicken.base#signum) + (string->uninterned-symbol . chicken.base#string->uninterned-symbol) + (sub1 . chicken.base#sub1) + (subvector . chicken.base#subvector) + (symbol-append . chicken.base#symbol-append) + (vector-copy! . chicken.base#vector-copy!) + (vector-resize . chicken.base#vector-resize) + (void . chicken.base#void) + (warning . chicken.base#warning)) + ;; OBSOLETE: This can be removed after bootstrapping + (if (##sys#symbol-has-toplevel-binding? '##sys#chicken.base-macro-environment) + ##sys#chicken.base-macro-environment + ##sys#chicken-macro-environment)) diff --git a/chicken.import.scm b/chicken.import.scm index ad4b677f..678937e5 100644 --- a/chicken.import.scm +++ b/chicken.import.scm @@ -33,17 +33,25 @@ (set! chicken.syntax#syntax-error chicken.expand#syntax-error) (set! chicken.syntax#get-line-number chicken.expand#get-line-number))) +;; OBSOLETE: This can be removed after bootstrapping (needed for +;; macros and constant evaluation in compiler) +(if (not (##sys#symbol-has-toplevel-binding? 'chicken.base#add1)) + (begin + (set! chicken.base#add1 add1) + (set! chicken.base#sub1 sub1) + (set! chicken.base#symbol-append symbol-append))) + (##sys#register-primitive-module 'chicken '((abort . chicken.condition#abort) - add1 + (add1 . chicken.base#add1) argc+argv argv - bignum? + (bignum? . chicken.base#bignum?) (build-platform . chicken.platform#build-platform) - call/cc + (call/cc . chicken.base#call/cc) case-sensitive - char-name + (char-name . chicken.base#char-name) (chicken-home . chicken.platform#chicken-home) (chicken-version . chicken.platform#chicken-version) command-line-arguments @@ -51,21 +59,21 @@ (condition-property-accessor . chicken.condition#condition-property-accessor) (condition? . chicken.condition#condition?) (condition->list . chicken.condition#condition->list) - cplxnum? - current-error-port + (cplxnum? . chicken.base#cplxnum?) + (current-error-port . chicken.base#current-error-port) (current-exception-handler . chicken.condition#current-exception-handler) delete-file directory-exists? (dynamic-load-libraries . chicken.load#dynamic-load-libraries) - enable-warnings - equal=? + (enable-warnings . chicken.base#enable-warnings) + (equal=? . chicken.base#equal=?) (er-macro-transformer . chicken.syntax#er-macro-transformer) errno - error + (error . chicken.base#error) (eval-handler . chicken.eval#eval-handler) - exact-integer? - exact-integer-sqrt - exact-integer-nth-root + (exact-integer? . chicken.base#exact-integer?) + (exact-integer-sqrt . chicken.base#exact-integer-sqrt) + (exact-integer-nth-root . chicken.base#exact-integer-nth-root) executable-pathname exit exit-handler @@ -73,14 +81,14 @@ (feature? . chicken.platform#feature?) (features . chicken.platform#features) file-exists? - finite? + (finite? . chicken.base#finite?) (fixnum-bits . chicken.fixnum#fixnum-bits) (fixnum-precision . chicken.fixnum#fixnum-precision) - fixnum? - flonum? + (fixnum? . chicken.base#fixnum?) + (flonum? . chicken.base#flonum?) flush-output - foldl - foldr + (foldl . chicken.base#foldl) + (foldr . chicken.base#foldr) force-finalizers (fx- . chicken.fixnum#fx-) (fx* . chicken.fixnum#fx*) @@ -107,15 +115,15 @@ (fxshr . chicken.fixnum#fxshr) (fxxor . chicken.fixnum#fxxor) (fxlen . chicken.fixnum#fxlen) - gensym - get-call-chain + (gensym . chicken.base#gensym) + (get-call-chain . chicken.base#get-call-chain) (get-condition-property . chicken.condition#get-condition-property) get-environment-variable (get-line-number . chicken.syntax#get-line-number) get-output-string - getter-with-setter + (getter-with-setter . chicken.base#getter-with-setter) implicit-exit-handler - infinite? + (infinite? . chicken.base#infinite?) input-port-open? (installation-repository . chicken.platform#installation-repository) (ir-macro-transformer . chicken.syntax#ir-macro-transformer) @@ -127,13 +135,13 @@ (machine-byte-order . chicken.platform#machine-byte-order) (machine-type . chicken.platform#machine-type) (make-composite-condition . chicken.condition#make-composite-condition) - make-parameter - make-promise + (make-parameter . chicken.base#make-parameter) + (make-promise . chicken.base#make-promise) (make-property-condition . chicken.condition#make-property-condition) (most-negative-fixnum . chicken.fixnum#most-negative-fixnum) (most-positive-fixnum . chicken.fixnum#most-positive-fixnum) - nan? - notice + (nan? . chicken.base#nan?) + (notice . chicken.base#notice) on-exit open-input-string open-output-string @@ -145,40 +153,39 @@ port? (provide . chicken.load#provide) (provided? . chicken.load#provided?) - print - print-call-chain - print* - procedure-information + (print . chicken.base#print) + (print-call-chain . chicken.base#print-call-chain) + (print* . chicken.base#print*) + (procedure-information . chicken.base#procedure-information) program-name - promise? - quotient&modulo - quotient&remainder - ratnum? + (promise? . chicken.base#promise?) + (quotient&modulo . chicken.base#quotient&modulo) + (quotient&remainder . chicken.base#quotient&remainder) + (ratnum? . chicken.base#ratnum?) (register-feature! . chicken.platform#register-feature!) rename-file (repository-path . chicken.platform#repository-path) (require . chicken.load#require) return-to-host set-port-name! - setter + (setter . chicken.base#setter) (signal . chicken.condition#signal) - signum - singlestep + (signum . chicken.base#signum) sleep (software-type . chicken.platform#software-type) (software-version . chicken.platform#software-version) - string->uninterned-symbol + (string->uninterned-symbol . chicken.base#string->uninterned-symbol) (strip-syntax . chicken.syntax#strip-syntax) - sub1 - subvector - symbol-append + (sub1 . chicken.base#sub1) + (subvector . chicken.base#subvector) + (symbol-append . chicken.base#symbol-append) symbol-escape (syntax-error . chicken.syntax#syntax-error) system (unregister-feature! . chicken.platform#unregister-feature!) - vector-resize - vector-copy! - void - warning + (vector-copy! . chicken.base#vector-copy!) + (vector-resize . chicken.base#vector-resize) + (void . chicken.base#void) + (warning . chicken.base#warning) (with-exception-handler . chicken.condition#with-exception-handler)) ##sys#chicken-macro-environment) ;XXX incorrect - won't work in compiled executable that does expansion diff --git a/defaults.make b/defaults.make index 88ba514c..741bb6a9 100644 --- a/defaults.make +++ b/defaults.make @@ -263,7 +263,8 @@ CHICKEN_PROGRAM_OPTIONS += $(if $(PROFILE_OBJECTS),-profile) # import libraries -PRIMITIVE_IMPORT_LIBRARIES = chicken chicken.condition chicken.csi chicken.foreign +PRIMITIVE_IMPORT_LIBRARIES = chicken chicken.base chicken.condition \ + chicken.csi chicken.foreign DYNAMIC_IMPORT_LIBRARIES = srfi-4 DYNAMIC_CHICKEN_IMPORT_LIBRARIES = bitwise blob errno file.posix \ fixnum flonum format gc io keyword load locative memory \ diff --git a/distribution/manifest b/distribution/manifest index 7e4436f2..6251b3f1 100644 --- a/distribution/manifest +++ b/distribution/manifest @@ -264,6 +264,8 @@ chicken-syntax.c common-declarations.scm chicken.import.scm chicken.import.c +chicken.base.import.scm +chicken.base.import.c chicken.bitwise.import.scm chicken.bitwise.import.c chicken.blob.import.scm diff --git a/expand.scm b/expand.scm index 9e51a41c..1c66a01f 100644 --- a/expand.scm +++ b/expand.scm @@ -173,7 +173,8 @@ (define ##sys#chicken-macro-environment '()) ; used later in chicken.import.scm (define ##sys#chicken-ffi-macro-environment '()) ; used later in foreign.import.scm (define ##sys#chicken.condition-macro-environment '()) ; used later in chicken.condition.import.scm -(define ##sys#chicken.type-macro-environment '()) ; used later in chicken.condition.import.scm +(define ##sys#chicken.type-macro-environment '()) ; used later in chicken.type.import.scm +(define ##sys#chicken.base-macro-environment '()) ; used later in chicken.base.import.scm (define (##sys#ensure-transformer t #!optional loc) (cond ((procedure? t) (##sys#slot (##sys#er-transformer t) 1)) ; DEPRECATED @@ -1620,13 +1621,6 @@ (cdr x)))))) (##sys#extend-macro-environment - 'require-extension - '() - (##sys#er-transformer - (lambda (x r c) - `(,(r 'import) ,@(cdr x))))) - -(##sys#extend-macro-environment 'require-extension-for-syntax '() (##sys#er-transformer diff --git a/library.scm b/library.scm index d190fd03..26d2f27d 100644 --- a/library.scm +++ b/library.scm @@ -178,6 +178,135 @@ signal_debug_event(C_word mode, C_word msg, C_word args) EOF ) ) +;; Pre-declaration of chicken.base, so it can be used later on. Many +;; declarations will be set! further down in this file, mostly to +;; avoid a cyclic dependency on itself (only pure Scheme and core +;; language operations are allowed in here). Also, this declaration +;; is incomplete: the module itself is defined as a primitive module +;; due to syntax exports, which are missing here. +(module chicken.base + (;; [syntax] and-let* case-lambda cut cute declare define-constant + ;; define-inline define-record define-record-type + ;; define-record-printer define-values fluid-let include + ;; include-relative let-optionals let-values let*-values + ;; letrec-values nth-value optional parameterize rec receive + ;; set!-values unless when use require-library require-extension + bignum? flonum? fixnum? ratnum? cplxnum? finite? infinite? nan? + exact-integer? exact-integer-sqrt exact-integer-nth-root + + get-call-chain print print* add1 sub1 call/cc + current-error-port error void gensym print-call-chain + make-promise promise? char-name enable-warnings + equal=? finite? foldl foldr getter-with-setter make-parameter + notice procedure-information setter signum string->uninterned-symbol + subvector symbol-append vector-copy! vector-resize + warning quotient&remainder quotient&modulo + ;; TODO: Move from data-structures.scm: + ;; alist-ref alist-update alist-update! rassoc atom? butlast chop + ;; compress flatten intersperse join list-of? tail? constantly + ;; complement compose conjoin disjoin each flip identity o + ) + +(import scheme) + +(define (fixnum? x) (##core#inline "C_fixnump" x)) +(define (flonum? x) (##core#inline "C_i_flonump" x)) +(define (bignum? x) (##core#inline "C_i_bignump" x)) +(define (ratnum? x) (##core#inline "C_i_ratnump" x)) +(define (cplxnum? x) (##core#inline "C_i_cplxnump" x)) +(define (exact-integer? x) (##core#inline "C_i_exact_integerp" x)) +(define exact-integer-sqrt) +(define exact-integer-nth-root) + +(define quotient&remainder (##core#primitive "C_quotient_and_remainder")) +;; Modulo's sign follows y (whereas remainder's sign follows x) +;; Inlining this is not much use: quotient&remainder is primitive +(define (quotient&modulo x y) + (call-with-values (lambda () (quotient&remainder x y)) + (lambda (div rem) + (if (positive? y) + (if (negative? rem) + (values div (+ rem y)) + (values div rem)) + (if (positive? rem) + (values div (+ rem y)) + (values div rem)))))) + + +(define (finite? x) (##core#inline "C_i_finitep" x)) +(define (infinite? x) (##core#inline "C_i_infinitep" x)) +(define (nan? x) (##core#inline "C_i_nanp" x)) + +(define signum (##core#primitive "C_signum")) + +(define equal=?) +(define get-call-chain) +(define print-call-chain) +(define print) +(define print*) +(define (add1 n) (+ n 1)) +(define (sub1 n) (- n 1)) +(define current-error-port) + +(define (error . args) + (if (pair? args) + (apply ##sys#signal-hook #:error args) + (##sys#signal-hook #:error #f))) + +(define (void . _) (##core#undefined)) + +(define call/cc) +(define char-name) +(define enable-warnings) +; (define enable-notices)??? +(define getter-with-setter) +(define make-parameter) +(define procedure-information) +(define setter) +(define string->uninterned-symbol) + +(define gensym) + +(define vector-copy!) +(define subvector) +(define vector-resize) + +(define symbol-append) +(define warning) +(define notice) + +;;; Promises: + +(define (promise? x) + (##sys#structure? x 'promise) ) + +(define (##sys#make-promise proc) + (##sys#make-structure 'promise proc)) + +(define (make-promise obj) + (if (promise? obj) obj + (##sys#make-promise (lambda () obj)))) + +;;; fast folds with correct argument order + +(define (foldl f z lst) + (##sys#check-list lst 'foldl) + (let loop ((lst lst) (z z)) + (if (not (pair? lst)) + z + (loop (##sys#slot lst 1) (f z (##sys#slot lst 0)))))) + +(define (foldr f z lst) + (##sys#check-list lst 'foldr) + (let loop ((lst lst)) + (if (not (pair? lst)) + z + (f (##sys#slot lst 0) (loop (##sys#slot lst 1)))))) + +) ; chicken.base + +(import (except chicken.base gensym add1 sub1)) ;;; see end of this file + (define-constant namespace-max-id-len 31) (define-constant char-name-table-size 37) (define-constant output-string-initial-size 256) @@ -236,27 +365,25 @@ EOF (define (exit #!optional (code 0)) ((##sys#exit-handler) code)) (define (##sys#debug-mode?) (##core#inline "C_i_debug_modep")) -(define (error . args) - (if (pair? args) - (apply ##sys#signal-hook #:error args) - (##sys#signal-hook #:error #f))) - (define ##sys#warnings-enabled #t) (define ##sys#notices-enabled (##sys#debug-mode?)) -(define (warning msg . args) - (when ##sys#warnings-enabled - (apply ##sys#signal-hook #:warning msg args) ) ) +(set! chicken.base#warning + (lambda (msg . args) + (when ##sys#warnings-enabled + (apply ##sys#signal-hook #:warning msg args) )) ) -(define (notice msg . args) - (when (and ##sys#notices-enabled - ##sys#warnings-enabled) - (apply ##sys#signal-hook #:notice msg args) ) ) +(set! chicken.base#notice + (lambda (msg . args) + (when (and ##sys#notices-enabled + ##sys#warnings-enabled) + (apply ##sys#signal-hook #:notice msg args) )) ) -(define (enable-warnings . bool) - (if (pair? bool) - (set! ##sys#warnings-enabled (car bool)) - ##sys#warnings-enabled) ) +(set! chicken.base#enable-warnings + (lambda bool + (if (pair? bool) + (set! ##sys#warnings-enabled (car bool)) + ##sys#warnings-enabled)) ) (define ##sys#error error) (define ##sys#warn warning) @@ -296,7 +423,6 @@ EOF (define (##sys#message str) (##core#inline "C_message" str)) (define (##sys#byte x i) (##core#inline "C_subbyte" x i)) (define (##sys#setbyte x i n) (##core#inline "C_setbyte" x i n)) -(define (void . _) (##core#undefined)) (define ##sys#void void) (define ##sys#undefined-value (##core#undefined)) (define (##sys#halt msg) (##core#inline "C_halt" msg)) @@ -838,16 +964,6 @@ EOF ;; [MpNT] Tiplea at al., "MpNT: A Multi-Precision Number Theory Package" ;; [MCA] Richard P. Brent & Paul Zimmermann, "Modern Computer Arithmetic" -(define (fixnum? x) (##core#inline "C_fixnump" x)) -(define (flonum? x) (##core#inline "C_i_flonump" x)) -(define (bignum? x) (##core#inline "C_i_bignump" x)) -(define (ratnum? x) (##core#inline "C_i_ratnump" x)) -(define (cplxnum? x) (##core#inline "C_i_cplxnump" x)) - -(define (finite? x) (##core#inline "C_i_finitep" x)) -(define (infinite? x) (##core#inline "C_i_infinitep" x)) -(define (nan? x) (##core#inline "C_i_nanp" x)) - (module chicken.flonum * (import chicken scheme chicken.foreign) @@ -1015,8 +1131,6 @@ EOF (define + (##core#primitive "C_plus")) (define - (##core#primitive "C_minus")) (define * (##core#primitive "C_times")) -(define (add1 n) (+ n 1)) -(define (sub1 n) (- n 1)) (define (number? x) (##core#inline "C_i_numberp" x)) (define ##sys#number? number?) @@ -1024,7 +1138,6 @@ EOF (define (real? x) (##core#inline "C_i_realp" x)) (define (rational? n) (##core#inline "C_i_rationalp" n)) (define (integer? x) (##core#inline "C_i_integerp" x)) -(define (exact-integer? x) (##core#inline "C_i_exact_integerp" x)) (define ##sys#integer? integer?) (define (exact? x) (##core#inline "C_i_exactp" x)) (define (inexact? x) (##core#inline "C_i_inexactp" x)) @@ -1126,8 +1239,6 @@ EOF ((cplxnum? x) (make-polar 1 (angle x))) (else (##sys#error-bad-number x 'signum)))) -(define signum (##core#primitive "C_signum")) - (define-inline (%flo->int x) (##core#inline_allocate ("C_s_a_u_i_flo_to_int" 5) x)) @@ -1327,19 +1438,6 @@ EOF (define (quotient a b) (##core#inline_allocate ("C_s_a_i_quotient" 5) a b)) (define (remainder a b) (##core#inline_allocate ("C_s_a_i_remainder" 5) a b)) (define (modulo a b) (##core#inline_allocate ("C_s_a_i_modulo" 5) a b)) -(define quotient&remainder (##core#primitive "C_quotient_and_remainder")) - -;; Modulo's sign follows y (whereas remainder's sign follows x) -;; Inlining this is not much use: quotient&remainder is primitive -(define (quotient&modulo x y) - (receive (div rem) (quotient&remainder x y) - (if (positive? y) - (if (negative? rem) - (values div (+ rem y)) - (values div rem)) - (if (positive? rem) - (values div (+ rem y)) - (values div rem))))) (define (even? n) (##core#inline "C_i_evenp" n)) (define (odd? n) (##core#inline "C_i_oddp" n)) @@ -1483,9 +1581,10 @@ EOF (- (+ r (arithmetic-shift s 1)) 1)) (values s r))))) -(define (exact-integer-sqrt x) - (##sys#check-exact-uinteger x 'exact-integer-sqrt) - (##sys#exact-integer-sqrt x)) +(set! chicken.base#exact-integer-sqrt + (lambda (x) + (##sys#check-exact-uinteger x 'exact-integer-sqrt) + (##sys#exact-integer-sqrt x))) ;; This procedure is so large because it tries very hard to compute ;; exact results if at all possible. @@ -1515,10 +1614,11 @@ EOF (define (sqrt x) (##sys#sqrt/loc 'sqrt x)) -(define (exact-integer-nth-root k n) - (##sys#check-exact-uinteger k 'exact-integer-nth-root) - (##sys#check-exact-uinteger n 'exact-integer-nth-root) - (##sys#exact-integer-nth-root/loc 'exact-integer-nth-root k n)) +(set! chicken.base#exact-integer-nth-root + (lambda (k n) + (##sys#check-exact-uinteger k 'exact-integer-nth-root) + (##sys#check-exact-uinteger n 'exact-integer-nth-root) + (##sys#exact-integer-nth-root/loc 'exact-integer-nth-root k n))) ;; Generalized Newton's algorithm for positive integers, with a little help ;; from Wikipedia ;) https://en.wikipedia.org/wiki/Nth_root_algorithm @@ -1993,7 +2093,6 @@ EOF ;;; Symbols: -(define ##sys#make-symbol (##core#primitive "C_make_symbol")) (define (symbol? x) (##core#inline "C_i_symbolp" x)) (define ##sys#snafu '##sys#fnord) (define ##sys#intern-symbol (##core#primitive "C_string_to_symbol")) @@ -2061,30 +2160,30 @@ EOF (##sys#check-string str 'string->symbol) (##sys#intern-symbol (string-copy str)) ) ) ) -(define string->uninterned-symbol - (let ([string-copy string-copy]) +(set! chicken.base#string->uninterned-symbol + (let ((string-copy string-copy)) (lambda (str) (##sys#check-string str 'string->uninterned-symbol) - (##sys#make-symbol (string-copy str)) ) ) ) + ((##core#primitive "C_make_symbol") (string-copy str)) ) )) -(define gensym - (let ([counter -1]) +(set! chicken.base#gensym + (let ((counter -1)) (lambda str-or-sym - (let ([err (lambda (prefix) (##sys#signal-hook #:type-error 'gensym "argument is not a string or symbol" prefix))]) + (let ((err (lambda (prefix) (##sys#signal-hook #:type-error 'gensym "argument is not a string or symbol" prefix)))) (set! counter (fx+ counter 1)) - (##sys#make-symbol + ((##core#primitive "C_make_symbol") (##sys#string-append (if (eq? str-or-sym '()) "g" - (let ([prefix (car str-or-sym)]) + (let ((prefix (car str-or-sym))) (or (and (##core#inline "C_blockp" prefix) - (cond [(##core#inline "C_stringp" prefix) prefix] - [(##core#inline "C_symbolp" prefix) (##sys#symbol->string prefix)] - [else (err prefix)] ) ) + (cond ((##core#inline "C_stringp" prefix) prefix) + ((##core#inline "C_symbolp" prefix) (##sys#symbol->string prefix)) + (else (err prefix)) ) ) (err prefix) ) ) ) (##sys#number->string counter) ) ) ) ) ) ) -(define symbol-append +(set! chicken.base#symbol-append (let ((string-append string-append)) (lambda ss (##sys#intern-symbol @@ -2231,37 +2330,40 @@ EOF ((fx>= i len)) (##sys#setslot v i x) ) ) ) -(define (vector-copy! from to . n) - (##sys#check-vector from 'vector-copy!) - (##sys#check-vector to 'vector-copy!) - (let* ((len-from (##sys#size from)) - (len-to (##sys#size to)) - (n (if (pair? n) (car n) (fxmin len-to len-from))) ) - (##sys#check-fixnum n 'vector-copy!) - (when (or (fx> n len-to) (fx> n len-from)) - (##sys#signal-hook - #:bounds-error 'vector-copy! - "cannot copy vector - count exceeds length" from to n) ) - (do ((i 0 (fx+ i 1))) - ((fx>= i n)) - (##sys#setslot to i (##sys#slot from i)) ) ) ) - -(define (subvector v i #!optional j) - (##sys#check-vector v 'subvector) - (let* ((len (##sys#size v)) - (j (or j len)) - (len2 (fx- j i))) - (##sys#check-range i 0 (fx+ len 1) 'subvector) - (##sys#check-range j 0 (fx+ len 1) 'subvector) - (let ((v2 (make-vector len2))) - (do ((k 0 (fx+ k 1))) - ((fx>= k len2) v2) - (##sys#setslot v2 k (##sys#slot v (fx+ k i))))))) - -(define (vector-resize v n #!optional init) - (##sys#check-vector v 'vector-resize) - (##sys#check-fixnum n 'vector-resize) - (##sys#vector-resize v n init) ) +(set! chicken.base#vector-copy! + (lambda (from to . n) + (##sys#check-vector from 'vector-copy!) + (##sys#check-vector to 'vector-copy!) + (let* ((len-from (##sys#size from)) + (len-to (##sys#size to)) + (n (if (pair? n) (car n) (fxmin len-to len-from))) ) + (##sys#check-fixnum n 'vector-copy!) + (when (or (fx> n len-to) (fx> n len-from)) + (##sys#signal-hook + #:bounds-error 'vector-copy! + "cannot copy vector - count exceeds length" from to n) ) + (do ((i 0 (fx+ i 1))) + ((fx>= i n)) + (##sys#setslot to i (##sys#slot from i)) ) )) ) + +(set! chicken.base#subvector + (lambda (v i #!optional j) + (##sys#check-vector v 'subvector) + (let* ((len (##sys#size v)) + (j (or j len)) + (len2 (fx- j i))) + (##sys#check-range i 0 (fx+ len 1) 'subvector) + (##sys#check-range j 0 (fx+ len 1) 'subvector) + (let ((v2 (make-vector len2))) + (do ((k 0 (fx+ k 1))) + ((fx>= k len2) v2) + (##sys#setslot v2 k (##sys#slot v (fx+ k i)))))))) + +(set! chicken.base#vector-resize + (lambda (v n #!optional init) + (##sys#check-vector v 'vector-resize) + (##sys#check-fixnum n 'vector-resize) + (##sys#vector-resize v n init)) ) (define (##sys#vector-resize v n init) (let ((v2 (##sys#make-vector n init)) @@ -2337,9 +2439,9 @@ EOF (##sys#check-char c 'char-alphabetic?) (##core#inline "C_u_i_char_alphabeticp" c) ) -(define char-name - (let ([chars-to-names (make-vector char-name-table-size '())] - [names-to-chars '()] ) +(set! chicken.base#char-name + (let ((chars-to-names (make-vector char-name-table-size '())) + (names-to-chars '()) ) (define (lookup-char c) (let* ([code (char->integer c)] [key (##core#inline "C_fixnum_modulo" code char-name-table-size)] ) @@ -2501,7 +2603,7 @@ EOF (apply cont results) ) (proc continuation))))) -(define call/cc call-with-current-continuation) +(set! chicken.base#call/cc call-with-current-continuation) (define (##sys#dynamic-unwind winds n) (cond [(eq? ##sys#dynamic-winds winds)] @@ -2733,14 +2835,15 @@ EOF (when set? (set! ##sys#standard-output p))) p))) -(define (current-error-port . args) - (if (null? args) - ##sys#standard-error - (let ((p (car args))) - (##sys#check-port p 'current-error-port) - (let-optionals (cdr args) ((convert? #t) (set? #t)) - (when set? (set! ##sys#standard-error p))) - p))) +(set! chicken.base#current-error-port + (lambda args + (if (null? args) + ##sys#standard-error + (let ((p (car args))) + (##sys#check-port p 'current-error-port) + (let-optionals (cdr args) ((convert? #t) (set? #t)) + (when set? (set! ##sys#standard-error p))) + p)))) (define (##sys#tty-port? port) (and (not (zero? (##sys#peek-unsigned-integer port 0))) @@ -2971,7 +3074,7 @@ EOF (##core#inline "C_copy_memory" s info sz) s) ) -(define procedure-information +(set! chicken.base#procedure-information (lambda (x) (##sys#check-closure x 'procedure-information) (and-let* ((info (##sys#lambda-info x))) @@ -2985,7 +3088,7 @@ EOF (define-inline (setter? x) (and (pair? x) (eq? setter-tag (##sys#slot x 0))) ) -(define setter +(set! chicken.base#setter (##sys#decorate-lambda (lambda (proc) (or (and-let* (((procedure? proc)) @@ -3012,27 +3115,28 @@ EOF (define ##sys#setter setter) -(define (getter-with-setter get set #!optional info) - (##sys#check-closure get 'getter-with-setter) - (##sys#check-closure set 'getter-with-setter) - (let ((getdec (cond (info - (##sys#check-string info 'getter-with-setter) - (##sys#make-lambda-info info)) - (else (##sys#lambda-info get)))) - (p1 (##sys#decorate-lambda - (##sys#copy-closure get) - setter? - (lambda (proc i) - (##sys#setslot proc i (cons setter-tag set)) - proc) ))) - (if getdec - (##sys#decorate-lambda - p1 - ##sys#lambda-info? - (lambda (p i) - (##sys#setslot p i getdec) - p)) - p1))) +(set! chicken.base#getter-with-setter + (lambda (get set #!optional info) + (##sys#check-closure get 'getter-with-setter) + (##sys#check-closure set 'getter-with-setter) + (let ((getdec (cond (info + (##sys#check-string info 'getter-with-setter) + (##sys#make-lambda-info info)) + (else (##sys#lambda-info get)))) + (p1 (##sys#decorate-lambda + (##sys#copy-closure get) + setter? + (lambda (proc i) + (##sys#setslot proc i (cons setter-tag set)) + proc) ))) + (if getdec + (##sys#decorate-lambda + p1 + ##sys#lambda-info? + (lambda (p i) + (##sys#setslot p i getdec) + p)) + p1)))) (set! car (getter-with-setter car set-car! "(car p)")) (set! cdr (getter-with-setter cdr set-cdr! "(cdr p)")) @@ -3063,7 +3167,7 @@ EOF (define ##sys#default-parameter-vector (##sys#make-vector default-parameter-vector-size)) (define ##sys#current-parameter-vector '#()) -(define make-parameter +(set! chicken.base#make-parameter (let ((count 0)) (lambda (init #!optional (guard (lambda (x) x))) (let* ((val (guard init)) @@ -3896,17 +4000,19 @@ EOF (define-inline (*print-each lst) (for-each (cut ##sys#print <> #f ##sys#standard-output) lst) ) -(define (print . args) - (##sys#check-output-port ##sys#standard-output #t 'print) - (*print-each args) - (##sys#write-char-0 #\newline ##sys#standard-output) - (void) ) - -(define (print* . args) - (##sys#check-output-port ##sys#standard-output #t 'print) - (*print-each args) - (##sys#flush-output ##sys#standard-output) - (void) ) +(set! chicken.base#print + (lambda args + (##sys#check-output-port ##sys#standard-output #t 'print) + (*print-each args) + (##sys#write-char-0 #\newline ##sys#standard-output) + (void)) ) + +(define print* + (lambda args + (##sys#check-output-port ##sys#standard-output #t 'print) + (*print-each args) + (##sys#flush-output ##sys#standard-output) + (void)) ) (define current-print-length (make-parameter 0)) (define ##sys#print-length-limit (make-parameter #f)) @@ -4380,7 +4486,7 @@ EOF (define-constant +trace-buffer-entry-slot-count+ 4) -(define get-call-chain +(set! chicken.base#get-call-chain (let ((extract (foreign-lambda* nonnull-c-string ((scheme-object x)) "C_return((C_char *)x);"))) (lambda (#!optional (start 0) (thread ##sys#current-thread)) @@ -4429,13 +4535,14 @@ EOF chain) (##sys#print "\t<--\n" #f port))) -(define (print-call-chain #!optional (port ##sys#standard-output) (start 0) - (thread ##sys#current-thread) - (header "\n\tCall history:\n")) - (##sys#check-output-port port #t 'print-call-chain) - (##sys#check-fixnum start 'print-call-chain) - (##sys#check-string header 'print-call-chain) - (##sys#really-print-call-chain port (get-call-chain start thread) header)) +(set! chicken.base#print-call-chain + (lambda (#!optional (port ##sys#standard-output) (start 0) + (thread ##sys#current-thread) + (header "\n\tCall history:\n")) + (##sys#check-output-port port #t 'print-call-chain) + (##sys#check-fixnum start 'print-call-chain) + (##sys#check-string header 'print-call-chain) + (##sys#really-print-call-chain port (get-call-chain start thread) header))) ;;; Interrupt handling: @@ -5517,19 +5624,6 @@ EOF (define ##sys#map-n map) -;;; Promises: - -(define (##sys#make-promise proc) - (##sys#make-structure 'promise proc)) - -(define (promise? x) - (##sys#structure? x 'promise) ) - -(define (make-promise obj) - (if (promise? obj) obj - (##sys#make-promise (lambda () obj)))) - - ;;; We need this here so `location' works: (define (##sys#make-locative obj index weak? loc) @@ -5727,22 +5821,6 @@ EOF (define ##sys#filter-heap-objects (##core#primitive "C_filter_heap_objects")) -;;; fast folds with correct argument order - -(define (foldl f z lst) - (##sys#check-list lst 'foldl) - (let loop ((lst lst) (z z)) - (if (not (pair? lst)) - z - (loop (##sys#slot lst 1) (f z (##sys#slot lst 0)))))) - -(define (foldr f z lst) - (##sys#check-list lst 'foldr) - (let loop ((lst lst)) - (if (not (pair? lst)) - z - (f (##sys#slot lst 0) (loop (##sys#slot lst 1)))))) - ;;; Platform configuration inquiry: (module chicken.platform @@ -5913,3 +5991,12 @@ EOF (loop (##sys#slot ids 1)))))) ) ; chicken.platform + + +;; TODO: Figure out how to ensure chicken.base is always available at +;; syntax expansion time. Related to #1131? This is a temporary +;; workaround (go ahead, laugh....) so at least macros have gensym, +;; add1 and so on available without needing (import (chicken base)): +(define gensym chicken.base#gensym) +(define add1 chicken.base#add1) +(define sub1 chicken.base#sub1) diff --git a/modules.scm b/modules.scm index a923fe01..f71519b6 100644 --- a/modules.scm +++ b/modules.scm @@ -40,6 +40,7 @@ (define-syntax d (syntax-rules () ((_ . _) (void)))) (import scheme + chicken.base chicken.internal chicken.keyword chicken.platform @@ -994,22 +995,22 @@ 'srfi-0 '() (se-subset '(cond-expand) ##sys#default-macro-environment)) (##sys#register-primitive-module - 'srfi-2 '() (se-subset '(and-let*) ##sys#chicken-macro-environment)) + 'srfi-2 '() (se-subset '(and-let*) ##sys#chicken.base-macro-environment)) (##sys#register-core-module 'srfi-6 'library '(open-input-string open-output-string get-output-string)) (##sys#register-primitive-module - 'srfi-8 '() (se-subset '(receive) ##sys#chicken-macro-environment)) + 'srfi-8 '() (se-subset '(receive) ##sys#chicken.base-macro-environment)) (##sys#register-primitive-module - 'srfi-9 '() (se-subset '(define-record-type) ##sys#chicken-macro-environment)) + 'srfi-9 '() (se-subset '(define-record-type) ##sys#chicken.base-macro-environment)) (##sys#register-core-module 'srfi-10 'read-syntax '((define-reader-ctor . chicken.read-syntax#define-reader-ctor))) (##sys#register-primitive-module - 'srfi-11 '() (se-subset '(let-values let*-values) ##sys#chicken-macro-environment)) + 'srfi-11 '() (se-subset '(let-values let*-values) ##sys#chicken.base-macro-environment)) (##sys#register-core-module 'srfi-12 'library @@ -1025,32 +1026,32 @@ (se-subset '(handle-exceptions) ##sys#chicken.condition-macro-environment)) (##sys#register-primitive-module - 'srfi-15 '() (se-subset '(fluid-let) ##sys#chicken-macro-environment)) + 'srfi-15 '() (se-subset '(fluid-let) ##sys#chicken.base-macro-environment)) (##sys#register-primitive-module - 'srfi-16 '() (se-subset '(case-lambda) ##sys#chicken-macro-environment)) + 'srfi-16 '() (se-subset '(case-lambda) ##sys#chicken.base-macro-environment)) (##sys#register-primitive-module 'srfi-17 '() (se-subset '(set!) ##sys#default-macro-environment)) (##sys#register-core-module - 'srfi-23 'library '(error)) + 'srfi-23 'library '((error . chicken.base#error))) (##sys#register-primitive-module - 'srfi-26 '() (se-subset '(cut cute) ##sys#chicken-macro-environment)) + 'srfi-26 '() (se-subset '(cut cute) ##sys#chicken.base-macro-environment)) (##sys#register-core-module 'srfi-28 'extras '((format . chicken.format#format))) (##sys#register-primitive-module - 'srfi-31 '() (se-subset '(rec) ##sys#chicken-macro-environment)) + 'srfi-31 '() (se-subset '(rec) ##sys#chicken.base-macro-environment)) (##sys#register-core-module - 'srfi-39 'library '(make-parameter) - (se-subset '(parameterize) ##sys#chicken-macro-environment)) + 'srfi-39 'library '((make-parameter . chicken.base#make-parameter)) + (se-subset '(parameterize) ##sys#chicken.base-macro-environment)) (##sys#register-primitive-module - 'srfi-55 '() (se-subset '(require-extension) ##sys#default-macro-environment)) + 'srfi-55 '() (se-subset '(require-extension) ##sys#chicken.base-macro-environment)) (##sys#register-core-module 'srfi-98 'posix diff --git a/tests/scrutiny-2.expected b/tests/scrutiny-2.expected index 412e7a5b..bd2c6f72 100644 --- a/tests/scrutiny-2.expected +++ b/tests/scrutiny-2.expected @@ -42,16 +42,16 @@ Note: at toplevel: (scrutiny-tests-2.scm:22) in procedure call to `null?', the predicate is called with an argument of type `float' and will always return false Note: at toplevel: - (scrutiny-tests-2.scm:23) in procedure call to `fixnum?', the predicate is called with an argument of type `fixnum' and will always return true + (scrutiny-tests-2.scm:23) in procedure call to `chicken.base#fixnum?', the predicate is called with an argument of type `fixnum' and will always return true Note: at toplevel: - (scrutiny-tests-2.scm:23) in procedure call to `fixnum?', the predicate is called with an argument of type `float' and will always return false + (scrutiny-tests-2.scm:23) in procedure call to `chicken.base#fixnum?', the predicate is called with an argument of type `float' and will always return false Note: at toplevel: - (scrutiny-tests-2.scm:25) in procedure call to `flonum?', the predicate is called with an argument of type `float' and will always return true + (scrutiny-tests-2.scm:25) in procedure call to `chicken.base#flonum?', the predicate is called with an argument of type `float' and will always return true Note: at toplevel: - (scrutiny-tests-2.scm:25) in procedure call to `flonum?', the predicate is called with an argument of type `fixnum' and will always return false + (scrutiny-tests-2.scm:25) in procedure call to `chicken.base#flonum?', the predicate is called with an argument of type `fixnum' and will always return false Note: at toplevel: (scrutiny-tests-2.scm:27) in procedure call to `number?', the predicate is called with an argument of type `fixnum' and will always return true diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected index 0641540f..0495a6e6 100644 --- a/tests/scrutiny.expected +++ b/tests/scrutiny.expected @@ -25,10 +25,10 @@ Warning: at toplevel: (scrutiny-tests.scm:21) in procedure call to `string?', expected 1 argument but was given 0 arguments Warning: at toplevel: - (scrutiny-tests.scm:23) expected a single result in argument #1 of procedure call `(print (values 1 2))', but received 2 results + (scrutiny-tests.scm:23) expected a single result in argument #1 of procedure call `(chicken.base#print (values 1 2))', but received 2 results Warning: at toplevel: - (scrutiny-tests.scm:24) expected a single result in argument #1 of procedure call `(print (values))', but received zero results + (scrutiny-tests.scm:24) expected a single result in argument #1 of procedure call `(chicken.base#print (values))', but received zero results Warning: at toplevel: (scrutiny-tests.scm:27) in procedure call to `x', expected a value of type `(procedure () *)' but was given a value of type `fixnum' @@ -108,7 +108,7 @@ Warning: at toplevel: (scrutiny-tests.scm:163) in procedure call to `apply1', expected argument #2 of type `(list-of number)' but was given an argument of type `(list symbol fixnum fixnum)' Note: at toplevel: - (scrutiny-tests.scm:176) in procedure call to `fixnum?', the predicate is called with an argument of type `fixnum' and will always return true + (scrutiny-tests.scm:176) in procedure call to `chicken.base#fixnum?', the predicate is called with an argument of type `fixnum' and will always return true Note: at toplevel: (scrutiny-tests.scm:184) in procedure call to `symbol?', the predicate is called with an argument of type `(or char string)' and will always return false @@ -198,18 +198,18 @@ Warning: in toplevel procedure `list-ref-standard-warn4': (scrutiny-tests.scm:279) in procedure call to `list-ref', expected argument #2 of type `fixnum' but was given an argument of type `symbol' Warning: in toplevel procedure `list-ref-type-warn1': - (scrutiny-tests.scm:283) in procedure call to `add1', expected argument #1 of type `number' but was given an argument of type `symbol' + (scrutiny-tests.scm:283) in procedure call to `chicken.base#add1', expected argument #1 of type `number' but was given an argument of type `symbol' Warning: in toplevel procedure `list-ref-type-warn2': - (scrutiny-tests.scm:285) in procedure call to `add1', expected argument #1 of type `number' but was given an argument of type `symbol' + (scrutiny-tests.scm:285) in procedure call to `chicken.base#add1', expected argument #1 of type `number' but was given an argument of type `symbol' Warning: in toplevel procedure `list-ref-type-warn3': - (scrutiny-tests.scm:289) in procedure call to `add1', expected argument #1 of type `number' but was given an argument of type `symbol' + (scrutiny-tests.scm:289) in procedure call to `chicken.base#add1', expected argument #1 of type `number' but was given an argument of type `symbol' Warning: in toplevel procedure `append-result-type-warn1': - (scrutiny-tests.scm:301) in procedure call to `add1', expected argument #1 of type `number' but was given an argument of type `symbol' + (scrutiny-tests.scm:301) in procedure call to `chicken.base#add1', expected argument #1 of type `number' but was given an argument of type `symbol' Warning: in toplevel procedure `append-result-type-warn2': - (scrutiny-tests.scm:306) in procedure call to `add1', expected argument #1 of type `number' but was given an argument of type `symbol' + (scrutiny-tests.scm:306) in procedure call to `chicken.base#add1', expected argument #1 of type `number' but was given an argument of type `symbol' Warning: redefinition of standard binding: car diff --git a/types.db b/types.db index 081b0e4b..fdc7da48 100644 --- a/types.db +++ b/types.db @@ -227,7 +227,6 @@ (symbol? (#(procedure #:pure #:predicate symbol) symbol? (*) boolean)) -(symbol-append (#(procedure #:clean #:enforce #:foldable) symbol-append (#!rest symbol) symbol)) (symbol->string (#(procedure #:clean #:enforce) symbol->string (symbol) string)) (string->symbol (#(procedure #:clean #:enforce #:foldable) string->symbol (string) symbol)) @@ -458,30 +457,6 @@ (##core#inline_allocate ("C_s_a_u_i_integer_remainder" 5) #(1) #(2))) ((* *) (##core#inline_allocate ("C_s_a_i_remainder" 5) #(1) #(2)))) -(quotient&remainder (#(procedure #:clean #:enforce #:foldable) quotient&remainder ((or integer float) (or integer float)) (or integer float) (or integer float)) - ((float float) (float float) - (let ((#(tmp1) #(1))) - (let ((#(tmp2) #(2))) - (##sys#values - (##core#inline_allocate - ("C_a_i_flonum_actual_quotient_checked" 4) #(tmp1) #(tmp2)) - (##core#inline_allocate - ("C_a_i_flonum_remainder_checked" 4) #(tmp1) #(tmp2)))))) - ;;XXX flonum/mixed case - ((fixnum fixnum) (integer fixnum) - (let ((#(tmp1) #(1))) - (let ((#(tmp2) #(2))) - (##sys#values - (##core#inline_allocate ("C_a_i_fixnum_quotient_checked" 5) - #(tmp1) #(tmp2)) - (##core#inline - "C_i_fixnum_remainder_checked" #(tmp1) #(tmp2)))))) - ((integer integer) (integer integer) - ((##core#primitive "C_u_integer_quotient_and_remainder") #(1) #(2)))) - -;; TODO: Add nonspecializing type specific entries, to help flow analysis? -(quotient&modulo (#(procedure #:clean #:enforce #:foldable) quotient&modulo ((or integer float) (or integer float)) (or integer float) (or integer float))) - (modulo (#(procedure #:clean #:enforce #:foldable) modulo ((or integer float) (or integer float)) (or integer float)) ((float float) (float) (##core#inline_allocate @@ -711,11 +686,9 @@ (##sys#vector->list (forall (a) (#(procedure #:clean #:enforce) ##sys#vector->list ((vector-of a)) (list-of a)))) (list->vector (forall (a) (#(procedure #:clean #:enforce) list->vector ((list-of a)) (vector-of a)))) (##sys#list->vector (forall (a) (#(procedure #:clean #:enforce) ##sys#list->vector ((list-of a)) (vector-of a)))) -(vector-fill! (#(procedure #:enforce) vector-fill! (vector *) undefined)) (procedure? (#(procedure #:pure #:predicate procedure) procedure? (*) boolean)) -(vector-copy! (#(procedure #:enforce) vector-copy! (vector vector #!optional fixnum) undefined)) (map (forall (a b) (#(procedure #:enforce) map ((procedure (a #!rest) b) (list-of a) #!rest list) (list-of b)))) @@ -867,7 +840,13 @@ ;; chicken -(add1 (#(procedure #:clean #:enforce #:foldable) add1 (number) number) +(argc+argv (#(procedure #:clean) argc+argv () fixnum pointer)) +(argv (#(procedure #:clean) argv () (list-of string))) + + +;; base + +(chicken.base#add1 (#(procedure #:clean #:enforce #:foldable) chicken.base#add1 (number) number) ((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_plus" 5) #(1) '1)) ((integer) (integer) @@ -877,8 +856,135 @@ ((*) (number) (##core#inline_allocate ("C_s_a_i_plus" 29) #(1) '1))) -(argc+argv (#(procedure #:clean) argc+argv () fixnum pointer)) -(argv (#(procedure #:clean) argv () (list-of string))) +(chicken.base#sub1 (#(procedure #:clean #:enforce #:foldable) chicken.base#sub1 (number) number) + ((fixnum) (integer) + (##core#inline_allocate ("C_a_i_fixnum_difference" 5) #(1) '1)) + ((integer) (integer) + (##core#inline_allocate ("C_s_a_u_i_integer_minus" 5) #(1) '1)) + ((float) (float) + (##core#inline_allocate ("C_a_i_flonum_difference" 4) #(1) '1.0)) + ((*) (number) + (##core#inline_allocate ("C_s_a_i_minus" 29) #(1) '1))) + +(chicken.base#subvector (forall (a) (#(procedure #:clean #:enforce) chicken.base#subvector ((vector-of a) fixnum #!optional fixnum) (vector-of a)))) +(chicken.base#vector-copy! (#(procedure #:enforce) chicken.base#vector-copy! (vector vector #!optional fixnum) undefined)) +(chicken.base#vector-fill! (#(procedure #:enforce) chicken.base#vector-fill! (vector *) undefined)) +(chicken.base#vector-resize + (forall (a b) (#(procedure #:clean #:enforce) chicken.base#vector-resize ((vector-of a) fixnum #!optional b) + (vector-of (or a b))))) + +(chicken.base#void (#(procedure #:pure) chicken.base#void (#!rest) undefined)) +(chicken.base#warning (procedure chicken.base#warning (* #!rest) undefined)) +(chicken.base#notice (procedure chicken.base#notice (* #!rest) undefined)) + +(chicken.base#exact-integer-nth-root (#(procedure #:clean #:enforce #:foldable) chicken.base#exact-integer-nth-root (integer integer) integer integer) + ((integer integer) (##sys#exact-integer-nth-root/loc 'exact-integer-nth-root #(1) #(2)))) + +(chicken.base#exact-integer-sqrt (#(procedure #:clean #:enforce #:foldable) chicken.base#exact-integer-sqrt (integer) integer integer) + ((integer) (##sys#exact-integer-sqrt #(1)))) + +(chicken.base#fixnum? (#(procedure #:pure #:predicate fixnum) chicken.base#fixnum? (*) boolean)) +(chicken.base#flonum? (#(procedure #:pure #:predicate float) chicken.base#flonum? (*) boolean)) +(chicken.base#bignum? (#(procedure #:pure #:predicate bignum) chicken.base#bignum? (*) boolean)) +(chicken.base#ratnum? (#(procedure #:pure #:predicate ratnum) chicken.base#ratnum? (*) boolean)) +(chicken.base#cplxnum? (#(procedure #:pure #:predicate cplxnum) chicken.base#cplxnum? (*) boolean)) + +(chicken.base#foldl (forall (a b) (#(procedure #:enforce) chicken.base#foldl ((procedure (a b) a) a (list-of b)) a))) +(chicken.base#foldr (forall (a b) (#(procedure #:enforce) chicken.base#foldr ((procedure (a b) b) b (list-of a)) b))) + +(chicken.base#nan? (#(procedure #:clean #:enforce #:foldable) chicken.base#nan? (number) boolean) + (((or integer ratnum)) (let ((#(tmp) #(1))) '#f)) + ((float) (##core#inline "C_u_i_flonum_nanp" #(1))) + ((*) (##core#inline "C_i_nanp" #(1)))) + +(chicken.base#infinite? (#(procedure #:clean #:enforce #:foldable) chicken.base#infinite? (number) boolean) + (((or integer ratnum)) (let ((#(tmp) #(1))) '#f)) + ((float) (##core#inline "C_u_i_flonum_infinitep" #(1))) + ((*) (##core#inline "C_i_infinitep" #(1)))) + +(chicken.base#finite? (#(procedure #:clean #:enforce #:foldable) chicken.base#finite? (number) boolean) + (((or integer ratnum)) (let ((#(tmp) #(1))) '#t)) + ((float) (##core#inline "C_u_i_flonum_finitep" #(1))) + ((*) (##core#inline "C_i_finitep" #(1)))) + +(chicken.base#get-call-chain (#(procedure #:clean #:enforce) chicken.base#get-call-chain (#!optional fixnum (struct thread)) (list-of vector))) +(chicken.base#print-call-chain (#(procedure #:clean #:enforce) chicken.base#print-call-chain (#!optional output-port fixnum * string) undefined)) + +(chicken.base#print (procedure chicken.base#print (#!rest *) undefined)) +(chicken.base#print* (procedure chicken.base#print* (#!rest) undefined)) +(chicken.base#procedure-information (#(procedure #:clean #:enforce) chicken.base#procedure-information (procedure) *)) +(chicken.base#promise? (#(procedure #:pure #:predicate (struct promise)) chicken.base#promise? (*) boolean)) + +(chicken.base#make-promise (#(procedure #:enforce) chicken.base#make-promise (*) (struct promise)) + (((struct promise)) #(1))) + +(chicken.base#call/cc (#(procedure #:enforce) chicken.base#call/cc ((procedure (*) . *)) . *)) + +(chicken.base#current-error-port + (#(procedure #:clean #:enforce) chicken.base#current-error-port (#!optional output-port boolean boolean) output-port) + ((output-port) (let ((#(tmp1) #(1))) + (let ((#(tmp2) (set! ##sys#standard-error #(tmp1)))) + #(tmp1)))) + (() ##sys#standard-error)) + +(chicken.base#enable-warnings (#(procedure #:clean) chicken.base#enable-warnings (#!optional *) *)) + +(chicken.base#error (procedure chicken.base#error (* #!rest) noreturn)) +(chicken.base#equal=? (#(procedure #:clean #:foldable) chicken.base#equal=? (* *) boolean) + ((fixnum fixnum) (eq? #(1) #(2))) + (((or symbol char eof null undefined) *) (eq? #(1) #(2))) + ((* (or symbol char eof null undefined)) (eq? #(1) #(2))) + ((number number) (= #(1) #(2)))) + +(chicken.base#gensym (#(procedure #:clean) chicken.base#gensym (#!optional (or string symbol)) symbol)) +(chicken.base#char-name (#(procedure #:clean #:enforce) chicken.base#char-name ((or char symbol) #!optional char) *)) ;XXX -> (or char symbol) ? + +(chicken.base#getter-with-setter + (#(procedure #:clean #:enforce) + chicken.base#getter-with-setter + ((procedure (#!rest) *) (procedure (* #!rest) . *) #!optional string) + procedure)) +(chicken.base#setter (#(procedure #:clean #:enforce) chicken.base#setter (procedure) procedure)) + +(chicken.base#signum (#(procedure #:clean #:enforce) chicken.base#signum (number) (or fixnum float cplxnum)) + ((fixnum) (fixnum) (##core#inline "C_i_fixnum_signum" #(1))) + ((integer) (fixnum) (##core#inline "C_u_i_integer_signum" #(1))) + ((float) (float) + (##core#inline_allocate ("C_a_u_i_flonum_signum" 4) #(1))) + ((ratnum) (fixnum) + (##core#inline "C_u_i_integer_signum" + (##core#inline "C_u_i_ratnum_num" #(1)))) + ((cplxnum) ((or float cplxnum)) (##sys#extended-signum #(1)))) + +(chicken.base#make-parameter (#(procedure #:clean #:enforce) chicken.base#make-parameter (* #!optional procedure) procedure)) +(chicken.base#string->uninterned-symbol (#(procedure #:clean #:enforce) chicken.base#string->uninterned-symbol (string) symbol)) +(chicken.base#symbol-append (#(procedure #:clean #:enforce #:foldable) chicken.base#symbol-append (#!rest symbol) symbol)) + +(chicken.base#quotient&remainder (#(procedure #:clean #:enforce #:foldable) chicken.base#quotient&remainder ((or integer float) (or integer float)) (or integer float) (or integer float)) + ((float float) (float float) + (let ((#(tmp1) #(1))) + (let ((#(tmp2) #(2))) + (##sys#values + (##core#inline_allocate + ("C_a_i_flonum_actual_quotient_checked" 4) #(tmp1) #(tmp2)) + (##core#inline_allocate + ("C_a_i_flonum_remainder_checked" 4) #(tmp1) #(tmp2)))))) + ;;XXX flonum/mixed case + ((fixnum fixnum) (integer fixnum) + (let ((#(tmp1) #(1))) + (let ((#(tmp2) #(2))) + (##sys#values + (##core#inline_allocate ("C_a_i_fixnum_quotient_checked" 5) + #(tmp1) #(tmp2)) + (##core#inline + "C_i_fixnum_remainder_checked" #(tmp1) #(tmp2)))))) + ((integer integer) (integer integer) + ((##core#primitive "C_u_integer_quotient_and_remainder") #(1) #(2)))) + +;; TODO: Add nonspecializing type specific entries, to help flow analysis? +(chicken.base#quotient&modulo (#(procedure #:clean #:enforce #:foldable) chicken.base#quotient&modulo ((or integer float) (or integer float)) (or integer float) (or integer float))) + +;; bitwise (chicken.bitwise#integer-length (#(procedure #:clean #:enforce #:foldable) chicken.bitwise#integer-length (integer) fixnum) @@ -889,18 +995,6 @@ (#(procedure #:clean #:enforce #:foldable) chicken.bitwise#arithmetic-shift (integer fixnum) integer) ((* *) (##core#inline_allocate ("C_s_a_i_arithmetic_shift" 5) #(1) #(2)))) -(exact-integer-nth-root (#(procedure #:clean #:enforce #:foldable) exact-integer-nth-root (integer integer) integer integer) - ((integer integer) (##sys#exact-integer-nth-root/loc 'exact-integer-nth-root #(1) #(2)))) - -(exact-integer-sqrt (#(procedure #:clean #:enforce #:foldable) exact-integer-sqrt (integer) integer integer) - ((integer) (##sys#exact-integer-sqrt #(1)))) - -(fixnum? (#(procedure #:pure #:predicate fixnum) fixnum? (*) boolean)) -(flonum? (#(procedure #:pure #:predicate float) flonum? (*) boolean)) -(bignum? (#(procedure #:pure #:predicate bignum) bignum? (*) boolean)) -(ratnum? (#(procedure #:pure #:predicate ratnum) ratnum? (*) boolean)) -(cplxnum? (#(procedure #:pure #:predicate cplxnum) cplxnum? (*) boolean)) - (chicken.bitwise#bit->boolean (#(procedure #:clean #:enforce #:foldable) chicken.bitwise#bit->boolean (integer integer) boolean) ((fixnum fixnum) (##core#inline "C_i_fixnum_bit_to_bool" #(1) #(2))) @@ -945,9 +1039,7 @@ ((fixnum) (##sys#make-blob #(1)))) (chicken.blob#string->blob (#(procedure #:clean #:enforce) chicken.blob#string->blob (string) blob)) -(call/cc (#(procedure #:enforce) call/cc ((procedure (*) . *)) . *)) (case-sensitive (#(procedure #:clean) case-sensitive (#!optional *) *)) -(char-name (#(procedure #:clean #:enforce) char-name ((or char symbol) #!optional char) *)) ;XXX -> (or char symbol) ? (command-line-arguments (#(procedure #:clean) command-line-arguments (#!optional (list-of string)) (list-of string))) ;; condition @@ -1000,12 +1092,6 @@ (#(procedure #:clean #:enforce) chicken.read-syntax#set-sharp-read-syntax! (char (or false (procedure (input-port) . *))) undefined)) -(current-error-port - (#(procedure #:clean #:enforce) current-error-port (#!optional output-port boolean boolean) output-port) - ((output-port) (let ((#(tmp1) #(1))) - (let ((#(tmp2) (set! ##sys#standard-error #(tmp1)))) - #(tmp1)))) - (() ##sys#standard-error)) ;; time @@ -1014,16 +1100,7 @@ (chicken.time#current-milliseconds (#(procedure #:clean) chicken.time#current-milliseconds () integer)) (delete-file (#(procedure #:clean #:enforce) delete-file (string) string)) -(enable-warnings (#(procedure #:clean) enable-warnings (#!optional *) *)) - -(equal=? (#(procedure #:clean #:foldable) equal=? (* *) boolean) - ((fixnum fixnum) (eq? #(1) #(2))) - (((or symbol char eof null undefined) *) (eq? #(1) #(2))) - ((* (or symbol char eof null undefined)) (eq? #(1) #(2))) - ((number number) (= #(1) #(2)))) - (errno (#(procedure #:clean) errno () fixnum)) -(error (procedure error (* #!rest) noreturn)) (##sys#error (procedure ##sys#error (* #!rest) noreturn)) (##sys#signal-hook (procedure ##sys#signal-hook (* #!rest) noreturn)) (##sys#debug-mode? (procedure ##sys#debug-mode? () boolean) @@ -1036,26 +1113,8 @@ (flush-output (#(procedure #:enforce) flush-output (#!optional output-port) undefined)) -(foldl (forall (a b) (#(procedure #:enforce) foldl ((procedure (a b) a) a (list-of b)) a))) -(foldr (forall (a b) (#(procedure #:enforce) foldr ((procedure (a b) b) b (list-of a)) b))) - (force-finalizers (procedure force-finalizers () undefined)) -(nan? (#(procedure #:clean #:enforce #:foldable) nan? (number) boolean) - (((or integer ratnum)) (let ((#(tmp) #(1))) '#f)) - ((float) (##core#inline "C_u_i_flonum_nanp" #(1))) - ((*) (##core#inline "C_i_nanp" #(1)))) - -(infinite? (#(procedure #:clean #:enforce #:foldable) infinite? (number) boolean) - (((or integer ratnum)) (let ((#(tmp) #(1))) '#f)) - ((float) (##core#inline "C_u_i_flonum_infinitep" #(1))) - ((*) (##core#inline "C_i_infinitep" #(1)))) - -(finite? (#(procedure #:clean #:enforce #:foldable) finite? (number) boolean) - (((or integer ratnum)) (let ((#(tmp) #(1))) '#t)) - ((float) (##core#inline "C_u_i_flonum_finitep" #(1))) - ((*) (##core#inline "C_i_finitep" #(1)))) - ;; flonum (chicken.flonum#flonum-decimal-precision fixnum) @@ -1194,8 +1253,6 @@ (chicken.fixnum#fx*? (#(procedure #:pure) chicken.fixnum#fx*? ((or fixnum false) (or fixnum false)) (or fixnum false))) (chicken.fixnum#fx/? (#(procedure #:clean) chicken.fixnum#fx/? ((or fixnum false) (or fixnum false)) (or fixnum false))) -(gensym (#(procedure #:clean) gensym (#!optional (or string symbol)) symbol)) - (get-environment-variable (#(procedure #:clean #:enforce) get-environment-variable (string) *)) (get-output-string (#(procedure #:clean #:enforce) get-output-string (output-port) string)) @@ -1248,18 +1305,11 @@ (chicken.plist#symbol-plist (#(procedure #:clean #:enforce) chicken.plist#symbol-plist (symbol) list) ((symbol) (##sys#slot #(1) '2))) -(getter-with-setter - (#(procedure #:clean #:enforce) - getter-with-setter - ((procedure (#!rest) *) (procedure (* #!rest) . *) #!optional string) - procedure)) - (implicit-exit-handler (#(procedure #:clean #:enforce) implicit-exit-handler (#!optional (procedure () . *)) procedure)) (keyword-style (#(procedure #:clean) keyword-style (#!optional symbol) symbol)) -(make-parameter (#(procedure #:clean #:enforce) make-parameter (* #!optional procedure) procedure)) (chicken.flonum#maximum-flonum float) (chicken.flonum#minimum-flonum float) (chicken.fixnum#most-negative-fixnum fixnum) @@ -1279,17 +1329,7 @@ (port-closed? (#(procedure #:clean #:enforce) port-closed? (port) boolean) ((port) (eq? (##sys#slot #(1) '8) '0))) -(get-call-chain (#(procedure #:clean #:enforce) get-call-chain (#!optional fixnum (struct thread)) (list-of vector))) -(print-call-chain (#(procedure #:clean #:enforce) print-call-chain (#!optional output-port fixnum * string) undefined)) - -(print (procedure print (#!rest *) undefined)) -(print* (procedure print* (#!rest) undefined)) -(procedure-information (#(procedure #:clean #:enforce) procedure-information (procedure) *)) (program-name (#(procedure #:clean #:enforce) program-name (#!optional string) string)) -(promise? (#(procedure #:pure #:predicate (struct promise)) promise? (*) boolean)) - -(make-promise (#(procedure #:enforce) make-promise (*) (struct promise)) - (((struct promise)) #(1))) (rename-file (#(procedure #:clean #:enforce) rename-file (string string) string)) (return-to-host (procedure return-to-host () . *)) @@ -1311,41 +1351,13 @@ (set-port-name! (#(procedure #:clean #:enforce) set-port-name! (port string) undefined) ((port string) (##sys#setslot #(1) '3 #(2)))) -(setter (#(procedure #:clean #:enforce) setter (procedure) procedure)) - -(signum (#(procedure #:clean #:enforce) signum (number) (or fixnum float cplxnum)) - ((fixnum) (fixnum) (##core#inline "C_i_fixnum_signum" #(1))) - ((integer) (fixnum) (##core#inline "C_u_i_integer_signum" #(1))) - ((float) (float) - (##core#inline_allocate ("C_a_u_i_flonum_signum" 4) #(1))) - ((ratnum) (fixnum) - (##core#inline "C_u_i_integer_signum" - (##core#inline "C_u_i_ratnum_num" #(1)))) - ((cplxnum) ((or float cplxnum)) (##sys#extended-signum #(1)))) (sleep (#(procedure #:clean #:enforce) sleep (fixnum) undefined)) -(string->uninterned-symbol (#(procedure #:clean #:enforce) string->uninterned-symbol (string) symbol)) - -(sub1 (#(procedure #:clean #:enforce #:foldable) sub1 (number) number) - ((fixnum) (integer) - (##core#inline_allocate ("C_a_i_fixnum_difference" 5) #(1) '1)) - ((integer) (integer) - (##core#inline_allocate ("C_s_a_u_i_integer_minus" 5) #(1) '1)) - ((float) (float) - (##core#inline_allocate ("C_a_i_flonum_difference" 4) #(1) '1.0)) - ((*) (number) - (##core#inline_allocate ("C_s_a_i_minus" 29) #(1) '1))) -(subvector (forall (a) (#(procedure #:clean #:enforce) subvector ((vector-of a) fixnum #!optional fixnum) (vector-of a)))) (symbol-escape (#(procedure #:clean) symbol-escape (#!optional *) *)) (system (#(procedure #:clean #:enforce) system (string) fixnum)) -(vector-resize - (forall (a b) (#(procedure #:clean #:enforce) vector-resize ((vector-of a) fixnum #!optional b) - (vector-of (or a b))))) -(void (#(procedure #:pure) void (#!rest) undefined)) (##sys#void (#(procedure #:pure) void (#!rest) undefined)) -(warning (procedure warning (* #!rest) undefined)) ;; chicken (internal) -- 2.11.0