~ chicken-r7rs (master) fda5e06fbaffcb589351132670af043f21ab51ed
commit fda5e06fbaffcb589351132670af043f21ab51ed
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Jun 5 10:01:43 2013 +0000
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Wed Jun 5 10:01:43 2013 +0000
Added various extensions and restructured the modules, initial implementation of define-library
diff --git a/NOTES.org b/NOTES.org
new file mode 100644
index 0000000..d2b636f
--- /dev/null
+++ b/NOTES.org
@@ -0,0 +1,10 @@
+NOTES
+
+
+* Redefinition of "import" may be tricky, as it is implicit and not in any module.
+ - possible reimplement using core functionality.
+
+* Use of "define-values" is elegant but loses lambda-info for the defined procedures.
+
+* "export" does not support "(rename ...)" specifier yet.
+ - this needs extensions to the core module system.
diff --git a/r7rs-compile-time-module.scm b/r7rs-compile-time-module.scm
new file mode 100644
index 0000000..172a7f9
--- /dev/null
+++ b/r7rs-compile-time-module.scm
@@ -0,0 +1,14 @@
+(module r7rs-compile-time (parse-library-definition
+ process-cond-expand
+ fixup-import/export-spec
+ parse-library-name
+ read-forms
+ current-source-filename
+ register-r7rs-module
+ locate-library)
+
+(import scheme chicken)
+
+(include "r7rs-compile-time.scm")
+
+)
diff --git a/r7rs-compile-time.scm b/r7rs-compile-time.scm
new file mode 100644
index 0000000..229a7be
--- /dev/null
+++ b/r7rs-compile-time.scm
@@ -0,0 +1,160 @@
+;;;; compile-time support code (mostly for modules)
+
+
+(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)
+ ((parts ...)
+ (string->symbol
+ (string-intersperse
+ (map (lambda (part)
+ (cond ((symbol? part) (symbol->string part))
+ ((number? part) (number->string part))
+ (else (fail))))
+ parts)
+ ".")))
+ (_ (fail))))
+
+(define (locate-library name loc) ; must be stripped
+ ;;XXX scan include-path?
+ (let* ((name2 (parse-library-name name loc))
+ (sname2 (symbol->string name2)))
+ (or (file-exists? (string-append sname2 ".import.so"))
+ (file-exists? (string-append sname2 ".import.scm"))
+ (extension-information name2))))
+
+(define (process-cond-expand clauses)
+ ;; returns list of forms of successful clause or #f
+ (define (fail msg . args)
+ (apply
+ syntax-error
+ msg
+ (append args
+ `((cond-expand
+ ,@(map (lambda (clause) (cons (car clause) '(...))) clauses))))))
+ (define (check test)
+ (match test
+ ('else #t)
+ (('and tests ...) (every check tests))
+ (('or tests ...) (any check tests))
+ (('library name) (locate-library name 'cond-expand))
+ ((? symbol? feature) (feature? feature))
+ (_ (fail "invalid test expression in \"cond-expand\" form" test))))
+ (let loop ((cs clauses))
+ (match cs
+ (() (fail "no clause applies in \"cond-expand\" form"))
+ (((test body ...) . more)
+ (if (check (strip-syntax test))
+ body
+ (loop more)))
+ (else (fail "invalid \"cond-expand\" form")))))
+
+(define (fixup-import/export-spec spec loc)
+ (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))
+ (_ (syntax-error loc "invalid import/export specifier" spec))))
+
+(define (current-source-filename)
+ (or (and (feature? #:compiling) ##compiler#source-filename)
+ ##sys#current-source-filename))
+
+(define (read-forms filename ci?)
+ (read-file
+ (if (absolute-pathname? filename)
+ filename
+ (make-pathname (current-source-filename) filename))
+ (lambda (port)
+ (parameterize ((case-sensitive ci?))
+ (read port)))))
+
+(define (parse-library-definition form dummy-export) ; expects stripped syntax
+ (match form
+ ((_ name decls ...)
+ (let ((real-name (parse-library-name name 'define-library)))
+ (define (parse-exports specs)
+ (map (match-lambda
+ ((and spec ('rename _ _))
+ (syntax-error
+ 'define-library
+ "\"rename\" export specifier currently not supported"
+ name))
+ ((? symbol? exp)
+ `(export ,exp))
+ (spec (syntax-error 'define-library "invalid export specifier" spec name)))
+ specs))
+ (define (parse-imports specs)
+ (map (lambda (spec)
+ `(import ,(fixup-import/export-spec spec 'import)))
+ specs))
+ (define (process-includes fnames ci?)
+ `(##core#begin
+ ,@(map (match-lambda
+ ((? string? fname)
+ `(##core#begin ,@(read-forms fname ci?)))
+ (fname (syntax-error 'include "invalid include-filename" fname)))
+ fnames)))
+ (define (process-include-decls fnames)
+ (parse-decls (append-map (lambda (fname) (read-forms fname #t)) fnames)))
+ (define (parse-decls decls)
+ (match decls
+ (() '(##core#begin))
+ ((('export specs ...) . more)
+ `(##core#begin
+ ,@(parse-exports specs)
+ ,(parse-decls more)))
+ ((('import specs ...) . more)
+ `(##core#begin
+ ,@(parse-imports specs)
+ ,(parse-decls more)))
+ ((('include fnames ...) . more)
+ `(##core#begin
+ ,@(process-includes fnames #f)
+ ,(parse-decls more)))
+ ((('include-ci fnames ...) . more)
+ `(##core#begin
+ ,@(process-includes fnames #t)
+ ,(parse-decls more)))
+ ((('include-library-declarations fnames ...) . more)
+ `(##core#begin
+ ,@(process-include-decls fnames)
+ ,(parse-decls more)))
+ ((('cond-expand decls ...) . more)
+ (parse-decls (process-cond-expand decls)))
+ ((('begin code ...) . more)
+ `(##core#begin
+ (##core#begin ,@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
+ (import (rename scheme (define-syntax hidden:define-syntax)))
+ (import (only scheme.base import export)) ; overwrites existing "import"
+ (hidden:define-syntax ,dummy-export (lambda () #f))
+ ,(parse-decls decls))))
+ (_ (syntax-error 'define-library "invalid library definition" form))))
+
+(define (register-r7rs-module name)
+ (let ((dummy (string->symbol (string-append (symbol->string name) "-dummy-export"))))
+ (put! name '##r7rs#module dummy)
+ dummy))
+
+(set! ##sys#register-export
+ (let ((register-export ##sys#register-export))
+ (lambda (sym mod)
+ (when mod
+ (let-values (((explist ve se) (##sys#module-exports mod)))
+ (and-let* ((dummy (get (##sys#module-name mod) '##r7rs#module)))
+ (unless (eq? sym dummy)
+ (cond ((memq sym explist))
+ ((find (lambda (a) (and (pair? a) (eq? (car a) dummy))) explist) =>
+ (lambda (dummylist)
+ (set-cdr! dummylist (cons sym (cdr dummylist))))))))
+ (register-export sym mod))))))
diff --git a/r7rs.meta b/r7rs.meta
index d351fcd..5854b1b 100644
--- a/r7rs.meta
+++ b/r7rs.meta
@@ -2,6 +2,6 @@
(author "The Chicken Team")
(category lang-exts)
(license "BSD")
- (depends)
+ (depends matchable make numbers)
(test-depends test)
(foreign-depends))
diff --git a/r7rs.scm b/r7rs.scm
index 619c2aa..9d731bb 100644
--- a/r7rs.scm
+++ b/r7rs.scm
@@ -1,29 +1,18 @@
-(module r7rs
+(module r7rs (define-library)
-(
- ;; Exception handling
- guard
- ;; Exceptions
- with-exception-handler
- raise
- raise-continuable
- error-object?
- error-object-message
- error-object-irritants
- read-error?
- file-error?
- ;; Input & output
- call-with-port
- close-port
- eof-object
- ;; System interface
- command-line
- exit
- emergency-exit
- )
+ (import scheme) ;XXX except ...
+ (import chicken) ;XXX except ...
+ (import numbers)
+ (import scheme.base)
+ (include "scheme.base-interface.scm")
-(import chicken scheme foreign)
-(use srfi-13)
+ (begin-for-syntax
+ (require-library r7rs-compile-time numbers))
+ (import-for-syntax r7rs-compile-time matchable)
+
+(use srfi-13) ;XXX get rid of this! (used for "string-downcase"?)
+
+(require-library scheme.base)
(define (read-asserted-ci-symbol port valid-symbols error-message)
(let ((sym (##sys#read port ##sys#default-read-info-hook)))
@@ -44,185 +33,17 @@
(else (old-hook char port))))))
;;;
-;;; 4.2.7. Exception handling
-;;;
-
-;; guard & guard-aux copied verbatim from the draft.
-(define-syntax guard
- (syntax-rules ()
- ((guard (var clause ...) e1 e2 ...)
- ((call/cc
- (lambda (guard-k)
- (with-exception-handler
- (lambda (condition)
- ((call/cc
- (lambda (handler-k)
- (guard-k
- (lambda ()
- (let ((var condition))
- (guard-aux
- (handler-k
- (lambda ()
- (raise-continuable condition)))
- clause ...))))))))
- (lambda ()
- (call-with-values
- (lambda () e1 e2 ...)
- (lambda args
- (guard-k
- (lambda ()
- (apply values args)))))))))))))
-
-(define-syntax guard-aux
- (syntax-rules (else =>)
- ((guard-aux reraise (else result1 result2 ...))
- (begin result1 result2 ...))
- ((guard-aux reraise (test => result))
- (let ((temp test))
- (if temp
- (result temp)
- reraise)))
- ((guard-aux reraise (test => result)
- clause1 clause2 ...)
- (let ((temp test))
- (if temp
- (result temp)
- (guard-aux reraise clause1 clause2 ...))))
- ((guard-aux reraise (test))
- (or test reraise))
- ((guard-aux reraise (test) clause1 clause2 ...)
- (let ((temp test))
- (if temp
- temp
- (guard-aux reraise clause1 clause2 ...))))
- ((guard-aux reraise (test result1 result2 ...))
- (if test
- (begin result1 result2 ...)
- reraise))
- ((guard-aux reraise
- (test result1 result2 ...)
- clause1 clause2 ...)
- (if test
- (begin result1 result2 ...)
- (guard-aux reraise clause1 clause2 ...)))))
-
-;;;
-;;; 6.11. Exceptions
-;;;
-
-(define-values (with-exception-handler raise raise-continuable)
- (let ((exception-handlers
- (let ((lst (list ##sys#current-exception-handler)))
- (set-cdr! lst lst)
- lst)))
- (values
- ;; with-exception-handler
- (lambda (handler thunk)
- (dynamic-wind
- (lambda ()
- (set! exception-handlers (cons handler exception-handlers))
- (set! ##sys#current-exception-handler handler))
- thunk
- (lambda ()
- (set! exception-handlers (cdr exception-handlers))
- (set! ##sys#current-exception-handler (car exception-handlers)))))
- ;; raise
- (lambda (obj)
- (with-exception-handler
- (cadr exception-handlers)
- (lambda ()
- ((cadr exception-handlers) obj)
- ((car exception-handlers)
- (make-property-condition
- 'exn
- 'message "exception handler returned"
- 'arguments '()
- 'location #f)))))
- ;; raise-continuable
- (lambda (obj)
- (with-exception-handler
- (cadr exception-handlers)
- (lambda ()
- ((cadr exception-handlers) obj)))))))
-
-(define error-object? condition?)
-(define error-object-message (condition-property-accessor 'exn 'message))
-(define error-object-irritants (condition-property-accessor 'exn 'arguments))
-
-(define-values (read-error? file-error?)
- (let ((exn? (condition-predicate 'exn))
- (i/o? (condition-predicate 'i/o))
- (file? (condition-predicate 'file))
- (syntax? (condition-predicate 'syntax)))
- (values
- ;; read-error?
- (lambda (obj)
- (and (exn? obj)
- (or (i/o? obj) ; XXX Not fine-grained enough.
- (syntax? obj))))
- ;; file-error?
- (lambda (obj)
- (and (exn? obj)
- (file? obj))))))
-
-;;;
-;;; 6.13. Input and Output
+;;; 5.6.1. Libraries
;;;
-(define (call-with-port port proc)
- (dynamic-wind void (lambda () (proc port)) (lambda () (close-port port))))
-
-(define (close-port port)
- (cond ((input-port? port)
- (close-input-port port))
- ((output-port? port)
- (close-output-port port))
- (else
- (error 'close-port "not a port" port))))
-
-(define (eof-object) #!eof)
-
-;;;
-;;; 6.14. System interface.
-;;;
-
-;; Should these go in a separate module (process-context)?
-
-(define command-line
- (let ((command-line #f)
- (arguments (command-line-arguments)))
- (lambda ()
- (unless command-line
- (set! command-line (cons (program-name) arguments)))
- command-line)))
-
-(define (->exit-status obj)
- (cond ((integer? obj) obj)
- ((eq? obj #f) 1)
- (else 0)))
-
-(define exit
- (case-lambda
- (()
- (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 ()
- (unless (null? ##sys#dynamic-winds)
- (let ((after (cdar ##sys#dynamic-winds)))
- (set! ##sys#dynamic-winds (cdr ##sys#dynamic-winds))
- (after)
- (unwind))))
- (##core#inline "C_exit_runtime" (->exit-status obj)))))
+(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 emergency-exit
- (case-lambda
- (()
- (emergency-exit 0))
- ((obj)
- (##sys#cleanup-before-exit)
- ((foreign-lambda void "_exit" int) (->exit-status obj)))))
)
diff --git a/r7rs.setup b/r7rs.setup
index 8046c71..1f2585f 100644
--- a/r7rs.setup
+++ b/r7rs.setup
@@ -1,7 +1,37 @@
-(compile -d0 -O2 -J -s r7rs.scm)
-(compile -d0 -O2 -s r7rs.import.scm)
+(use make)
+
+
+(define scheme-modules
+ '("base" "process-context")) ;XXX
+
+(make (("r7rs-compile-time.so" ("r7rs-compile-time.scm" "r7rs-compile-time-module.scm")
+ (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")
+ (compile -s -O3 -d1 scheme.base.scm -J)
+ (compile -s -O3 -d0 scheme.base.import.scm)))
+ '("r7rs-compile-time.so" "scheme.base.so"))
+
+(for-each
+ (lambda (m)
+ (let* ((mname (string-append "scheme." m))
+ (so (string-append mname ".so"))
+ (scm (string-append mname ".scm")))
+ (make/proc (list (list so (list scm)
+ (lambda ()
+ (compile -s -O3 -d1 ,scm -J)
+ (compile -s -O3 -d0 ,(string-append mname ".import.scm")))))
+ (list so))))
+ scheme-modules)
+
+(make (("r7rs.so" ("r7rs.scm" "scheme.base-interface.scm")
+ (compile -s -O3 -d0 r7rs.scm -J)
+ (compile -s -O3 -d0 r7rs.import.scm))))
(install-extension
'r7rs
- '("r7rs.so" "r7rs.import.so")
+ '("r7rs.so" "r7rs.import.so"
+ "r7rs-compile-time.so" "r7rs-compile-time.import.so"
+ "scheme.base.so" "scheme.base.import.so"
+ "scheme.process-context.so" "scheme.process-context.import.so")
'((version "0.0.1")))
diff --git a/scheme.base-interface.scm b/scheme.base-interface.scm
new file mode 100644
index 0000000..91c0c0b
--- /dev/null
+++ b/scheme.base-interface.scm
@@ -0,0 +1,183 @@
+(export
+ #|
+ * + - /
+ <= < >= = >
+ abs
+ and
+ append
+ apply
+ assoc assq assv
+ begin
+ binary-port?
+ boolean? boolean=?
+ bytevector-append bytevector-copy bytevector-copy!
+ bytevector-length bytevector-u8-ref bytevector-u8-set!
+ bytevector?
+ car cdr caar cadr cdar
+ call-with-current-continuation call/cc
+ |#
+ call-with-port
+ #|
+ call-with-values
+ case
+ ceiling
+ char-ready?
+ char->integer integer->char
+ char<? char>? char<=? char>=?
+ char?
+ close-input-port close-output-port close-port
+ complex?
+ cond
+ |#
+ cond-expand
+ #|
+ cons
+ current-input-port current-output-port current-error-port
+ define
+ define-record-type
+ define-syntax
+ define-values
+ denominator numerator
+ do
+ dynamic-wind
+ else
+ |#
+ eof-object
+ #|
+ eof-object?
+ eq? eqv? equal?
+ error
+ |#
+ error-object-irritants error-object-message
+ error-object?
+ #|
+ even? odd?
+ exact inexact
+ exact-integer-sqrt
+ exact-integer?
+ exact? inexact?
+ expt
+ features
+ |#
+ file-error?
+ #|
+ floor floor-quotient floor-remainder
+ floor/
+ flush-output-port
+ for-each
+ gcd lcm
+ get-output-bytevector
+ get-output-string
+ |#
+ guard
+ #|
+ if
+ import
+ ;; import-for-syntax XXX should we?
+ include include-ci
+ input-port-open? output-port-open?
+ input-port? output-port?
+ integer?
+ lambda
+ length
+ let let*
+ letrec letrec*
+ let-values let*-values
+ let-syntax
+ letrec-syntax
+ library ; for "cond-expand"
+ list
+ list-copy
+ list-ref list-set!
+ list-tail
+ list?
+ make-bytevector
+ make-list
+ make-parameter
+ make-string
+ make-vector
+ map
+ max min
+ member memq memv
+ modulo remainder
+ negative? positive?
+ newline
+ not
+ null?
+ number->string string->number
+ number?
+ open-input-bytevector open-output-bytevector
+ open-input-string open-output-string
+ pair?
+ parameterize
+ peek-char
+ peek-u8
+ port?
+ procedure?
+ quasiquote
+ quote
+ quotient remainder
+ |#
+ raise raise-continuable
+ #|
+ rational?
+ rationalize
+ read-bytevector read-bytevector!
+ read-char
+ |#
+ read-error?
+ #|
+ read-line
+ read-string
+ read-u8
+ real?
+ reverse
+ round
+ set!
+ set-car! set-cdr!
+ square
+ string
+ string->list list->string
+ string->utf8 utf8->string
+ string->symbol symbol->string
+ string->vector
+ string-append
+ string-copy string-copy!
+ string-fill!
+ string-for-each
+ string-length
+ string-map
+ string-ref string-set!
+ string=? string<? string>? string<=? string>=?
+ string?
+ substring
+ symbol=?
+ symbol?
+ syntax-error
+ ;syntax-rules XXX???
+ textual-port?
+ truncate
+ truncate-quotient truncate-remainder
+ truncate/
+ u8-ready?
+ unless
+ unquote unquote-splicing
+ values
+ vector
+ vector-append
+ vector-copy vector-copy!
+ vector-for-each
+ vector-length
+ vector-map
+ vector-ref vector-set!
+ when
+ |#
+ with-exception-handler
+ #|
+ write-bytevector
+ write-char
+ write-string
+ write-u8
+ zero?
+ |#
+ )
diff --git a/scheme.base.scm b/scheme.base.scm
new file mode 100644
index 0000000..1e03416
--- /dev/null
+++ b/scheme.base.scm
@@ -0,0 +1,164 @@
+(module scheme.base ()
+
+(import (except scheme cond-expand))
+(import (except chicken with-exception-handler raise))
+
+(include "scheme.base-interface.scm")
+
+(begin-for-syntax (require-library r7rs-compile-time))
+(import-for-syntax r7rs-compile-time)
+
+
+;;;
+;;; 4.2.1. Conditionals
+;;;
+
+(define-syntax cond-expand
+ (er-macro-transformer
+ (lambda (x r c)
+ (process-cond-expand (cdr x)))))
+
+
+;;;
+;;; 4.2.7. Exception handling
+;;;
+
+;; guard & guard-aux copied verbatim from the draft.
+(define-syntax guard
+ (syntax-rules ()
+ ((guard (var clause ...) e1 e2 ...)
+ ((call/cc
+ (lambda (guard-k)
+ (with-exception-handler
+ (lambda (condition)
+ ((call/cc
+ (lambda (handler-k)
+ (guard-k
+ (lambda ()
+ (let ((var condition))
+ (guard-aux
+ (handler-k
+ (lambda ()
+ (raise-continuable condition)))
+ clause ...))))))))
+ (lambda ()
+ (call-with-values
+ (lambda () e1 e2 ...)
+ (lambda args
+ (guard-k
+ (lambda ()
+ (apply values args)))))))))))))
+
+(define-syntax guard-aux
+ (syntax-rules (else =>)
+ ((guard-aux reraise (else result1 result2 ...))
+ (begin result1 result2 ...))
+ ((guard-aux reraise (test => result))
+ (let ((temp test))
+ (if temp
+ (result temp)
+ reraise)))
+ ((guard-aux reraise (test => result)
+ clause1 clause2 ...)
+ (let ((temp test))
+ (if temp
+ (result temp)
+ (guard-aux reraise clause1 clause2 ...))))
+ ((guard-aux reraise (test))
+ (or test reraise))
+ ((guard-aux reraise (test) clause1 clause2 ...)
+ (let ((temp test))
+ (if temp
+ temp
+ (guard-aux reraise clause1 clause2 ...))))
+ ((guard-aux reraise (test result1 result2 ...))
+ (if test
+ (begin result1 result2 ...)
+ reraise))
+ ((guard-aux reraise
+ (test result1 result2 ...)
+ clause1 clause2 ...)
+ (if test
+ (begin result1 result2 ...)
+ (guard-aux reraise clause1 clause2 ...)))))
+
+
+;;;
+;;; 6.11. Exceptions
+;;;
+
+(define-values (with-exception-handler raise raise-continuable)
+ (let ((exception-handlers
+ (let ((lst (list ##sys#current-exception-handler)))
+ (set-cdr! lst lst)
+ lst)))
+ (values
+ ;; with-exception-handler
+ (lambda (handler thunk)
+ (dynamic-wind
+ (lambda ()
+ (set! exception-handlers (cons handler exception-handlers))
+ (set! ##sys#current-exception-handler handler))
+ thunk
+ (lambda ()
+ (set! exception-handlers (cdr exception-handlers))
+ (set! ##sys#current-exception-handler (car exception-handlers)))))
+ ;; raise
+ (lambda (obj)
+ (with-exception-handler
+ (cadr exception-handlers)
+ (lambda ()
+ ((cadr exception-handlers) obj)
+ ((car exception-handlers)
+ (make-property-condition
+ 'exn
+ 'message "exception handler returned"
+ 'arguments '()
+ 'location #f)))))
+ ;; raise-continuable
+ (lambda (obj)
+ (with-exception-handler
+ (cadr exception-handlers)
+ (lambda ()
+ ((cadr exception-handlers) obj)))))))
+
+(define error-object? condition?)
+(define error-object-message (condition-property-accessor 'exn 'message))
+(define error-object-irritants (condition-property-accessor 'exn 'arguments))
+
+(define-values (read-error? file-error?)
+ (let ((exn? (condition-predicate 'exn))
+ (i/o? (condition-predicate 'i/o))
+ (file? (condition-predicate 'file))
+ (syntax? (condition-predicate 'syntax)))
+ (values
+ ;; read-error?
+ (lambda (obj)
+ (and (exn? obj)
+ (or (i/o? obj) ; XXX Not fine-grained enough.
+ (syntax? obj))))
+ ;; file-error?
+ (lambda (obj)
+ (and (exn? obj)
+ (file? obj))))))
+
+
+;;;
+;;; 6.13. Input and Output
+;;;
+
+(define (call-with-port port proc)
+ (dynamic-wind void (lambda () (proc port)) (lambda () (close-port port))))
+
+(define (close-port port)
+ (cond ((input-port? port)
+ (close-input-port port))
+ ((output-port? port)
+ (close-output-port port))
+ (else
+ (error 'close-port "not a port" port))))
+
+(define (eof-object) #!eof)
+
+
+)
diff --git a/scheme.process-context.scm b/scheme.process-context.scm
new file mode 100644
index 0000000..26d9a22
--- /dev/null
+++ b/scheme.process-context.scm
@@ -0,0 +1,56 @@
+(module scheme.process-context (command-line
+ exit
+ emergency-exit
+ ;;XXX
+ ;get-environment-variable
+ ;get-environment-variables
+ )
+
+ (import scheme
+ (rename chicken (exit chicken:exit))
+ foreign)
+
+;;;
+;;; 6.14. System interface.
+;;;
+
+;; Should these go in a separate module (process-context)?
+
+(define command-line
+ (let ((command-line #f)
+ (arguments (command-line-arguments)))
+ (lambda ()
+ (unless command-line
+ (set! command-line (cons (program-name) arguments)))
+ command-line)))
+
+(define (->exit-status obj)
+ (cond ((integer? obj) obj)
+ ((eq? obj #f) 1)
+ (else 0)))
+
+(define exit
+ (case-lambda
+ (()
+ (chicken: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 ()
+ (unless (null? ##sys#dynamic-winds)
+ (let ((after (cdar ##sys#dynamic-winds)))
+ (set! ##sys#dynamic-winds (cdr ##sys#dynamic-winds))
+ (after)
+ (unwind))))
+ (##core#inline "C_exit_runtime" (->exit-status obj)))))
+
+(define emergency-exit
+ (case-lambda
+ (()
+ (emergency-exit 0))
+ ((obj)
+ (##sys#cleanup-before-exit)
+ ((foreign-lambda void "_exit" int) (->exit-status obj)))))
+
+)
diff --git a/tests/run.scm b/tests/run.scm
index ccb0a2b..e33838a 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -3,7 +3,7 @@
(define (read-from-string s)
(with-input-from-string s read))
-(test-group "long boolean literalsa"
+(test-group "long boolean literals"
(test #t (read-from-string "#t"))
(test #f (read-from-string "#f"))
(test #t (read-from-string "#true"))
Trap