~ chicken-r7rs (master) 50fff6c946b166e4b3b15aab2550a766c993f22e
commit 50fff6c946b166e4b3b15aab2550a766c993f22e
Merge: 779e1ce c666cef
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Wed May 30 13:04:26 2018 +1200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Wed May 30 13:05:32 2018 +1200
Merge branch 'chicken-5'
diff --cc r7rs-compile-time-module.scm
index 5751c66,5e5132a..51d32e3
--- a/r7rs-compile-time-module.scm
+++ b/r7rs-compile-time-module.scm
@@@ -1,8 -1,6 +1,7 @@@
--(module r7rs-compile-time (r7rs-cond-expand
++(module r7rs-compile-time (r7rs-begin
++ r7rs-cond-expand
r7rs-define-library
- r7rs-import
- r7rs-import-for-syntax
r7rs-include
r7rs-include-ci)
-- (import scheme chicken)
++ (import scheme chicken.base)
(include "r7rs-compile-time.scm"))
diff --cc r7rs-compile-time.scm
index 2fe8238,addef42..4bc2fe3
--- a/r7rs-compile-time.scm
+++ b/r7rs-compile-time.scm
@@@ -1,12 -1,9 +1,10 @@@
;;;; compile-time support code (mostly for modules)
-
- (module r7rs-compile-time *
--
- (import scheme matchable)
- (import srfi-1 chicken.base chicken.syntax chicken.plist
- chicken.pathname chicken.platform chicken.file)
-(import matchable)
-(use srfi-1)
-(use r7rs-library r7rs-support)
++(import-syntax matchable)
++(import chicken.base chicken.file chicken.plist)
++(import chicken.syntax chicken.platform)
++(import srfi-1)
+(import r7rs-library r7rs-support)
(define (locate-library name loc) ; must be stripped
;;XXX scan include-path?
@@@ -86,29 -65,17 +65,27 @@@
(map expand/begin exps)))
(define (read-forms filename ci?)
- (let ((path (##sys#resolve-include-filename filename #t)))
- (fluid-let ((##sys#default-read-info-hook
- (and (feature? 'compiling) ##compiler#read-info-hook))
- (##sys#include-pathnames
- (cond ((pathname-directory path) =>
- (cut cons <> ##sys#include-pathnames))
- ((current-source-directory) =>
- (cut cons <> ##sys#include-pathnames))
- (else ##sys#include-pathnames))))
- (expand-toplevel-r7rs-library-forms
- (parameterize ((case-sensitive (not ci?)))
- (##sys#include-forms-from-file path))))))
+ (fluid-let ((##sys#default-read-info-hook
+ (let ((name 'chicken.compiler.support#read-info-hook))
+ (and (feature? 'compiling)
+ (##sys#symbol-has-toplevel-binding? name)
+ (##sys#slot name 0)))))
+ (parameterize ((case-sensitive (not ci?)))
+ (##sys#include-forms-from-file
+ filename
+ ##sys#current-source-filename
+ expand-toplevel-r7rs-library-forms))))
+(define implicit-r7rs-library-bindings
+ '(begin
+ cond-expand
+ export
+ import
+ import-for-syntax
+ include
+ include-ci
+ syntax-rules))
+
(define (parse-library-definition form dummy-export) ; expects stripped syntax
(match form
((_ name decls ...)
@@@ -169,16 -136,16 +146,17 @@@
,@code
,(parse-decls more)))
(decl (syntax-error 'define-library "invalid library declaration" decl))))
- `(##core#module
- ,real-name ((,dummy-export))
- ;; gruesome hack: we add a dummy export for adding indirect exports
- (##core#define-syntax ,dummy-export (##core#lambda _ '(##core#undefined)))
- ;; Another gruesome hack: provide feature so "use" works properly
- (##sys#provide (##core#quote ,real-name))
- ;; Set up an R7RS environment for the module's body.
- (import-for-syntax (only r7rs ,@implicit-r7rs-library-bindings))
- (import (only r7rs ,@implicit-r7rs-library-bindings))
- ,(parse-decls decls))))
+ `(##core#module ,real-name ((,dummy-export))
+ ;; gruesome hack: we add a dummy export for adding indirect exports
- (##core#define-syntax ,dummy-export (##core#lambda _ (##core#undefined)))
++ (##core#define-syntax ,dummy-export
++ (##sys#er-transformer (##core#lambda (x r c) (##core#undefined))))
+ ;; Another gruesome hack: provide feature so "use" works properly
+ (##sys#provide (##core#quote ,real-name))
+ ;; Set up an R7RS environment for the module's body.
- (import-for-syntax r7rs) ; overwrites "syntax-rules"
- (import r7rs) ; overwrites "export" et al.
++ (import-for-syntax (only r7rs ,@implicit-r7rs-library-bindings))
++ (import (only r7rs ,@implicit-r7rs-library-bindings))
+ ;; Now process all toplevel library declarations
- ,(parse-decls decls))))
++ ,(parse-decls decls))))
(_ (syntax-error 'define-library "invalid library definition" form))))
(define (register-r7rs-module name)
diff --cc r7rs-library.scm
index 61589bb,9d2cb5a..acd4cd5
--- a/r7rs-library.scm
+++ b/r7rs-library.scm
@@@ -6,10 -6,9 +6,10 @@@
;;;
(module r7rs-library *
--
- (import scheme chicken.base matchable)
- (import scheme chicken matchable)
- (use (only data-structures string-intersperse))
++ (import-syntax matchable)
++ (import scheme chicken.base)
+ (import (only chicken.string string-intersperse))
+ (import (only chicken.syntax syntax-error))
(define (fixup-import/export-spec spec loc)
(match spec
diff --cc r7rs-support.scm
index 1606043,feadb9c..85ec645
--- a/r7rs-support.scm
+++ b/r7rs-support.scm
@@@ -3,8 -3,8 +3,7 @@@
;;;
(module r7rs-support *
--
- (import scheme chicken)
+ (import scheme chicken.base chicken.syntax)
(define (macro-handler name)
(cond ((assq name (##sys#macro-environment)) => caddr)
diff --cc r7rs.egg
index 7783a1d,0000000..7106ca7
mode 100644,000000..100644
--- a/r7rs.egg
+++ b/r7rs.egg
@@@ -1,35 -1,0 +1,35 @@@
+((synopsis "R7RS compatibility")
+ (author "The Chicken Team")
+ (category lang-exts)
+ (license "BSD")
+ (dependencies matchable srfi-13)
+ (test-dependencies test)
+ (components
- (extension r7rs
++ (extension r7rs
+ (component-dependencies r7rs-compile-time)
- (source-dependencies "synrules.scm"
- "scheme.base-interface.scm"))
++ (source-dependencies "synrules.scm" "scheme.base-interface.scm"))
+ (extension r7rs-support)
+ (extension r7rs-library)
+ (extension r7rs-compile-time
++ (source "r7rs-compile-time-module.scm")
++ (source-dependencies "r7rs-compile-time.scm")
+ (component-dependencies r7rs-library r7rs-support))
+ (extension scheme.base
- (source-dependencies "scheme.base-interface.scm")
+ (types-file)
++ (source-dependencies "scheme.base-interface.scm")
+ (component-dependencies r7rs-support r7rs-compile-time))
+ (extension scheme.case-lambda (types-file))
+ (extension scheme.char (types-file) (component-dependencies r7rs-support))
+ (extension scheme.complex (types-file))
+ (extension scheme.cxr (types-file))
+ (extension scheme.eval (types-file) (component-dependencies r7rs-library))
+ (extension scheme.file (types-file))
+ (extension scheme.inexact (types-file))
+ (extension scheme.lazy (types-file))
+ (extension scheme.load (types-file))
+ (extension scheme.process-context (types-file))
- (extension scheme.r5rs (types-file)
- (component-dependencies scheme.eval))
++ (extension scheme.r5rs (types-file) (component-dependencies scheme.eval))
+ (extension scheme.read (types-file))
+ (extension scheme.repl (types-file))
+ (extension scheme.time (types-file))
+ (extension scheme.write (types-file))))
diff --cc r7rs.scm
index 724a12c,3c527b2..4a4bbf3
--- a/r7rs.scm
+++ b/r7rs.scm
@@@ -1,18 -1,19 +1,19 @@@
(module r7rs (define-library import import-for-syntax export syntax-rules)
--
-- (import (except scheme syntax-rules)) ;XXX except ...
- (import (only chicken.platform feature? register-feature!))
- (import (only chicken feature? include register-feature!))
++ (import (except scheme syntax-rules))
+ (import (only chicken.base include))
- (import chicken.module)
++ (import (only chicken.module export))
++ (import (only chicken.platform feature? register-feature!))
+ (import (only chicken.syntax begin-for-syntax))
- (import srfi-4)
;; For syntax definition helpers.
-- (import-for-syntax matchable)
++ (import-syntax-for-syntax matchable)
(import-for-syntax r7rs-compile-time)
- (begin-for-syntax
- (require-library r7rs-compile-time))
+ ;; For #u8(...) syntax.
- (require-extension srfi-4)
++ (import srfi-4)
+
;; Reexport (scheme base).
- (require-extension scheme.base)
+ (import scheme.base)
(include "scheme.base-interface.scm")
(let ((old-hook ##sys#user-read-hook))
diff --cc scheme.base.scm
index 39f8b9f,3de2760..eb629fd
--- a/scheme.base.scm
+++ b/scheme.base.scm
@@@ -1,62 -1,69 +1,70 @@@
(module scheme.base ()
- (import (rename chicken.platform
-(import (rename (except (chicken) vector-copy! with-exception-handler)
-- (features feature-keywords)))
- (import (except chicken.condition with-exception-handler))
- (import chicken.module)
- (import (except scheme syntax-rules assoc member list-tail
- char=? char<? char>? char<=? char>=?
- string=? string<? string>? string<=? string>=?
- string-copy string->list vector->list vector-fill!))
--
- (import (prefix (only scheme char=? char<? char>? char<=? char>=?
- string=? string<? string>? string<=? string>=?)
-(import (except (scheme) syntax-rules cond-expand assoc list-tail member
- char=? char<? char>? char<=? char>=? string=? string<?
- string>? string<=? string>=? string-copy string->list
- vector->list vector-fill!))
-
-(import (prefix (only (scheme) char=? char<? char>? char<=? char>=?
- string=? string<? string>? string<=? string>=?)
-- %))
--
- (import (rename (only srfi-4 make-u8vector subu8vector u8vector u8vector?
- u8vector-length u8vector-ref u8vector-set!
- read-u8vector read-u8vector! write-u8vector)
-(import (rename (only (srfi 4) make-u8vector subu8vector u8vector
- u8vector? u8vector-length u8vector-ref
- u8vector-set! read-u8vector read-u8vector!
- write-u8vector)
-- (u8vector bytevector)
-- (u8vector-length bytevector-length)
-- (u8vector-ref bytevector-u8-ref)
-- (u8vector-set! bytevector-u8-set!)
-- (u8vector? bytevector?)
-- (make-u8vector make-bytevector)
- (read-u8vector read-bytevector)
-- (write-u8vector write-bytevector)))
-
-(include "scheme.base-interface.scm")
++(import chicken.fixnum
++ chicken.module
++ chicken.syntax
++ chicken.type
++ (except chicken.condition with-exception-handler)
++ (rename chicken.platform (features feature-keywords))
++ (only chicken.base call/cc case-lambda current-error-port
++ define-values exact-integer? exact-integer-sqrt letrec*
++ let-values let*-values make-parameter open-input-string
++ parameterize quotient&remainder error foldl cut optional
++ when unless receive)
++ (except scheme syntax-rules assoc list-tail member string-copy
++ string->list vector->list vector-fill! char=? char<? char>?
++ char<=? char>=? string=? string<? string>? string<=? string>=?))
;; For syntax definition helpers.
(import-for-syntax r7rs-support)
(import-for-syntax r7rs-compile-time)
-(begin-for-syntax
- (require-library r7rs-compile-time))
(import r7rs-support)
- (import chicken.type)
- (import (only chicken.base exact-integer? exact-integer-sqrt
- quotient&remainder error
- error foldl cut optional when case-lambda unless receive))
- (include "scheme.base-interface.scm")
++;; Export all of scheme.base from this module.
++(import (prefix (only chicken.base include) %))
++(%include "scheme.base-interface.scm")
++
+ ;; Numerical operations.
-(import (rename (only scheme exact->inexact inexact->exact modulo quotient remainder)
++(import (rename (only scheme exact->inexact inexact->exact)
+ (exact->inexact inexact)
- (inexact->exact exact)
- (modulo floor-remainder)
- (quotient truncate-quotient)
- (remainder truncate-remainder))
- (rename (only chicken quotient&remainder)
- (quotient&remainder truncate/)))
++ (inexact->exact exact)))
;; read/write-string/line/byte
- (import (prefix (only chicken.io read-string write-string) %))
- (import (rename (only chicken.io read-line read-byte write-byte)
-(import (prefix (only (chicken io) write-string) %))
-(import (rename (only (chicken io) read-line read-string read-byte write-byte)
++(import (prefix (only chicken.io write-string) %))
++(import (rename (only chicken.io read-line read-string read-byte write-byte)
(read-byte read-u8)
(write-byte write-u8)))
- (import chicken.fixnum)
-
;; flush-output
-(import (rename (only chicken flush-output)
+(import (rename (only chicken.base flush-output)
(flush-output flush-output-port)))
++;; Bytevectors.
++(import (rename (only srfi-4 make-u8vector subu8vector u8vector
++ u8vector? u8vector-length u8vector-ref
++ u8vector-set! read-u8vector read-u8vector!
++ write-u8vector)
++ (u8vector bytevector)
++ (u8vector-length bytevector-length)
++ (u8vector-ref bytevector-u8-ref)
++ (u8vector-set! bytevector-u8-set!)
++ (u8vector? bytevector?)
++ (make-u8vector make-bytevector)
++ (read-u8vector read-bytevector)
++ (write-u8vector write-bytevector)))
++
;; u8-ready?
(import (rename (only scheme char-ready?)
(char-ready? u8-ready?)))
--;; Non-R5RS string-*
-(import (prefix (only (srfi 13) string-for-each string-map) %))
-(import (only (srfi 13) string-copy string-copy! string-fill! string->list))
++;; Non-R5RS string and char procedures.
++(import (prefix (only scheme char=? char<? char>? char<=? char>=?) %))
++(import (prefix (only scheme string=? string<? string>? string<=? string>=?) %))
+(import (prefix (only srfi-13 string-for-each string-map) %))
+(import (only srfi-13 string-copy string-copy! string-fill! string->list))
;; For d-r-t redefinition.
-(import-for-syntax (only chicken define-record-type))
+(import-for-syntax (only chicken.base define-record-type))
;;;
;;; 4.1.7. Inclusion
@@@ -138,6 -145,6 +146,9 @@@
;;; 5.5 Record-type definitions
;;;
++(define ##sys#make-symbol
++ (##core#primitive "C_make_symbol"))
++
;; Rewrite the standard d-r-t expansion so that each newly-defined
;; record type has a unique type tag. This is every kind of hacky.
(define-syntax define-record-type
@@@ -158,49 -165,9 +169,51 @@@
;;; 6.2.6 Numerical operations
;;;
+;; TODO: Copy the specializations from types.db
+(: truncate/ ((or integer float) (or integer float) -> (or integer float) (or integer float)))
+
+(define truncate/ quotient&remainder)
+
+(: truncate-remainder ((or integer float) (or integer float) -> (or integer float)))
+
+(define truncate-remainder remainder)
+
+(: truncate-quotient ((or integer float) (or integer float) -> (or integer float)))
+
+(define truncate-quotient quotient)
+
+;; XXX These are bad bad bad definitions; very inefficient.
+;; But to improve it we would need to provide another implementation
+;; of the quotient procedure which floors instead of truncates.
+
+(: floor-remainder ((or fixnum bignum float ratnum) (or fixnum bignum float ratnum) -> (or fixnum bignum float ratnum) (or fixnum bignum float ratnum)))
+
+(define (floor-remainder x y)
+ (receive (div rem) (floor/ x y) rem))
+
+(: floor-quotient ((or fixnum bignum float ratnum) (or fixnum bignum float ratnum) -> (or fixnum bignum float ratnum) (or fixnum bignum float ratnum)))
+
+(define (floor-quotient x y)
+ (receive (div rem) (floor/ x y) div))
+
+(: floor/ ((or fixnum bignum float ratnum) (or fixnum bignum float ratnum) -> (or fixnum bignum float ratnum) (or fixnum bignum float ratnum)))
+
+;; Same as quotient&remainder, but quotient gets adjusted along with
+;; the remainder.
+(define (floor/ x y)
+ (receive (div rem) (quotient&remainder x y)
+ (if (positive? y)
+ (if (negative? rem)
+ (values (- div 1) (+ rem y))
+ (values div rem))
+ (if (positive? rem)
+ (values (- div 1) (+ rem y))
+ (values div rem)))))
+
+
(: square (number -> number))
+ (: floor/ (number number -> number number))
+ (: floor-quotient (number number -> number))
(define (square n) (* n n))
diff --cc scheme.char.scm
index 05f03c8,f792a86..5f58425
--- a/scheme.char.scm
+++ b/scheme.char.scm
@@@ -7,8 -7,7 +7,7 @@@
string-upcase string-downcase
digit-value)
- (import chicken.base chicken.fixnum)
- (import (only chicken.type :))
-(import chicken)
++(import chicken.base chicken.fixnum chicken.type)
(import r7rs-support)
(import
(except scheme
diff --cc scheme.cxr.scm
index b3463aa,b3463aa..5c16276
--- a/scheme.cxr.scm
+++ b/scheme.cxr.scm
@@@ -22,5 -22,5 +22,4 @@@
cddadr
cdddar
cddddr)
-- (import scheme)
--)
++ (import scheme))
diff --cc scheme.eval.scm
index 6c167d2,f221d82..9d56c96
--- a/scheme.eval.scm
+++ b/scheme.eval.scm
@@@ -1,9 -1,8 +1,7 @@@
--(module scheme.eval (eval
-- environment)
--
- (import (rename scheme (eval %eval)) chicken.base)
- (import (only chicken.type :))
- (import (rename scheme (eval %eval)) chicken)
- (use r7rs-library)
++(module scheme.eval (eval environment)
++ (import (rename scheme (eval %eval)))
++ (import chicken.base chicken.type)
+ (import r7rs-library)
;;;
;;; 6.12. Environments and evaluation
diff --cc scheme.file.scm
index 435dd36,c83f4d3..d6355fb
--- a/scheme.file.scm
+++ b/scheme.file.scm
@@@ -10,10 -10,9 +10,8 @@@
open-binary-output-file
open-output-file
with-output-to-file)
--
-- (import scheme)
- (import (only chicken.type :))
- (import (rename (only chicken delete-file file-exists? :)
++ (import scheme chicken.type)
+ (import (rename (only chicken.file delete-file file-exists?)
(file-exists? chicken-file-exists?)))
;; CHICKEN's file-exists? returns the filename when true,
diff --cc scheme.inexact.scm
index 6744b62,ca402df..3a822b2
--- a/scheme.inexact.scm
+++ b/scheme.inexact.scm
@@@ -1,3 -1,13 +1,13 @@@
- (module scheme.inexact ()
- (import scheme chicken.base chicken.module)
- (export acos asin atan exp infinite? sin cos tan finite? log sqrt nan?))
-(module scheme.inexact (acos
++(module scheme.inexact (acos
+ asin
+ atan
+ exp
+ infinite?
+ sin
+ cos
+ tan
+ finite?
+ log
+ sqrt
+ nan?)
- (import scheme chicken))
++ (import scheme chicken.base))
diff --cc scheme.load.scm
index 460598e,f664f86..aab5ade
--- a/scheme.load.scm
+++ b/scheme.load.scm
@@@ -1,8 -1,7 +1,6 @@@
(module scheme.load (load)
- (import chicken.base
- (only chicken.type :))
- (import chicken)
-- (import (rename scheme (load %load)
-- (eval %eval)))
++ (import chicken.base chicken.type)
++ (import (rename scheme (load %load) (eval %eval)))
(: load (string #!optional (struct environment) -> undefined))
diff --cc scheme.process-context.scm
index 94347bd,c09eef2..0f6ea6d
--- a/scheme.process-context.scm
+++ b/scheme.process-context.scm
@@@ -3,20 -3,17 +3,16 @@@
exit
get-environment-variable
get-environment-variables)
--
-- (import scheme
- (rename chicken.base (exit chicken-exit))
- chicken.type
- (rename chicken (exit chicken-exit))
- foreign)
++ (import scheme
+ chicken.process-context
- (only chicken.fixnum fx+)
- chicken.foreign)
++ chicken.type
++ (rename chicken.base (exit chicken-exit)))
;;;
;;; 6.14. System interface.
;;;
(: command-line (-> (list-of string)))
--(: get-environment-variables (-> (list-of (pair string string))))
(: exit (#!optional * -> noreturn))
(: emergency-exit (#!optional * -> noreturn))
@@@ -24,33 -21,33 +20,6 @@@
;; Don't cache these; they may be parameterized at any time!
(cons (program-name) (command-line-arguments)))
--;; XXX get-environment-variables copied from posixunix.scm.
--;; (And not actually expected to work on other platforms yet.)
--
--#>
--#ifdef __APPLE__
--# include <crt_externs.h>
--# define C_getenventry(i) ((*_NSGetEnviron())[ i ])
--#else
--extern char **environ;
--# define C_getenventry(i) (environ[ i ])
--#endif
--<#
--
--(define get-environment-variables
-- (let ([get (foreign-lambda c-string "C_getenventry" int)])
-- (lambda ()
-- (let loop ([i 0])
-- (let ([entry (get i)])
-- (if entry
-- (let scan ([j 0])
-- (if (char=? #\= (##core#inline "C_subchar" entry j))
-- (cons (cons (##sys#substring entry 0 j)
-- (##sys#substring entry (fx+ j 1) (##sys#size entry)))
-- (loop (fx+ i 1)))
-- (scan (fx+ j 1)) ) )
-- '()))))))
--
(define (->exit-status obj)
(cond ((integer? obj) obj)
((eq? obj #f) 1)
diff --cc scheme.r5rs.scm
index 4e5ca11,dcd9953..d97f26e
--- a/scheme.r5rs.scm
+++ b/scheme.r5rs.scm
@@@ -1,26 -1,26 +1,19 @@@
(module scheme.r5rs ()
-
- (import
- (rename scheme
- (null-environment %null-environment)
- (scheme-report-environment %scheme-report-environment)))
- (import chicken.base chicken.module chicken.module
- chicken.syntax
- (only chicken.type :))
++ (import (rename scheme
++ (null-environment %null-environment)
++ (scheme-report-environment %scheme-report-environment)))
++ (import chicken.base chicken.module chicken.syntax chicken.type)
+ (import scheme.eval)
- (import chicken)
- (import
- (rename scheme
- (null-environment %null-environment)
- (scheme-report-environment %scheme-report-environment)))
-
- (reexport
- (only chicken angle make-polar make-rectangular rationalize))
-
- (require-extension scheme.eval)
+ (export angle make-polar make-rectangular rationalize)
(export null-environment scheme-report-environment)
(reexport
-- (except scheme
-- null-environment scheme-report-environment eval
-- and begin begin-for-syntax case cond cond-expand
-- define define-syntax delay delay-force do export if
-- import import-for-syntax lambda let let* let-syntax
-- letrec letrec* letrec-syntax module or quasiquote quote
-- reexport require-extension require-extension-for-syntax
-- require-library set! syntax syntax-rules))
++ (except scheme
++ null-environment scheme-report-environment eval
++ and begin case cond define define-syntax delay do
++ if lambda let let* let-syntax letrec letrec-syntax
++ or quasiquote quote set! syntax-rules))
(define-constant null-environment-identifiers
'(and begin case cond cond-expand define define-syntax delay
diff --cc scheme.read.scm
index e828958,d9f5afc..de40b49
--- a/scheme.read.scm
+++ b/scheme.read.scm
@@@ -1,12 -1,9 +1,11 @@@
-(module (scheme read) (read)
- (import (except (scheme) read)
- (only (chicken) : case-sensitive current-read-table feature?)
- (only (chicken) fluid-let fx+ fx= optional unless when)
- (only (chicken) define-constant define-inline parameterize)
- (only (chicken read-syntax) set-read-syntax!))
+(module scheme.read (read)
+ (import (except scheme read)
- (only chicken.type :)
- (only chicken.platform feature?)
- (only chicken.fixnum fx+ fx=)
- (only chicken.read-syntax current-read-table)
- (only chicken.base fluid-let
- optional unless when case-sensitive
- define-constant define-inline parameterize))
++ (only chicken.base case-sensitive define-constant define-inline)
++ (only chicken.base fluid-let parameterize optional unless when)
++ (only chicken.fixnum fx+ fx=)
++ (only chicken.platform feature?)
++ (only chicken.read-syntax current-read-table set-read-syntax!)
++ (only chicken.type :))
;;;
;;; 2.1 Identifiers
diff --cc scheme.time.scm
index f9a64e0,9f9524f..5654bdc
--- a/scheme.time.scm
+++ b/scheme.time.scm
@@@ -1,11 -1,9 +1,10 @@@
(module scheme.time (current-second
current-jiffy
jiffies-per-second)
- (import (only scheme define inexact->exact)
- (import (only (chicken) : define-constant)
- (only (chicken time) current-seconds current-milliseconds)
- (only (scheme) + define inexact->exact))
++ (import (only chicken.base define-constant)
++ (only chicken.time current-seconds current-milliseconds)
+ (only chicken.type :)
- (only chicken.base define-constant)
- (only chicken.time current-seconds current-milliseconds)
- (only chicken.flonum fp+))
++ (only scheme + define inexact->exact))
;; As of 2012-06-30.
(define-constant tai-offset 35.)
diff --cc scheme.write.scm
index 3bfc4fd,3a24f15..e270810
--- a/scheme.write.scm
+++ b/scheme.write.scm
@@@ -3,10 -3,7 +3,10 @@@
write-shared
write-simple)
(import (rename scheme (display display-simple) (write write-simple))
- (only chicken : feature? foldl fx+ fx= fx<= optional when))
+ (only chicken.base foldl when optional)
- (only chicken.platform feature?)
- (only chicken.type :)
- (only chicken.fixnum fx+ fx= fx<=))
++ (only chicken.platform feature?)
++ (only chicken.type :)
++ (only chicken.fixnum fx+ fx= fx<=))
(when (feature? 'csi)
(set! ##sys#repl-print-hook
diff --cc synrules.scm
index c797c00,c797c00..a306827
--- a/synrules.scm
+++ b/synrules.scm
@@@ -98,6 -98,6 +98,10 @@@
(define %temp (r 'temp))
(define %syntax-error '##sys#syntax-error-hook)
(define %ellipsis (r ellipsis))
++ (define %take-right (r 'chicken.internal.syntax-rules#take-right))
++ (define %drop-right (r 'chicken.internal.syntax-rules#drop-right))
++ (define %syntax-rules-mismatch
++ (r 'chicken.internal.syntax-rules#syntax-rules-mismatch))
(define (ellipsis? x)
(c x %ellipsis))
@@@ -180,7 -180,7 +184,7 @@@
(let* ((tail-length (length (cddr pattern)))
(%match (if (zero? tail-length) ; Simple segment?
path ; No list traversing overhead at runtime!
-- `(##sys#drop-right ,path ,tail-length))))
++ `(,%drop-right ,path ,tail-length))))
(append
(process-pattern (car pattern)
%temp
@@@ -191,7 -191,7 +195,7 @@@
`(,%map1 (,%lambda (,%temp) ,x) ,%match))))
#f el?)
(process-pattern (cddr pattern)
-- `(##sys#take-right ,path ,tail-length)
++ `(,%take-right ,path ,tail-length)
mapit #t el?))))
((pair? pattern)
(append (process-pattern (car pattern) `(,%car ,path) mapit #f el?)
diff --cc tests/run.scm
index 238b919,d8b10b9..b40f3a3
--- a/tests/run.scm
+++ b/tests/run.scm
@@@ -1,15 -1,12 +1,12 @@@
- (use r7rs)
-
- ;; XXX: This seems to be necessary in order to get the syntax-rules
- ;; from r7rs rather than the built-in CHICKEN one. I'm not sure if
- ;; that's correct or not...
- (import-for-syntax (r7rs))
-
- (import (chicken)
+ (import (r7rs)
- (chicken)
- (chicken data-structures)
++ (chicken base)
+ (chicken io)
- (chicken ports)
++ (chicken port)
++ (chicken string)
(test)
- (ports)
(scheme base)
(scheme char)
+ (scheme eval)
(scheme file)
(scheme read)
(scheme write))
@@@ -24,12 -26,12 +26,12 @@@
'(FOO mooh qux blah foo BAR)
(append
(with-input-from-string
- "FOO #!fold-case mooh QUX blah #!no-fold-case foo BAR" read-file)))
- "FOO #!fold-case mooh QUX blah #!no-fold-case foo BAR" read-all)))
++ "FOO #!fold-case mooh QUX blah #!no-fold-case foo BAR" read-list)))
(test "#!(no-)fold-case only affects subsequent reads from the same port"
'(FOO bar baz downcased UPCASED)
(append
- (with-input-from-string "FOO #!fold-case bar BAZ" read-file)
- (with-input-from-string "downcased UPCASED" read-file))))
- (with-input-from-string "FOO #!fold-case bar BAZ" read-all)
- (with-input-from-string "downcased UPCASED" read-all))))
++ (with-input-from-string "FOO #!fold-case bar BAZ" read-list)
++ (with-input-from-string "downcased UPCASED" read-list))))
(test-group "4.1.7: Inclusion"
(test-group "include"
Trap