~ chicken-core (chicken-5) 56aada40da14e9f60be946b940c21b5fee3d4c8b
commit 56aada40da14e9f60be946b940c21b5fee3d4c8b
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Mon Sep 11 18:35:10 2017 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Thu Oct 12 11:32:34 2017 +1300
Add preliminary 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.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/README b/README
index a518db00..09da6817 100644
--- a/README
+++ b/README
@@ -281,6 +281,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..bad52153 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<=? string-ci=? 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..b6086a76 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)
@@ -365,20 +365,6 @@
(##core#lambda () ,exp)
(##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
@@ -399,49 +385,6 @@
(##sys#check-syntax 'include-relative form '(_ string))
`(##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
@@ -474,33 +417,6 @@
ids old-tmps)
(##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
@@ -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 06212515..077b38f9 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,20 +59,20 @@
(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)
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
@@ -72,14 +80,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*)
@@ -106,15 +114,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)
@@ -126,13 +134,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
@@ -144,39 +152,38 @@
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!)
(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 5ce932d5..29bf2aff 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -266,6 +266,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
@@ -1619,13 +1620,6 @@
`(##core#require ,lib ,(module-requirement name)))))
(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
'()
diff --git a/library.scm b/library.scm
index 584e539c..864d3032 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)))
@@ -2931,7 +3034,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)))
@@ -2945,7 +3048,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))
@@ -2972,27 +3075,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)"))
@@ -3023,7 +3127,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))
@@ -3856,17 +3960,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))
@@ -4340,7 +4446,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))
@@ -4389,13 +4495,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:
@@ -5477,19 +5584,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)
@@ -5687,22 +5781,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
@@ -5873,3 +5951,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 717b60fd..d2c9a3f8 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
@@ -1013,16 +1099,7 @@
(chicken.time#current-seconds (#(procedure #:clean) chicken.time#current-seconds () integer))
(chicken.time#current-milliseconds (#(procedure #:clean) chicken.time#current-milliseconds () integer))
-(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)
@@ -1035,26 +1112,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)
@@ -1193,8 +1252,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))
@@ -1247,18 +1304,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)
@@ -1278,17 +1328,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)))
(return-to-host (procedure return-to-host () . *))
@@ -1309,41 +1349,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)
Trap