* Added file-options macro

src/ikarus.codecs.ss

@@ -1,11 +1,12 @@
 
 (library (ikarus codecs)
   (export latin-1-codec utf-8-codec utf-16-codec native-eol-style
-          make-transcoder native-transcoder buffer-mode?)
+          make-transcoder native-transcoder buffer-mode?
+          file-options-spec)
   (import 
     (except (ikarus) latin-1-codec utf-8-codec utf-16-codec 
       native-eol-style make-transcoder native-transcoder
-      buffer-mode?)
+      buffer-mode? file-options-spec)
     (ikarus system $transcoders))
   (define (latin-1-codec) 'latin-1-codec)
   (define (utf-8-codec)   'utf-8-codec)
@@ -65,5 +66,31 @@
   (define (buffer-mode? x)
     (and (memq x '(none line block)) #t))
 
+  (define file-options-vec
+    '#(fo:default
+       fo:no-create
+       fo:no-fail
+       fo:no-fail/no-create
+       fo:no-truncate
+       fo:no-truncate/no-create
+       fo:no-truncate/no-fail
+       fo:no-truncate/no-fail/no-create))
+
+  (define file-options-alist
+    '([no-create .   #b001]
+      [no-fail .     #b010]
+      [no-truncate . #b100]))
+      
+  (define (file-options-spec ls)
+    (unless (list? ls) 
+      (error 'file-options-spec "~s is not a list" ls))
+    (let f ([ls ls] [n 0])
+      (cond
+        [(null? ls) (vector-ref file-options-vec n)]
+        [(assq (car ls) file-options-alist) => 
+         (lambda (a) 
+           (f (cdr ls) (fxlogor (cdr a) n)))]
+        [else #f])))
+
   )
 

src/makefile.ss

@@ -133,6 +133,7 @@
     [trace-define        (macro . trace-define)]
     [eol-style           (macro . eol-style)]
     [buffer-mode         (macro . buffer-mode)]
+    [file-options        (macro . file-options)]
     [error-handling-mode (macro . error-handling-mode)]
     ))
 
@@ -969,7 +970,7 @@
     [close-port                                  r ip]
     [eol-style                                   i r ip]
     [error-handling-mode                         i r ip]
-    [file-options                                r ip]
+    [file-options                                i r ip]
     [flush-output-port                           i r ip]
     [get-bytevector-all                          r ip]
     [get-bytevector-n                            r ip]
@@ -1199,6 +1200,7 @@
     [$transcoder?                                $transc]
     [$transcoder->data                           $transc]
     [$data->transcoder                           $transc]
+    [file-options-spec                           i]
   ))
 
 (define (macro-identifier? x) 

src/psyntax.compat.ss

@@ -1,7 +1,8 @@
 
 (library (psyntax compat)
   (export define-record make-parameter parameterize format gensym
-          eval-core make-record-type symbol-value set-symbol-value!)
+          eval-core make-record-type symbol-value set-symbol-value!
+          file-options-spec)
   (import 
     (only (ikarus compiler) eval-core)
     (rename (ikarus) (define-record sys.define-record)))

src/psyntax.expander.ss

@@ -1879,6 +1879,13 @@
         ((type-descriptor) type-descriptor-transformer)
         (else (error 'macro-transformer "cannot find ~s" name)))))
   
+  (define file-options-macro
+    (lambda (x)
+      (syntax-match x ()
+        ((_ opt* ...)
+         (and (for-all id? opt*) (file-options-spec (map id->sym opt*)))
+         (bless `(quote ,(file-options-spec (map id->sym opt*))))))))
+
   (define symbol-macro
     (lambda (x set)
       (syntax-match x ()
@@ -1920,6 +1927,7 @@
            ((buffer-mode)         
             (lambda (x) 
               (symbol-macro x '(none line block))))
+           ((file-options)     file-options-macro)
            ((... => _ else unquote unquote-splicing
              unsyntax unsyntax-splicing)
             incorrect-usage-macro)

src/todo-r6rs.ss

@@ -546,7 +546,7 @@
     [close-port                                 S ip]
     [eol-style                                  C ip]
     [error-handling-mode                        C ip]
-    [file-options                               S ip]
+    [file-options                               C ip]
     [flush-output-port                          S ip]
     [get-bytevector-all                         S ip]
     [get-bytevector-n                           S ip]