Re: define-foreign & C structs

[dorab@CS.UCLA.EDU (Dorab Patel)]

here is my version of the same thing ---- doesnt support the "print"
"cref" and "typename" operations as derek's does, but allows structure
components that are arrays. also, appears to do more syntax error
checking.

enjoy!

'dorab

(herald cstruct)

;;; Copyleft (l) 1989, Dorab Patel <dorab@cs.ucla.edu>

;;; make a T (bytev) version of a C structure
;;; typically called as
;;;
;;; (define-cstruct struct-name (c-type component-name opt-array)...)
;;;
;;; for example ...
;;;
;;; (define-cstruct foo (int x) (char y 4) (short z))
;;;
;;; which defines
;;;
;;; (lset sym (make-foo)) ==> returns a 10 byte bytev
;;; (foo-x sym) ==> accesses the x component (settable)
;;; (foo-y sym i) ==> accesses the i'th element of the y component (settable)
;;; (foo-z sym) ==> accesses the z component (settable)
;;;
;;;
;;; the C types that can be specified are:
;;;
;;; int     30 bits signed
;;; long    30 bits signed
;;; ulong   32 bits unsigned     ; supported via local UCLA hack
;;; short   16 bits signed
;;; ushort  16 bits unsigned
;;; char     8 bits signed
;;; uchar    8 bits unsigned


(define-syntax (define-cstruct structName . componentList)
  (labels (
	   ;; check the type of the argument
	   ((badtype? x)
	    (not (and (pair? x)
		      (let ((y (car x)))
			   (if (pair? y)
			       (let ((l (length y)))
				    (or (fx= l 2) (fx= l 3)))
			       '#f)))))
	   
	   ;; check to see if there is a third value and if
	   ;; the array length seems reasonable
	   ;; returns array length if ok, else 0
	   ((ArrayLength x)
	    (if (pair? (cddr x))
		(let ((y (caddr x)))
		      (if (and (fixnum? y)
			       (fx> y 0))
			  y
			  0))
		0))

	   ;; returns the total length of the structure (bytev)
	   ;; and the list of definitions of the accessors
	   ((makeDefList sName cList)
	    (iterate loop
		     ((componentType (caar cList))
		      (componentName (cadar cList))
		      (componentArrayLength (ArrayLength (car cList)))
		      (structSize 0)	; current offset into structure
		      (defList nil)	; definition list so far
		      (componentNames nil)	; list of component names so far
		      (rest (cdr cList)))	; input still to be looked at
		     (receive-values
		      (lambda (componentAccessor componentSize)
			      (let* ((isArray? (not (fixnum-zero? componentArrayLength)))
				     (totalSize (fx+ structSize 
						     (if isArray?
							 (fx* componentArrayLength componentSize)
							 componentSize)))
				     (thisComponentDef
				      `(define ,(concatenate-symbol
						 sName
						 '-
						 componentName)
					       (operation (lambda (x
								   ,@(if isArray?
									 '(i) nil))
								  (,componentAccessor
								   x
								   ,(if isArray?
									`(fx+ (fx* i ,componentSize) ,structSize)
									structSize)))
							  ((setter self)
							   (lambda (x ,@(if isArray?
									    '(i)
									    nil)
								      val)
								   (set (,componentAccessor
									 x
									 ,(if isArray?
									      `(fx+ (fx* i ,componentSize) ,structSize) structSize))
									val)))))))
				    ;; the order of these cond clauses is IMPORTANT
				    (cond ((mem? equiv? componentName componentNames)
					   (syntax-error
					    "define-cstruct: Multiple components ~a in structure ~a~%"
					    componentName
					    sName))
					  ((null? rest)
					   (return totalSize
						   (cons thisComponentDef defList)))
					  ((badtype? rest)
					   (syntax-error
					    "define-cstruct: Bad component specification in structure ~a~%"
					    sName))
					  (else (loop (caar rest)
						      (cadar rest)
						      (ArrayLength (car rest))
						      totalSize
						      (cons thisComponentDef defList)
						      (cons componentName componentNames)
						      (cdr rest))))))
		      ;; return componentAccessor and componentSize
		      ;; based on componentType
		      (lambda ()
			      (case componentType
				    ((int long)
				     (return 'bref-32 4))
				    ((ulong)
				     (return 'bref-32-u 4))
				    ((short)
				     (return 'bref-16-s 2))
				    ((ushort)
				     (return 'bref-16-u 2))
				    ((char)
				     (return 'bref-8-s 1))
				    ((uchar)
				     (return 'bref-8-u 1))
				    (else (syntax-error
					   "define-cstruct: Unknown type: ~a in structure ~a~%"
					   componentType sName)))))))
	   
	   )
	  
	  ;; beginning of define-cstruct
	  
	  (cond ((not (atom? structName))
		 (syntax-error
		  "define-cstruct: Struct name ~a must be atom~%"
		  structName))
		((badtype? componentList)
		 (syntax-error
		  "define-cstruct: Bad component specification in structure ~a~%"
		  structName))
		(else (receive-values
		       (lambda (totalLength defList)
			       `(block (define
					(,(concatenate-symbol 'make-
							      structName))
					(make-bytev ,totalLength))
				       ,@defList))
		       (lambda () (makeDefList structName componentList)))))))