( COMPATIBLE STRUCTURES--TYPE BROWSER
      Version:  1.0.1
         File:  shotype.fs
       Author:  David.N.Williams@umich.edu
      License:  LGPL
Starting date:  July 2, 1995
Last revision:  July 10, 1995 [version 1.0]
                June 14, 2000 [version 1.0.1]
)
\ Copyright (C) 2000 by David N. Williams
(
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or at your
option any later version.

This library is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License
for more details.

You should have received a copy of the GNU Lesser General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.

Please see the file POLITENESS included with this distribution.
)

\ *** BEGIN nonportable stuff

: .token  ( token.dfa -- )
(
This word is not portable, because of the phrase 6 - NFA WCOUNT below.  If
possible, recode it to do your system's method for converting a dfa to a
name field address.  If not, you could rewrite the word TOKEN so it copies
the names of newly CREATE'd tokens to let you get at them.  Or you could
replace the line as indicated below.
)
 ?dup IF
  6 - nfa wcount type	\ for simple portability, replace this line with
			\   ." id " 0 .r
 ELSE ." anonymous" THEN ;

\ hide-case ans-on 
hide-case

\ *** END nonportable stuff

CR .( Loading file: cstruct.fs)
S" cstruct.fs" INCLUDED

: .0	( n -- ) 0 .R ;
: .2	( n -- ) 2 .R ;

: hex.	( n -- )
 BASE @ >R HEX . R> BASE ! ;

: .class  ( class -- )
 CASE
   unstruct-class OF ." type unstruct"  ENDOF
     struct-class OF ." type struct"    ENDOF
     atomic-class OF ." type atomic"    ENDOF
      array-class OF ." type array"     ENDOF
      union-class OF ." type union"     ENDOF
  bit-field-class OF ." bit-field type" ENDOF
 ENDCASE ;

: shotype  ( type -- )
(
Show the type definition parameters for a general type.  In the present 
context, it would be silly to factor this word.
)
 DUP >type-size @ ( type size)
 SWAP DUP >type-class @ ( size type class)
 SWAP DUP >type-align @ SWAP ( size class align type) 
 LOCALS| type align class size |
 BASE @ >R DECIMAL
 CR
 class CASE
  unstruct-class OF
   ." unstruct type, size " size .0 ." , alignment " align .0
  ENDOF
  struct-class OF
   ." struct type, size " size .0 ." , alignment " align .0
   type >field-parms
   type >#fields @
   CR ." fields:"
   0 DO ( field-parms)
    CR I 1+ .2 ." . " DUP @ .token
     ." :  offset " DUP >field-os @ .0
     ." , " DUP >field-type @ >type-class @ .class
     ." , type pointer hex " DUP >field-type @ hex.
    /field-parms +
   LOOP DROP
  ENDOF
  atomic-class OF
   ." atomic type, size " size .0 ." , alignment " align .0
  ENDOF
  array-class OF
   ." array type, size " size .0 ." , alignment " align .0 ." ,"
   CR 2 SPACES type >ar-#elems @ . ." array elements of "
   type >ar-elemtype @ dup >type-class @ .class
   ." , size " dup /type .0 ." , alignment " /align .0
  ENDOF
  union-class OF
   ." union type, size " size .0 ." , alignment " align .0
   type >field-parms 
   type >#fields @
   CR ." fields:"
   0 DO ( field-parms)
    CR I 1+ .2 ." . " DUP @ .token
     ." :  offset " DUP >field-os @ .0
     ." , " DUP >field-type @ >type-class @ .class
     ." , type pointer hex " DUP >field-type @ hex.
     /field-parms +
   LOOP ( field-parms) DROP
  ENDOF
  bit-field-class OF
   ." bit-field type, container(s) size " size .0
   ." , container alignment " align .0 ." ,"
   CR ."   max bit width " type >bf-max#bits @ .0
   ." , bit offset " type >bf-os @ .0
   ." , bits in field " type >bf-#bits @ .0
  ENDOF
  ." Type class " class . ." not implemented."
 ENDCASE R> BASE ! ;

: }shotype  ( id_m ... id_1 stype|utype -- )
\ syntax:  { name_m ... name_1 stype|utype.word }shotype
(
Show the type definition parameters for a structure or union field, with a
complete or incomplete chain for nested substructures.  There has to be at
least one argument.  Then, for example,

	{ utype.word }shotype

is equivalent to

	utype.word shotype
)
 }# 1- SWAP >sfo&type shotype DROP ;

\ Sample structures for browsing.

struct{ cint 3 bit-field george
 	cint 5 bit-field sue
        cint 25 bit-field jimmy
        cint 32 bit-field melissa	
}struct bits.s

union{ cint 3 bit-field george
 	cint 5 bit-field sue
        cint 25 bit-field jimmy
        cint 32 bit-field melissa
}union bits.u

struct{ cint 3 bit-field george }struct one.s
union{ cint 3 bit-field george }union one.u

struct{
cint field george
cint field sue
}struct try.s

union{
cint field george
cint field sue
}union try.u

	struct{
	 cchar field sue
	 10 clong array-field george
	}struct harry.s

	union{
	 cchar field sue
	 10 clong array-field george
	}union harry.u

	struct{
	 15 harry.s array-field arthur
	 20 harry.u array-field marie
	}struct harrys.s

	union{
	 15 harry.s array-field arthur
	 20 harry.u array-field marie
	}union harrys.u

\ Sample use of SHOTYPE and }SHOTYPE.

CR .( Sample:  bits.s shotype)
bits.s shotype

CR CR .( Sample: { bits.s }shotype  \ same as bits.s shotype)
{ bits.s }shotype

CR CR .( Sample: { sue bits.s }shotype)
{ sue bits.s }shotype

CR CR .( Sample: { jimmy bits.s }shotype)
{ jimmy bits.s }shotype

CR CR .( Sample: { melissa bits.s }shotype)
{ melissa bits.s }shotype