~ chicken-r7rs (master) d53abe8763a18284d85df9e766bf0d033ac517e8
commit d53abe8763a18284d85df9e766bf0d033ac517e8
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Sun Jun 8 19:15:18 2014 +0000
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Sun Jun 8 19:15:18 2014 +0000
Bug fixes, type fixes, include expansion, vector-fill!, support code reorganization
diff --git a/NOTES.org b/NOTES.org
index 100b899..2896f5b 100644
--- a/NOTES.org
+++ b/NOTES.org
@@ -15,10 +15,6 @@ NOTES
* Should bytevectors be implemented over blobs instead of srfi-4 (or something else)?
-* I think library forms (i.e. ".sld" files) should look for includes relative to themselves
- - this seems to be the standard amongst other Schemes that support R7RS-style libs
- - not sure how to get that info when expanding define-library
-
* get-environment-variable: "It is also an error to mutate the resulting string" ...
- can we just ignore this?
diff --git a/r7rs-compile-time-module.scm b/r7rs-compile-time-module.scm
index 5f004d3..5751c66 100644
--- a/r7rs-compile-time-module.scm
+++ b/r7rs-compile-time-module.scm
@@ -1,16 +1,8 @@
-(module r7rs-compile-time (parse-library-definition
- define-extended-arity-comparator
- process-cond-expand
- fixup-import/export-spec
- parse-library-name
- wrap-er-macro-transformer
- import-transformer
- read-forms
- register-r7rs-module
- locate-library)
-
-(import scheme chicken)
-
-(include "r7rs-compile-time.scm")
-
-)
+(module r7rs-compile-time (r7rs-cond-expand
+ r7rs-define-library
+ r7rs-import
+ r7rs-import-for-syntax
+ r7rs-include
+ r7rs-include-ci)
+ (import scheme chicken)
+ (include "r7rs-compile-time.scm"))
diff --git a/r7rs-compile-time.scm b/r7rs-compile-time.scm
index cc4eba4..2a3e022 100644
--- a/r7rs-compile-time.scm
+++ b/r7rs-compile-time.scm
@@ -2,33 +2,16 @@
(import matchable)
-(use srfi-1 files extras data-structures)
-
-(define (parse-library-name name loc)
- (define (fail) (syntax-error loc "invalid library name" name))
- (match name
- ((? symbol?) name)
- ;; We must replicate the core magic that handles SRFI-55's
- ;; (require-extension (srfi N)), because we also need to generate
- ;; SRFI-N library names when defining SRFIs from an R7RS module.
- (('srfi (and num (? fixnum?)))
- (string->symbol (string-append "srfi-" (number->string num))))
- ((parts ...)
- (string->symbol
- (string-intersperse
- (map (lambda (part)
- (cond ((symbol? part) (symbol->string part))
- ((number? part) (number->string part))
- (else (fail))))
- parts)
- ".")))
- (_ (fail))))
+(use srfi-1 files extras)
+(use r7rs-library r7rs-support)
(define (locate-library name loc) ; must be stripped
;;XXX scan include-path?
(let* ((name2 (parse-library-name name loc))
(sname2 (symbol->string name2)))
- (or (##sys#provided? name2)
+ (or (##sys#find-module name2 #f)
+ (memq name2 ##sys#core-library-modules)
+ (memq name2 ##sys#core-syntax-modules)
(file-exists? (string-append sname2 ".import.so"))
(file-exists? (string-append sname2 ".import.scm"))
(extension-information name2))))
@@ -60,15 +43,6 @@
(loop more)))
(else (fail "invalid \"cond-expand\" form")))))
-(define (fixup-import/export-spec spec loc) ; expects spec to be stripped
- (match spec
- (((and head (or 'only 'except 'rename 'prefix)) name . more)
- (cons* head (fixup-import/export-spec name loc) more))
- ((name ...)
- (parse-library-name name loc))
- ((? symbol? spec) spec)
- (_ (syntax-error loc "invalid import/export specifier" spec))))
-
;; Dig e.g. foo.bar out of (only (foo bar) ...) ...
(define (import/export-spec-feature-name spec loc)
(match spec
@@ -80,13 +54,6 @@
(else
(syntax-error loc "invalid import/export specifier" spec))))
-(define (wrap-er-macro-transformer name handler)
- (er-macro-transformer
- (let ((orig (caddr (assq name (##sys#macro-environment)))))
- (lambda (x r c)
- (let ((e (##sys#current-environment)))
- (handler x r c (lambda (x*) (orig x* '() e))))))))
-
(define (import-transformer type)
(wrap-er-macro-transformer
type
@@ -101,9 +68,25 @@
`(##core#require-extension (,name) #f))))
(strip-syntax (cdr x)))))))
+(define (current-source-directory)
+ (cond (##sys#current-source-filename => pathname-directory)
+ (else #f)))
+
+(define (expand-toplevel-r7rs-library-forms exps)
+ (parameterize ((##sys#macro-environment (r7rs-library-macro-environment)))
+ (map (cut expand <> '()) exps)))
+
(define (read-forms filename ci?)
- (parameterize ((case-sensitive (not ci?)))
- (##sys#include-forms-from-file filename)))
+ (let ((path (##sys#resolve-include-filename filename #t)))
+ (fluid-let ((##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))))))
(define (parse-library-definition form dummy-export) ; expects stripped syntax
(match form
@@ -179,7 +162,7 @@
(_ (syntax-error 'define-library "invalid library definition" form))))
(define (register-r7rs-module name)
- (let ((dummy (string->symbol (conc "\x04r7rs" name))))
+ (let ((dummy (string->symbol (string-append "\x04r7rs" (symbol->string name)))))
(put! name '##r7rs#module dummy)
dummy))
@@ -196,15 +179,46 @@
(set-cdr! dummylist (cons sym (cdr dummylist))))))))
(register-export sym mod))))))
-(define-syntax define-extended-arity-comparator
- (syntax-rules ()
- ((_ name comparator check-type)
- (define name
- (let ((c comparator))
- (lambda (o1 o2 . os)
- (check-type o1 'name)
- (let lp ((o1 o1) (o2 o2) (os os) (eq #t))
- (check-type o2 'name)
- (if (null? os)
- (and eq (c o1 o2))
- (lp o2 (car os) (cdr os) (and eq (c o1 o2)))))))))))
+(define r7rs-define-library
+ (er-macro-transformer
+ (lambda (x r c)
+ (match (strip-syntax x)
+ ((_ name decls ...)
+ (let ((dummy (register-r7rs-module (parse-library-name name 'define-library))))
+ (parse-library-definition x dummy)))
+ (else
+ (syntax-error 'define-library "invalid library definition" x))))))
+
+(define r7rs-cond-expand
+ (er-macro-transformer
+ (lambda (x r c)
+ (cons (r 'begin)
+ (process-cond-expand (cdr x))))))
+
+(define r7rs-include
+ (er-macro-transformer
+ (lambda (e r c)
+ (cons (r 'begin)
+ (append-map (cut read-forms <> #f) (cdr e))))))
+
+(define r7rs-include-ci
+ (er-macro-transformer
+ (lambda (e r c)
+ (cons (r 'begin)
+ (append-map (cut read-forms <> #t) (cdr e))))))
+
+(define r7rs-import
+ (import-transformer 'import))
+
+(define r7rs-import-for-syntax
+ (import-transformer 'import-for-syntax))
+
+(define (r7rs-library-macro-environment)
+ (filter (lambda (p)
+ (memv (caddr p)
+ (map (cut ##sys#slot <> 1)
+ (list r7rs-cond-expand
+ r7rs-define-library
+ r7rs-include
+ r7rs-include-ci))))
+ (##sys#macro-environment)))
diff --git a/r7rs-library.scm b/r7rs-library.scm
new file mode 100644
index 0000000..9d2cb5a
--- /dev/null
+++ b/r7rs-library.scm
@@ -0,0 +1,41 @@
+;;;
+;;; Helpers for working with R7RS library import forms.
+;;;
+;;; These are used by r7rs-compile-time during library expansion
+;;; and scheme.eval for (environment ...) module renaming.
+;;;
+
+(module r7rs-library *
+
+ (import scheme chicken matchable)
+ (use (only data-structures string-intersperse))
+
+ (define (fixup-import/export-spec spec loc)
+ (match spec
+ (((and head (or 'only 'except 'rename 'prefix)) name . more)
+ (cons head (cons (fixup-import/export-spec name loc) more)))
+ ((name ...)
+ (parse-library-name name loc))
+ ((? symbol? spec) spec)
+ (else
+ (syntax-error loc "invalid import/export specifier" spec))))
+
+ (define (parse-library-name name loc)
+ (define (fail) (syntax-error loc "invalid library name" name))
+ (match name
+ ((? symbol?) name)
+ ;; We must replicate the core magic that handles SRFI-55's
+ ;; (require-extension (srfi N)), because we also need to generate
+ ;; SRFI-N library names when defining SRFIs from an R7RS module.
+ (('srfi (and num (? fixnum?)))
+ (string->symbol (string-append "srfi-" (number->string num))))
+ ((parts ...)
+ (string->symbol
+ (string-intersperse
+ (map (lambda (part)
+ (cond ((symbol? part) (symbol->string part))
+ ((number? part) (number->string part))
+ (else (fail))))
+ parts)
+ ".")))
+ (else (fail)))))
diff --git a/r7rs-support.scm b/r7rs-support.scm
new file mode 100644
index 0000000..abefc0d
--- /dev/null
+++ b/r7rs-support.scm
@@ -0,0 +1,27 @@
+;;;
+;;; Support code for building the R7RS extension.
+;;;
+
+(module r7rs-support *
+
+ (import scheme chicken)
+
+ (define (wrap-er-macro-transformer name handler)
+ (er-macro-transformer
+ (let ((orig (caddr (assq name (##sys#macro-environment)))))
+ (lambda (x r c)
+ (let ((e (##sys#current-environment)))
+ (handler x r c (lambda (x*) (orig x* '() e))))))))
+
+ (define-syntax define-extended-arity-comparator
+ (syntax-rules ()
+ ((_ name comparator check-type)
+ (define name
+ (let ((c comparator))
+ (lambda (o1 o2 . os)
+ (check-type o1 'name)
+ (let lp ((o1 o1) (o2 o2) (os os) (eq #t))
+ (check-type o2 'name)
+ (if (null? os)
+ (and eq (c o1 o2))
+ (lp o2 (car os) (cdr os) (and eq (c o1 o2))))))))))))
diff --git a/r7rs.scm b/r7rs.scm
index 7615d70..e892c8b 100644
--- a/r7rs.scm
+++ b/r7rs.scm
@@ -1,11 +1,13 @@
(module r7rs (define-library import import-for-syntax export syntax-rules)
(import (except scheme syntax-rules)) ;XXX except ...
- (import (only chicken feature? include)) ;XXX except ...
+ (import (only chicken feature? include register-feature!))
;; For syntax definition helpers.
- (import-for-syntax r7rs-compile-time matchable)
- (begin-for-syntax (require-library r7rs-compile-time))
+ (import-for-syntax matchable)
+ (import-for-syntax r7rs-compile-time)
+ (begin-for-syntax
+ (require-library r7rs-compile-time))
;; For extended number literals.
(if (feature? 'compiler-extension)
@@ -52,8 +54,8 @@
;;; 5.2. Import declarations
;;;
-(define-syntax import (import-transformer 'import))
-(define-syntax import-for-syntax (import-transformer 'import-for-syntax))
+(define-syntax import r7rs-import)
+(define-syntax import-for-syntax r7rs-import-for-syntax)
;;;
;;; 5.4. Syntax definitions
@@ -64,11 +66,10 @@
;;; 5.6.1. Libraries
;;;
-(define-syntax define-library
- (er-macro-transformer
- (lambda (x r c)
- (match (strip-syntax x)
- ((_ name decls ...)
- (let ((dummy (register-r7rs-module (parse-library-name name 'define-library))))
- (parse-library-definition x dummy)))
- (_ (syntax-error 'define-library "invalid library definition" x)))))))
+(define-syntax define-library r7rs-define-library)
+
+;;;
+;;; Appendix B. Standard feature identifiers
+;;;
+
+(register-feature! #:r7rs))
diff --git a/r7rs.setup b/r7rs.setup
index cb489c5..8e42ef6 100644
--- a/r7rs.setup
+++ b/r7rs.setup
@@ -6,10 +6,18 @@
(define scheme-modules
'("case-lambda" "char" "complex" "cxr" "eval" "file" "inexact" "lazy" "load" "process-context" "r5rs" "read" "repl" "time" "write"))
-(make (("r7rs-compile-time.so" ("r7rs-compile-time.scm" "r7rs-compile-time-module.scm")
+(make (("r7rs-support.so" ("r7rs-support.scm")
+ (compile -s -O3 -d1 r7rs-support.scm -J)
+ (compile -s -O3 -d0 r7rs-support.import.scm))
+ ("r7rs-library.so" ("r7rs-library.scm")
+ (compile -s -O3 -d1 r7rs-library.scm -J)
+ (compile -s -O3 -d0 r7rs-library.import.scm))
+ ("r7rs-compile-time.so"
+ ("r7rs-compile-time.scm" "r7rs-compile-time-module.scm" "r7rs-library.so" "r7rs-support.so")
(compile -s -O3 -d1 r7rs-compile-time-module.scm -J -o r7rs-compile-time.so)
(compile -s -O3 -d0 r7rs-compile-time.import.scm))
- ("scheme.base.so" ("scheme.base.scm" "scheme.base-interface.scm")
+ ("scheme.base.so"
+ ("scheme.base.scm" "scheme.base-interface.scm" "r7rs-support.so")
(compile -s -O3 -d1 scheme.base.scm -J -emit-type-file scheme.base.types)
(compile -s -O3 -d0 scheme.base.import.scm)))
'("r7rs-compile-time.so" "scheme.base.so"))
@@ -33,6 +41,8 @@
(install-extension
'r7rs
`("r7rs.so" "r7rs.import.so"
+ "r7rs-support.so" "r7rs-support.import.so"
+ "r7rs-library.so" "r7rs-library.import.so"
"r7rs-compile-time.so" "r7rs-compile-time.import.so"
"scheme.base.so" "scheme.base.import.so" "scheme.base.types"
,@(append-map
diff --git a/scheme.base-interface.scm b/scheme.base-interface.scm
index 0dd0025..ec85dc0 100644
--- a/scheme.base-interface.scm
+++ b/scheme.base-interface.scm
@@ -35,7 +35,7 @@
define
define-record-type
define-syntax
- define-values
+ define-values ; TODO
denominator numerator
do
dynamic-wind
@@ -155,6 +155,7 @@
vector
vector-append
vector-copy vector-copy!
+ vector-fill!
vector-for-each
vector-length
vector-map
diff --git a/scheme.base.scm b/scheme.base.scm
index f87b183..0d26dec 100644
--- a/scheme.base.scm
+++ b/scheme.base.scm
@@ -1,16 +1,20 @@
(module scheme.base ()
-(import (except chicken with-exception-handler include
- quotient remainder modulo vector-copy!))
+(import (rename (except chicken modulo quotient remainder
+ vector-copy!
+ with-exception-handler)
+ (features feature-keywords)))
+
(import (except scheme syntax-rules cond-expand
assoc list-set! list-tail member
char=? char<? char>? char<=? char>=?
string=? string<? string>? string<=? string>=?
- string-copy string->list vector->list))
+ 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 chicken include) (include %include)))
+
(import (rename (only srfi-4 make-u8vector subu8vector u8vector u8vector?
u8vector-length u8vector-ref u8vector-set!
read-u8vector read-u8vector! write-u8vector)
@@ -22,12 +26,14 @@
(make-u8vector make-bytevector)
(write-u8vector write-bytevector)))
-(%include "scheme.base-interface.scm")
+(include "scheme.base-interface.scm")
;; For syntax definition helpers.
-(begin-for-syntax (require-library r7rs-compile-time))
+(import-for-syntax r7rs-support)
(import-for-syntax r7rs-compile-time)
-(import r7rs-compile-time)
+(begin-for-syntax
+ (require-library r7rs-compile-time))
+(import r7rs-support)
(import numbers)
;; read/write-string/line/byte
@@ -57,28 +63,14 @@
;;; 4.1.7. Inclusion
;;;
-(define-syntax include
- (er-macro-transformer
- (lambda (e r c)
- (cons (r 'begin)
- (append-map (cut read-forms <> #f) (cdr e))))))
-
-(define-syntax include-ci
- (er-macro-transformer
- (lambda (e r c)
- (cons (r 'begin)
- (append-map (cut read-forms <> #t) (cdr e))))))
+(define-syntax include r7rs-include)
+(define-syntax include-ci r7rs-include-ci)
;;;
;;; 4.2.1. Conditionals
;;;
-(define-syntax cond-expand
- (er-macro-transformer
- (lambda (x r c)
- (cons (r 'begin)
- (process-cond-expand (cdr x))))))
-
+(define-syntax cond-expand r7rs-cond-expand)
;;;
;;; 4.2.7. Exception handling
@@ -267,16 +259,18 @@
(else (lp (cdr lst))))))))
-(: list-copy (forall (a) ((list-of a) -> (list-of a))))
+(: list-copy (forall (a) (a -> a)))
;; TODO: Test if this is the quickest way to do this, or whether we
;; should just cons recursively like our SRFI-1 implementation does.
(define (list-copy lst)
- (let lp ((res '())
- (lst lst))
- (if (null? lst)
- (##sys#fast-reverse res)
- (lp (cons (car lst) res) (cdr lst)))))
+ (cond ((pair? lst)
+ (let lp ((res '())
+ (lst lst))
+ (if (pair? lst)
+ (lp (cons (car lst) res) (cdr lst))
+ (append (##sys#fast-reverse res) lst))))
+ (else lst)))
;;;
;;; 6.5 Symbols
@@ -364,6 +358,7 @@
(: vector-append (#!rest vector -> vector))
(: vector-copy (forall (a) ((vector-of a) #!optional fixnum fixnum -> (vector-of a))))
(: vector-copy! (vector fixnum vector #!optional fixnum fixnum -> undefined))
+(: vector-fill! (vector * #!optional fixnum fixnum -> undefined))
(: vector->list (forall (a) ((vector-of a) #!optional fixnum fixnum -> (list-of a))))
(define vector-copy
@@ -403,6 +398,21 @@
((to at from start) (copy! to at from start))
((to at from start end) (copy! to at from start end)))))
+(define vector-fill!
+ (let ((fill! (lambda (v f start . end)
+ (##sys#check-vector v 'vector-fill!)
+ (let* ((len (##sys#size v))
+ (end (optional end len)))
+ (##sys#check-range start 0 (fx+ end 1) 'vector-fill!)
+ (##sys#check-range end start (fx+ len 1) 'vector-fill!)
+ (do ((i start (fx+ i 1)))
+ ((fx= i end))
+ (##sys#setslot v i f))))))
+ (case-lambda
+ ((v f) (fill! v f 0))
+ ((v f start) (fill! v f start))
+ ((v f start end) (fill! v f start end)))))
+
(define vector->list
(let ((v->l (lambda (v start . end)
(##sys#check-vector v 'vector->list)
@@ -504,7 +514,7 @@
(let ((s (##sys#make-string (fx- end start))))
(do ((si 0 (fx+ si 1))
(vi start (fx+ vi 1)))
- ((fx= si end) s)
+ ((fx= vi end) s)
(##sys#setbyte s si (bytevector-u8-ref bv vi))))))))
(case-lambda
((bv) (bv->s bv 0))
@@ -521,7 +531,7 @@
(let ((bv (make-bytevector (fx- end start))))
(do ((vi 0 (fx+ vi 1))
(si start (fx+ si 1)))
- ((fx= vi end) bv)
+ ((fx= si end) bv)
(bytevector-u8-set! bv vi (##sys#byte s si))))))))
(case-lambda
((s) (s->bv s 0))
@@ -532,10 +542,10 @@
;;; 6.10. Control features
;;;
-(: string-for-each ((char -> *) string #!rest string -> void))
-(: string-map ((char -> char) string #!rest string -> string))
-(: vector-for-each ((* -> *) vector #!rest vector -> void))
-(: vector-map ((* -> *) vector #!rest vector -> vector))
+(: string-for-each ((char #!rest char -> *) string #!rest string -> void))
+(: string-map ((char #!rest char -> char) string #!rest string -> string))
+(: vector-for-each ((* #!rest * -> *) vector #!rest vector -> void))
+(: vector-map ((* #!rest * -> *) vector #!rest vector -> vector))
(define string-map
(case-lambda
@@ -651,7 +661,7 @@
(lambda ()
((cadr exception-handlers) obj))))))
-(: error-object? (* --> boolean : (struct condition)))
+(: error-object? (* -> boolean : (struct condition)))
(: error-object-message ((struct condition) -> string))
(: error-object-irritants ((struct condition) -> list))
@@ -696,7 +706,7 @@
(: read-u8 (#!optional input-port -> fixnum))
(: textual-port? (* --> boolean : port?))
(: u8-ready? (#!optional input-port -> boolean))
-(: write-string (string #!optional input-port fixnum fixnum -> void))
+(: write-string (string #!optional output-port fixnum fixnum -> void))
(: write-u8 (fixnum #!optional output-port -> void))
;; CHICKEN's ports can handle both.
@@ -828,4 +838,13 @@
(define (get-output-bytevector p)
(string->utf8 (get-output-string p)))
-)
+;;;
+;;; 6.14. System interface
+;;;
+
+(: features (--> (list-of symbol)))
+
+(define (features)
+ (map (lambda (s)
+ (##sys#string->symbol (##sys#symbol->string s)))
+ (feature-keywords))))
diff --git a/scheme.char.scm b/scheme.char.scm
index e9e9e70..261bc6a 100644
--- a/scheme.char.scm
+++ b/scheme.char.scm
@@ -7,6 +7,8 @@
string-upcase string-downcase
digit-value)
+(import chicken)
+(import r7rs-support)
(import
(except scheme
char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=?
@@ -20,9 +22,6 @@
(require-library srfi-13)
(import (only srfi-13 string-map string-upcase string-downcase))
-(import chicken)
-(require-extension r7rs-compile-time)
-
(: char-ci=? (char char #!rest char -> boolean))
(: char-ci<? (char char #!rest char -> boolean))
(: char-ci>? (char char #!rest char -> boolean))
diff --git a/scheme.eval.scm b/scheme.eval.scm
index f753d12..4727c01 100644
--- a/scheme.eval.scm
+++ b/scheme.eval.scm
@@ -2,7 +2,7 @@
environment)
(import (rename scheme (eval %eval)) chicken)
- (import r7rs-compile-time)
+ (use r7rs-library)
;;;
;;; 6.12. Environments and evaluation
@@ -12,7 +12,7 @@
(define (eval expr env) (%eval expr env))
- (: environment (list -> (struct environment)))
+ (: environment (#!rest list -> (struct environment)))
(define (environment . specs)
(let ((name (gensym "environment-module-")))
@@ -29,7 +29,7 @@
specs)))
(let ((mod (##sys#find-module name)))
(##sys#make-structure 'environment
- name
+ (cons 'import specs)
(let ((env (##sys#slot mod 13)))
(append (car env) (cdr env))) ; combine env and syntax bindings
#t)))
diff --git a/scheme.process-context.scm b/scheme.process-context.scm
index 22dabe2..c09eef2 100644
--- a/scheme.process-context.scm
+++ b/scheme.process-context.scm
@@ -5,7 +5,7 @@
get-environment-variables)
(import scheme
- (rename chicken (exit chicken:exit))
+ (rename chicken (exit chicken-exit))
foreign)
;;;
@@ -56,9 +56,8 @@ extern char **environ;
(define exit
(case-lambda
(()
- (chicken:exit 0))
+ (exit 0))
((obj)
- (##sys#cleanup-before-exit)
;; ##sys#dynamic-unwind is hidden, have to unwind manually.
; (##sys#dynamic-unwind '() (length ##sys#dynamic-winds))
(let unwind ()
@@ -67,7 +66,8 @@ extern char **environ;
(set! ##sys#dynamic-winds (cdr ##sys#dynamic-winds))
(after)
(unwind))))
- (##core#inline "C_exit_runtime" (->exit-status obj)))))
+ ;; The built-in exit runs cleanup handlers for us.
+ (chicken-exit (->exit-status obj)))))
(define emergency-exit
(case-lambda
diff --git a/scheme.r5rs.scm b/scheme.r5rs.scm
index d5b8d8b..1e664ea 100644
--- a/scheme.r5rs.scm
+++ b/scheme.r5rs.scm
@@ -15,11 +15,12 @@
(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 else export if lambda let
- let* let-syntax letrec letrec* letrec-syntax module or
- quasiquote quote reexport require-extension
- require-extension-for-syntax require-library set! syntax))
+ 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))
(define-constant null-environment-identifiers
'(and begin case cond cond-expand define define-syntax delay
diff --git a/synrules.scm b/synrules.scm
index f8cf331..3654038 100644
--- a/synrules.scm
+++ b/synrules.scm
@@ -128,7 +128,7 @@
0
ellipsis?
(meta-variables pattern 0 ellipsis? '() #f)))))
- (%syntax-error "ill-formed syntax rule" rule)))
+ (##sys#syntax-error "ill-formed syntax rule" rule)))
;; Generate code to test whether input expression matches pattern
@@ -209,12 +209,13 @@
(if probe
(if (<= (cdr probe) dim)
template
- (%syntax-error "template dimension error (too few ellipses?)"
- template))
+ (##sys#syntax-error-hook
+ "template dimension error (too few ellipses?)"
+ template))
`(,%rename (##core#syntax ,template)))))
((ellipsis-escaped-pattern? template el?)
(if (or (not (pair? (cdr template))) (pair? (cddr template)))
- (%syntax-error "Invalid escaped ellipsis template" template)
+ (##sys#syntax-error-hook "Invalid escaped ellipsis template" template)
(process-template (cadr template) dim (lambda _ #f) env)))
((segment-template? template el?)
(let* ((depth (segment-depth template el?))
@@ -222,7 +223,7 @@
(vars
(free-meta-variables (car template) seg-dim el? env '())))
(if (null? vars)
- (%syntax-error "too many ellipses" template)
+ (##sys#syntax-error-hook "too many ellipses" template)
(let* ((x (process-template (car template) seg-dim el? env))
(gen (if (and (pair? vars)
(null? (cdr vars))
@@ -295,9 +296,9 @@
(and (segment-template? p el?)
(cond
(seen-segment?
- (%syntax-error "Only one segment per level is allowed" p))
+ (##sys#syntax-error-hook "Only one segment per level is allowed" p))
((not (list? p)) ; Improper list
- (%syntax-error "Cannot combine dotted tail and ellipsis" p))
+ (##sys#syntax-error-hook "Cannot combine dotted tail and ellipsis" p))
(else #t))))
(define (segment-template? pattern el?)
Trap