diff options
Diffstat (limited to 'runtime/io-primitives.scm')
| -rw-r--r-- | runtime/io-primitives.scm | 178 |
1 files changed, 178 insertions, 0 deletions
diff --git a/runtime/io-primitives.scm b/runtime/io-primitives.scm new file mode 100644 index 0000000..85bc51b --- /dev/null +++ b/runtime/io-primitives.scm @@ -0,0 +1,178 @@ + +;;; These are the IO primitives used by PreludeIOPrims + +;;; Note: the box in write-string-stdout, write-string-file, and +;;; append-string-file are due to the NoConversion in the .hi file. +;;; The problem is that NoConversion applies to everything, not just +;;; the input arg that the conversion is not needed or. + + +(predefine (notify-input-request)) + +(define *emacs-notified* '#f) +(define *stdin-read* '#f) + +(define (initialize-io-system) + (setf *emacs-notified* '#f) + (setf *stdin-read* '#f)) + +(define (io-success . res) + (make-tagged-data 0 + (if (null? res) + (box 0) + (box (make-haskell-string (car res)))))) + +(define (io-success/bin res) + (make-tagged-data 0 (box res))) + +(define (io-success/lazy res) + (make-tagged-data 0 res)) + +(define (io-failure string) + (make-tagged-data 1 (box (make-haskell-string string)))) + +; primReadStringFile +(define (prim.read-string-file filename) + (if (file-exists? filename) + (let ((str (call-with-input-file filename + (lambda (port) + (port->string port))))) + (io-success str)) + (io-failure (format '#f "File not found: ~A~%" filename)))) + +(define (port->string port) + (call-with-output-string + (lambda (string-port) + (copy-till-eof port string-port)))) + +(define (copy-till-eof in-port out-port) + (do ((ch (read-char in-port) (read-char in-port))) + ((eof-object? ch)) + (write-char ch out-port))) + +; primWriteStringFile +(define (prim.write-string-file filename contents state) + (declare (ignore state)) + (box + (let ((stream (lisp:open (haskell-string->string filename) + :direction :output + :if-exists :overwrite + :if-does-not-exist :create))) + (print-haskell-string contents stream) + (close-output-port stream) + (io-success)))) + +;primAppendStringFile +(define (prim.append-string-file filename contents state) + (declare (ignore state)) + (box + (let ((stream (lisp:open (haskell-string->string filename) + :direction :output + :if-exists :append + :if-does-not-exist '()))) + (cond ((not (eq? stream '())) + (print-haskell-string contents stream) + (close-output-port stream) + (io-success)) + (else + (io-failure "Can't open file")))))) + +; primReadBinFile +(define (prim.read-bin-file name) + (let ((bin (lisp-read name))) + (if (and (pair? bin) (eq? (car bin) ':binary)) + (io-success/bin bin) + (io-failure "Not a bin file")))) + +; primWriteBinFile +(define (prim.write-bin-file name contents) + (let ((stream (lisp:open name :direction :output + :if-exists :overwrite + :if-does-not-exist :create))) + (write (cons ':binary contents) stream) + (close-output-port stream) + (io-success))) + +; primAppendBinFile +(define (prim.append-bin-file name contents) + (let ((bin (lisp-read name))) + (if (and (pair? bin) (eq? (car bin) ':binary)) + (let ((stream (lisp:open name :direction :output :if-exists :overwrite))) + (write (append bin contents) stream) + (io-success)) + (io-failure "Can't open Bin file")))) + +; primDeleteFile +(define (prim.delete-file name) + (if (file-exists? name) + (if (lisp:delete-file name) + (io-success) + (io-failure "Can't delete file")) + (io-failure "File not found"))) + +; primStatusFile +(define (prim.status-file name) + (if (file-exists? name) + (io-success "frw") + (io-failure (format '#f "File ~A not found" name)))) + +;primReadStdin +(define (prim.read-string-stdin state) + (declare (ignore state)) + (cond (*stdin-read* + (haskell-runtime-error "Multiple ReadChan from stdin")) + (else + (setf *stdin-read* '#t) + (delay (read-next-char))))) + +(define (read-next-char) + (when (and *emacs-mode* (not *emacs-notified*)) + (setf *emacs-notified* '#t) + (notify-input-request)) + (let ((ch (read-char))) + (if (eof-object? ch) + '() + (cons (box (char->integer ch)) + (delay (read-next-char)))))) + +; primWriteStdout +(define (prim.write-string-stdout string state) + (declare (ignore state)) + (print-haskell-string string (current-output-port)) + (box (io-success))) + +; primReadBinStdin +(define (prim.read-bin-stdin) + (haskell-runtime-error "ReadBinChan not implemented")) + +; primWriteBinStdout +(define (prim.write-bin-stdout bin) + (declare (ignore bin)) + (haskell-runtime-error "WriteBinChan not implemented")) + +;;; %%% probably bogus +; primGetEnv +(define (prim.getenv name) + (io-success (getenv name))) + +(define (lisp-read file) + (if (not (file-exists? file)) + 'error + (call-with-input-file file + (lambda (port) + (lisp:read port '#f 'error '#f))))) + +(define-integrable (prim.returnio x s) + (declare (ignore s)) + x) + +(define-integrable (prim.getstate x) + (declare (ignore x)) + 'state) + +(define-integrable (prim.getres x) + (force x)) + + + + |