home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / NotInROM / +ToolUtils.lisp < prev    next >
Encoding:
Text File  |  1992-02-07  |  2.9 KB  |  79 lines
  1. ;; -*- package: NotInROM -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;; +ToolUtils.Lisp
  4. ;;
  5. ;; Copyright ⌐ 1991 Northwestern University Institute for the Learning Sciences
  6. ;; All Rights Reserved
  7. ;;
  8. ;; author: Michael S. Engber
  9. ;;
  10. ;; Provides ToolBox Utilities Routines
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12.  
  13. (eval-when (:compile-toplevel :load-toplevel :execute)
  14.   (require    :NotInROM-u)
  15.   (in-package :NotInROM))
  16.  
  17. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18.  
  19. (deftrap-NotInROM _ScreenRes :none ((scrnHRes (:pointer :signed-integer)) (scrnVRes (:pointer :signed-integer)))
  20.   (%put-word scrnHRes (%get-word (%int-to-ptr #$ScrHRes)))
  21.   (%put-word scrnVRes (%get-word (%int-to-ptr #$ScrVRes))))
  22.  
  23.  
  24. ;;perhaps these 2 should call ReleaseResource, I'm not sure?
  25.  
  26. (deftrap-NotInROM _GetIndString :none ((theString (:string 255)) (strListID :signed-integer) (index :signed-integer))
  27.   (with-macptrs ((strList_h (#_GetResource "STR#" strListID)))
  28.     (unless (%null-ptr-p strList_h)
  29.       (with-dereferenced-handles ((strList_p strList_h))
  30.         (let ((num-strings (%get-unsigned-word strList_p)))
  31.           (when (and (plusp index) (<= index num-strings))
  32.             (%incf-ptr strList_p 2)
  33.             (dotimes (i (1- index))
  34.               (declare (fixnum i))
  35.               (%incf-ptr strList_p (1+ (%get-unsigned-byte strList_p))))
  36.             (#_BlockMove strList_p theString (1+ (%get-unsigned-byte strList_p)))))))))
  37.  
  38.  
  39. (deftrap-NotInROM _GetIndPattern :none ((thePattern (:string 255)) (patListID :signed-integer) (index :signed-integer))
  40.   (with-macptrs ((patList_h (#_GetResource "PAT#" patListID)))
  41.     (unless (%null-ptr-p patList_h)
  42.       (with-dereferenced-handles ((patList_p patList_h))
  43.         (let ((num-pats (%get-unsigned-word patList_p)))
  44.           (when (and (plusp index) (<= index num-pats))
  45.             (%incf-ptr patList_p (+ 2 (* 8 (1- index))))
  46.             (#_BlockMove patList_p thePattern #.(ccl::record-field-length :Pattern))))))))
  47.  
  48. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49.  
  50. (deftrap-NotInROM _c2pstr :pointer ((cstr (:pointer :character)))
  51.   (unless (%null-ptr-p cstr)
  52.     (let ((last (%get-byte cstr))
  53.           (cur)
  54.           (len 0))
  55.       (declare (fixnum last cur len)
  56.                (dynamic-extent last cur len))
  57.       (loop
  58.         (when (zerop last) (return))
  59.         (incf len)
  60.         (setf cur (%get-byte cstr len))
  61.         (%put-byte cstr last len)
  62.         (setf last cur))
  63.       (%put-byte cstr (min len 255))))
  64.   cstr)
  65.  
  66. (deftrap-alt-name _c2pstrProc _c2pstr)
  67.  
  68.  
  69. (deftrap-NotInROM _p2cstr :pointer ((pstr (:string 255)))
  70.   (let ((len (%get-unsigned-byte pstr)))
  71.     (declare (fixnum len))
  72.     (#_BlockMove (%inc-ptr pstr) pstr len)
  73.     (%put-byte pstr 0 len))
  74.   pstr)
  75.  
  76. (deftrap-alt-name _p2cstrProc _p2cstr)
  77.  
  78. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  79.