~ chicken-core (chicken-5) e213ec8a5e8faa5fb1b1caffd5d2908fd14e7197
commit e213ec8a5e8faa5fb1b1caffd5d2908fd14e7197
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sun Feb 25 11:53:13 2018 +0100
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Mon Feb 26 18:54:44 2018 +1300
Move remaining macros from "chicken" into other modules or drop them.
- Removed eval-when, select and ensure. Only "select" was really
being used by core, in a handful of places in the posix modules
which is trivially replaced by a "cond". These macros will be
moved to the miscmacros egg.
- Moved define-for-syntax and {let,define}-compiler-syntax into
chicken.syntax
- Moved time into chicken.time
- Moved assert into chicken.base
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/NEWS b/NEWS
index 30a9c344..e7486888 100644
--- a/NEWS
+++ b/NEWS
@@ -64,6 +64,8 @@
- Added the `glob->sre` procedure to the irregex library.
- Removed the `get-host-name' and `system-information' procedures.
These are available in the "system-information" egg.
+ - Removed the `eval-when`, `select` and `ensure` macros. These are
+ available in the "miscmacros" egg.
- Renamed bit-set? to bit->boolean because of swapped argument order
with respect to SRFI-33 and SRFI-60, which was confusing (fixes
#1385, thanks to Lemonboy).
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 53a6ef1d..c267f198 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -286,6 +286,31 @@
(##sys#register-meta-expression `(##core#begin ,@(cdr x)))
`(##core#elaborationtimeonly (##core#begin ,@(cdr x))))))
+(##sys#extend-macro-environment
+ 'define-for-syntax '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'define-for-syntax form '(_ _ . _))
+ `(,(r 'begin-for-syntax)
+ (,(r 'define) ,@(cdr form))))))
+
+
+;;; Compiler syntax
+
+(##sys#extend-macro-environment
+ 'define-compiler-syntax '()
+ (syntax-rules ()
+ ((_ name)
+ (##core#define-compiler-syntax name #f))
+ ((_ name transformer)
+ (##core#define-compiler-syntax name transformer))))
+
+(##sys#extend-macro-environment
+ 'let-compiler-syntax '()
+ (syntax-rules ()
+ ((_ (binding ...) body ...)
+ (##core#let-compiler-syntax (binding ...) body ...))))
+
(macro-subset me0 ##sys#default-macro-environment)))
@@ -1236,27 +1261,8 @@
(lambda (x r c)
`(,(r 'begin-for-syntax) (,(r 'require-extension) ,@(cdr x))))))
-(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))))))))
+;;; Assertions
(##sys#extend-macro-environment
'assert '()
@@ -1280,124 +1286,39 @@
(cdr msg-and-args)
`((##core#quote ,(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))))))))))
+(macro-subset me0 ##sys#default-macro-environment)))
-(##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))
- (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'"
- (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:
+;;; "time"
+
+(set! ##sys#chicken.time-macro-environment
+ (let ((me0 (##sys#macro-environment)))
(##sys#extend-macro-environment
- 'define-for-syntax '()
+ 'time '()
(##sys#er-transformer
(lambda (form r c)
- (##sys#check-syntax 'define-for-syntax form '(_ _ . _))
- `(,(r 'begin-for-syntax)
- (,(r 'define) ,@(cdr form))))))
-
-
-;;; compiler syntax
+ (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
- 'define-compiler-syntax '()
- (syntax-rules ()
- ((_ name)
- (##core#define-compiler-syntax name #f))
- ((_ name transformer)
- (##core#define-compiler-syntax name transformer))))
+(macro-subset me0 ##sys#default-macro-environment)))
-(##sys#extend-macro-environment
- 'let-compiler-syntax '()
- (syntax-rules ()
- ((_ (binding ...) body ...)
- (##core#let-compiler-syntax (binding ...) body ...))))
+(set! ##sys#chicken-macro-environment ;; OBSOLETE, remove after bootstrapping
+ (let ((me0 (##sys#macro-environment)))
;; capture current macro env and add all the preceding ones as well
-;; TODO: omit `chicken.{base,condition,type}-m-e' when plain "chicken" module goes away
+;; TODO: omit `chicken.{base,condition,time,type}-m-e' when plain "chicken" module goes away
(append ##sys#chicken.condition-macro-environment
+ ##sys#chicken.time-macro-environment
##sys#chicken.type-macro-environment
##sys#chicken.base-macro-environment
(macro-subset me0 ##sys#default-macro-environment))))
diff --git a/chicken.time.import.scm b/chicken.time.import.scm
new file mode 100644
index 00000000..6face8a7
--- /dev/null
+++ b/chicken.time.import.scm
@@ -0,0 +1,35 @@
+;;;; chicken.time.import.scm - GENERATED BY CHICKEN 5.0.0 -*- Scheme -*-
+;
+; Copyright (c) 2018, 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 conditionsand 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.time
+ 'library
+ '((cpu-time . chicken.time#cpu-time)
+ (current-milliseconds . chicken.time#current-milliseconds)
+ (current-seconds . chicken.time#current-seconds))
+ ;; OBSOLETE: This can be removed after bootstrapping
+ (if (##sys#symbol-has-toplevel-binding? '##sys#chicken.time-macro-environment)
+ ##sys#chicken.time-macro-environment
+ ##sys#chicken.base-macro-environment))
diff --git a/defaults.make b/defaults.make
index dc536b7e..5c33f10e 100644
--- a/defaults.make
+++ b/defaults.make
@@ -263,13 +263,13 @@ CHICKEN_PROGRAM_OPTIONS += $(if $(PROFILE_OBJECTS),-profile)
# import libraries
PRIMITIVE_IMPORT_LIBRARIES = chicken chicken.base chicken.condition \
- chicken.csi chicken.foreign chicken.syntax
+ chicken.csi chicken.foreign chicken.syntax chicken.time
DYNAMIC_IMPORT_LIBRARIES = srfi-4
DYNAMIC_CHICKEN_IMPORT_LIBRARIES = bitwise blob errno file.posix \
fixnum flonum format gc io keyword load locative memory \
memory.representation platform plist posix pretty-print \
process process.signal process-context process-context.posix \
- random sort string time time.posix
+ random sort string time.posix
DYNAMIC_CHICKEN_COMPILER_IMPORT_LIBRARIES = user-pass
DYNAMIC_CHICKEN_UNIT_IMPORT_LIBRARIES = continuation eval file \
internal irregex pathname port read-syntax repl tcp
diff --git a/expand.scm b/expand.scm
index 2dfa6ae2..5cacd1e9 100644
--- a/expand.scm
+++ b/expand.scm
@@ -174,9 +174,10 @@
(define ##sys#scheme-macro-environment '()) ; reassigned below
;; These are all re-assigned by chicken-syntax.scm:
-(define ##sys#chicken-macro-environment '()) ; used later in chicken.import.scm
+(define ##sys#chicken-macro-environment '()) ; used later in chicken.import.scm [OBSOLETE]
(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.time-macro-environment '()) ; used later in chicken.time.import.scm
(define ##sys#chicken.type-macro-environment '()) ; used later in chicken.type.import.scm
(define ##sys#chicken.syntax-macro-environment '()) ; used later in chicken.syntax.import.scm
(define ##sys#chicken.base-macro-environment '()) ; used later in chicken.base.import.scm
@@ -360,8 +361,8 @@
;; These might not exist in se, use default or chicken env:
(%let* (macro-alias 'let* ##sys#default-macro-environment))
(%lambda '##core#lambda)
- (%opt (macro-alias 'optional ##sys#chicken-macro-environment))
- (%let-optionals* (macro-alias 'let-optionals* ##sys#chicken-macro-environment))
+ (%opt (macro-alias 'optional ##sys#chicken.base-macro-environment))
+ (%let-optionals* (macro-alias 'let-optionals* ##sys#chicken.base-macro-environment))
(%let '##core#let))
(let loop ([mode 0] ; req=0, opt=1, rest=2, key=3, end=4
[req '()]
diff --git a/library.scm b/library.scm
index 7a7e5429..cd71a216 100644
--- a/library.scm
+++ b/library.scm
@@ -1077,7 +1077,11 @@ EOF
(##sys#setslot x i y) )
(module chicken.time
- (cpu-time current-milliseconds current-seconds)
+ ;; NOTE: We don't emit the import lib. Due to syntax exports, it has
+ ;; to be a hardcoded primitive module.
+ ;;
+ ;; [syntax] time
+ (cpu-time current-milliseconds current-seconds)
(import scheme)
(import (only (chicken module) reexport))
diff --git a/posix-common.scm b/posix-common.scm
index d3f1c751..2805bd27 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -275,15 +275,16 @@ EOF
(define (file-type file #!optional link (err #t))
(and (stat file link err 'file-type)
- (select (foreign-value "C_stat_type" unsigned-int)
- ((S_IFREG) 'regular-file)
- ((S_IFLNK) 'symbolic-link)
- ((S_IFDIR) 'directory)
- ((S_IFCHR) 'character-device)
- ((S_IFBLK) 'block-device)
- ((S_IFIFO) 'fifo)
- ((S_IFSOCK) 'socket)
- (else 'regular-file))))
+ (let ((res (foreign-value "C_stat_type" unsigned-int)))
+ (cond
+ ((fx= res S_IFREG) 'regular-file)
+ ((fx= res S_IFLNK) 'symbolic-link)
+ ((fx= res S_IFDIR) 'directory)
+ ((fx= res S_IFCHR) 'character-device)
+ ((fx= res S_IFBLK) 'block-device)
+ ((fx= res S_IFIFO) 'fifo)
+ ((fx= res S_IFSOCK) 'socket)
+ (else 'regular-file)))))
(define (regular-file? file)
(eq? 'regular-file (file-type file #f #f)))
diff --git a/posixunix.scm b/posixunix.scm
index 7607854d..02dec49a 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -428,8 +428,8 @@ static C_word C_i_fifo_p(C_word name)
(##sys#check-fixnum fd 'file-close)
(let loop ()
(when (fx< (##core#inline "C_close" fd) 0)
- (select _errno
- ((_eintr) (##sys#dispatch-interrupt loop))
+ (cond
+ ((fx= _errno _eintr) (##sys#dispatch-interrupt loop))
(else
(posix-error #:file-error 'file-close "cannot close file" fd)))))))
@@ -925,12 +925,13 @@ static C_word C_i_fifo_p(C_word name)
(let loop ()
(let ([cnt (##core#inline "C_read" fd buf bufsiz)])
(cond ((fx= cnt -1)
- (select _errno
- ((_ewouldblock _eagain)
+ (cond
+ ((or (fx= _errno _ewouldblock)
+ (fx= _errno _eagain))
(##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
(##sys#thread-yield!)
(loop) )
- ((_eintr)
+ ((fx= _errno _eintr)
(##sys#dispatch-interrupt loop))
(else (posix-error #:file-error loc "cannot read" fd nam) )))
[(and more? (fx= cnt 0))
@@ -1032,16 +1033,17 @@ static C_word C_i_fifo_p(C_word name)
(letrec ([poke
(lambda (str len)
(let loop ()
- (let ([cnt (##core#inline "C_write" fd str len)])
+ (let ((cnt (##core#inline "C_write" fd str len)))
(cond ((fx= -1 cnt)
- (select _errno
- ((_ewouldblock _eagain)
- (##sys#thread-yield!)
- (poke str len) )
- ((_eintr)
- (##sys#dispatch-interrupt loop))
- (else
- (posix-error loc #:file-error "cannot write" fd nam) ) ) )
+ (cond
+ ((or (fx= _errno _ewouldblock)
+ (fx= _errno _eagain))
+ (##sys#thread-yield!)
+ (poke str len) )
+ ((fx= _errno _eintr)
+ (##sys#dispatch-interrupt loop))
+ (else
+ (posix-error loc #:file-error "cannot write" fd nam) ) ) )
((fx< cnt len)
(poke (##sys#substring str cnt len) (fx- len cnt)) ) ) ) ))]
[store
@@ -1121,8 +1123,8 @@ static C_word C_i_fifo_p(C_word name)
(let loop ()
(let ((lock (setup port args 'file-lock)))
(if (fx< (##core#inline "C_flock_lock" port) 0)
- (select _errno
- ((_eintr) (##sys#dispatch-interrupt loop))
+ (cond
+ ((fx= _errno _eintr) (##sys#dispatch-interrupt loop))
(else (err "cannot lock file" lock 'file-lock)))
lock)))))
(set! file-lock/blocking
@@ -1130,8 +1132,8 @@ static C_word C_i_fifo_p(C_word name)
(let loop ()
(let ((lock (setup port args 'file-lock/blocking)))
(if (fx< (##core#inline "C_flock_lockw" port) 0)
- (select _errno
- ((_eintr) (##sys#dispatch-interrupt loop))
+ (cond
+ ((fx= _errno _eintr) (##sys#dispatch-interrupt loop))
(else (err "cannot lock file" lock 'file-lock/blocking)))
lock)))))
(set! file-test-lock
@@ -1145,8 +1147,8 @@ static C_word C_i_fifo_p(C_word name)
(##sys#check-structure lock 'lock 'file-unlock)
(##core#inline "C_flock_setup" _f_unlck (##sys#slot lock 2) (##sys#slot lock 3))
(when (fx< (##core#inline "C_flock_lock" (##sys#slot lock 1)) 0)
- (select _errno
- ((_eintr) (##sys#dispatch-interrupt (lambda () (file-unlock lock))))
+ (cond
+ ((fx= _errno _eintr) (##sys#dispatch-interrupt (lambda () (file-unlock lock))))
(else (posix-error #:file-error 'file-unlock "cannot unlock file" lock))))))
diff --git a/posixwin.scm b/posixwin.scm
index d0dad8b8..38a3fbfc 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -586,8 +586,8 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(##sys#check-fixnum fd 'file-close)
(let loop ()
(when (fx< (##core#inline "C_close" fd) 0)
- (select _errno
- ((_eintr) (##sys#dispatch-interrupt loop))
+ (cond
+ ((fx= _errno _eintr) (##sys#dispatch-interrupt loop))
(else
(posix-error #:file-error 'file-close "cannot close file" fd)))))))
diff --git a/rules.make b/rules.make
index 02449ce8..23a1fc11 100644
--- a/rules.make
+++ b/rules.make
@@ -772,8 +772,7 @@ library.c: $(SRCDIR)library.scm
-emit-import-library chicken.keyword \
-emit-import-library chicken.platform \
-emit-import-library chicken.plist \
- -emit-import-library chicken.process-context \
- -emit-import-library chicken.time
+ -emit-import-library chicken.process-context
internal.c: $(SRCDIR)internal.scm $(SRCDIR)mini-srfi-1.scm
$(bootstrap-lib) -emit-import-library chicken.internal
eval.c: $(SRCDIR)eval.scm $(SRCDIR)common-declarations.scm $(SRCDIR)mini-srfi-1.scm
diff --git a/tests/compiler-syntax-tests.scm b/tests/compiler-syntax-tests.scm
index 77f31ca2..7f57f6a9 100644
--- a/tests/compiler-syntax-tests.scm
+++ b/tests/compiler-syntax-tests.scm
@@ -15,7 +15,7 @@
(assert (= 2 (foo 42)))
(module m1 (bar)
- (import (prefix scheme s:) chicken)
+ (import (prefix scheme s:) (chicken syntax))
(define-compiler-syntax s:+
(syntax-rules ()
((_ x y) (s:- x y))))
@@ -25,7 +25,7 @@
(s:define (bar x) (s:+ x 1)) )
(module m2 ()
- (import scheme chicken (prefix m1 m-))
+ (import scheme (chicken base) (prefix m1 m-))
(print (m-bar 10))
(assert (= 9 (m-bar 10)))
(print (+ 4 3)))
@@ -55,7 +55,7 @@
(assert (eq? 'cs-goo2 (car (goo 5))))
(module bar (xxx)
- (import scheme chicken)
+ (import scheme (chicken syntax) (chicken base))
(define (xxx) 'yyy) ; ineffective - suboptimal
;(assert (eq? 'yyy (xxx)))
(define-compiler-syntax xxx
@@ -79,7 +79,7 @@
(define (f1 x) x)
(module m3 ()
-(import scheme chicken)
+(import scheme (chicken syntax))
(define-compiler-syntax f1
(syntax-rules () ((_ x) (list x))))
)
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index 9bc25f0e..b3ba18ee 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -1132,11 +1132,10 @@ eval
other-eval
-;; #805: case-lambda is unhygienic (as well as ensure, see 4706afb4 and bc5cc698)
+;; #805: case-lambda is unhygienic (see 4706afb4 and bc5cc698)
(module case-lambda-and-ensure-hygiene ()
(import (prefix chicken c/) (prefix scheme s/))
- (c/case-lambda ((a) a))
- (c/ensure s/even? 2))
+ (c/case-lambda ((a) a)))
;; #816: compiler-syntax should obey hygiene in its rewrites
Trap