layout.scm

wm PNE 3.3 source code, running at more than vxworks6.x version.

(hash-table/put! enumeration-processors 'opaque
		 process-unsigned-enumeration)

(hash-table/put! enumeration-processors 'signed-8bit-little
		 process-signed-enumeration)

(hash-table/put! enumeration-processors 'signed
		 process-signed-enumeration)

;
; Aggregates
;

(define (process-aggregate form)
  (let ((group (get-aggregate-group 8 form)))
    (let loop ((specs (cdr group))
	       (out '()))
      (if (null? specs)
	  (make-type (make-layout-type #F 'aggregate (car group) '() #F out))
	  (let ((spec (car specs)))
	    (when (assq (cadr spec) out)
	      (err 'layout "Field name ~S used more than once: ~S"
		   (cadr (car specs)) form))
	    (loop (cdr specs)
		  (cons (list (cadr spec) (car spec) (caddr spec))
			out)))))))

(def-operator '(struct * (symbol * any)) process-aggregate)
(def-operator '(union * (symbol * any)) process-aggregate)

(define (get-aggregate-group align form)
  ;; returns a "group", which is of the form: (size (offset name type) ...)
  (for-each check-clause-syntax (cdr form))
  (let ((align (clause-value form 'align 'constant #T align)))
    (define (process-clause clause)
      (let* ((group (case (car clause)
		      ((struct union)
		       (get-aggregate-group align clause))
		      ((fill)
		       (list (if (null? (cdr clause))
				 #F
				 (layout-eval-constant (cadr clause)))))
		      ((field)
		       (let ((type (layout-eval-type (caddr clause))))
			 (list (layout-type:size type)
			       (list 0 (cadr clause) type))))
		      (else
		       (list 0))))
	     (size (car group)))
	(unless (or (not size)
		    (aligned? size align))
	  (err 'layout "size ~S is not a multiple of ~S: ~S"
	       size align clause))
	group))
    (let* ((union? (eq? 'union (car form)))
	   (groups (map process-clause (cdr form)))
	   (minsize (reduce-map (if union? max +)
				0
				(lambda (group) (or (car group) 0))
				groups))
	   (size (clause-value form 'size 'constant #T minsize)))
      (unless (aligned? size align)
	(err 'layout "requested size ~S is not a multiple of ~S: ~S"
	     size align form))
      (unless (>= size minsize)
	(err 'layout "size ~S is smaller than the minimum of ~S: ~S"
	     size minsize form))
      (unless union?
	(let ((p (assq #F groups)))
	  (cond (p (set-car! p (- size minsize)))
		((not (= size minsize))
		 (err 'layout "size ~S is incorrect, computed size is ~S: ~S"
		      size minsize form)))))
      (unless (not (assq #F groups))
	(err 'layout "too many unspecified fill clauses: ~S" form))
      (let loop ((groups groups)
		 (offset 0)
		 (specs '()))
	(if (null? groups)
	    (cons size specs)
	    (loop (cdr groups)
		  (if union?
		      0
		      (+ offset (caar groups)))
		  (map* specs
			(lambda (spec)
			  (cons (+ offset (car spec))
				(cdr spec)))
			(cdar groups))))))))

;
; Arrays
;

(def-operator '(array * (symbol * any))
  (lambda (form)
    (for-each check-clause-syntax (cdr form))
    (let* ((align (clause-value form 'align 'constant #T 8))
	   (type (clause-value form 'type 'type #F #F))
	   (typesize (layout-type:size type))
	   (spacing (clause-value form 'spacing 'constant #T typesize))
	   (count (clause-value form 'count 'constant #F #F))
	   (default-size (* spacing count))
	   (minsize (- default-size (- spacing typesize)))
	   (size (clause-value form 'size 'constant #T default-size)))
      (unless (>= spacing typesize)
	(err 'layout "spacing ~S is smaller than the minimum of ~S: ~S"
	     spacing typesize form))
      (unless (aligned? spacing align)
	(err 'layout "spacing of ~S is not a multiple of ~S: ~S"
	     spacing align form))
      (check-size form size)
      (unless (>= size minsize)
	(err 'layout "size ~S is smaller than the minimum of ~S: ~S"
	     size minsize form))
      (unless (aligned? size align)
	(err 'layout "requested size ~S is not a multiple of ~S: ~S"
	     size align form))
      (make-type (make-layout-type #F 'array size '() type
				   (list 0 (list spacing 0 (- count 1))))))))

;
; Output driver loops
;

; The new way:
(define (generate-layout-defs gen-def)
  (hash-table/for-each layout-working-env
    (lambda (name val)
      (when (eq? 'type (layout-val:kind val))
	(gen-def name (generate-layout-defs-type (layout-val:data val)))))))

(define (generate-layout-defs-subtype type)
  (or (layout-type:name type)
      (generate-layout-defs-type type)))

(define (generate-layout-defs-type type)
  ;; <type> :=
  ;;   <name>
  ;;   (<kind> <size> <atrs>)
  ;;   (aggregate <size> <atrs> (<name> <offset> <type>) ...)
  ;;   (enumeration <size> <atrs> <type> (<name> <value>))
  ;;   (array <size> <atrs> <type> <offset> (<coefficient> <min> <max>) ...)
  ;; Note that the array coefficients are in -reverse- order!
  (let ((kind (layout-type:kind type))
	(base (layout-type:base type))
	(data (layout-type:data type)))
    (cons* kind
	   (layout-type:size type)
	   (layout-type:atrs type)
	   (case kind
	     ((aggregate)
	      (map (lambda (triple)
		     (list (car triple)
			   (cadr triple)
			   (generate-layout-defs-subtype (caddr triple))))
		   data))
	     ((enumeration array)
	      (cons (generate-layout-defs-subtype base)
		    data))
	     (else '())))))

; The old way:
(define (generate-layout gen-header gen-size gen-enum-defs gen-ptr gen-refset)
  (hash-table/for-each layout-working-env
    (lambda (name val)
      (when (eq? 'type (layout-val:kind val))
	(let ((type (layout-val:data val)))
	  (when (eq? name (layout-type:name type))
	    (gen-header name)
	    (let ((total-size (layout-type:size type)))
	      (define (recur path offset dope type)
		(let ((recur? (or (null? path)
				  (not (layout-type:name type))))
		      (kind (layout-type:kind type))
		      (size (layout-type:size type))
		      (atrs (layout-type:atrs type))
		      (base (layout-type:base type))
		      (data (layout-type:data type)))
		  (case kind
		    ((aggregate)
		     (when recur?
		       (gen-size name path size atrs)
		       (for-each (lambda (triple)
				   (let ((path (cons (car triple) path))
					 (offset (+ offset (cadr triple)))
					 (type (caddr triple)))
				     (gen-ptr name path offset dope
					      (layout-type:size type)
					      (layout-type:atrs type))
				     (recur path offset dope type)))
				 data)))
		    ((array)
		     (when recur?

		       ;; Each element in `path' is either a field name
		       ;; symbol or the string "ELT" for an array
		       ;; reference.  Each element in `dope' is a
		       ;; (coefficient min max) triple.  Both lists are in
		       ;; reverse order.  If you don't want to handle
		       ;; arrays, don't.

		       (gen-size name path size atrs)
		       (let ((path (cons "ELT" path))
			     (offset (+ offset (car data)))
			     (dope (append (cdr data) dope)))
			 (gen-ptr name path offset dope
				  (layout-type:size base)
				  (layout-type:atrs base))
			 (recur path offset dope base))))
		    ((enumeration)
		     (when (null? path)
		       (gen-size name path size atrs))
		     (let ((kind (layout-type:kind base)))
		       (gen-refset name path offset dope kind
				   size atrs total-size)
		       (when recur?
			 (gen-enum-defs name path kind size atrs data))))
		    (else
		     (when (null? path)
		       (gen-size name path size atrs))
		     (gen-refset name path offset dope kind
				 size atrs total-size)))))
	      (recur '() 0 '() type))))))))

;
; Output Scheme->C header file:
;

; The new way:
(define (generate-s2c-layout-definitions port schfile)
  (for-each-boilerplate-line
    (lambda (line)
      (format port "; ~A~%" line)))
  (newline port)
  (generate-layout-defs (lambda (name type)
			  (write `(define-layout-macro ,name ,type) port)
			  (newline port))))

; The old way:
(define (generate-old-s2c-layout-definitions port)

  (define (out expr)
    (write expr port)
    (newline port))

  (define (cant sym ctl . args)
    (format port "; Can't define ~S because:~%; " sym)
    (apply format port ctl args)
    (newline port))

  (define (mksym name path tail)
    (let loop ((path path)
	       (tail tail))
      (cond ((null? path)
	     (apply symbol-append name tail))
	    (else
	     (loop (cdr path)
		   (cons '/ (cons (car path) tail)))))))

  (define (mkixs l)
    (let loop ((in l)
	       (out '())
	       (n 0))
      (if (null? in)
	  out
	  (loop (cdr in)
		(cons (symbol-append 'x n) out)
		(+ 1 n)))))

  (define (mksum p const coeffs vars)
    (let loop ((coeffs coeffs)
	       (vars vars)
	       (terms '()))
      (cond ((not (null? coeffs))
	     (loop (cdr coeffs)
		   (cdr vars)
		   (cond ((= 0 (car coeffs))
			  terms)
			 ((= 1 (car coeffs))
			  (cons (car vars) terms))
			 ((= -1 (car coeffs))
			  (cons `(- ,(car vars)) terms))
			 (else
			  (cons `(* ,(car coeffs) ,(car vars)) terms)))))
	    ((not (= 0 const))
	     `(+ ,p ,const ,@terms))
	    ((not (null? terms)) `(+ ,p ,@terms))
	    (else p))))

  (define (gen-header name)
    (format port "~%; Definitions for ~S~%~%" name))

  (define (gen-size name path size atrs)
    (let ((sym (mksym name path '(/size))))
      (if (aligned? size 8)
	  (out `(define-constant ,sym ,(/ size 8)))
	  (cant sym "Size ~S is not a multiple of 8." size))))

  (define (gen-enum-defs name path kind size atrs pairs)
    ;; In theory the `kind' and `size' can be used here to adjust the
    ;; value of the constant.  For example, if `kind' is `opaque'
    ;; and `size' is 16, we might arrange here to byteswap the value
    ;; (assuming that the `-ref' and `-set!' routines join in the
    ;; conspiracy).  In the Scheme->C version, we treat `opaque' just like
    ;; `unsigned'.
    (out `(define ,(mksym name path '(/values)) ',pairs))
    (for-each (lambda (pair)
		(out `(define-constant ,(mksym name path (list '= (car pair)))
			,(cadr pair))))
	      pairs))

  (define (gen-ptr name path offset dope size atrs)
    (let ((sym (mksym name path '(/ptr)))
	  (ixs (mkixs dope)))
      (cond ((not (aligned? size 8))
	     (cant sym "Size ~S is not a multiple of 8." size))
	    ((not (aligned? offset 8))
	     (cant sym "Offset ~S is not a multiple of 8." offset))
	    ((there-exists? dope
	       (lambda (elt)
		 (not (aligned? (car elt) 8))))
	     (cant sym
		   "Array elements are not aligned on octet boundaries: ~S"
		   dope))
	    (else
	     ;; No bounds checking on arrays...
	     (out `(define-in-line (,sym p ,@(reverse ixs))
		     ,(mksum 'p
			     (/ offset 8)
			     (map (lambda (elt) (/ (car elt) 8)) dope)
			     ixs)))))))

  (define (gen-refset name path offset dope kind size atrs total-size)
    (let ((refsym (mksym name path '(/ref)))
	  (setsym (mksym name path '(/set!)))
	  (ixs (mkixs dope))
	  (bytes? (and (aligned? size 8)
		       (aligned? offset 8)
		       (for-all? dope (lambda (elt) (aligned? (car elt) 8)))))
	  (signed? (memq kind '(signed signed-8bit-little)))
	  (littlendian? (memq kind
			      '(signed-8bit-little unsigned-8bit-little))))
      (cond ((not (memq kind '(opaque
			       boolean signed unsigned
			       signed-8bit-little unsigned-8bit-little)))
	     (cant (list refsym setsym) "Unsupported scalar type: ~S" kind))
	    ((and littlendian? (not bytes?))
	     (cant (list refsym setsym)
		   "Unaligned little endian: offset ~S size ~S dope ~S"
		   offset size dope))
	    (bytes?
	     (let ((size (/ size 8))
		   (pexpr (mksum 'p
				 (/ offset 8)
				 (map (lambda (elt) (/ (car elt) 8)) dope)
				 ixs)))
	       (out `(define-in-line (,refsym b p ,@(reverse ixs))
		       (,(if signed?
			     (if littlendian?
				 `signed-littlendian-bytefield-ref
				 `signed-bigendian-bytefield-ref)
			     (if littlendian?
				 `unsigned-littlendian-bytefield-ref
				 `unsigned-bigendian-bytefield-ref))
			b ,pexpr ,size)))
	       (out `(define-in-line (,setsym b p ,@(reverse ixs) val)
		       (,(if littlendian?
			     `littlendian-bytefield-set!
			     `bigendian-bytefield-set!)
			b ,pexpr ,size val)))))
	    (else
	     (let ((pexpr (mksum '(* 8 p) offset (map car dope) ixs)))
	       (out `(define-in-line (,refsym b p ,@(reverse ixs))
		       (,(if signed?
			     (if littlendian?
				 `signed-littlendian-bitfield-ref
				 `signed-bigendian-bitfield-ref)
			     (if littlendian?
				 `unsigned-littlendian-bitfield-ref
				 `unsigned-bigendian-bitfield-ref))
			b ,pexpr ,size)))
	       (out `(define-in-line (,setsym b p ,@(reverse ixs) val)
		       (,(if littlendian?
			     `littlendian-bitfield-set!
			     `bigendian-bitfield-set!)
			b ,pexpr ,size val))))))))

  
  (for-each-boilerplate-line
    (lambda (line)
      (format port "; ~A~%" line)))
  (newline port)
  (generate-layout gen-header gen-size gen-enum-defs gen-ptr gen-refset)

  )

;
; Check the uniqueness of generated names:
;

(define name-length-limit 31)
(define name-length-table (make-string-hash-table 100))

(define (check-name-length name)
  (hash-table/modify!
      name-length-table
      (if (> (string-length name) name-length-limit)
	  (substring name 0 name-length-limit)
	  name)
      '()
    (lambda (l) (cons name l)))
  name)

(define (first-difference s1 s2)
  (let ((l1 (string-length s1))
	(l2 (string-length s2)))
    (let ((stop (min l1 l2)))
      (let loop ((i 0))
	(if (< i stop)
	    (if (char=? (string-ref s1 i)
			(string-ref s2 i))
		(loop (+ 1 i))
		i)
	    (if (= l1 l2)
		#F
		i))))))

(define (write-n-chars n c port)
  (let loop ((n n))
    (when (> n 0)
      (write-char c port)
      (loop (- n 1)))))

(define (report-name-length-problems hfile)
  (hash-table/for-each name-length-table
    (lambda (prefix names)
      (cond ((not (null? (cdr names)))
	     (format (error-output-port)
	       "Warning: In ~A, the first ~A characters are the same in:~%"
	       hfile name-length-limit)
	     (let loop ((names (sort-list! names string<?))
			(min-i #F)
			(max-i #F))
	       (display (car names) (error-output-port))
	       (newline (error-output-port))
	       (if (null? (cdr names))
		   (when min-i
		     (write-n-chars name-length-limit
				    #\-
				    (error-output-port))
		     (write-n-chars (- min-i name-length-limit)
				    #\=
				    (error-output-port))
		     (write-n-chars (+ 1 (- max-i min-i))
				    #\#
				    (error-output-port))
		     (format (error-output-port) " (must shorten by ~A)~%"
		       (+ 1 (- max-i name-length-limit))))
		   (let ((i (first-difference (car names) (cadr names))))
		     (loop (cdr names)
			   (if i (if min-i (min i min-i) i) min-i)
			   (if i (if max-i (max i max-i) i) max-i)))))))))
  (hash-table/clear! name-length-table))

;
; Output C header file:
;

(define (generate-C-layout-definitions port hfile include-check)

  ;; This whole thing was written under the assumption that we only support