layout.scm

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

  ;; the unsigned types.  If you're thinking about adding support for the
  ;; signed scalar types BE CAREFUL!

  (define (out ctl . args)
    (apply format port ctl args))

  (define (outdefmac nam ixs)
    (out "#define ~A(_P_" nam)
    (for-each (lambda (ix)
		(out ", ~A" ix))
	      (reverse ixs)))

  (define (mks ctl . args)
    (apply format #F ctl args))

  (define (cant name ctl . args)
    (format port "/* Can't define ~A because:~%   " name)
    (apply format port ctl args)
    (display "   */" port)
    (newline port))

  (define (include-check-name file)
    (list->string (map (lambda (c)
			 (cond ((char-alphabetic? c)
				(char-upcase c))
			       ((char-numeric? c)
				c)
			       (else #\_)))
		       (string->list (pathname-entry-name file)))))

  (define (namify x tail)
    (cond ((symbol? x)
	   ;; -!- Should error check...
	   (cons* "_" (symbol->string x) tail))
	  ((string? x) (cons* "_" x tail))
	  ((null? x) tail)
	  ((pair? x)
	   ;; Lists are reversed to make it easy to deal with a `path':
	   (namify (cdr x) (namify (car x) tail)))
	  (else (err 'layout "Illegal name: ~S" x))))

  (define (mknam . args)
    (check-name-length (apply string-append (cdr (fold namify args)))))

  (define (mkixs l)
    (let loop ((in l)
	       (out '())
	       (n 0))
      (if (null? in)
	  out
	  (loop (cdr in)
		(cons (mks "_X~S_" 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))
			  (mks "+(~A)~A" (car vars) terms))
			 ((= -1 (car coeffs))
			  (mks "-(~A)~A" (car vars) terms))
			 ((> 0 (car coeffs))
			  (mks "-(~A)*(~A)~A"
			       (mknum (- (car coeffs)))
			       (car vars)
			       terms))
			 (else
			  (mks "+(~A)*(~A)~A"
			       (mknum (car coeffs))
			       (car vars)
			       terms)))))
	    ((= 0 const)
	     (mks "(~A)~A" p terms))
	    ((> 0 const)
	     (mks "(~A)-(~A)~A" p (mknum (- const)) terms))
	    (else
	     (mks "(~A)+(~A)~A" p (mknum const) terms)))))

  (define (mknum n)
    (unless (integer? n)
      (err 'layout "Not an integer: ~S" n))
    (encode-integer-in-base n 10 "0123456789"))

  (define (mksize size)
    (cond ((<= size 8) "08")
	  ((<= size 16) "16")
	  ((<= size 32) "32")
	  (else (err 'layout "Size more than 32: ~S" size))))

  (define (mkcast size x)
    ;; The GLUE_CASTnn() family should cast the value to the same type that
    ;; the GLUE_Gxnn() family returns.
    (mks "GLUE_CAST~A(~A)" (mksize size) x))

  (define (mkopaque size n base)
    ;; The GLUE_OPAQUEnn() family should return the same type and values as
    ;; GLUE_GUnn() returns.
    (mks "GLUE_OPAQUE~A(~A)"
	 (mksize size)
	 (mkconst size n base)))

  (define (mkconst size n base)
    ;; Caller's responsibility to cope with signed/unsigned issues
    (mkcast size
	    (if (zero? n)
		"0L"
		(mks (case base
		       ((8) "0~AL")
		       ((10) "~AL")
		       ((16) "0x~AL")
		       (else (err 'layout "Bad base: ~S" base)))
		     (encode-integer-in-base n base "0123456789ABCDEF")))))

  ;; The next four deal with extracting a field from a loaded value

  (define (mkldb shift size osize get)
    (let ((mask (mkconst osize
			 (arithmetic-shift (- (arithmetic-shift 1 size) 1)
					   shift)
			 16)))
      (cond ((= osize size) get)
	    ((= 0 shift)
	     (mkcast size (mks "~A & ~A"
			       get mask)))
	    ((= osize (+ size shift))
	     (mkcast size (mks "~A >> ~A"
			       get (mknum shift))))
	    (else
	     (mkcast size (mks "(~A & ~A) >> ~A"
			       get mask (mknum shift)))))))

  (define (mkdpb shift size osize get val)
    (let ((mask (mkconst osize
			 (arithmetic-shift (- (arithmetic-shift 1 size) 1)
					   shift)
			 16))
	  (val (mkcast osize val)))
      (cond ((= osize size) val)
	    ((= 0 shift)
	     (mks "(~A & ~~~A) | (~A & ~A)"
		  get mask val mask))
	    (else
	     (mks "(~A & ~~~A) | ((~A << ~A) & ~A)"
		  get mask val (mknum shift) mask)))))

  (define (mkldbool shift osize get)
    (let ((mask (mkconst osize (arithmetic-shift 1 shift) 16)))
      (mks "(~A & ~A)" get mask)))

  (define (mkdpbool shift osize get val)
    (let ((mask (mkconst osize (arithmetic-shift 1 shift) 16)))
      (mks "((~A) ? ~A | ~A : ~A & ~~~A)" val get mask get mask)))

  ;; If you mess with the next three, you better understand all the issues.
  ;; These guys decide what bytes to load to obtain a given field.

  (define (byte-offset offset size tsize)
    ;; Compute the byte offset most likely to result in an aligned
    ;; reference to a quantity at the given offset and size.
    ;; (While staying within the object (if possible).)
    (let ((ldsize (+ size (modulo offset 8))))
      (cond ((<= ldsize 16) (quotient offset 8))	;;; 1 or 2 bytes
	    ((<= ldsize 24)				;;; 3 bytes
	     (let ((boffset (* 2 (quotient offset 16))))
	       ;; If the proposed 32-bit load would take us beyond the end of
	       ;; the object, and there is room to back up, then back up.
	       (if (and (> (+ 32 (* 8 boffset))
			   tsize)
			(>= offset 8))
		   (- (quotient offset 8) 1)
		   boffset)))
	    ((<= ldsize 32) (quotient offset 8))	;;; 4 bytes
	    (else #F))))				;;; too many

  (define (outer-size offset size)
    ;; Compute the size field to load
    (let ((ldsize (+ size (modulo offset 8))))
      (cond ((<= ldsize  8)  8)				;;; 1 byte
	    ((<= ldsize 16) 16)				;;; 2 bytes
	    ((<= ldsize 32) 32)				;;; 3 or 4 bytes
	    (else #F))))				;;; too many

  (define (bit-shift boffset osize offset size)
    ;; Compute the bit offset within the loaded field
    ;; Note that this is a little-endian quantity!
    (- (+ osize (* 8 boffset))
       (+ size offset)))

  ;; Finally, the routines that are actually called by the driver:

  (define (gen-header name)
    (out "~%/* Definitions for ~S */~%~%" name))

  (define (gen-size name path size atrs)
    (let ((nam (mknam "SIZEOF" name path)))
      (if (aligned? size 8)
	  (out "#define ~A (~A)~%" nam (mknum (/ size 8)))
	  (cant nam "Size ~S is not a multiple of 8." size))))

  (define (gen-enum-defs name path kind size atrs pairs)
    ;; `kind' and `size' should 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).
    (let ((base (cdr (assq 'base atrs))))
      (for-each (case kind
		  ((opaque)
		   (lambda (pair)
		     (out "#define ~A ~A~%"
			  (mknam name path "is" (car pair))
			  (mkopaque size (cadr pair) base))))
		  ((unsigned unsigned-8bit-little)
		   (lambda (pair)
		     (out "#define ~A ~A~%"
			  (mknam name path "is" (car pair))
			  (mkconst size (cadr pair) base))))
		  (else (cant (mknam name path "is" "*")
			      "Unsupported scalar type: ~S" kind)))
		pairs)))

  (define (gen-ptr name path offset dope size atrs)
    (let ((nam (mknam "PTR" name path))
	  (ixs (mkixs dope)))
      (cond ((not (aligned? size 8))
	     (cant nam "Size ~S is not a multiple of 8." size))
	    ((not (aligned? offset 8))
	     (cant nam "Offset ~S is not a multiple of 8." offset))
	    ((there-exists? dope
	       (lambda (elt)
		 (not (aligned? (car elt) 8))))
	     (cant nam
		   "Array elements are not aligned on octet boundaries: ~S"
		   dope))
	    (else
	     ;; No bounds checking on arrays...
	     (outdefmac nam ixs)
	     (out ")\\~% (~A)~%"
		  (mksum "GLUE_CAST_PTR(_P_)"
			 (/ offset 8)
			 (map (lambda (elt) (/ (car elt) 8)) dope)
			 ixs))))))

  (define (gen-refset name path offset dope kind size atrs total-size)
    (let ((getnam (mknam "GET" name path))
	  (setnam (mknam "SET" name path))
	  (ixs (mkixs dope))
	  (boffset (byte-offset offset size total-size))
	  (osize (outer-size offset size)))
      (cond ((not (memq kind '(opaque boolean unsigned unsigned-8bit-little)))
	     (cant (list getnam setnam) "Unsupported scalar type: ~S" kind))
	    ((> size 32)
	     (cant (list getnam setnam)
		   "Size ~S is greater than 32." size))
	    ((not (and boffset osize))
	     (cant (list getnam setnam)
		   "Requires load of more than 32 bits: offset ~S size ~S"
		   offset size))
	    ((there-exists? dope
	       (lambda (elt)
		 (not (aligned? (car elt) 8))))
	     (cant (list getnam setnam)
		   "Array elements are not aligned on octet boundaries: ~S"
		   dope))
	    ;; For the cases that involve byte swapping in some form, don't
	    ;; get involved in shifting and masking later:
	    ((and (memq kind '(opaque unsigned-8bit-little))
		  (not (and (aligned? offset 8)
			    (or (= size 8)
				(= size 16)
				(= size 32)))))
	     (cant (list getnam setnam)
		   "Unaligned ~S: offset ~S size ~S dope ~S"
		   kind offset size dope))
	    (else
	     (let* ((shift (bit-shift boffset osize offset size))
		    (kind-char (case kind
				 ((opaque) "U")
				 ((unsigned-8bit-little) "L")
				 (else "B")))	; unsigned or boolean
		    (size-chars (mksize osize))
		    (hint24 (cond ((not (= osize 32)) "")
				  ((<= 8 shift) "MS24")
				  ((>= 24 (+ shift size)) "LS24")
				  (else "")))
		    (pexpr (mksum "GLUE_CAST_PTR(_P_)"
				  boffset
				  (map (lambda (elt) (/ (car elt) 8)) dope)
				  ixs))
		    (getexpr (mks "GLUE_G~A~A~A(~A)"
				  kind-char size-chars hint24 pexpr)))
	       (outdefmac getnam ixs)
	       (out ")\\~% ~A~%"
		    (if (eq? kind 'boolean)
			(mkldbool shift osize getexpr)
			(mkldb shift size osize getexpr)))
	       (outdefmac setnam ixs)
	       (out ", _V_)\\~% GLUE_S~A~A~A(~A, ~A)~%"
		    kind-char size-chars hint24 pexpr
		    (if (eq? kind 'boolean)
			(mkdpbool shift osize getexpr "_V_")
			(mkdpb shift size osize getexpr "_V_")))
	       )))))

  (let ((h-name (include-check-name hfile))
	(first? #T))
    (for-each-boilerplate-line
      (lambda (line)
	(cond (first?
	       (out "/* ~A~%" line)
	       (set! first? #F))
	      (else (out " * ~A~%" line)))))
    (unless first?
      (out " */~%"))
    (when include-check
      (out "~%#ifndef ~A~A~%#define ~A~A~%"
	   include-check h-name
	   include-check h-name))
    (unless (null? (car layout-working-C-includes))
      (newline port))
    (for-each (lambda (pair)
		(if (car pair)
		    (out "#ifndef ~S~%#include ~S~%#endif~%"
			 (car pair)
			 (cdr pair))
		    (out "#include ~S~%" (cdr pair))))
	      (reverse (car layout-working-C-includes)))
    (generate-layout gen-header gen-size gen-enum-defs gen-ptr gen-refset)
    (when include-check
      (out "~%#endif /* ~A~A */~%"
	   include-check h-name)))

  (report-name-length-problems hfile)
  )

;
; Command line interface
;

(define user-layouts-package #F)

(define (load-layouts name)
  (unless user-layouts-package
    (set! user-layouts-package (get-package 'user-layouts)))
  (with-interaction-environment user-layouts-package
    (lambda ()
      (load name))))

(define (do-layout-command-line args)
  (let ((alist (parse-options (cdr args)
			      '(("-define" arg defs)
				("-makesch" arg schfiles)
				("-makeoldsch" arg oldschfiles)
				("-makeh" arg hfiles)
				("-include-check" arg include-check)
				("-unique-names" arg unique-names)))))
    (let ((unique-names (assq 'unique-names alist)))
      (unless (null? (cdr unique-names))
	(set! name-length-limit
	      (string->number (car (last-pair (cdr unique-names)))))))
    (for-each load-layouts (cdr (assq 'defs alist)))
    (fix-layout-env)
    (for-each load-layouts (cdr (assq 'args alist)))
    (for-each (lambda (oldschfile)
		(call-with-output-file oldschfile
		  generate-old-s2c-layout-definitions))
	      (cdr (assq 'oldschfiles alist)))
    (for-each (lambda (schfile)
		(call-with-output-file schfile
		  (lambda (port)
		    (generate-s2c-layout-definitions port schfile))))
	      (cdr (assq 'schfiles alist)))
    (let ((include-check (let ((ic (assq 'include-check alist)))
			   (if (null? (cdr ic))
			       #F
			       (car (last-pair (cdr ic)))))))
      (for-each (lambda (hfile)
		  (call-with-output-file hfile
		    (lambda (port)
		      (generate-C-layout-definitions port
						     hfile
						     include-check))))
		(cdr (assq 'hfiles alist))))))

;  $Log: layout.scm,v $
;  Revision 1.1.1.1  2001/11/05 17:47:21  tneale
;  Tornado shuffle
;
;  Revision 1.3  2001/01/19 22:22:35  paul
;  Update copyright.
;
;  Revision 1.2  1998/02/25 04:54:24  sra
;  Update copyrights.
;
;  Revision 1.1  1997/09/26 20:14:39  alan
;  Initial Revision
;
;  At this point, we migrated from Scheme->C to scsh
;  
;  Revision 1.17  1997/06/03 22:49:35  alan
;  Add support for `define-rcs-info' and boilerplate printing.
;
;  Revision 1.16  1997/06/03 02:35:18  alan
;  Add `define-layout-macro' so people can define macros in the layout
;  language.
;
;  Revision 1.15  1997/05/10 20:44:36  alan
;  Add `-include-check'.
;
;  Revision 1.14  1995/06/08 18:42:43  alan
;  Sort enumeration values.
;
;  Revision 1.13  1995/06/05  19:51:21  alan
;  Totally new output format for -makesch files.  -makeoldsch-makeoldsch gets
;  the previous format.  Less error checking of littlendian scalars -- a
;  better theory is needed.
;
;  Revision 1.12  1995/05/25  23:51:32  alan
;  Types have attribues.  Enums have a `base' attribute that controls how
;  their constants look in a `.h' file.
;
;  Revision 1.11  1995/05/17  22:15:03  alan
;  New scheme: .sch files include each other using the directory name
;
;  Revision 1.10  1995/05/09  04:33:13  alan
;  Be more careful about 24 bit cases.
;
;  Revision 1.9  1995/04/24  18:16:34  alan
;  Fix "can't" comment.
;
;  Revision 1.8  1995/04/19  08:01:42  alan
;  Seems to be a working .h file generator.
;  Still needs more error checking.
;  Only opaque and little-endian of size 8, 16 and 32 actually work.
;
;  Revision 1.7  1995/04/09  11:53:11  alan
;  First working command line version.
;
;  Revision 1.6  1995/04/06  23:19:46  alan
;  `generate-s2c-layout-definitions' now works
;
;  Revision 1.5  1995/04/05  21:19:23  alan
;  More work on `generate-scheme-layout-definitions'.
;
;  Revision 1.4  1995/04/03  07:55:55  alan
;  Still undebugged...
;
;  Revision 1.3  1995/03/31  21:52:38  alan
;  First crack at output driver loop -- undebugged
;
;  Revision 1.2  1995/03/29  01:09:02  alan
;  Tweak format.  Redefinition warnings.
;  Slot for base type.  Boolean type.
;
;  Revision 1.1  1995/03/28  19:42:00  alan
;  Initial revision

; Local Variables:
; mode: Scheme
; eval: (put 'sort-list! 'scheme-indent-hook 1)
; eval: (put 'generate-layout 'scheme-indent-hook 0)
; eval: (put 'for-each-boilerplate-line 'scheme-indent-hook 0)
; eval: (put 'with-interaction-environment 'scheme-indent-hook 1)
; End: