;;; -*- LISP -*-
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;; 
;;; Functions to implement alien-structures as described in ,alien-doc.
;;; 
;;; Written by Jim Large
;;; Modified by:
;;;		Rob MacLachlan
;;;		      Made multiple-alien-setq a macro so that it really is
;;;		      fast.  Changed the data vectors to be 16 bit.
;;;		      Rewrote most aa- and as- functions to be more tense.
;;;		      now only 3 kinds of integers allowed: byte, word 
;;;		      and long.  Changed the options a selection to be
;;;		      evaluated at compile time.  Ripped out any support
;;;		      for :occurs in aa- and as- forms.  Supposing we need
;;;		      this someday we can put it in right.  Ripped out any
;;;		      DEC specific brain-damage.
;;;             Dan Aronson 8 August, 1983
;;;                   Took out pointers for immediate release.  Will
;;;                   fix them SOON.
;;;             Dan Aronson 2 August, 1983
;;;                   Added constructor for MULTIPLE-ALIEN-SETQ-<FOO>
;;;                   which is a fast way of assigning to an alien structure
;;;                   (the vector is only computed once).  Added 
;;;                   :MULTIPLE-ASSIGN keyword to DEF-ALIEN-STRUCTURE
;;;                   to give a different value to the this function.
;;;		Dan Aronson 21 July, 1983
;;;		      Added OCCURS field to all accessing and setqing
;;;		      functions that tells whether or not a slot has
;;;		      an :OCCURS keyword (can generate less code
;;;		      without it).  Made no accessor for a constant slot.
;;;             Dan Aronson 19 July, 1983
;;;                   Reintroduced PORTS.  Made D, F, and H forms into
;;;                   vax-mumble forms.  Changed POINTER to be a
;;;                   perq-pascal pointer.
;;; **********************************************************************

;;; hacks for compiling in maclisp.
(eval-when (compile-maclisp)
  (load '|ncode:ahacks.lsp|)
  (putprop 'integerp (get 'fixp 'subr) 'subr)
  (putprop 'truncate (get 'fixnum-identity 'subr) 'subr))


;;; this file must be loaded into the compiler.
(eval-when (compile-maclisp) (load '|ncode:alien.slisp|))

;;; def-alien-structure passes hairy options around as the values of dynamic
;;;  variables.
(eval-when (compile load eval)

(proclaim '
 (special *alien-name*	    ; The name of the structure being defined (symbol)
	  *alien-options*   ; The list of keyword/value options (list)
	  *alien-conc-name* ; Prefix for slot accessor names (symbol)
	  *alien-constructor* ; The name of the constructor (symbol)
	  *alien-predicate* ; The name of the type predicate (symbol)
	  ;; The name of the multiple assign function (symbol)
	  *alien-multiple-assign* 
	  *alien-slots*	    ; A list of alien-slot structures
	  *alien-length*    ; The number of bytes in the U-vector (integer)
	  ))

(proclaim '(special static-space dynamic-space))

)


;;; Alien-Structure

(defstruct (alien-structure (:conc-name alien-structure-))
  (name :read-only)           ; the type of this particular alien structure.
  (length)		      ; the actual length of the data 
                              ; (not always the length of the data vector.)
  (data)		      ; the data vector
  )

;;; Ports
;;;
;;; One of the data types known to aliens is PORT.  The corresponding lisp
;;;  type is a PORT structure.  Since a port has no meaning inside the lisp
;;;  system, a port is just a pair of words.

(defstruct (port (:constructor make-port (word0 word1)))
  word0
  word1)




;;; Parse-alien-slot-options

;;; The alien-slot structure is used internaly to represent a single slot
;;;  in an alien structure.

(defstruct (alien-slot (:type list) (:conc-name alien-slot-))
  (name () :read-only)		      ; the name of the slot
  (accessor ())	      		      ; the name of the access function
  (setq ())		              ; the name of the setq function
  (alien-field-type () :read-only)    ; a defined alien field type.
  (start () :read-only)		      ; the byte pointer to start of field
  (end () :read-only)		      ; ''   ''    ''    ''  end  ''  ''
  (invisible)			      ; true if slot should not print
  (read-only)			      ; true if no setf generated.
  (write-only)			      ; true if no accessor generated.
  (constant)			      ; true if no constructor keyword.
  (default-value)		      ; default value used by constructor.
  (offset 0 :read-only)		      ; bytes from start of one occurrance to
				      ;  start of next
  (max-occurrences 0 :read-only)       ; max length of slot vector
)



;;; parse-1-alien-slot takes a slot description as provided to the def-alien-
;;;  structure macro, and returns a single alien-slot object.  a slot 
;;;  description is of the form
;;;  (name field-type start end &rest keyword-args)
;;; 
;;; If the global special, *ALIEN-LENGTH*, is less than the end value for
;;;  the slot, then it is set to the end value.

(defun parse-1-alien-slot (slot-description)
  (let ((slot-start (eval (caddr slot-description)))
	(slot-end   (eval (cadddr slot-description)))
	(name (car slot-description)))
    (do ((slot (make-alien-slot
		':name (if (member name '(allocation alien-data-length))
			   (error "Reserved alien slot name:  ~s." name)
			   name)
		':accessor (concat-pnames *alien-conc-name* (car slot-description))
		':setq (concat-pnames
			'setq-
			(concat-pnames *alien-conc-name* (car slot-description)))
		':alien-field-type (cadr slot-description)
		':start slot-start
		':end slot-end
		':invisible ()
		':read-only ()
		':write-only ()
		':constant ()
		':default-value ()
		':offset (- slot-end slot-start)
		':max-occurrences 0))
         (keylist (nthcdr 4 slot-description) (cddr keylist)))
        ((null keylist)
	 ;; If its a POINTER slot it gets special treatment
	 (if (or (and (listp (alien-slot-alien-field-type slot))
		      (equal (car (alien-slot-alien-field-type slot)) 'pointer))
		 (equal (alien-slot-alien-field-type slot) 'pointer))
	     (setf (alien-slot-write-only slot) t))
	 ;; Figure out the data length
	 (setq *alien-length* (max (alien-slot-end slot) 
			   *alien-length*
		           (+ (alien-slot-start slot)
			      (* (alien-slot-offset slot)
			         (alien-slot-max-occurrences slot)))))
          slot)

      (case (car keylist)
        (:invisible 
	    (if (cadr keylist) (setf (alien-slot-invisible slot) t)))
        (:direction
	    (case (cadr keylist)
		(read (setf (alien-slot-read-only slot) t))
		(write (setf (alien-slot-write-only slot) t))
		(read-write)
		(T (error "Unknown alien slot direction:  ~s."
			  (cadr keylist)))))
	(:constant (setf (alien-slot-read-only slot)     t
		         (alien-slot-constant slot)      t
		         (alien-slot-default-value slot) (cadr keylist)))
        (:default (setf (alien-slot-default-value slot) (cadr keylist)))
	(:occurs (setf (alien-slot-max-occurrences slot) (cadr keylist)))
	(:offset (setf (alien-slot-offset slot) (cadr keylist)))
        (T (error "Unknown ~s slot option:  ~s."
		  'def-alien-structure (car keylist))))
      )))




;;; Parse-alien-slot-options takes the list of slot-description arguments
;;;  provided to def-alien-structure, and returns a list of alien-slot
;;;  structures.
;;; 
;;; Afterward, if the global special, *ALIEN-LENGTH*, is not a whole number,
;;;  it is incremented so that the vector will contain the partial end byte.

(defun parse-alien-slot-options (slot-descriptions)
  (do ((desc-list slot-descriptions (cdr desc-list))
       (AS-List () (cons (parse-1-alien-slot (car desc-list)) AS-List)))
      ((null desc-list)
       (if (/= *alien-length* (truncate *alien-length*))
	   (setq *alien-length* (1+ *alien-length*)))
       AS-List)))


;;; Parse-Alien-Options

;;; Parse-alien-options parses the list of options to def-alien-structure,
;;;  and sets the option variables.  Name+options may be either a symbol
;;;  which is the name, or a list of name followed by options.  Like
;;;  defstruct, each option is a list of a keyword & a value.
;;; 
;;; All of the hairy caars & cadars are pretty gross.  Find a better way
;;;  once the compiler is moved to spice-lisp.

(defun parse-alien-options (name+options)
  (cond
   ;; if the "list" is a symbol, then it is the name, and there are no options.
   ((symbolp name+options) (setq *alien-name* name+options))
   
   ;; if the list is a list, then the car is the name, and the cdr is
   ;;  the option list.
   ((not (atom name+options))
    (setq *alien-name* (car name+options))
    (setq *alien-options* (cdr name+options))
    (do ((olist *alien-options* (cdr olist)))
	((null olist))
      (case (caar olist)
	(:conc-name (setq *alien-conc-name* (cadar olist)))
	(:constructor (setq *alien-constructor* (cadar olist)))
	(:predicate (setq *alien-predicate* (cadar olist)))
	(:multiple-assign (setq *alien-multiple-assign* (cadar olist)))
	(T (error "Unknown ~s option:  ~s."
		  'def-alien-structure (car olist)))
	))
    )
   (T (error "Illegal option list to DEF-ALIEN-STRUCTURE:  ~s."
	     name+options))
   ))


;;; Def-Alien-Structure
;;; 
;;; The big macro that does it all.

(defmacro def-alien-structure (name+options &rest slot-descriptions)
  "Defines alien-structure types.  See {DN003} for details."

  (let* ((*alien-name* ())  ; bind the option variables
	 (*alien-options* ())
	 (*alien-conc-name* ())
	 (*alien-constructor* ())
	 (*alien-predicate* ())
	 (*alien-multiple-assign* ())
	 (*alien-slots* ())
	 (*alien-length* 0)		     ; set by parse-alien-slot-options
	 )

    (parse-alien-options name+options)
    (if (not *alien-conc-name*)
	(setq *alien-conc-name* (concat-pnames *alien-name* '-)))
    (if (not *alien-constructor*)
	(setq *alien-constructor* (concat-pnames 'make- *alien-name*)))
    (if (not *alien-multiple-assign*)
	(setq *alien-multiple-assign* (concat-pnames 'multiple-alien-setq-
					     *alien-name*)))
    (if (not *alien-predicate*) 
	(setq *alien-predicate* (concat-pnames *alien-name* '-p)))


    (setq *alien-slots* (parse-alien-slot-options slot-descriptions))

    `(eval-when (compile load eval)       ; return a huge eval-when which
       ,@(alien-declarations)		  ; declares accessor function types,
       ,@(alien-accessors)		  ; defines the slot accessors,
       ,@(alien-defsetfs)		  ; declares the slot defsetfs,
       ,(alien-constructor)		  ; defines the constructor,

       ,(alien-multiple-setq)             ; defines the multiple-setq form.

       (defun ,*alien-predicate* (alien)  ; defines the predicate.
	 (and (alien-structure-p alien)
	      (equal (alien-structure-name alien) ',*alien-name*)))
       ',*alien-name*
     )
  ))


;;; Def-Alien-Field-Type

;;; Def-alien-field-type is a macro which allows a program to define new alien
;;;  field types in terms of old ones.  The accessor operates on the new type
;;;  by extracting the field with the accessor for the PRIMITIVE-TYPE, and then
;;;  applying ACCESS-FN to the result.  The setf form applies SETF-FN to
;;;  the new datum, and stores the result in the field with the setf form for
;;;  PRIMITIVE-TYPE.  
;;; 
;;; LISP-TYPE is the type of the arg to SETF-FN and the result of ACCESS-FN.
;;;  it is used for declarations.
;;; 
;;; Def-alien-field-type returns a form which puts the args in a
;;;  user-alien-field structure on the user-alien-field property of NAME at
;;;  both compile time and at load time.  The information stored there is used
;;;  only by the functions Alien-access-form, and Alien-setf-form.


(defstruct (user-alien-field (:type list) (:conc-name user-alien-field-))
  (lisp-type () :read-only)
  (primitive-type () :read-only)
  (access-fn () :read-only)
  (setf-fn () :read-only))


(defmacro def-alien-field-type
  (name lisp-type primitive-type access-fn setf-fn)
  "Defines a new alien field type."

  `(eval-when (compile load eval)
     (setf (get ',name 'user-alien-field)
	   (make-user-alien-field  ':lisp-type ,lisp-type
				   ':primitive-type ,primitive-type
				   ':access-fn ',access-fn
				   ':setf-fn ',setf-fn))))

;;; Alien-Field

;;; Alien-field is a function which allows arbitrary hacking of an alien
;;;  structure.  Any part of the structure can be accessed or setfed
;;;  as if it were of any data type.  While this function is useful for
;;;  debugging code involving alien structures it should not usually be
;;;  built into programs.  
;;;
;;; Alien-field works by EVALing the values of the internal functions which 
;;;  generate access and setf function bodies for DEF-ALIEN-STRUCTURE.  This
;;;  is inherently much slower than normal compiled alien structure access.
;;;
(defun alien-field (alien type start end)
    (let ((vector `(alien-structure-data ',alien)))
         (declare (type (mod 65536) vector))
       (eval (alien-access-form type vector start end 
		 (integerp start) (integerp end)))))

;;; Setq-alien-field is the SETF form for ALIEN-FIELD.

(defun setq-alien-field (alien type start end value)
    (let ((vector `(alien-structure-data ',alien)))
         (declare (type (mod 65536) vector))
       (eval (alien-setf-form type vector start end
		 (integerp start) (integerp end) value)))
    value)

(defsetf alien-field setq-alien-field)


;;; Pack-Alien-Structure

;;; Pack-alien-structure uses ALIEN-FIELD to create an initialized alien
;;;  structure instance with arbitrary contents.  It both slower and less
;;;  safe than normal alien structure constructor functions.
;;;
(defmacro pack-alien-structure (name length &rest values)
    (with-keywords values ((:allocation allocation :dynamic))
	(case allocation
	    (:static (setf allocation static-space))
	    (:dynamic (setf allocation dynamic-space))
	    (t (error "Invalid allocation space:  ~s." allocation)))
	`(let ((alien (make-alien-structure 
			  :name ',name
			  :length ,length
			  :data (let ((allocation-space ,allocation))
				     (declare (special allocation-space))
				   (%sp-alloc-u-vector ,length 8)))))
	     ,@(mapcan #'(lambda (stuff-spec)
			     (if (listp stuff-spec)
				 `((setf (alien-field alien 
					     ',(second stuff-spec)
					     (eval ,(third stuff-spec))
					     (eval ,(fourth stuff-spec)))
				       '(eval ,(first stuff-spec))))))
		   values)
	     alien)))

;;;    AA & AS functions
;;; An AA function returns a single form which will return a field of an 8-bit
;;;  u-vector as a lisp object.  The name of the vector is a constant in the
;;;  resulting form.  The args to an AA function are; 
;;; 
;;;    VECTOR -- the name of the u-vector within the result form
;;;    START  -- an alien-bit-pointer to the lowest numbered bit in the 
;;;		  desired field of the target u-vector.
;;;    END    -- an alien-bit-pointer to the bit after the higest numbered
;;;		  bit in the field.  END must be greater than START.
;;;    SALIGN -- T iff the starting position is integral.
;;;    EALIGN -- T iff the ending position is integral.
;;; 
;;; An AS function returns a single form which will store a lisp object into
;;;  a field of an 8-bit u-vector.  The resulting form returns no meaningful
;;;  value.  The args to an AS function are VECTOR, START, END, SALIGN and
;;;  EALIGN which have the same meaning as in an AA function; and
;;; 
;;;    VALUE  -- The name of the value to be stored into the vector.
;;; 
;;; 
;;; The alien-bit-pointer to bit n in a u-vector is the rational number n/8.  
;;;  The integer part of a bit pointer is the byte number in the u-vector, 
;;;  and the fractional part times 8 is the bit number within that byte.
;;; 
;;; The SALIGN and EALIGN arguments allow these functions to produce optimum 
;;;  code for the case where START and END are integers.  This corresponds to 
;;;  the case where the data fields in the u-vector are whole numbers of 
;;;  vector elements.

;;;       Unsigned Integers

;;; AA-unsigned-integer returns a form which extracts a field from an 8-bit
;;;  u-vector, and returns a positive integer.  The low order bit of the 
;;;  integer is taken from the START bit (the low end of the field).
;;; 
;;; The field may be one byte, byte aligned, or one or two words, word
;;; aligned.

(defun aa-unsigned-integer (vector start end salign ealign occurs)
  (cond
   ((or (not salign) (not ealign))
    (error "Integer field (~S ~S) is not byte aligned." start end))
   (occurs (error ":Occurs is not supported for integers."))
   ((= (- end start) 1) `(%sp-typed-v-access 3 ,vector ,start))
   ((oddp start) (error "Field (~S ~S) is not word aligned." start end))
   ((= (- end start) 2) `(aref ,vector ,(ash start -1)))
   ((= (- end start) 4) 
    `(logior (ash (aref ,vector ,(1+ (ash start -1))) 16)
	     (aref ,vector ,(ash start -1))))
   (t (error "(~S ~S) is not a valid field size for an unsigned integer."
	     start end)))))

;;; AS-unsigned-integer returns a form which stores an integer into a field of
;;;  an 8-bit u-vector.  The interpretation of the field is the same as for
;;;  aa-unsigned-integer.
;;; 
;;; The form returned works equaly well for storing signed integers in which
;;;  case, the field is interpreted as by aa-signed-integer.
;;; 
;;; If the form is used to store an integer which is too large to fit the 
;;;  field, then the excess upper bits will be truncated.

(defun as-unsigned-integer (vector start end salign ealign value occurs)
  (cond
   ((or (not salign) (not ealign))
    (error "Integer field (~S ~S) is not byte aligned." start end))
   (occurs (error ":Occurs is not supported for integers."))
   ((= (- end start) 1) `(%sp-typed-v-store 3 ,vector ,start ,value))
   ((oddp start) (error "Field (~S ~S) is not word aligned." start end))
   ((= (- end start) 2) `(setf (aref ,vector ,(ash start -1)) ,value))
   ((= (- end start) 4) 
    `(let ((value ,value))
       (setf (aref ,vector ,(1+ (ash start -1))) (ash value -16)
	     (aref ,vector ,(ash start -1)) (logand value 65535))))
   (t (error "(~S ~S) is not a valid field size for an unsigned integer."
	     start end))))


;;;       Signed-Integers

;;; AA-signed-integer returns a form which extracts a field from an 8-bit
;;;  u-vector, and returns a signed integer.  The field is taken to be a
;;;  signed two's complement number whose low order bit is START.
;;; 
;;; The field may be one byte, byte aligned, or one or two words, word
;;; aligned.

(defun aa-signed-integer (vector start end salign ealign occurs)
  (cond
   ((or (not salign) (not ealign))
    (error "Integer field (~S ~S) is not byte aligned." start end))
   (occurs (error ":Occurs is not supported for integers."))
   ((= (- end start) 1) 
    `(let ((res (%sp-typed-v-access 3 ,vector ,start)))
       (if (zerop (logand res ,(ash 1 7)))
	   res
	   (logior res ,(ash -1 8)))))
   ((oddp start) (error "Field (~S ~S) is not word aligned." start end))
   ((= (- end start) 2) 
    `(let ((res (aref ,vector ,(ash start -1))))
       (if (zerop (logand res ,(ash 1 15)))
	   res
	   (logior res ,(ash -1 16)))))
   ((= (- end start) 4) 
    `(logior (aref ,vector ,(ash start -1))
	     (ash (let ((hi (aref ,vector ,(1+ (ash start -1)))))
		    (if (zerop (logand hi ,(ash 1 15)))
			hi
			(logior hi ,(ash -1 16))))
		  16)))
   (t (error "(~S ~S) is not a valid field size for a signed integer."
	     start end))))

;;; AS-signed-integer is identical to as-unsigned-integer.  Name it anyway.

(defun as-signed-integer (vector start end salign ealign value occurs)
  (as-unsigned-integer vector start end salign ealign value occurs))

;;;       Strings

;;; AA-string returns a form which extracts a field from an 8-bit u-vector,
;;;  and returns a string.  The length of the string returned is always
;;;  END - START, and the lowest byte of the field is the zeroth char
;;;  of the string.
;;; 
;;; END and START are constrained to be integers.

(defun aa-string (vector start end salign ealign occurs)
  (if (not (and salign ealign))
      (error "Alien strings restricted to start and end on byte boundaries."
	     start end))
  (if occurs (error ":Occurs is not supported for string fields."))
  `(let ((res (make-string ,(- end start))))
     (%sp-byte-blt ,vector ,start res 0 ,(- end start))
     res))

;;; AS-string returns a form which stores a string into a field in an 8-bit
;;;  u-vector.  The meaning of the field is the same as for aa-string.
;;; 
;;; If the form is given a string which is longer than END - START, then the
;;;  excess bytes at the end of the string will be ignored.  It is an error to
;;;  give the form a string which is too short.

(defun as-string (vector start end salign ealign value)
  (if (not (and salign ealign))
      (error "Alien strings restricted to start and end on byte boundaries."
	     start end))
  `(%sp-byte-blt ,value 0 ,vector ,start ,end))

;;;       bit-vectors

;;; AA-bit-vector interprets a field as a bit vector, (a vector of mod 2).
;;;  the bit vector may start and end at any bit position.  The length of 
;;;  the bit vector returned is always (end - start) * 8 bits.

(defun aa-bit-vector (vector start end salign ealign occurs)
  (if occurs
      `(let ((start-bit (* ,start 8))
	     (end-bit (* ,end 8)))
	 (do ((vp start-bit (1+ vp))
	      (bp 0 (1+ bp))
	      (bit-vector (%sp-alloc-u-vector (- end-bit start-bit) 1)))
	     ((= vp end-bit) bit-vector)
	   (setf (aref bit-vector bp) (%sp-typed-v-access 1 ,vector vp))))
      (let ((start-bit (* start 8))
	    (end-bit (* end 8)))
	`(do ((vp ,start-bit (1+ vp))
	      (bp 0 (1+ bp))
	      (bit-vector (%sp-alloc-u-vector ,(- end-bit start-bit) 1)))
	     ((= vp ,end-bit) bit-vector)
	   (setf (aref bit-vector bp) (%sp-typed-v-access 1 ,vector vp))))))


;;; AS-bit-vector returns a form which copies a bit vector into an 8-bit 
;;;  u-vector.  If the bit vector is longer than the field, then the extra
;;;  bits at the end of the vector will be ignored.

(defun as-bit-vector (vector start end salign ealign value)
  `(let* ((start-bit (* ,start 8))
	  (end-bit (* ,end 8))
	  (value ,value)
	  (i-bits (if (>= (length value) (- end-bit start-bit))
		      value
		      (replace (make-simple-vector (- end-bit start-bit) 
						   :element-type '(mod 2)
						   :initial-element 0)
			       value))))
     (do ((vp start-bit (1+ vp))
	  (bp 0 (1+ bp)))
	 ((= vp end-bit) ())
       (%sp-typed-v-store 1 ,vector vp (aref i-bits bp)))))

;;;       Ports

;;; AA-port interprets a field as a port object.  The field is constrained to
;;;  start and end on word boundaries, and it must be exactly 32 bits long.
;;;
;;; A port object is a 2 element structure of type PORT.  Each element is one
;;;  word of the 32 bit port passed in from accent.

(defun aa-port (vector start end occurs)
  (if occurs (error "Illegal :OCCURS keyword in port slot"))
  (if (not (= (- end start) 4))
      (error "An alien port must be 32 bits long."))
  (if (or (not (integerp start)) (oddp start))
      (error "Alien ports are constrained to word boundaries."))
  `(make-port (aref ,vector ,(ash start -1))
	      (aref ,vector ,(+ (ash start -1) 1))))


;;; AS-port returns a form which stashes a port into a field in a u-vector.
;;;  the same constraints apply as in AA-port.

(defun AS-port (vector start end value occurs)
  (if occurs (error "Illegal :OCCURS keyword in port slot"))
  (if (not (= (- end start) 4))
      (error "An alien port must be 32 bits long."))
  (if (or (not (integerp start)) (oddp start))
      (error "Alien ports are constrained to word boundaries."))
  `(let ((value ,value))
     (setf (aref ,vector ,(ash start -1)) (port-word0 value))
     (setf (aref ,vector ,(+ (ash start -1) 1)) (port-word1 value))))

;;;       selections

;;; AA-selection returns a form which is completely evil.

(defun aa-selection (vector start end salign ealign occurs selection)
  `(nth ,(aa-unsigned-integer vector start end salign ealign occurs)
	',(mapcar #'eval selection)))
     

(defun as-selection (vector start end salign ealign value occurs selection)
  (do ((N 0 (1+ N))
       (alist ())
       (choices (mapcar #'eval selection) (cdr choices)))
      ((null choices)
       (as-unsigned-integer vector start end salign ealign
			    `(cdr (assq ,value ',alist)) occurs))
    (push (cons (car choices) n) alist)))

;;;       perq-strings

;;; In Perq Pascal, a string is a packed array of N bytes where 0 < N <= 256.
;;;  byte 0 is a fill pointer, FP, and bytes 1 through FP are the characters.
;;;
;;; AA-perq-string is like aa-string except that the length of the string
;;;  returned is determined by byte 0 of the data field.  Byte 0 of the lisp
;;;  string is taken from byte 1 of the perq string and so on.
;;;
;;; If the incoming string indicates that it is longer than the field, then
;;;  an error is signaled.

(defun aa-perq-string (vector start end salign ealign)
  (if (not (and salign ealign))	
      (error "Alien strings restricted to start and end on byte boundaries."))

  `(let ((length (%sp-typed-v-access 3 ,vector ,start)))
     (let ((new-string (make-string length)))
       (%sp-byte-blt ,vector ,(1+ start) new-string 0 length)
       new-string)))


;;; AS-perq-string returns a form which stores a string into a u-vector in 
;;;  perq style format.  The string may be any length up to the length of the
;;;  field -1.  If the string is longer, then an error will be signaled.

(defun as-perq-string (vector start end salign ealign value)
  (if (not (and salign ealign))
      (error "Alien strings restricted to start and end on byte boundaries."))

  `(let* ((value ,value)
	  (length (%sp-get-vector-length value)))
     (if (> length ,(- end start 1)) ;end-start includes byte for fill ptr.
	 (error "Alien Perq string too large for field."))
     (%sp-typed-v-store 3 ,vector ,start length) ;put in the fill pointer.
     (%sp-byte-blt value 0 ,vector ,(1+ start) (+ length ,(+ start 1)))))

;;;       User Defined Field Types

;;; AA-user-defined returns a form which accesses a field in an 16-bit u-vector
;;;  and returns a value.  FIELD-TYPE is the name of an alien-field-type which
;;;  has been defined by def-alien-field-type.  It will have a user-alien-field
;;;  property with a user-alien-field structure on it.  The form returned by
;;;  aa-user-defined applies the ACCESS-FN from the structure to the result of
;;;  the alien-access-form for the PRIMITIVE-TYPE from the structure.
;;; 
;;; If the FIELD-TYPE is a list, then (car FIELD-TYPE) is the name of the field
;;;  type, and (cdr FIELD-TYPE) is a list of additional args to the ACCESS-FN.

(defun aa-user-defined (field-type vector start end salign ealign occurs)
  (let ((ft-name (if (symbolp field-type) field-type (car field-type)))
	(ft-rest (if (symbolp field-type) () (cdr field-type))))
    (let ((desc (get ft-name 'user-alien-field)))

      (if (not desc) (error "Unknown alien field type:  ~s." 
			    ft-name))

      `(funcall ,(user-alien-field-access-fn desc)
		,(alien-access-form (user-alien-field-primitive-type desc)
				    vector
				    start
				    end
				    salign
				    ealign
				    occurs)
		,@ft-rest)
      )))



;;; AS-user-defined is the AS function which corresponds to aa-user-defined.
;;;  The result of applying the SETF-FN from the user-alien-field property
;;;  of FIELD-TYPE is used as the value in an alien-setf-form.

(defun as-user-defined (field-type vector start end salign ealign
				   value occurs)
  (let ((ft-name (if (symbolp field-type) field-type (car field-type)))
	(ft-rest (if (symbolp field-type) () (cdr field-type))))
    (let ((desc (get ft-name 'user-alien-field)))

      (if (not desc) (error "Unknown alien field type:  ~s." 
			 ft-name))

      `(let ((primitive-value (funcall ,(user-alien-field-setf-fn desc)
				       ,value
				       ,@ft-rest)))
	 ,(alien-setf-form (user-alien-field-primitive-type desc)
			   vector
			   start
			   end
			   salign
			   ealign
			   'primitive-value
			   occurs))
      )))

;;;    Alien-Access-form  & Alien-Setf-Form

;;; Alien-access-form returns the body of an alien accessor function.
;;;  FIELD-TYPE is the type of alien field being accessed. (a symbol)
;;;  VECTOR     is the name of the u-vector inside the accessor function.
;;;  START      is the alien-bit-pointer to the start of the field.
;;;  END        is the pointer to the end of the field.
;;;  SALIGN	is T iff the start position is integral
;;;  EALIGN     is T iff the end position is integral
;;;  OCCURS	is T iff the slot occurs more than once.

;;; 
;;; If FIELD-TYPE is not one of the primitive alien field types, and it has
;;;  a user-alien-field property, then the body applies the ACCESS-FN from the
;;;  property to the alien-access-form for the PRIMITIVE-TYPE from the 
;;;  property.  The user-alien-field structure is declared alongside the
;;;  macro def-alien-field-type.

(defun alien-access-form (field-type vector start end salign ealign
				     &optional occurs)
  (cond
   ((symbolp field-type)
    (case field-type
      (string (aa-string vector start end salign ealign occurs))
      (perq-string (aa-perq-string vector start end salign ealign))
      (signed-integer (aa-signed-integer vector start end salign
					 ealign occurs))
      (unsigned-integer (aa-unsigned-integer vector start end salign
					     ealign occurs))
      (bit-vector (aa-bit-vector vector start end salign ealign occurs))
      (port (aa-port vector start end occurs))
      (T (aa-user-defined field-type vector start end salign ealign occurs))
      ))
   ((equal (car field-type) 'selection)
    (aa-selection vector start end salign ealign occurs (cdr field-type)))

   (T (aa-user-defined field-type vector start end salign ealign occurs))
   ))


;;; Alien-setf-form returns the body of the setf function for an alien field.
;;;  The args correspond to those of alien-access-form, but there is an 
;;;  additional VALUE argument which is the name of the value to be stored 
;;;  within the setf function.

(defun alien-setf-form (field-type vector start end salign ealign value
				   &optional occurs)
  (cond
   ((symbolp field-type)
    (case field-type
      (string (as-string vector start end salign ealign value))
      (perq-string (as-perq-string vector start end salign ealign value))
      (signed-integer (as-signed-integer vector start end salign
					 ealign value occurs))
      (unsigned-integer (as-unsigned-integer vector start end salign ealign 
			                     value occurs))
      (bit-vector (as-bit-vector vector start end salign ealign value))
      (port (as-port vector start end value occurs))

      ;; not a primitive, maybe user defined.
      (T (as-user-defined field-type vector start end salign ealign
			  value occurs))
      ))
   ((equal (car field-type) 'selection)
    (as-selection vector start end salign ealign value occurs (cdr field-type)))

   (T (as-user-defined field-type vector start end salign ealign value occurs))
   ))

;;; Alien-Accessors

;;; One-alien-accessor returns a defun form which defines an accessor function
;;;  for a slot in an alien structure.
;;; 
;;; SLOT is an alien-slot structure.
;;; 
;;; There are two free variables bound by def-alien-structure.
;;;   *ALIEN-NAME* is the name of the alien structure, a symbol.
;;;   *ALIEN-CONC-NAME*, concatenated onto the slot name is the name of the accessor.
;;; 
;;; concat-pnames is defined by defstruct.  if first arg is () return second,
;;;  else return new symbol whose pname is concationation of pnames.

(defun one-alien-accessor (slot 
			   &aux (indexed (> (alien-slot-max-occurrences slot) 
					     0))
			        (start  (alien-slot-start slot))
				(end    (alien-slot-end slot))
				(offset (alien-slot-offset slot)))
  `(defun
     ,(alien-slot-accessor slot)
     ,(if indexed		; make correct arg list
	  '(alien index)
	  '(alien))
     ;; body of the accessor is determined by type of slot we are accessing.
     ,(if indexed
          `(let ((vector (alien-structure-data alien)))
	      (declare (type (simple-array (mod 65536)) vector))
	      ,(alien-access-form (alien-slot-alien-field-type slot)
		                  'vector
			          `(+ ,start (* ,offset index))
			          `(+ ,end (* ,offset index))
				  (and (integerp start) (integerp offset))
				  (and (integerp end) (integerp
						       offset))
				  indexed))
          `(let ((vector (alien-structure-data alien)))
	      (declare (type (simple-array (mod 65536)) vector))
              ,(alien-access-form (alien-slot-alien-field-type slot)
                                  'vector
                                  start
                                  end
				  (integerp start)
				  (integerp end))))
   ))





;;; Alien-accessors returns a list of function definitions for the slot
;;;  accessor functions.  *ALIEN-SLOTS* is a free variable which is bound by 
;;;  def-alien-structure to a list of alien-slot descriptions.

(defun alien-accessors ()
  (do ((slot-list *alien-slots* (cdr slot-list))
       (definitions () (nconc (if (not
				   (or (alien-slot-write-only (car slot-list))
				       (alien-slot-constant (car slot-list))))
				  `(,(one-alien-accessor (car slot-list))))
			      definitions)))
      ((null slot-list) definitions)))

;;; Alien-Defsetfs

;;; One-Alien-Setq returns a defun for a function of two arguments.  The
;;;  first is an alien structure, and the second is a new value to be
;;;  stored into a slot in the alien.  The name of the function is the name
;;;  of the corresponding accessor with the word Setq- tacked on.
;;; 
;;; SLOT is an alien-slot structure.

(defun one-alien-setq (slot
		       &aux (indexed (> (alien-slot-max-occurrences slot)
					 0))
		       	    (start  (alien-slot-start slot))
			    (end    (alien-slot-end slot))
			    (offset (alien-slot-offset slot)))
  `(defun 
     ,(alien-slot-setq slot) 
     ,(if indexed
	  '(alien index value)
	  '(alien value))
     ,(if indexed
	 `(let ((vector (alien-structure-data alien)))
	     (declare (type (simple-array (mod 65536)) vector))
	     ,(alien-setf-form (alien-slot-alien-field-type slot)
		  	       'vector
		       	       `(+ ,start (* ,offset index))
			       `(+ ,end (* ,offset index))
			       (and (integerp start) (integerp offset))
			       (and (integerp end) (integerp offset))
			       'value
			       indexed))
         `(let ((vector (alien-structure-data alien)))
	     (declare (type (simple-array (mod 65536)) vector))
             ,(alien-setf-form (alien-slot-alien-field-type slot)
			       'vector
			       start
			       end
			       (integerp start)
			       (integerp end)
			       'value)))
     value		; setf forms return the newvalue
   ))


;;; Alien-defsetfs returns a list of forms which define the setfs which alter
;;;  the non read-only slots in an alien structure.  There are no args, but
;;;  there are two free variables bound by def-alien-structure.
;;; 
;;; *ALIEN-NAME* -- the name of the alien structure being defined.
;;; *ALIEN-CONC-NAME* -- symbol to concat with slot names to form 
;;;  accessor names.
;;; *ALIEN-SLOTS* -- a list of alien-slot structures describing slots in 
;;;  this alien.

(defun alien-defsetfs ()
  (do ((slot-list *alien-slots* (cdr slot-list))
       (slot ())
       (setqs ())
       (defsetfs ()))
      ((null slot-list) (append defsetfs setqs))
    (setq slot (car slot-list))
    (if (not (alien-slot-read-only slot))
	(push (one-alien-setq slot) setqs))
    (if (not (alien-slot-read-only slot))
	(push `(defsetf ,(alien-slot-accessor slot) ,(alien-slot-setq slot))
	      defsetfs))
    ))

;;; Alien-Constructor

;;; Alien-constructor returns a form which defines the constructor function for
;;;  the alien type we are defining.  Free variables,
;;; 
;;; *ALIEN-LENGTH* -- the length of the u-vector that the constructor allocates
;;; *ALIEN-NAME* -- the name of the alien-structure.

(defun alien-constructor ()
  `(defun ,*alien-constructor* (&rest args &aux (alloc-space dynamic-space)
			   		(alloc-length ,*alien-length*))
     (unless (evenp (length args))
       (error "Keywords and values must come in pairs."))
     (let ((tail (member :allocation args :test #'equal)))
	 (if (not (null tail))
	     (case (cadr tail)
		 (:static (setf alloc-space static-space))
		 (:dynamic)
		 (otherwise (error "Invalid allocation space:  ~s."
				   (cadr tail))))))
     (let ((tail (member :alien-data-length args :test #'equal)))
	 (if (not (null tail))
	     (setf alloc-length (cadr tail))))
     (let* ((alien (make-alien-structure
		    :name ',*alien-name*
		    :length alloc-length
		    :data (let ((allocation-space  alloc-space))
			       (declare (special allocation-space))
			    (%sp-alloc-u-vector
			     (ash (1+ alloc-length) -1)
			     4)))))
       ,@(alien-constructor-defaults)
       (do ((args args (cddr args))
	    (slots-done ()))
	   ((null args) alien)
	 (unless
	  (or (eq (car args) :allocation) 
	      (eq (car args) :alien-data-length)
	      (member (car args) slots-done))
	  (let ((keyword (car args))
		(value (cadr args)))
	    (case keyword
	      ,@(alien-constructor-case-clauses)
	      (otherwise (error "Unknown ~s slot keyword:  ~s."
				'def-alien-structure keyword)))
	    (push keyword slots-done))
	  ))
       )))


;;; Alien-constructor-defaults returns a list of forms which set the default
;;;  values for the slots in the alien structure we are defining.
;;; Note that the setting cannot use the alien structure setf form for read
;;;  only or constant slots.
;;; 
;;; *ALIEN-SLOTS* is a free variable containing the list of slot descriptions.

(defun alien-constructor-defaults ()
  (do ((slotlis *alien-slots* (cdr slotlis))
       (defaults ()))
      ((null slotlis) defaults)
      (declare (special *alien-slots*))
    (if (alien-slot-default-value (car slotlis))
	(do ((i 0 (1+ i)))
	    ((= i (max 1 (alien-slot-max-occurrences (car slotlis)))))
	    (let ((slot (car slotlis)))
	       (if (alien-slot-read-only slot)
		   (push `(let ((vector (alien-structure-data alien))
				(new-value ,(alien-slot-default-value slot)))
			      (declare (type (simple-array (mod 65536)) vector))
			      ,(alien-setf-form 
				   (alien-slot-alien-field-type slot)
				   'vector
				   (+ (alien-slot-start slot)
				       (* i (alien-slot-offset slot)))
				   (+ (alien-slot-end slot)
				       (* i (alien-slot-offset slot)))
				   (and (integerp (alien-slot-start slot))
				       (integerp (alien-slot-offset slot)))
				   (and (integerp (alien-slot-end slot))
				       (integerp (alien-slot-offset slot)))
				   'new-value))
		         defaults)
		   (if (< 0 (alien-slot-max-occurrences slot))
		       (push `(,(alien-slot-setq slot)
				  alien
				  ,i
				  ,(alien-slot-default-value slot))
			     defaults)
		       (push `(,(alien-slot-setq slot)
				  alien
				  ,(alien-slot-default-value slot))
			     defaults))))))
  ))






;;; alien-constructor-case-clauses returns a list of case clauses which look
;;;  like (:fazbaz (set-alien-form))

(defun alien-constructor-case-clauses ()
    (do ((slotlis *alien-slots* (cdr slotlis))
	 (clauses ()))
	((null slotlis) clauses)
	(let ((slot (car slotlis)))
	  (declare (special *alien-slots*))
	  (push `(,(make-keyword (alien-slot-name slot))
		  ,(cond ((alien-slot-constant slot)
			  `(error "attempt to set a constant slot: ~1g~s, ~
				  in alien structure ~g~s."
				  ',*alien-name* ',(alien-slot-name slot)))
			 ((alien-slot-read-only slot)
			  (if (< 0 (alien-slot-max-occurrences slot))
			      `(dotimes (i (min ,(alien-slot-max-occurrences slot)
						(length value)))
				 (setf (alien-field alien
						    ',(alien-slot-alien-field-type slot)
						    (+ ,(alien-slot-start slot)
						       (* ,(alien-slot-offset slot) i))
						    (+ ,(alien-slot-end slot)
						       (* ,(alien-slot-offset slot) i)))
				       (elt value i)))
			      `(setf (alien-field alien
						  ',(alien-slot-alien-field-type slot)
						  ,(alien-slot-start slot)
						  ,(alien-slot-end slot))
				     value)))
			 (t (if (< 0 (alien-slot-max-occurrences slot))
				`(dotimes 
				  (i (min ,(alien-slot-max-occurrences slot)
					  (length value)))
				  (,(alien-slot-setq slot) 
				   alien i (elt value i)))
				`(,(alien-slot-setq slot) alien value)))))
		clauses))))
;;; Alien-multiple-setq

;;; Alien-multiple-setq returns a from which defines the multiple-setq 
;;; function for the alien.  Free  variables:

;;;   *alien-name* - the name of the alien-structure.


(defun alien-multiple-setq ()
  `(eval-when (compile eval)
   (defmacro ,*alien-multiple-assign* (alien &rest args)
     (do ((args args (cdr args))
	  (forms ()))
	 ((null args)
	  `(let ((vector (alien-structure-data ,alien)))
	     (declare (type (simple-array (mod 65536)) vector))
	     ,@(nreverse forms)))
       (let* ((this-arg (car args))
	      (keyword (car this-arg))
	      (value (cadr this-arg)))
	 (push (alien-setf-form-for-slot ',*alien-slots* keyword value)
	       forms))))))

(defun alien-setf-form-for-slot (slots name value)
  (do ((slotlis slots (cdr slotlis)))
      ((eq (make-keyword (alien-slot-name (car slotlis))) name)
       (let ((slot (car slotlis)))
	 (when (or (alien-slot-read-only slot)
		   (alien-slot-constant slot)
		   (not (zerop (alien-slot-max-occurrences slot))))
	   (error "Losing Alien Multiple-Setq."))
	 (alien-setf-form (alien-slot-alien-field-type slot)
			  'vector
			  (alien-slot-start slot)
			  (alien-slot-end slot)
			  (integerp (alien-slot-start slot))
			  (integerp (alien-slot-end slot))
			  value)))
    (cond ((null slotlis) 
	   (error "Unknown Alien slot: ~S" name)))))

;;; alien declarations

;;; alien-declarations returns a list of forms which declare the types of
;;;  the accessor & setq functions.  the functions are also declared to
;;;  be inline.
;;; 
;;; the free variable *alien-slots* is bound by def-alien-structure.

(defun alien-declarations ()
    (do ((slots *alien-slots* (cdr slots))
	    (declarations () (nconc (one-alien-declaration (car slots))
				 declarations)))
	((null slots) declarations)))
	
	
	
;;; one-alien-declaration returns a single (declare ...) form which declares
;;;  the types of the accessor & setq functions for slot, & also declares
;;;  them to be inline.

(defun one-alien-declaration (slot)
    `(,@(if (not (alien-slot-write-only slot))
	    `((declare (function ,(alien-slot-accessor slot)
			   (simple-vector)
			   ,(=>lisp-type (alien-slot-alien-field-type slot)))
		  (inline ,(alien-slot-accessor slot)))))
	 ,@(if (not (alien-slot-read-only slot))
	       `((declare (function ,(alien-slot-setq slot)
			      (simple-vector 
				  ,(=>lisp-type (alien-slot-alien-field-type slot)))
			      t)
		     (inline ,(alien-slot-setq slot))))))
)
	
	
	
;;; =>lisp-type takes the name of an alien-slot type and returns the name
;;;  of the corresponding lisp type
	
(defun =>lisp-type (field-type)
    (if (not (atom field-type)) (setq field-type (car field-type)))
    (case field-type
	((string varying-string perq-string) 'string)
	((signed-integer unsigned-integer) 'integer)
	(bit-vector 'bit-vector)
	(port 'simple-vector)
	(selection 't)
	(t (let ((desc (get field-type 'user-alien-field)))
	       (if (not desc) (error "unknown alien field type:  ~s." 
				  field-type))
	       (user-alien-field-lisp-type desc)))
    ))