layout.scm

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

; $Header: /usr/cvsroot/target/h/wrn/wm/util/layout/ldbcomp/layout.scm,v 1.1.1.1 2001/11/05 17:47:21 tneale Exp $
; Describe the layout of a string of bits

;****************************************************************************
;
;  *** Restricted Rights Legend ***
;
;  The programs and information contained herein are licensed only
;  pursuant to a license agreement that contains use, reverse
;  engineering, disclosure, and other restrictions; accordingly, it
;  is "Unpublished--all rights reserved under the applicable
;  copyright laws".
;
;  Use duplication, or disclosure by the Government is subject to
;  restrictions as set forth in subparagraph (c)(1)(ii) of the Rights
;  in Technical Data and Computer Licensed Programs clause of DFARS
;  52.227 7013.
;
;  Copyright 2000-2001 Wind River Systems, Inc.
;  Copyright 1997 Epilogue Technology Corporation.
;  Copyright 1998 Integrated Systems, Inc.
;  All rights reserved.
;
;  *** Government Use ***
;
;  The Licensed Programs and their documentation were developed at
;  private expense and no part of them is in the public domain.
;
;  The Licensed Programs are "Restricted Computer Software" as that
;  term is defined in Clause 52.227-19 of the Federal Acquisition
;  Regulations (FAR) and are "Commercial Computer Software" as that
;  term is defined in Subpart 227.401 of the Department of Defense
;  Federal Acquisition Regulation Supplement (DFARS).
;
;  (i) If the licensed Programs are supplied to the Department of
;      Defense (DoD), the Licensed Programs are classified as
;      "Commercial Computer Software" and the Government is acquiring
;      only "restricted rights" in the Licensed Programs and their
;      documentation as that term is defined in Clause 52.227
;      7013(c)(1) of the DFARS, and
;
;  (ii) If the Licensed Programs are supplied to any unit or agency
;      of the United States Government other than DoD, the
;      Government's rights in the Licensed Programs and their
;      documentation will be as defined in Clause 52.227-19(c)(2) of
;      the FAR.
;****************************************************************************

(define-integrable (aligned? size align)
  (= 0 (modulo size align)))

;
; The Environment
;

(define layout-working-env (make-symbol-hash-table 100))
(define layout-used-env (make-symbol-hash-table 100))
(define layout-fixed-env (make-symbol-hash-table 100))

(define layout-working-rcs-info (list '()))
(define layout-used-rcs-info (list '()))
(define layout-fixed-rcs-info (list '()))

(define layout-working-C-includes (list '()))
(define layout-used-C-includes (list '()))

(define layout-current-env layout-working-env)
(define layout-current-rcs-info layout-working-rcs-info)
(define layout-current-C-includes layout-working-C-includes)

(define (layout-env-lookup name)
  (hash-table/lookup layout-current-env name
    (lambda (val) val)
    (lambda ()
      (hash-table/lookup layout-used-env name
	(lambda (val) val)
	(lambda ()
	  (hash-table/lookup layout-fixed-env name
	    (lambda (val) val)
	    (lambda ()
	      (err 'layout "Undefined: ~S" name))))))))

(define (layout-env-set! name value)
  (when (or (hash-table/get layout-working-env name #F)
	    (hash-table/get layout-used-env name #F)
	    (hash-table/get layout-fixed-env name #F))
    (format (error-output-port) "Warning: Redefining ~S~%" name))
  (hash-table/put! layout-current-env name value))

(defmac (define-layout name form)
  (%define-layout 'name 'form))

(define (%define-layout name form)
  (let ((val (layout-eval form)))
    (when (and (eq? 'type (layout-val:kind val))
	       (not (layout-type:name (layout-val:data val))))
      (set-layout-type:name (layout-val:data val) name))
    (layout-env-set! name val)
    name))

(define (use-layouts file)
  (unless (string? file)
    (err 'layout "Invalid use-layouts file: ~S" file))
  (let ((saved-env layout-current-env)
	(saved-rcs-info layout-current-rcs-info)
	(saved-C-includes layout-current-C-includes))
    (set! layout-current-env layout-used-env)
    (set! layout-current-rcs-info layout-used-rcs-info)
    (set! layout-current-C-includes layout-used-C-includes)
    (load-layouts file)
    (set! layout-current-env saved-env)
    (set! layout-current-rcs-info saved-rcs-info)
    (set! layout-current-C-includes saved-C-includes)))

(define (show-layout)	; for debugging
  (hash-table/for-each layout-working-env
    (lambda (name value)
      (format #T "~S -> ~S~%" name value)))
  (format #T " -- Used --~%")
  (hash-table/for-each layout-used-env
    (lambda (name value)
      (format #T "~S -> ~S~%" name value)))
  (format #T " -- Fixed --~%")
  (hash-table/for-each layout-fixed-env
    (lambda (name value)
      (format #T "~S -> ~S~%" name value))))

(define (reset-layout)
  (hash-table/clear! layout-working-env)
  (hash-table/clear! layout-used-env)
  (set-car! layout-working-rcs-info '())
  (set-car! layout-used-rcs-info  '())
  (set-car! layout-working-C-includes '())
  (set-car! layout-used-C-includes '()))

(define (fix-layout-env)
  (hash-table/for-each layout-used-env
    (lambda (name value)
      (hash-table/put! layout-fixed-env name value)))
  (hash-table/for-each layout-working-env
    (lambda (name value)
      (hash-table/put! layout-fixed-env name value)))
  (set-car! layout-fixed-rcs-info
	    (append (car layout-working-rcs-info)
		    (car layout-used-rcs-info)
		    (car layout-fixed-rcs-info)))
  (reset-layout))

(defmac (C-include test file)
  (%C-include 'test 'file ))

(define (%C-include test file)
  (set-car! layout-current-C-includes
	    (cons (cons test file)
		  (car layout-current-C-includes))))

(define (define-rcs-info info)
  (unless (and (string? info)
	       (char=? #\$ (string-ref info 0))
	       (let ((end (- (string-length info) 1)))
		 (and (char=? #\$ (string-ref info end))
		      (not (string-search-forwards #\$ info 1 end)))))
    (err 'layout "Invalid RCS keyword string: ~S" info))
  (set-car! layout-current-rcs-info
	    (cons (substring info 1 (- (string-length info) 1))
		  (car layout-current-rcs-info))))

(define (for-each-boilerplate-line proc)
  (for-each proc
	    '("This file was automatically generated by Epilogue Technology's"
	      "network datastructure layout tool."
	      ""
	      "DO NOT MODIFY THIS FILE BY HAND."
	      ""
	      "Source file information:"
	      ))
  (for-each (lambda (x)
	      (proc (string-append " " x)))
	    (reverse (car layout-working-rcs-info)))
  (unless (null? (car layout-used-rcs-info))
    (proc "   --used --")
    (for-each (lambda (x)
		(proc (string-append " " x)))
	      (reverse (car layout-used-rcs-info))))
  (unless (null? (car layout-fixed-rcs-info))
    (proc "   -- fixed --")
    (for-each (lambda (x)
		(proc (string-append " " x)))
	      (reverse (car layout-fixed-rcs-info)))))

;
; Evaluation
;

(define (layout-eval form)
  ((cond ((symbol? form) layout-env-lookup)
	 ((pair? form)
	  (layout-val:combination-handler (layout-eval (car form))))
	 (else make-constant))
   form))

(define (bad-combination form)
  (err 'layout "Bad combination: ~S" form))

(define (check-syntax pattern thing)
  (unless (match? (cdr pattern) (cdr thing))
    (err 'layout "Bad syntax for ~S: ~S" (car pattern) thing)))

(define (check-size form size)
  (unless (and (integer? size)
	       (>= size 0))
    (err 'layout "Bad size ~S: ~S" size form)))

(define-record layout-val
  kind			; constant, type, operator
  data
  combination-handler
  ((disclose self)
   (list "Val"
	 (layout-val:kind self)
	 (layout-val:data self)
	 ))
  )

(define (layout-eval-kind kind form)
  (let ((v (layout-eval form)))
    (unless (eq? kind (layout-val:kind v))
      (err 'layout "~S is not a ~S" form kind))
    (layout-val:data v)))

(define-integrable (layout-eval-constant form)
  (layout-eval-kind 'constant form))

(define (make-constant data)
  (make-layout-val 'constant data bad-combination))

(define-integrable (layout-eval-type form)
  (layout-eval-kind 'type form))

(define (make-type data)
  (make-layout-val 'type data bad-combination))

;
; Types
;

(define-record layout-type
  name			; symbol or #F
  kind			; enumeration, aggregate, array, or some scalar type
  size			; size in bits
  atrs			; alist of attributes, usually '().
  base			; base type for enumeration and array, else #F
  data			; per-kind data:
			;  aggregate: ((name offset type) ...)
			;  enumeration: ((name value) ...) sorted by value
			;  array: (offset (coefficient min max) ...)
			;  else: #F
  ((disclose self)
   (list "Type"
	 (layout-type:name self)
	 (layout-type:kind self)
	 (layout-type:size self)
	 (layout-type:atrs self)
	 (layout-type:base self)
	 ))
  )

;
; Operators in the layout language:
;

(define (def-operator pattern proc)
  (let ((name (car pattern)))
    (hash-table/put! layout-current-env
		     name
		     (make-layout-val 'operator name
				      (lambda (form)
					(check-syntax pattern form)
					(proc form))))
    name))

(defmac (define-layout-macro pattern proc)
  (%define-layout-macro 'pattern proc))

(define (%define-layout-macro pattern proc)
  (def-operator pattern
    (lambda (form)
      (layout-eval (proc form)))))

(def-operator '(sizeof any)
  (lambda (form)
    (make-constant (layout-type:size (layout-eval-type (cadr form))))))

;
; Simple operations on constants:
;

(define (def-constant-operator pattern proc)
  (def-operator pattern
    (lambda (form)
      (make-constant (apply proc (map layout-eval-constant (cdr form)))))))

(def-constant-operator '(+ * any) +)
(def-constant-operator '(- + any) -)
(def-constant-operator '(* * any) *)

(def-constant-operator '(octets * any)
  (lambda args
    (let loop ((l args)
	       (val 0.0))
      (if (null? l)
	  val
	  (loop (cdr l)
		(bitwise-ior (car l) (arithmetic-shift val 8)))))))

;
; Scalar type constructors:
;

(define (def-type-constructor pattern proc)
  (def-operator pattern
    (lambda (form)
      (make-type (apply proc form (map layout-eval-constant (cdr form)))))))

(def-type-constructor '(boolean any)
  (lambda (form size)
    (check-size form size)
    (unless (= size 1)
      (err 'layout "Size ~S must be 1: ~S" size form))
    (make-layout-type #F 'boolean size '() #F #F)))

(def-type-constructor '(opaque any)
  (lambda (form size)
    (check-size form size)
    (make-layout-type #F 'opaque size '() #F #F)))

(def-type-constructor '(signed any)
  (lambda (form size)
    (check-size form size)
    (make-layout-type #F 'signed size '() #F #F)))

(def-type-constructor '(unsigned any)
  (lambda (form size)
    (check-size form size)
    (make-layout-type #F 'unsigned size '() #F #F)))

(def-type-constructor '(signed-8bit-little any)
  (lambda (form size)
    (check-size form size)
    (make-layout-type #F 'signed-8bit-little size '() #F #F)))

(def-type-constructor '(unsigned-8bit-little any)
  (lambda (form size)
    (check-size form size)
    (make-layout-type #F 'unsigned-8bit-little size '() #F #F)))

;
; Helpers for things that have clauses (struct, union, array, enum):
;

;NOTES.  The general theory for things that have clauses is to -ignore-
; clauses that aren't defined.  This lets you mark up layouts with
; information that isn't used now but might be used in the future.  Of
; course you give up some error checking by doing this.  Perhaps that makes
; it a bad idea?

(define clause-patterns
  '((struct * (symbol * any))
    (union * (symbol * any))
    (field symbol any)
    (value symbol any)
    (fill ? any)
    (type any)
    (size any)
    (align any)
    (count any)
    (spacing any)
    (base (or 8 10 16))))

(define (check-clause-syntax clause)
  ;; Assuming `clause' is a cons whose car is a symbol.
  (let ((pattern (assq (car clause) clause-patterns)))
    (when pattern
      (check-syntax pattern clause))))

(define (clause-value form key kind default? default)
  (let loop ((clauses (cdr form)))
    (cond ((null? clauses)
	   (unless default?
	     (err 'layout "Missing ~S clause: ~S" key form))
	   default)
	  ((eq? key (caar clauses))
	   (when (assq key (cdr clauses))
	     (err 'layout "More than one ~S clause: ~S" key form))
	   (if (eq? kind 'literal)
	       (cadar clauses)
	       (layout-eval-kind kind (cadar clauses))))
	  (else
	   (loop (cdr clauses))))))

;
; Enumerations
;

(define enumeration-processors (make-symbol-hash-table 25))

(def-operator '(enum * (symbol * any))
  (lambda (form)
    (let* ((type (clause-value form 'type 'type #F #F))
	   (process (or (hash-table/get enumeration-processors
					(layout-type:kind type)
					#F)
			(err 'layout
			     "Don't know how to enumerate in this type: ~S"
			     form))))
      (let loop ((clauses (cdr form))
		 (out '()))
	(if (null? clauses)
	    (make-type (make-layout-type #F
					 'enumeration
					 (layout-type:size type)
					 (list (cons 'base
						     (clause-value form
								   'base
								   'literal
								   #T
								   10)))
					 type
					 ;; preserve original clause order for
					 ;; duplicate values:
					 (sort-list! (reverse! out)
					   (lambda (x y)
					     (< (cadr x) (cadr y))))))
	    (let ((clause (car clauses)))
	      (check-clause-syntax clause)
	      (cond ((eq? (car clause) 'value)
		     (when (assq (cadr clause) out)
		       (err 'layout "Name ~S used more than once: ~S"
			    (cadr clause) form))
		     (loop (cdr clauses)
			   (cons (list (cadr clause)
				       (process form
						type
						(cadr clause)
						(layout-eval-constant
						  (caddr clause))))
				 out)))
		    (else 
		     (loop (cdr clauses) out)))))))))

(define (process-unsigned-enumeration form type name val)
  (let ((size (layout-type:size type)))
    (unless (and (integer? val)
		 (<= 0 val)
		 (< val (expt 2 size)))
      (err 'layout "Bad value ~S for ~S in: ~S" val name form))
    val))

(define (process-signed-enumeration form type name val)
  (let ((size (layout-type:size type)))
    (unless (and (integer? val)
		 (<= (- (expt 2 (- size 1))) val)
		 (< val (expt 2 (- size 1))))
      (err 'layout "Bad value ~S for ~S in: ~S" val name form))
    val))

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

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