[movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv11748

Modified Files:
	basic-functions.lisp 
Log Message:
Moved some code around, to fix compilation order.

Date: Tue May 24 08:33:19 2005
Author: ffjeld

Index: movitz/losp/muerte/basic-functions.lisp
diff -u movitz/losp/muerte/basic-functions.lisp:1.18 movitz/losp/muerte/basic-functions.lisp:1.19
--- movitz/losp/muerte/basic-functions.lisp:1.18	Thu May  5 15:21:46 2005
+++ movitz/losp/muerte/basic-functions.lisp	Tue May 24 08:33:19 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Sep  4 18:41:57 2001
 ;;;;                
-;;;; $Id: basic-functions.lisp,v 1.18 2005/05/05 13:21:46 ffjeld Exp $
+;;;; $Id: basic-functions.lisp,v 1.19 2005/05/24 06:33:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -383,4 +383,48 @@
    (place-name
     (error "The value of ~S, ~S, is not of type ~S."
 	   place-name value type))
-   (t (error "~S is not of type ~S." value type))))
\ No newline at end of file
+   (t (error "~S is not of type ~S." value type))))
+
+(defun memrange (object offset index length type)
+  (ecase type
+    (:unsigned-byte8
+     (let ((vector (make-array length :element-type '(unsigned-byte 8))))
+       (let ((i index))
+	 (dotimes (j length)
+	   (setf (aref vector j)
+	     (memref object offset :index i :type :unsigned-byte8))
+	   (incf i)))
+       vector))))
+
+(defun (setf memrange) (value object offset index length type)
+  (ecase type
+    (:unsigned-byte8
+     (etypecase value
+       ((unsigned-byte 8)
+	(do ((end (+ index length))
+	     (i index (1+ i)))
+	    ((>= i end))
+	  (setf (memref object offset :index i :type :unsigned-byte8) value)))
+       (vector
+	(do ((end (+ index length))
+	     (i index (1+ i))
+	     (j 0 (1+ j)))
+	    ((or (>= i end) (>= j (length value))))
+	  (setf (memref object offset :index i :type :unsigned-byte8)
+	    (aref value j))))))
+    (:character
+     (etypecase value
+       (character
+	(do ((end (+ index length))
+	     (i index (1+ i)))
+	    ((>= i end))
+	  (setf (memref object offset :index i :type :character) value)))
+       (string
+	(do ((end (+ index length))
+	     (i index (1+ i))
+	     (j 0 (1+ j)))
+	    ((or (>= i end) (>= j (length value))))
+	  (setf (memref object offset :index i :type :character)
+	    (char value j)))))))
+  value)
+