home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / progs / lib / hbc / NativePrims.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  5.5 KB  |  196 lines  |  [TEXT/CCL2]
  1. ;;; NativePrims.scm -- Lisp primitives for Native I/O operations
  2. ;;;
  3. ;;; author :  Sandra Loosemore
  4. ;;; date   :  09 Jun 1994
  5. ;;;
  6. ;;; Note:  this file contains code specific to various Common Lisp
  7. ;;; implementations since it isn't possible to do this stuff portably.
  8. ;;;
  9. ;;;
  10.  
  11.  
  12. ;;;========================================================================
  13. ;;; Shared support code
  14. ;;;========================================================================
  15.  
  16.  
  17. ;;; Constructors for Maybe type
  18.  
  19. (define-integrable nothing (make-tagged-data 0))
  20. (define-integrable (just x) (make-tagged-data 1 (box x)))
  21.  
  22.  
  23. ;;; Primitive operations on byte files
  24.  
  25. (define (prim.open-input-byte-file name)
  26.   (if (file-exists? name)
  27.       (lisp:open name :direction :input :element-type '(lisp:unsigned-byte 8))
  28.       (haskell-runtime-error (format '#f "File ~s not found." name))))
  29.  
  30. (define (prim.open-output-byte-file name)
  31.   (lisp:open name :direction :output :element-type '(lisp:unsigned-byte 8)))
  32.  
  33.  
  34. (define (prim.close-byte-file f)
  35.   (lisp:close f)
  36.   0)
  37.  
  38. (define (prim.show-byte-file b f)
  39.   (lisp:write-byte b f)
  40.   0)
  41.  
  42. (define (prim.read-byte-file f)
  43.   (let ((b  (lisp:read-byte f '#f '#f)))
  44.     (if b
  45.     (just b)
  46.         nothing)))
  47.  
  48.  
  49.  
  50. ;;; The magic in the interface file makes the character arguments be passed
  51. ;;; as small integers, allowing us to mess with them directly as byte objects.
  52.  
  53. (define (prim.char-show-bytes x list) 
  54.   (cons (box x) list))
  55.  
  56. (define (prim.char-read-bytes list)
  57.   (if (null? list)
  58.       nothing
  59.       (just (make-tuple (car list) (cdr list)))))
  60.  
  61. (define (prim.char-show-byte-file x f state)
  62.   (declare (ignore state))
  63.   (prim.show-byte-file x f))
  64.  
  65. (define (prim.char-read-byte-file f state)
  66.   (declare (ignore state))
  67.   (io-return (prim.read-byte-file f)))
  68.  
  69.  
  70.  
  71. ;;;========================================================================
  72. ;;; CMU CL stuff
  73. ;;;========================================================================
  74. #+cmu
  75. (begin
  76.  
  77.  
  78. ;;; This is easy; all we have to do is copy the stuff in and out of an
  79. ;;; alien union structure.
  80.  
  81. (define *conversion-buffer*
  82.   (alien:make-alien
  83.     (alien:union lisp:nil
  84.          (s c-call:short)
  85.          (i c-call:int)
  86.          (f c-call:float)
  87.          (d c-call:double)
  88.          (b (lisp:array c-call:unsigned-char 8)))))
  89. (define *conversion-bytes* (alien:slot *conversion-buffer* 'b))
  90.  
  91.  
  92. (define-integrable short-size (alien:alien-size c-call:short :bytes))
  93. (define-integrable int-size (alien:alien-size c-call:int :bytes))
  94. (define-integrable float-size (alien:alien-size c-call:float :bytes))
  95. (define-integrable double-size (alien:alien-size c-call:double :bytes))
  96.  
  97. (define-syntax (define-byte-functions size slot
  98.          show-bytes-fn read-bytes-fn
  99.          show-byte-file-fn read-byte-file-fn)
  100.   `(begin
  101.      (define (,show-bytes-fn x list)
  102.        (setf (alien:slot *conversion-buffer* ',slot) x)
  103.        (show-bytes-aux ,size list))
  104.      (define (,read-bytes-fn list)
  105.        (multiple-value-bind (success? tail) (read-bytes-aux ,size list)
  106.      (if success?
  107.          (just
  108.            (make-tuple (box (alien:slot *conversion-buffer* ',slot))
  109.                tail))
  110.          nothing)))
  111.      (define (,show-byte-file-fn x f state)
  112.        (declare (ignore state))
  113.        (setf (alien:slot *conversion-buffer* ',slot) x)
  114.        (show-byte-file-aux ,size f))
  115.      (define (,read-byte-file-fn f state)
  116.        (declare (ignore state))
  117.        (io-return
  118.      (if (read-byte-file-aux ,size f)
  119.          nothing
  120.          (just (alien:slot *conversion-buffer* ',slot)))))
  121.      ))
  122.  
  123. (define-byte-functions short-size s
  124.   prim.short-show-bytes prim.short-read-bytes
  125.   prim.short-show-byte-file prim.short-read-byte-file)
  126. (define-byte-functions int-size i
  127.   prim.int-show-bytes prim.int-read-bytes
  128.   prim.int-show-byte-file prim.int-read-byte-file)
  129. (define-byte-functions float-size f
  130.   prim.float-show-bytes prim.float-read-bytes
  131.   prim.float-show-byte-file prim.float-read-byte-file)
  132. (define-byte-functions double-size d
  133.   prim.double-show-bytes prim.double-read-bytes
  134.   prim.double-show-byte-file prim.double-read-byte-file)
  135.  
  136.  
  137. ;;; Shared helper functions for copying bytes in and out of the buffer.
  138.  
  139. (define (show-bytes-aux size list)
  140.   (declare (type fixnum size))
  141.   (do ((i  size (1- i)))
  142.       ((eqv? i 0) list)
  143.     (declare (type fixnum i))
  144.     (setf list
  145.       (cons (box (alien:deref *conversion-bytes* (1- i)))
  146.         (if (eqv? i size) list (box list))))))
  147.  
  148.  
  149. (define (read-bytes-aux size list)
  150.   (declare (type fixnum size))
  151.   ;; This is a little bizarre because the list argument is strict, but
  152.   ;; on subsequent iterations we don't force the tail until we have to.
  153.   (if (or (null? list) (eqv? size 0))
  154.       (values (eqv? i size) (box list))
  155.       (read-bytes-aux-aux 0 size list)))
  156.  
  157. (define (read-bytes-aux-aux i size list)
  158.   (declare (type fixnum i size))
  159.   (setf (alien:deref *conversion-bytes* i) (force (car list)))
  160.   (incf i)
  161.   (if (eqv? i size)
  162.       (values '#t (cdr list))
  163.       (let ((tail  (force (cdr list))))
  164.     (if (null? tail)
  165.         (values '#f (cdr list))
  166.         (read-bytes-aux-aux i size tail)))))
  167.  
  168.  
  169. (define (show-byte-file-aux size f)
  170.   (dotimes (i size)
  171.     (lisp:write-byte (alien:deref *conversion-bytes* i) f))
  172.   0)
  173.  
  174. (define (read-byte-file-aux size f)
  175.   (let ((error?  '#f))
  176.     (dotimes (i size)
  177.       (let ((b  (lisp:read-byte f '#f '#f)))
  178.     (if b
  179.         (setf (alien:deref *conversion-bytes* i) b)
  180.         (setf error? '#t))))
  181.     error?))
  182.  
  183.  
  184. ) ; end of cmu-specific code
  185.  
  186.  
  187.  
  188. ;;;========================================================================
  189. ;;; Other lisps
  190. ;;;========================================================================
  191.  
  192. #-cmu
  193. (lisp:eval-when (lisp:eval lisp:compile lisp:load)
  194.   (error "Sorry, Native IO primitives not implemented in this lisp."))
  195.  
  196.