;;; -*- 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)))
))