home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / brutal-utils / macptr-u.lisp < prev    next >
Encoding:
Text File  |  1992-06-26  |  3.8 KB  |  112 lines
  1. (in-package :oou)
  2. (oou-provide :macptr-u)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; macptr-u.lisp
  5. ;;
  6. ;; Copyright ⌐ 1991 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; utilities for working with macptrs
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (export '(%get-boolean   %put-boolean
  15.           %get-character %put-character
  16.           %get-text      %put-text
  17.           %get-list      %put-list
  18.           %get-hex-str   %put-hex-str
  19.           ))
  20.  
  21. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22. #|
  23.  
  24. |#
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26.  
  27. (defun %get-boolean (ptr &optional (offset 0))
  28.   (logbitp 8 (%get-signed-byte ptr offset)))
  29.  
  30. (defun %put-boolean (ptr bool &optional (offset 0))
  31.   (%put-byte ptr (if bool -1 0) offset))
  32.  
  33.  
  34. (defun %get-character (ptr &optional (offset 0))
  35.   (code-char (%get-unsigned-byte ptr offset)))
  36.  
  37. (defun %put-character (ptr char &optional (offset 0))
  38.   (%put-byte ptr (char-code char) offset))
  39.  
  40.  
  41. ;;These 2 need to be rewritten to operate more efficiently
  42. ;; look into (ccl::%str-from-ptr ptr size)
  43.  
  44. (defun %get-text (ptr length &optional (offset 0))
  45.   (let ((text_p (%inc-ptr ptr offset))
  46.         (str (make-array length :element-type 'base-character :fill-pointer 0)))
  47.     (dotimes (i length str) (vector-push (%get-character text_p i) str))))
  48.  
  49. (defun %put-text (ptr string &optional (offset 0))
  50.   (with-cstrs ((cstr_p string))
  51.     (#_BlockMove cstr_p (%inc-ptr ptr offset) (length string)))
  52.   nil)
  53.  
  54.  
  55. (defun %get-list (ptr elt-%get-fn elt-size elt-count &optional (offset 0))
  56.   (when (plusp elt-count)
  57.     (cons (funcall elt-%get-fn ptr offset) (%get-list (%inc-ptr ptr elt-size)
  58.                                               elt-%get-fn
  59.                                               elt-size
  60.                                               (1- elt-count)
  61.                                               offset))))
  62.  
  63. (defun %put-list (ptr list elt-%put-fn elt-size &optional (offset 0))
  64.   (dolist (elt list nil)
  65.     (funcall elt-%put-fn ptr elt offset)
  66.     (incf offset elt-size)))
  67.  
  68. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  69.  
  70.  
  71. (defun %get-hex-str (ptr byte-count &optional (offset 0))
  72.   (let ((str (make-string (+ (* 2 byte-count) (1- (ceiling byte-count 2)))
  73.                           :initial-element #\space))
  74.         (hex-vector #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\A #\B #\C #\D #\E #\F)))
  75.     (dotimes (i byte-count str)
  76.       (let ((byte (%get-unsigned-byte ptr (+ i offset)))
  77.             (str-index (+ (* i 2) (truncate i 2))))
  78.         (setf (schar str str-index)      (svref hex-vector (ash byte -4)))
  79.         (setf (schar str (1+ str-index)) (svref hex-vector (logand #x0F byte)))))))
  80.  
  81. (defun %put-hex-str (ptr hex-str &optional (offset 0))
  82.   (let ((i offset)
  83.         (byte nil))
  84.     (etypecase hex-str
  85.       (simple-string
  86.        (dotimes (str-index (length hex-str))
  87.          (let ((nibble (digit-char-p (schar hex-str str-index) 16)))
  88.            (when nibble
  89.              (if byte
  90.                (progn
  91.                  (%put-byte ptr (+ byte nibble) i)
  92.                  (incf i)
  93.                  (setf byte nil))
  94.                (setf byte (ash nibble 4)))))))
  95.       (string
  96.        (dotimes (str-index (length hex-str))
  97.          (let ((nibble (digit-char-p (char hex-str str-index) 16)))
  98.            (when nibble
  99.              (if byte
  100.                (progn
  101.                  (%put-byte ptr (+ byte nibble) i)
  102.                  (incf i)
  103.                  (setf byte nil))
  104.                (setf byte (ash nibble 4))))))))
  105.  
  106.     ;take care of the odd half byte
  107.     (when byte (%put-byte ptr (+ byte (logand #x0F (%get-byte ptr i))) i)))
  108.   nil)
  109.  
  110. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  111.  
  112.