~ chicken-r7rs (master) f4f0f3a1d59fcdc390063b9d123ec316c6167d09

commit f4f0f3a1d59fcdc390063b9d123ec316c6167d09
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Thu May 30 08:38:00 2013 +0000
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Thu May 30 08:38:00 2013 +0000

    Add exit procedures

diff --git a/r7rs.scm b/r7rs.scm
index ccd77a9..409861e 100644
--- a/r7rs.scm
+++ b/r7rs.scm
@@ -10,9 +10,12 @@
  read-error?
  file-error?
  ; TODO guard
+ ;; System interface
+ exit
+ emergency-exit
  )
 
-(import chicken scheme)
+(import chicken scheme foreign)
 (use srfi-13)
 
 (define (read-asserted-ci-symbol port valid-symbols error-message)
@@ -59,4 +62,39 @@
        (and (exn? obj)
             (file? obj))))))
 
+;;;
+;;; 6.14. System interface.
+;;;
+
+;; Should these go in a separate module (process-context)?
+
+(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 emergency-exit
+  (case-lambda
+    (()
+     (emergency-exit 0))
+    ((obj)
+     (##sys#cleanup-before-exit)
+     ((foreign-lambda void "_exit" int) (->exit-status obj)))))
+
 )