Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
Duncan White
C-datadec
Commits
43ebd2b3
Commit
43ebd2b3
authored
May 20, 2014
by
Duncan White
Browse files
removed some more m2datadec leftovers
parent
69792c72
Changes
3
Hide whitespace changes
Inline
Side-by-side
m2decs.c
deleted
100644 → 0
View file @
69792c72
/* Generate data declarations in Modula-2 */
#include
<dcw.h>
#include
<string.h>
#include
"struct.h"
#include
"decs.h"
/*
/^#ifdef HASPROTOS
!/endif$
stat %
*/
#ifdef HASPROTOS
static
void
line
(
char
*
,
long
,
long
,
long
,
long
);
static
void
defn_declns
(
char
*
,
char
*
,
declnlist
);
static
void
defn_onetype
(
decln
);
static
void
impln_declns
(
char
*
,
char
*
,
char
*
,
declnlist
);
static
void
impln_onetype
(
decln
);
static
void
variantfields
(
decln
);
static
void
normalfields
(
decln
);
static
void
consproc_header
(
char
*
,
shape
);
static
void
consproc_body
(
decln
,
shape
);
static
void
deconskind_header
(
char
*
);
static
void
deconskind_body
(
decln
);
static
void
deconskind_inner
(
decln
);
static
void
deconsproc_header
(
char
*
,
shape
);
static
void
deconsproc_body
(
decln
,
shape
);
static
void
writeproc_header
(
char
*
);
static
void
writeproc_body
(
decln
);
static
void
write_using_case
(
char
*
,
char
*
,
shapelist
);
static
void
write_all_params
(
char
*
,
shape
);
static
void
write_default_printlist
(
shape
);
static
void
write_printlist
(
shape
,
char
*
);
static
void
write_param
(
char
*
,
param
);
static
void
outstring
(
char
*
);
static
void
write_bool
(
void
);
static
char
*
lookup_type
(
char
*
);
static
char
*
lookup_write_proc
(
char
*
);
static
int
predefined_type
(
char
*
);
#else
static
void
line
();
static
void
defn_declns
();
static
void
defn_onetype
();
static
void
impln_declns
();
static
void
impln_onetype
();
static
void
variantfields
();
static
void
normalfields
();
static
void
consproc_header
();
static
void
consproc_body
();
static
void
deconskind_header
();
static
void
deconskind_body
();
static
void
deconskind_inner
();
static
void
deconsproc_header
();
static
void
deconsproc_body
();
static
void
writeproc_header
();
static
void
writeproc_body
();
static
void
write_using_case
();
static
void
write_all_params
();
static
void
write_default_printlist
();
static
void
write_printlist
();
static
void
write_param
();
static
void
outstring
();
static
void
write_bool
();
static
char
*
lookup_type
();
static
char
*
lookup_write_proc
();
static
int
predefined_type
();
#endif
/* ------------------------- PUBLIC PROCEDURES --------------------------- */
void
make_declns
(
exports
,
globals
,
begin
,
d
,
base
)
declnlist
d
;
char
*
exports
,
*
globals
,
*
begin
,
*
base
;
{
printf
(
"m2datadec: Making data declarations in %s.{def,mod}
\n
"
,
base
);
defn_declns
(
exports
,
base
,
d
);
impln_declns
(
globals
,
begin
,
base
,
d
);
}
/* ------------------------- PRIVATE PROCEDURES -------------------------- */
static
int
numtabs
=
0
;
static
FILE
*
outfile
;
#define indent() numtabs++
#define outdent() numtabs--
#define nl() fputc( '\n', outfile )
#define outchar(c) fputc( c, outfile )
#define usefile(f) outfile = f, numtabs = 0
/*VARARGS*/
static
void
line
(
fmt
,
a
,
b
,
c
,
d
)
char
*
fmt
;
long
a
,
b
,
c
,
d
;
{
int
i
;
for
(
i
=
numtabs
;
i
;
i
--
)
fputc
(
'\t'
,
outfile
);
fprintf
(
outfile
,
fmt
,
a
,
b
,
c
,
d
);
nl
();
}
/* ------------------------- Definition module --------------------------- */
static
void
defn_declns
(
exports
,
modulename
,
decs
)
char
*
exports
,
*
modulename
;
declnlist
decs
;
{
FILE
*
defnfile
;
char
tempname
[
256
];
declnlist
d
;
char
*
exportptr
;
sprintf
(
tempname
,
"%s.def"
,
modulename
);
defnfile
=
fopen
(
tempname
,
"w"
);
ASSERT
(
defnfile
!=
NULL
,
(
"m2datadec: can't create '%s'
\n
"
,
tempname
)
);
usefile
(
defnfile
);
line
(
"DEFINITION MODULE %s ;"
,
modulename
);
nl
();
line
(
"(*"
);
line
(
" * Automatically Generated by M2DataDec"
);
line
(
" *)"
);
nl
();
nl
();
line
(
"FROM FIO IMPORT File;"
);
nl
();
nl
();
exportptr
=
exports
;
if
(
*
exports
!=
'\0'
)
{
int
i
;
line
(
"(* Contents of EXPORT section *)"
);
for
(
;
*
exportptr
;
exportptr
++
)
{
if
(
*
exportptr
==
'@'
&&
exportptr
[
1
]
==
'@'
&&
exportptr
[
2
]
==
'\n'
)
{
exportptr
+=
2
;
break
;
}
outchar
(
*
exportptr
);
}
nl
();
nl
();
}
line
(
"(* Types - declared forward *)"
);
nl
();
line
(
"TYPE"
);
indent
();
for
(
d
=
decs
;
d
!=
NULL
;
d
=
d
->
next
)
{
if
(
d
->
Struct
)
{
line
(
"%s;"
,
d
->
name
);
}
else
{
line
(
"%s
\t
= INTEGER;"
,
d
->
name
);
}
}
outdent
();
nl
();
for
(
d
=
decs
;
d
!=
NULL
;
d
=
d
->
next
)
{
defn_onetype
(
d
);
}
if
(
*
exportptr
!=
'\0'
)
{
nl
();
line
(
"(* Remaining contents of EXPORT section *)"
);
line
(
exportptr
);
nl
();
}
line
(
"END %s."
,
modulename
);
nl
();
fclose
(
defnfile
);
}
static
void
defn_onetype
(
d
)
decln
d
;
{
shapelist
s
;
BOOL
first
;
line
(
"(* ----------- Type %s ----------- *)"
,
d
->
name
);
nl
();
line
(
"(* Constructor functions for %s *)"
,
d
->
name
);
for
(
s
=
d
->
shapes
;
s
!=
NULL
;
s
=
s
->
next
)
{
consproc_header
(
d
->
name
,
s
);
}
nl
();
if
(
d
->
ManyShapes
)
{
line
(
"(* Kind of %s *)"
,
d
->
name
);
line
(
"TYPE"
);
fprintf
(
outfile
,
"
\t
KindOf%s = ( "
,
d
->
name
);
first
=
TRUE
;
for
(
s
=
d
->
shapes
;
s
;
s
=
s
->
next
)
{
if
(
!
first
)
fputs
(
", "
,
outfile
);
fprintf
(
outfile
,
"%sIs%s"
,
d
->
name
,
s
->
name
);
first
=
FALSE
;
}
fprintf
(
outfile
,
" );
\n
"
);
nl
();
line
(
"(* Deconstructor kind function for %s *)"
,
d
->
name
);
deconskind_header
(
d
->
name
);
nl
();
}
if
(
d
->
Struct
)
{
line
(
"(* Deconstructor functions for %s *)"
,
d
->
name
);
for
(
s
=
d
->
shapes
;
s
!=
NULL
;
s
=
s
->
next
)
{
if
(
s
->
params
!=
NULL
)
{
deconsproc_header
(
d
->
name
,
s
);
}
}
nl
();
}
line
(
"(* write function for %s *)"
,
d
->
name
);
writeproc_header
(
d
->
name
);
nl
();
nl
();
}
/* ----------------------- Implementation module ------------------------- */
static
void
impln_declns
(
globals
,
begin
,
modulename
,
decs
)
char
*
globals
,
*
begin
,
*
modulename
;
declnlist
decs
;
{
FILE
*
implnfile
;
char
tempname
[
256
];
declnlist
d
;
char
*
globalptr
;
sprintf
(
tempname
,
"%s.mod"
,
modulename
);
implnfile
=
fopen
(
tempname
,
"w"
);
ASSERT
(
implnfile
!=
NULL
,
(
"m2datadec: can't create '%s'
\n
"
,
tempname
)
);
usefile
(
implnfile
);
line
(
"IMPLEMENTATION MODULE %s ;"
,
modulename
);
nl
();
line
(
"(*"
);
line
(
" * Automatically Generated by M2DataDec"
);
line
(
" *)"
);
nl
();
nl
();
line
(
"FROM Assertions IMPORT Assert, Abort;"
);
nl
();
line
(
"FROM FIO IMPORT"
);
indent
();
line
(
"File, WriteString, WriteChar, WriteInteger,"
);
line
(
"WriteCardinal, WriteReal, WriteLine, WriteLn;"
);
nl
();
outdent
();
line
(
"FROM Storage IMPORT ALLOCATE;"
);
nl
();
nl
();
globalptr
=
globals
;
if
(
*
globals
!=
'\0'
)
{
line
(
"(* Contents of GLOBAL section *)"
);
for
(
;
*
globalptr
;
globalptr
++
)
{
if
(
*
globalptr
==
'@'
&&
globalptr
[
1
]
==
'@'
&&
globalptr
[
2
]
==
'\n'
)
{
globalptr
+=
2
;
break
;
}
outchar
(
*
globalptr
);
}
nl
();
}
line
(
"(* Pointer type declarations *)"
);
line
(
"TYPE"
);
indent
();
for
(
d
=
decs
;
d
!=
NULL
;
d
=
d
->
next
)
{
if
(
d
->
Struct
)
{
line
(
"%s
\t
= POINTER TO %sRec;"
,
d
->
name
,
d
->
name
);
nl
();
}
}
outdent
();
for
(
d
=
decs
;
d
!=
NULL
;
d
=
d
->
next
)
{
impln_onetype
(
d
);
}
write_bool
();
if
(
*
globalptr
!=
'\0'
)
{
nl
();
nl
();
line
(
"(* Remaining contents of GLOBAL section *)"
);
line
(
globalptr
);
nl
();
}
line
(
"BEGIN"
);
if
(
*
begin
!=
'\0'
)
{
line
(
"
\t
(* Contents of BEGIN section *)"
);
line
(
begin
);
}
line
(
"END %s."
,
modulename
);
fclose
(
implnfile
);
}
static
void
impln_onetype
(
d
)
decln
d
;
{
shapelist
s
;
nl
();
line
(
"(* ---- Type %s ---- *)"
,
d
->
name
);
nl
();
if
(
d
->
Struct
)
{
line
(
"TYPE"
);
indent
();
line
(
"%sRec = RECORD"
,
d
->
name
);
indent
();
if
(
d
->
Union
)
{
variantfields
(
d
);
}
else
if
(
d
->
TagField
)
{
line
(
"tag
\t
: KindOf%s;"
,
d
->
name
);
normalfields
(
d
);
}
else
{
normalfields
(
d
);
}
outdent
();
line
(
"END;"
);
nl
();
outdent
();
}
nl
();
for
(
s
=
d
->
shapes
;
s
!=
NULL
;
s
=
s
->
next
)
{
consproc_body
(
d
,
s
);
}
if
(
d
->
ManyShapes
)
{
deconskind_body
(
d
);
}
for
(
s
=
d
->
shapes
;
s
!=
NULL
;
s
=
s
->
next
)
{
if
(
s
->
params
!=
NULL
)
{
deconsproc_body
(
d
,
s
);
}
}
writeproc_body
(
d
);
}
/* ------------------------- Fields of record ---------------------------- */
static
void
variantfields
(
d
)
decln
d
;
{
shapelist
s
;
paramlist
p
;
line
(
"CASE tag : KindOf%s OF"
,
d
->
name
);
for
(
s
=
d
->
shapes
;
s
!=
NULL
;
s
=
s
->
next
)
{
line
(
"|%sIs%s:"
,
d
->
name
,
s
->
name
);
indent
();
for
(
p
=
s
->
params
;
p
!=
NULL
;
p
=
p
->
next
)
{
line
(
"%s%s
\t
: %s;"
,
s
->
name
,
p
->
name
,
lookup_type
(
p
->
type
)
);
}
outdent
();
}
line
(
"END;"
);
}
static
void
normalfields
(
d
)
decln
d
;
{
shapelist
s
;
paramlist
p
;
for
(
s
=
d
->
shapes
;
s
!=
NULL
;
s
=
s
->
next
)
{
for
(
p
=
s
->
params
;
p
!=
NULL
;
p
=
p
->
next
)
{
line
(
"%s%s
\t
: %s;"
,
s
->
name
,
p
->
name
,
lookup_type
(
p
->
type
)
);
}
}
}
/* ----------------------- Construction procedures ----------------------- */
static
void
consproc_header
(
name
,
s
)
char
*
name
;
shape
s
;
{
paramlist
p
;
BOOL
first
;
fprintf
(
outfile
,
"PROCEDURE %s%s( "
,
name
,
s
->
name
);
first
=
TRUE
;
for
(
p
=
s
->
params
;
p
!=
NULL
;
p
=
p
->
next
)
{
if
(
!
first
)
fputs
(
"; "
,
outfile
);
fprintf
(
outfile
,
"%s : %s "
,
p
->
name
,
lookup_type
(
p
->
type
)
);
first
=
FALSE
;
}
fprintf
(
outfile
,
") : %s;
\n
"
,
name
);
}
static
void
consproc_body
(
d
,
s
)
decln
d
;
shape
s
;
{
paramlist
p
;
consproc_header
(
d
->
name
,
s
);
nl
();
if
(
d
->
Struct
&&
!
(
d
->
UseNull
&&
d
->
shapes
==
s
)
)
{
line
(
"VAR
\t
new : %s;"
,
d
->
name
);
nl
();
}
line
(
"BEGIN"
);
indent
();
if
(
d
->
UseNull
&&
d
->
shapes
==
s
)
{
line
(
"RETURN NIL;"
);
}
else
if
(
!
d
->
Struct
)
{
if
(
d
->
ManyShapes
)
{
line
(
"RETURN %s( ORD(%sIs%s) );"
,
d
->
name
,
d
->
name
,
s
->
name
);
}
else
{
line
(
"RETURN %s( 0 );"
,
d
->
name
);
}
}
else
{
line
(
"NEW( new );"
,
d
->
name
);
if
(
d
->
TagField
)
{
line
(
"new^.tag
\t
:= %sIs%s;"
,
d
->
name
,
s
->
name
);
}
for
(
p
=
s
->
params
;
p
!=
NULL
;
p
=
p
->
next
)
{
line
(
"new^.%s%s
\t
:= %s;"
,
s
->
name
,
p
->
name
,
p
->
name
);
}
line
(
"RETURN new;"
);
}
outdent
();
line
(
"END %s%s;"
,
d
->
name
,
s
->
name
);
nl
();
nl
();
}
/* -------------------- Deconstruction Kind procedure -------------------- */
static
void
deconskind_header
(
name
)
char
*
name
;
{
line
(
"PROCEDURE %sKind( this : %s ) : KindOf%s;"
,
name
,
name
,
name
);
}
static
void
deconskind_body
(
d
)
decln
d
;
{
deconskind_header
(
d
->
name
);
nl
();
line
(
"BEGIN"
);
indent
();
deconskind_inner
(
d
);
outdent
();
line
(
"END %sKind;"
,
d
->
name
);
nl
();
nl
();
}
static
void
deconskind_inner
(
d
)
decln
d
;
{
shapelist
s
=
d
->
shapes
;
if
(
!
d
->
Struct
)
/* enumerated type */
{
line
(
"RETURN VAL(KindOf%s, this);"
,
d
->
name
);
return
;
}
if
(
d
->
UseNull
)
{
line
(
"IF this = NIL"
);
line
(
"THEN"
);
indent
();
line
(
"RETURN %sIs%s;"
,
d
->
name
,
s
->
name
);
outdent
();
line
(
"END; (* IF *)"
);
s
=
s
->
next
;
}
if
(
d
->
TagField
)
{
line
(
"RETURN this^.tag;"
);
}
else
{
line
(
"RETURN %sIs%s;"
,
d
->
name
,
s
->
name
);
}
}
/* ---------------------- Deconstruction procedures ---------------------- */
static
void
deconsproc_header
(
name
,
s
)
char
*
name
;
shape
s
;
{
paramlist
p
;
fprintf
(
outfile
,
"PROCEDURE Get%s%s( this : %s "
,
name
,
s
->
name
,
name
);
for
(
p
=
s
->
params
;
p
!=
NULL
;
p
=
p
->
next
)
{
fprintf
(
outfile
,
"; VAR %s : %s "
,
p
->
name
,
lookup_type
(
p
->
type
)
);
}
fprintf
(
outfile
,
");
\n
"
);
}
static
void
deconsproc_body
(
d
,
s
)
decln
d
;
shape
s
;
{
paramlist
p
;
deconsproc_header
(
d
->
name
,
s
);
nl
();
line
(
"BEGIN"
);
indent
();
for
(
p
=
s
->
params
;
p
!=
NULL
;
p
=
p
->
next
)
{
line
(
"%s
\t
:= this^.%s%s;"
,
p
->
name
,
s
->
name
,
p
->
name
);
}
outdent
();
line
(
"END Get%s%s;"
,
d
->
name
,
s
->
name
);
nl
();
nl
();
}
/* --------------------------- Write procedure --------------------------- */
static
void
writeproc_header
(
name
)
char
*
name
;
{
line
(
"PROCEDURE Write%s( f : File; this : %s );"
,
name
,
name
);
}
static
void
writeproc_body
(
d
)
decln
d
;
{
shapelist
shapes
;
writeproc_header
(
d
->
name
);
nl
();
if
(
d
->
PutLoop
)
{
line
(
"VAR over : BOOLEAN;"
);
nl
();
}
line
(
"BEGIN"
);
indent
();
if
(
d
->
PutLoop
)
{
line
(
"REPEAT"
);
indent
();
line
(
"over := TRUE;"
);
nl
();
}
shapes
=
d
->
shapes
;
if
(
d
->
UseNull
)
{
line
(
"IF this = NIL"
);
line
(
"THEN"
);
indent
();
write_all_params
(
d
->
name
,
/* first */
shapes
);
outdent
();
line
(
"ELSE"
);
indent
();
shapes
=
shapes
->
next
;
}
if
(
d
->
TagField
)
{