// This file is #include'd from parser.c
static int debug_scope = 0;
static int debug_structures = 0;
static int global_pointer_hack = 0;
static int global_fpp_hack = 0;
#include "symtab.c"
static int global_bounds_valid = FALSE,
global_upper_bound_hack,
global_lower_bound_hack;
static int blocktype_nextfree;
static int blocktype_arraysize = 0;
static int *blocktype = NULL;
#define blocktype(x) FLEX(blocktype, x, __LINE__)
#define BLOCKTYPE_EXTERNAL 1
#define BLOCKTYPE_MAIN_PROGRAM 2
#define BLOCKTYPE_FPP 3
#define BLOCKTYPE_ROUTINE 4
#define BLOCKTYPE_NESTED_BEGIN 4
int C_Zero; // tuples with CONST INTs 0 and 1. Reused a lot.
int C_One;
// In an AST_* tuple (as returned by parser.c), apart from a couple of special BIPS
// which are handled explicitly, all the fields are indexes of other AST tuples.
// This makes walking the AST quite trivial and can be done without knowing the
// format of all of these pseudo-structs.
// However the contents of a C_* tuple are arbitrary (with the exception that there
// are no pointers stored, only integer indexes, which was done (among other reasons)
// to avoid problems with 64-bit systems where a pointer will not fit within an int.)
// So we are adding an extra "fmt" field to mark CAST fields as links to other CASTs
// or whatever.
// Note that the C_AST structure contains only descriptors of the tuple functions.
// These are *not* what are returned from ctuple() calls - those are just blocks of
// plain integers.
typedef struct C_AST {
int idx;
int prio;
char *op;
char *name;
char *fmt;
} C_AST;
enum C_ast_command {
C_BASE = 11000,
C_TO_DO = 11000,
C_ABS,
C_BINMINUS,
C_BINPLUS,
C_BRACKET,
C_CONCAT,
C_ADD_COMMA_AFTER,
C_IDIV,
C_IMPMINUSMINUS,
C_IMPPLUSPLUS,
C_BITAND,
C_BITEXOR,
C_BITOR,
C_MUL,
C_PTRIDX,
C_RDIV,
C_SHL,
C_SHR,
C_TEMPNAME,
C_UNARY_MINUS,
C_BITNOT,
C_UNARY_PLUS,
C_IEXP,
C_REXP,
C_AST_OBJECT,
C_spare1,
C_spare2,
C_LOGNOT,
C_LOGAND,
C_LOGOR,
C_COMP_LT_EQ,
C_COMP_LT,
C_COMP_GT_EQ,
C_COMP_GT,
C_COMP_EQ,
C_COMP_NOTEQ,
C_PARAMETER_LIST,
C_INDEX_LIST,
C_FUNCTION_CALL,
C_ACCESS_ARRAY_ELEMENT,
C_LVALUE,
C_ADDRESS,
C_ACCESS_THROUGH_PERCENTNAME,
C_ASSIGN_VALUE,
C_ASSIGN_ADDRESS,
C_NAME,
C_SCALAR,
C_INIT,
C_ACCESS_RECORD_FIELD,
C_STR_RES,
C_COND_STR_RES,
C_JAM_TRANSFER,
C_ADD_SEMI,
C_SEQ,
C_STRING_LITERAL,
C_COMP_EQ_ADDRESS,
C_COMP_NOTEQ_ADDRESS,
C_CONST_REAL,
C_CONST_INT,
C_CONST_STRING,
C_STR_MATCH,
C_STR_ASSIGN,
C_ONE_FAULT,
C_SWITCH_LABEL_DEST,
C_NAME_LABEL_DEST,
C_NUMERIC_LABEL_DEST,
C_ADD_COMMA_BEFORE,
C_FOLDremoved,
C_SWITCH_LABEL_COLON,
C_EXPR_LIST,
C_COMREG,
C_END_OF_PERM,
C_END_OF_PRIM,
C_MAIN_PROGRAM_BLOCK,
C_NESTED_BLOCK,
C_SWITCH_LABEL_DEFAULT,
C_DECLARE_SWITCH,
C_END_OF_LIST,
C_START_OF_LIST,
C_END_OF_MCODE,
C_START_OF_MCODE,
C_TRUSTED_PROGRAM,
C_MAIN_EP,
C_CONTROL,
C_DIAGNOSE,
C_REALS_LONG,
C_REALS_NORMAL,
C_68K_AT,
C_SPEC_ALIAS,
C_SPEC68K,
C_68K_ENTRY_ADDRESS,
C_SPEC,
C_ALPHANUMERIC_LABEL_COLON,
C_NUMERIC_LABEL_COLON,
C_ON_EVENT_BLOCK,
C_SHORT_ROUTINE,
C_BRACKETED_LIST,
C_TYPE_INT,
C_TYPE_REAL,
C_TYPE_STRING,
C_TYPE_RECORDFORMAT,
C_TYPE_RECORD_VARIANT,
C_TYPE_ARRAY_OF,
C_TYPE_POINTER_TO,
C_TYPE_ROUTINE,
C_TYPE_FN,
C_TYPE_MAP,
C_TYPE_PARAMETERS,
C_TYPE_SWITCH,
C_TYPE_RECORD_FIELD,
C_TYPE_GENERAL_NAME,
C_TYPE_PREDICATE,
C_COMREG_XTYPE,
C_TYPE_LABEL,
C_DECLARE_SCALAR,
C_DECLARE_ARRAY,
C_ALIAS,
C_STORAGE,
C_FORMAT,
C_BOUNDS,
C_BOUNDSPAIR,
C_IF,
C_UNLESS,
C_WHILE,
C_UNTIL,
C_IMP_FOR,
C_STATEMENT_BLOCK,
C_COMMENT,
C_MACHINE_CODE_INSTR,
C_THEN_ELSE,
C_PROCEDURE_BLOCK,
C_FOREVER,
C_RESULT,
C_STOP,
C_unused2,
C_NULL_STATEMENT,
C_PRINTSTRING,
C_FAULT_GROUP,
C_GOTO,
C_BREAK,
C_CONTINUE,
C_SIGNAL,
C_MONITOR,
C_OPTIONS,
C_INCLUDEFILE,
C_INCLUDEMODULE,
C_INIT_REPEATS,
C_DEBUG,
C_C,
C_DECLARE_RECORDFORMAT,
C_CONST_BIGINT,
C_CALLBACK,
C_DECLARE_REGISTER,
C_ASSIGN_PLUS,
C_ASSIGN_MINUS,
C_ASSIGN_PLUSPLUS,
C_ASSIGN_MINUSMINUS
};
#define C_LAST C_ASSIGN_MINUSMINUS
#define MAX_C (C_LAST-C_BASE+1) // REMEMBER TO UPDATE THE STRING ARRAY BELOW!
C_AST CAST[MAX_C];
// unfortunately C99 designated initialiser syntax appears not to be accepted.
// (I wanted to be able to reorder these without having to renumber all the #define's)
// so... taking a different tack...
#define DefineCAST(idxv, priov, opv, namev, fmtv) CAST[idxv-C_BASE].idx = idxv; CAST[idxv-C_BASE].prio = priov; CAST[idxv-C_BASE].op = opv; CAST[idxv-C_BASE].name = namev; CAST[idxv-C_BASE].fmt = fmtv;
// Use of 'XX' is just a way of emphasizing that priority is not
// relevant, rather than meaning 'absolute highest priority value'
#define XX 0
void Init_CAST(void) {
DefineCAST(C_DEBUG, XX, "", "DEBUG" ,"") // "? expr" etc in source outputs what code would have been generated,
// with debugging turned on for that one expression
DefineCAST(C_TO_DO, XX, "", "TO_DO" ,"")
DefineCAST(C_ADD_COMMA_AFTER, XX, "", "ADD_COMMA_AFTER" ,"")
/*
C AST TUPLE DEFINITION
======================
The IMP to C converter generates an analysis record from the initial parse. This is
converted 1:1 into AST tuples and the C conversion happens primarily in a subsequent
conversion of the AST tuples into C-AST tuples (aka CAST tuples) and secondarily at
the point where the CAST tuples are output as C text.
This document lists the various CAST tuples available. These were created in a somewhat
adhoc manner as the translator was developed and some of them are no longer used and
some are going to be removed or simplified in the next phase of development.
The first set of notes on declarations and types are not what currently exists, but are
what I'm considering changing to, in an attempt to clean up the CAST design which had
grown somewhat piecemeal until we got to the current point. The cleanup will be a pretty
major upheaval and I'm still in two minds about it, but I'm starting to convince myself
that it is necessary. Being done hand-in-hand with the code generation for phrase <LVALUE>.
The other tuples are listed after the declaration and types section, and are more or less
in the final form.
C_TYPE_REGISTER
C_TYPE_LABEL
C_TYPE_SWITCH
# int, real and string may be %const and have data attached. Not true of arrays or records,
# although it would be nice for the folding code to have access to const array elements...
# should I have separate flex tables for large integer and real constants in excess of 4 bytes? (Call it 'GLA'?)
C_TYPE_INT
C_TYPE_REAL
C_TYPE_STRING
C_TYPE_RECORD recordname recordformat initialisation spare=-1 is_pointer(or -1)
C_TYPE_ARRAY_OF
C_TYPE_GENERIC_NAME
C_TYPE_PRIVATE_DOPEVECTOR
C_TYPE_FN
C_TYPE_PREDICATE is equivalent to a C_TYPE_FN whose result is C_TYPE_INT_boolean
C_TYPE_ROUTINE
C_TYPE_MAP is equivalent to a C_TYPE_FN whose result is a C_TYPE_POINTER_TO(type of map result) ... apart from the automatic de-referencing...
C_TYPE_NAMEPTR_TO object # this is an object %name
C_TYPE_ARRAYNAME(object) is equivalent to C_TYPE_POINTER_TO(C_TYPE_ARRAY_OF(object))
# Examples:
# %integer C_TYPE_INT
# %integername C_TYPE_POINTER_TO(C_TYPE_INT)
# %integerarray C_TYPE_ARRAY_OF(C_TYPE_INT)
# %integerarrayname C_TYPE_POINTER_TO(C_TYPE_ARRAY_OF(C_TYPE_INT))
# %integernamearray C_TYPE_ARRAY_OF(C_TYPE_POINTER_TO(C_TYPE_INT))
# %integernamearrayname C_TYPE_POINTER_TO(C_TYPE_ARRAY_OF(C_TYPE_POINTER_TO(C_TYPE_INT)))
C_DECLARE_* is used to output declarations. The parameters of C_DECLARE (ie C_TYPE_* info) are what is entered in the
symbol table, except that the C_DECLARE_* includes the initialisation data.
C_TYPE_* is what is found from lookups of the symbol table, to be used in type matching and code generation
C_DECLARE C_TYPE_*, linkage (includes is_param)
#C_DECLARE_VARIABLE C_TYPE_*
#C_DECLARE_PARAMETER C_TYPE_* not sure if this is needed or C_STORAGE_param is a better way to handle it?
#C_DECLARE_RECORD_FORMAT indentinfo
# these may not be needed at all. Use the similarly-named TYPE fields instead.
#C_DECLARE_PROCEDURE
#C_DECLARE_SWITCH
#C_DECLARE_SCALAR
#C_DECLARE_SCALARNAME
#C_DECLARE_ARRAY
#C_DECLARE_ARRAYNAME
#C_DECLARE_REGISTER Move this to 'linkage' info, and make it part of a regular declaration?
# easier if *all* record definitions have a variant list, even if only one present.
C_TYPE_RECORD_FORMAT identinfo
C_TYPE_RECORD_VARIANT_LIST record variant, next variant list/-1
C_TYPE_RECORD_FIELD_LIST record field, next field list/-1
C_TYPE_RECORD_FIELD name C_TYPE_* etc
C_DECLARE_RECORD
# to access:
C_ACCESS_RECORD_FIELD parent list-of-allowed-fields child-name
C_ADDRESS_OF lvalue # &lvalue
C_ACCESS_THROUGH_PERCENTNAME pointer # *pointer
C_ACCESS_ARRAY_ELEMENT array-object param-list # first draft used array-name but that doesn't work for record fields that are arrays or arraynames
in addition to fields in some tuples of 'is_pointer' which denotes a %name variable; -1 if not, but what if so???
Rather than have 'is_pointer fields' in various tuples, those tuples should be wrapped in a C_TYPE_POINTER_TO() tuple,
and the access to a variable should mirror its type info.
============================== CURRENT ACTUAL DECLARATION-RELATED TUPLES ==============================
DefineCAST(C_DECLARE_SWITCH, XX, "", "DECLARE_SWITCH" ,"") // #1 name #2 boundspair #index of switch info table
// Not sure if we can use these for formal parameter lists in addition to actual declarations:
DefineCAST(C_DECLARE_SCALAR, XX, "", "DECLARE_SCALAR" ,"") // #1 name
// #2 %sex
// #3 pointer to(ie %name) (or -1)
// #4 arrayname
// #5 C_TYPE...
// #6 initialisation
// an 'arrayname' is always 1-D (at least as a parameter). Treat it as a dopevector container for now (ie like a struct)
DefineCAST(C_DECLARE_ARRAY, XX, "", "DECLARE_ARRAY" ,"") // #1 name #2 %sex #3 <BOUNDS> #4 C_TYPE... #5 initialisation
// Should I add a C_POINTER_DECLARATION for <type> %name ?
DefineCAST(C_DECLARE_RECORDFORMAT, XX, "", "DECLARE_RECORDFORMAT" ,"") // #1 recordformat (C_TYPE_RECORDFORMAT) #2 C_SPEC or -1
// *** SEE *** research/variant-records.imp+c for what we should be doing...
DefineCAST(C_DECLARE_REGISTER, XX, "", "DECLARE_REGISTER" ,"") // #1 reg name #2 reg number
DefineCAST(C_TYPE_INT, XX, "", "TYPE_INT" ,"")
// scalar types include value field for %const variables, stored in an ascii representation.
// #1 <name or -1>
// #2 precision/signedness
// #3 initialisation C_AST or -1
// #4 canonical folded value of %const, or -1
// #5 %name or -1
DefineCAST(C_TYPE_REAL, XX, "", "TYPE_REAL" ,"")
// #1 <name or -1>
// #2 precision
// #3 initialisation C_AST or -1
// #4 canonical folded value of %const, or -1
// #5 %name or -1
DefineCAST(C_REALS_LONG, XX, "", "REALS_LONG" ,"")
DefineCAST(C_REALS_NORMAL, XX, "", "REALS_NORMAL" ,"")
DefineCAST(C_TYPE_STRING, XX, "", "TYPE_STRING" ,"")
DefineCAST(C_TYPE_RECORDFORMAT, XX, "", "TYPE_RECORDFORMAT" ,"") // #1 <record name or -1> #2 record format name #3 field list of C_TYPE_RECORD_FIELD
DefineCAST(C_TYPE_RECORD_VARIANT, XX, "", "TYPE_RECORD_VARIANT" ,"")
// #1 field name
// #2 field offset if known relative to start of current record, or -1 (for later)
// #3 field type could be a basic type, or another C_TYPE_RECORD_VARIANT sublist!
// #4 %name ?
// #5 next <C_TYPE_RECORD_VARIANT> or -1
DefineCAST(C_FORMAT, XX, "", "FORMAT" ,"")
DefineCAST(C_TYPE_ARRAY_OF, XX, "", "TYPE_ARRAY_OF" ,"")
// arrays with dopevectors - dope vector is a C struct and pointed to as such
// #1 <name or -1>
// #2 C_type of array element
// #3 dimensionality
// #4 dopevector or -1
// #5 array type (ie one of Hamish's funny ones)
// #6 bounds: lower bound upper bound <more bounds>
// #7 init data depends on column-major or row-major implementation...
DefineCAST(C_TYPE_POINTER_TO, XX, "", "TYPE_POINTER_TO" ,"") // #1 <name or -1> #2 object pointed to (<C_TYPE_...>) { %name variable or parameter }
// These *could* all be one generic procedure type with different result types, but having different C_* objects for each makes for more readable code.
DefineCAST(C_TYPE_ROUTINE, XX, "", "TYPE_ROUTINE" ,"") // #1 name #2 spare
// #3 parameter list (C_TYPE_PARAMETERS)
// #4 body or spec or -1 #5 alias or -1 #6 %sex
DefineCAST(C_TYPE_FN, XX, "", "TYPE_FN" ,"") // #1 name #2 result type #3 parameter list (C_TYPE_PARAMETERS)
// #4 body or spec or -1 #5 alias or -1 #6 %sex
DefineCAST(C_TYPE_MAP, XX, "", "TYPE_MAP" ,"") // #1 name #2 result type #3 parameter list (C_TYPE_PARAMETERS)
// #4 body or spec or -1 #5 alias or -1 #6 %sex
DefineCAST(C_ALIAS, XX, "", "ALIAS" ,"")
DefineCAST(C_TYPE_PARAMETERS, XX, "", "TYPE_PARAMETERS" ,"") // #1 name #2 C_TYPE_... #3 next <C_TYPE_PARAMETERS> or -1
// #1 object this hangs off (may be name, may be -1) #2 this object #3 next object <C_BRACKETED_LIST> or -1
// Should be replaced by one of these before we get to the output routine:
// C_PARAMETER_LIST #1 object this hangs off #2 actual parameter #3 more parameters (another C_PARAMETER_LIST)
// C_INDEX_LIST #1 object this hangs off #2 array index #3 more indices (another C_INDEX_LIST)
DefineCAST(C_TYPE_SWITCH, XX, "", "TYPE_SWITCH" ,"") // #1 name #2 lower bound #3 upper bound
// #4 'default' declared? #5 list of used labels for output after parsing.
DefineCAST(C_TYPE_RECORD_FIELD, XX, "", "TYPE_RECORD_FIELD" ,"")
// #1 field name
// #2 field offset if known relative to start of current record, or -1 (for later)
// #3 type: field type could be a basic type, or a C_TYPE_RECORD_VARIANT list
// #4 %name?
// #5 next <C_TYPE_RECORD_FIELD> or -1
DefineCAST(C_TYPE_GENERAL_NAME, XX, "", "TYPE_GENERAL_NAME" ,"")
// #1 name #2 register (68K only) or -1 ; <much like a dope vector, it is implemented as a C_TYPE_STRUCT>
// Cannot declare a %name variable (yet?) - only a %name parameter
DefineCAST(C_TYPE_PREDICATE, XX, "", "TYPE_PREDICATE" ,"") // #1 name #2 spare
// #3 parameter list (C_TYPE_PARAMETERS)
// #4 body or spec or -1 #5 alias or -1 #6 %sex
DefineCAST(C_COMREG_XTYPE, XX, "", "COMREG_XTYPE" ,"")
// only used to pass this info around internally while building the C AST:
// #1 68K-register-name #2 68K-memptr (bitmask, default 0) #3 <C_TYPE_...> #4 %name?
DefineCAST(C_TYPE_LABEL, XX, "", "TYPE_LABEL" ,"") // forward declaration of alphanumeric label. no params any more.
// Name comes in some other way. UGLY.
DefineCAST(C_COMREG, XX, "", "COMREG" ,"")
// temporary COMmunication REGisters, used to pass arbitrary data around *while building the
// C AST*, without requiring the overhead of their own structure. They should be gone by the
// time the CAST is finally passed to 'out()' at the top-level.
DefineCAST(C_STORAGE, XX, "", "STORAGE" ,"")
// Originally: _auto, own, constant, external, _system, dynamic, prim, perm, _fpp
// C_STORAGE types are specific to data. Storage and linkage codes may be OR-ed.
*************************************** C_CALLBACK ***************************************
This is used to add items found while compiling a procedure to a 'to do' list that will be added to the body of
the procedure when the end of the procedure is compiled. This list will then be available for use when the
procedure is later output by the 'out()' call. Primarily intended for adding things like switch label
declarations, but could be used for all sorts of fixing up.
Fields:
#1 table name
#2 entry name
#3 saved data
It's not decided yet for certain whether the data set up for the callback will remain valid after the callback
has executed and scope of the procedure is popped.
*************************************** C_SEQ ***************************************
Originally intended for sequences of statements - and specifically for converting the CAST from a tree into a
control flow graph (CFG) before being output linearly in source form - this has morphed into a generic mechanism
for holding any sort of list. In the Grand Rewrite to clean up the code, I would like to undo this and have
separate linked list types for every type of linked list, so that there's no confusion of what you're looking at
when you have a C_SEQ. Note that the overloading of C_SEQ somewhat suggests that there should not be a C_SEQ
entry in the out() procedure - rather, that any phrase which contains C_SEQ elements should output that sublist
itself, explicitly.
*************************************** C_NULL_STATEMENT ***************************************
Some of the tidying up code can remove redundant semi-colons from compound statements. This was a way to force
a null statement to be kept that would otherwise have been removed. Eventually, improved generation of the C
code should make this unnecessary.
*************************************** C_ADD_SEMI ***************************************
Add a ';' to whatever object is to be output. Again, improved C generation *should* always generate the
appropriate semicolons when needed and not rely on the programmer to have to insert them into the data structure
manually.
*************************************** C_ADD_COMMA_BEFORE ***************************************
Similar to 'ADD SEMI' but with commas. In this case the comma is to be inserted *before* the designated object,
which was probably done for lists such as procedure parameters where you don't have the option of an optional
comma at the end of the list of items, the way you do with say array initialisers.
*************************************** C_C ***************************************
This was a 'get out of jail free' instruction to allow arbitrary text to be generated while avoiding the need to
create a new C_ entry in out(). Intended to be used for one-offs.
*************************************** C_COMMENT ***************************************
This takes an IMP comment and outputs it in C with whatever minimal changes may be needed to accomodate C syntax
such as replacing "* /" if it occurred in the IMP comment string. Note that only "!" or "%comment" style comments
that are full IMP statements are converted this way. New "{ ... }" style comments which in IMP are handled by
the line reconstruction phase and are therefore removed before the parser even sees them, do *not* come through
this path. They're actually attached to the whitespace surrounding each of the tokens and will have to be
extracted differently.
*************************************** C_AST_OBJECT ***************************************
This was used to postpone conversion of an AST tuple into a CAST tuple. Probably isn't needed.
*************************************** C_PTRIDX ***************************************
This is to handle 68000 IMP's pointer-indexing feature. Not used in the majority of IMP programs.
#1 ptr
#2 index offset
*************************************** C_IMPMINUSMINUS ***************************************
This is a binary pointer operator from another 68000 IMP feature, ptr -- index
which I think is identical to ptr[-index]. It is *not* C's --
*************************************** C_IMPPLUSPLUS ***************************************
Same as above. This is a binary pointer operator from the same 68000 IMP feature, ptr ++ index
which I think is identical to ptr[index]. It is *not* C's ++
*************************************** C_TEMPNAME ***************************************
*************************************** C_CONST_REAL ***************************************
Holds a %const %real, represented in string form.
*************************************** C_CONST_INT ***************************************
Holds a %const %integer, in both string form (ie preferred representation - plain integer, based constant, character constant) and integer form.
#1 string rep
#2 int val (32 bits)
*************************************** C_CONST_BIGINT ***************************************
Similar to CONST_INT except that the integer form requires two words.
#1 string rep
#2 int val (high 32 bits)
#3 int val (low 32 bits)
*************************************** C_CONST_STRING ***************************************
Points to string pool - contains the string *contents*, does not include containing quotes or escaped chars.
*************************************** C_BRACKET ***************************************
For explicit brackets around an arithmetic expression, so they are copied to the output. The expression tree
would still be correct without them, but would not guarantee that there would be brackets in the same place
in the generated C.
*************************************** C_ABS ***************************************
For the |expr| operator. Will be replaced by appropriate real or integer library call. Or perm code.
*************************************** C_BINMINUS ***************************************
Arithmetic "A - B", real or integer.
*************************************** C_BINPLUS ***************************************
Arithmetic "A + B", real or integer.
*************************************** C_BITNOT ***************************************
Bitwise integer NOT
*************************************** C_BITAND ***************************************
Bitwise integer AND
*************************************** C_BITEXOR ***************************************
Bitwise integer EXOR
*************************************** C_BITOR ***************************************
Bitwise integer OR
*************************************** C_MUL ***************************************
Integer or Real multiply
*************************************** C_IDIV ***************************************
Integer divide A // B
*************************************** C_RDIV ***************************************
Real divide A / B
*************************************** C_SHL ***************************************
Shift left A << B
*************************************** C_SHR ***************************************
Shift right A >> B (unsigned in IMP)
*************************************** C_UNARY_MINUS ***************************************
Unary minus, integer or real.
Note that the IMP rules for parsing unary minus are rather strange, by substituting "0-" for "-", which causes
-1 >> 1 to be broken - it is supposed to be parsed as 0-1>>1 which precedence converts to -(1>>1) and which then
returns 0, whereas C returns -1 (or MAXINT, depending on signedness) for the literal output of "-1 >> 1".
*************************************** C_UNARY_PLUS ***************************************
Unary plus. Effectively redundant, I only included this tuple for consistency.
*************************************** C_IEXP ***************************************
Integer exponentiation.
*************************************** C_REXP ***************************************
Real exponentiation.
*************************************** C_LOGNOT ***************************************
NOT to be used in conditions.
*************************************** C_LOGAND ***************************************
AND to be used in conditions.
*************************************** C_LOGOR ***************************************
OR to be used in conditions.
*************************************** C_COMP_LT_EQ ***************************************
Integer or real <=
*************************************** C_COMP_LT ***************************************
Integer or real <
*************************************** C_COMP_GT_EQ ***************************************
Integer or real >=
*************************************** C_COMP_GT ***************************************
Integer or real >
*************************************** C_COMP_EQ ***************************************
Integer or real = (comparison, not assignment)
*************************************** C_COMP_NOTEQ ***************************************
Integer or real != (comparison, not assignment)
*************************************** C_COMP_EQ_ADDRESS **************************************
Pointer comparison = (comparison, not assignment)
*************************************** C_COMP_NOTEQ_ADDRESS ***************************************
Pointer comparison != (comparison, not assignment)
*************************************** C_LVALUE ***************************************
<LVALUE> is a phrase rather than a CAST object. Ideally we never want to see C_LVALUE making it through to
the out() procedure. It covers everything that starts with a <NAME>, whether a procedure call, function call,
array element, scalar variable or record with field (to any depth). LVALUEs should be converted into a tree
before we get to the output stage.
*************************************** C_ASSIGN_VALUE ***************************************
Simple assignment of RHS to LHS. While being built, LHS or RHS can be -1.
*************************************** C_JAM_TRANSFER ***************************************
Identical to C_ASSIGN_VALUE except for size of operands. This will truncate longer operands or fail to sign-
extend shorter ones. It's possible that strings can also come through here and will only copy enough of the
string that the destination has capacity for.
*************************************** C_ASSIGN_ADDRESS ***************************************
Like simple assignment, but the RHS is an address and the LHS must be a pointer variable.
*************************************** C_ASSIGN_PLUS ***************************************
A 'tidy up' part of the code, where we recognise <LVALUE> = <LVALUE> + <EXPR> and convert to <LVALUE> += <EXPR>
This is only to make the C code look more C-like...
*************************************** C_ASSIGN_MINUS ***************************************
A 'tidy up' part of the code, where we recognise <LVALUE> = <LVALUE> - <EXPR> and convert to <LVALUE> -= <EXPR>
Note this is only done after The C_ASSIGN_VALUE tuple is fully populated.
*************************************** C_ASSIGN_PLUSPLUS ***************************************
If the EXPR part of C_ASSIGN_PLUS is the constant '1', we can substitute the C "++" postfix operator.
Again, cosmetic only.
*************************************** C_ASSIGN_MINUSMINUS ***************************************
If the EXPR part of C_ASSIGN_PLUS is the constant '1', we can substitute the C "++" postfix operator.
Again, cosmetic only. Note that do not ever substitute += or ++ etc in expressions, only as replacement
statements, thus avoiding issues with C sequence points and unexpected side-effects.
*************************************** C_FUNCTION_CALL ***************************************
Call a RT/FN/PRED/MAP.
#1 = proc name (C_NAME)
#2 = C_PARAMETER_LIST
*************************************** C_INIT ***************************************
Initialise a scalar or array variable in a declaration
#1 = type of assignment to use (empty ctuple of type C_ASSIGN_VALUE or C_JAM_TRANSFER)
#2 = EXPR_LIST
#3 lower bound or -1
#4 upper bound or -1
In hindsight it will make a lot more sense to split this into C_INIT_ARRAY and C_INIT_SCALAR...
*************************************** C_INIT_REPEATS ***************************************
This is a special case of an element in a declaration initialisation list - it handles the IMP "(n)" and "(*)"
constructs where an item is to be repeated a specific number of times or until the array is full.
#1 value
#2 lower bound
#3 upper bound
#4 number of repeats
Lower and upper may be set to -1 when nn(rep) is encountered but must be filled in by parent level
by the time the object is passed to out() for code generation.
See https://gcc.gnu.org/onlinedocs/gcc-4.1.2/gcc/Designated-Inits.html for syntax:
%integer widths = 1 (10), 2(90), 3
can be implemented with GNU extensions by:
int WIDTHS[101] = { [0 ... 9] = 1, [10 ... 99] = 2, 3 };
If generating code without gnu extensions, simply repeat the numbers.
*************************************** C_EXPR_LIST ***************************************
*************************************** C_BRACKETED_LIST ***************************************
This is for a list of expressions in brackets which could be either array indexing or procedure parameters -
the compile phase works out which and replaces this tuple with the appropriate C_PARAMETER_LIST or C_INDEX_LIST.
#1 object this hangs off
#2 actual parameter
#3 rest of actual parameter list (another C_BRACKETED_LIST)
*************************************** C_PARAMETER_LIST ***************************************
Linked list of parameters to a function call. When evaluating, each actual parameter has to be paired off with
a parallel list of formal parameters (extracted from the declaration and stored in/retrieved from the symbol
table)
#1 object this hangs off
#2 actual parameter
#3 rest of actual parameter list (another C_PARAMETER_LIST)
*************************************** C_INDEX_LIST ***************************************
Linked list of indexes to an array.
#1 object this hangs off
#2 array index
#3 more indices
*************************************** C_BOUNDS ***************************************
Used in the descriptor for an array - number of dimensions and upper/lower bound of each dimension.
More data may be needed than just this and will probably end up being built up into a dopevector shadow variable
#1 dimensionality
#2 boundspair list
*************************************** C_BOUNDSPAIR ***************************************
Info for one dimension of an array. Stored as a linked list with the next bound as the link.
#1 lower bound <expr>
#2 upper bound <expr>
#3 lower bound (castp) value if constant
#4 upper bound (castp) value if constant
#5 next boundspair
*************************************** C_ACCESS_ARRAY_ELEMENT ***************************************
Access the Nth element of an array
// array and indexes
*************************************** C_ACCESS_RECORD_FIELD ***************************************
Access a field of a record object.
#1 parent
#2 child
#3 parent is a pointer? (i.e. use '->' rather than '.' to access the field)
although note that the '->' vs '.' is just to make the C look more natural, as var.field is functionally
identical to &var->field; and ptr->field could equally be expressed as (*ptr).field ...
*************************************** C_ADDRESS ***************************************
If we have a CAST object that expands to a variable, applying C_ADDRESS is equivalent to taking &variable in C.
THIS TUPLE SHOULD NOT BE INSERTED IF THE LVALUE IS ALREADY A %name OR A %map.
*************************************** C_ACCESS_THROUGH_PERCENTNAME ***************************************
If a CAST tuple expands to a <some type> %name or a call to a %map, then this will indirect through it and
return the <some type> object.
Note that *&variable is identical to variable, so these two ops can be cancelled out. Ditto &*ptr.
*************************************** C_NAME ***************************************
This is just the variable's name, it contains no semantic significance. The actual representation of the name
is stored an an AST object, as well as the canonicalised string which is in the stringpool. This should support
some later tweaks to better represent IMP variables with mixed-case names and internal spaces. Not to mention
the usual short comments preceding any token and indeed comments which could appear *within* the variable name.
#1 = stringpool index
#2 = astp of <NAME> or perhaps -1.
*************************************** C_SCALAR ***************************************
Simple scalar variables (parsed as unadorned C_NAMEs) need to be tagged with their type information.
// #1 name #2 %sex #3 pointer to(ie %name) (or -1) #4 arrayname #5 C_TYPE...
*************************************** C_CONCAT ***************************************
Concatenate two IMP strings. Beware capacity issues.
*************************************** C_STR_RES ***************************************
IMP unconditional string resolution. Failure raises a %signal
*************************************** C_COND_STR_RES ***************************************
IMP string resolution with a condition
*************************************** C_STR_MATCH ***************************************
IMP string conparison - A < B is handled as strcmp(A,B) < 0
*************************************** C_STR_ASSIGN ***************************************
Assign a string expression to a string variable. %signal on overflow.
*************************************** C_STRING_LITERAL ***************************************
A string literal. Not quite the same as a C_CONST_STRING. May be single or double quoted, may be an integer
constant. This might need to be split into more than one tuple.
#1 index into stringpool
*************************************** C_ON_EVENT_BLOCK ***************************************
Holds the info from an IMP event block - converted to more C-like code on output.
#1 event list SEQ list,
#2 code block
*************************************** C_ONE_FAULT ***************************************
Similar but for %fault - but just one destination
#1 label
#2 fault number list (in AST format perhaps? Check...)
*************************************** C_FAULT_GROUP ***************************************
Linked list of above. An IMP %fault statement can have a list of faults that go to one labelled destination,
and a subsequent list of different fault numbers that go to a different destination.
#1 C_ONE_FAULT
#2 next C_FAULT_GROUP
*************************************** C_SIGNAL ***************************************
Raise an IMP signal. C mechanism to be used is not specified. Currently under review.
*************************************** C_MONITOR ***************************************
Produce an IMP backtrace and raise a numbered signal. Unfortunately in C we can only abuse gdb to produce an
IMP-like backtrace if we are also stopping execution (eg with %monitorstop or %monitor unconditionally followed
by a %stop.) If the code has to resume we can only produce a procedure call trace, without showing variables.
#1 digit-seq or -1
*************************************** C_STOP ***************************************
IMP's %stop is effectively identical to C's stdlib 'exit(0)'.
*************************************** C_GOTO ***************************************
Jump. Destination may be any kind of label, including %switch jumps.
#1 label dest (3 types)
*************************************** C_SWITCH_LABEL_COLON ***************************************
Target label for switch jumps. Not sure if this is used - may have been replaced by C_ALPHANUMERIC_LABEL_COLON
*************************************** C_SWITCH_LABEL_DEST ***************************************
Output the label part of a goto when the jump target is a switch label.
#1 name
#2 expr
#3 decln
#4 low
#5 high
*************************************** C_SWITCH_LABEL_DEFAULT ***************************************
For the default destination of a switch when a label in the switch range is not explicitly given.
*************************************** C_ALPHANUMERIC_LABEL_COLON ***************************************
For the destination of a goto when the label is an alphanumeric style <NAME>
#1 switch name
#2 label index
#3 Output name_index, with negative indices handled as name_'M'nnn
Since this appears to be designed for %switch labels, need to compare use of C_SWITCH_LABEL_COLON and determine
why it exists as well.
*************************************** C_NAME_LABEL_DEST ***************************************
Output the label part of a goto when the jump target is a standad alphanumeric name.
#1 <name>
*************************************** C_NUMERIC_LABEL_COLON ***************************************
Same as above but for old-style numeric-only labels. (Positive integers)
#1 number. Output L__number
*************************************** C_NUMERIC_LABEL_DEST ***************************************
For the placing of a numeric label as the destination of a go to.
#1 <digit-seq>
*************************************** C_MAIN_PROGRAM_BLOCK ***************************************
This is the body of %begin/%endofprogram (OR a procedure flagged by %mainep). If some extra code has to be
added to the main program, it can be inserted after the C return(0) that is implied by the %endofprogram. This
is likely to be some extra code to handle the jumps to %switch statements, but could be anything.
#1 code
#2 code to be inserted after 'return'!
*************************************** C_NESTED_BLOCK ***************************************
An IMP %begin/%end is not quite the same as a C { ... } block. The IMP block allows %on %event at the head of it
and IMP77 specifically allows %return within the %begin/%end block to return to just after the %end, as if the
block were really an anonymous nested procedure followed by a call to that procedure.
*************************************** C_PROCEDURE_BLOCK ***************************************
Body of a RT/FN/PRED/MAP
#1 is code. Needed as well as C_MAIN_PROGRAM_BLOCK and C_NESTED_BLOCK, unfortunately
*************************************** C_STATEMENT_BLOCK ***************************************
This is a single C statement or bracketed list of statements that can be treated like a single C statement.
No comment here as to the handling of 'else' parts. That's still under development.
#1 C_SEQ list of statements
If it is being output as the action part of a construct like if or while, then it has to be bracketed with {} so
that it is syntactically like a single statement, but if it is just in the middle of a list of sequential
statements, then the extra brackets are redundant and distracting and may be removed. For example where a
'return' statement has an '_imp_leave()' statement prepended to it.
*************************************** C_RESULT ***************************************
%result in an IMP function. May include %true/%false if a predicate.
#1 is assop (missing lhs) ... -1 for "return" with no result value.
*************************************** C_END_OF_PERM ***************************************
*************************************** C_END_OF_PRIM ***************************************
*************************************** C_END_OF_LIST ***************************************
*************************************** C_START_OF_LIST ***************************************
*************************************** C_END_OF_MCODE ***************************************
*************************************** C_START_OF_MCODE ***************************************
*************************************** C_TRUSTED_PROGRAM ***************************************
*************************************** C_MAIN_EP ***************************************
Use this as the main program instead of the default.
#1 name of procedure
*************************************** C_CONTROL ***************************************
#1 int
*************************************** C_DIAGNOSE ***************************************
#1 int
*************************************** C_OPTIONS ***************************************
*************************************** C_68K_AT ***************************************
// ignore for now
*************************************** C_SPEC_ALIAS ***************************************
// ignore for now
*************************************** C_SPEC68K ***************************************
// ignore for now
*************************************** C_68K_ENTRY_ADDRESS ***************************************
// ignore for now
*************************************** C_SPEC ***************************************
// ignore for now
*************************************** C_SHORT_ROUTINE ***************************************
// ALL FIVE of the types below *must* make the <block> to be executed their first parameter:
*************************************** C_IF ***************************************
Standard IF/THEN/ELSE condition with then or else part optionally being absent (-1)
Care needs to be taken with 'dangling else' issues.
#1 'then' statement to be executed
#2 cond
#3 'else' statement to be executed - when used in the context of IU/WUF, #3 must be -1. (ie no 'else' in a reversed condition)
#4 const value of cond if possible - used to convert top-level if/then/else into #if/#else/#endif
C_IF with no 'then' part will invert the condition and move the 'then' part to the 'if' part.
*************************************** C_UNLESS ***************************************
Prefer to invert the condition and replace with C_IF. If both 'then' and 'else' parts present, swap them over.
*************************************** C_THEN_ELSE ***************************************
Not sure if the THEN_ELSE tuple is still being used. IF or UNLESS tuples should be sufficient.
#1 "then" block (may be -1)
#2 "else" block (may be -1).
Each block is either a single statement ending in ";" or multiple surrounded by "{...}"
(a 'then' without an else could be given a "else ;" to avoid the dangling else problem?)
*************************************** C_WHILE ***************************************
Generates a "while (...) <block>" loop
*************************************** C_UNTIL ***************************************
Generates a "do <block> while (!...)" loop
*************************************** C_IMP_FOR ***************************************
Generates a "for (;;) <block>" loop
#1 body
#2 name
#3 assop
#4 initial
#5 step
#6 final
*************************************** C_FOREVER ***************************************
Unbounded loop.
#1 is <block>
*************************************** C_BREAK ***************************************
Output a C 'break;' statement. Hopefully no issues with other forms of 'break' in C - c 'switch() {...}' would
have been an issue but we don't use that in our style of conversion to C.
*************************************** C_CONTINUE ***************************************
Output a C 'continue;' statement. C always jumps to the same place in a loop (not sure if it is the start or
the end - it matters which when converting %while ... %cycle;%repeat and %cycle; %repeat %until ... as one of
them might not jump to the test according to the C definition that I saw.
A discouraged form of IMP loop - %while C1 %cycle ; ... ; %repeat %until C2 may also be problematic! Will both
conditions be tested in C. Depends how thar construct is translated.
*************************************** C_MACHINE_CODE_INSTR ***************************************
Embed machine code in C. C does support this but there is some ambiguity in some versions of IMP as to whether
the *OPC_OPD statement ends as a semicolon and whether unbalanced single-character constants in the machine code
#1 text of instr. (Remove trailing \n if there is one)
*************************************** C_PRINTSTRING ***************************************
The actual 'print string' perm routine will be used for calls to printstring, but if the old-style %printtext is
called, this will be used to output it.
#1 'sqstring'
*************************************** C_INCLUDEFILE ***************************************
%include "file"
#1 filename
*************************************** C_INCLUDEMODULE ***************************************
%from Library %include "module"
#1 lib name
#2 filename
*****************************************************************************************************************/
DefineCAST(C_DECLARE_SWITCH, XX, "", "DECLARE_SWITCH" ,"")
DefineCAST(C_DECLARE_SCALAR, XX, "", "DECLARE_SCALAR" ,"")
DefineCAST(C_DECLARE_ARRAY, XX, "", "DECLARE_ARRAY" ,"")
DefineCAST(C_DECLARE_RECORDFORMAT, XX, "", "DECLARE_RECORDFORMAT" ,"")
DefineCAST(C_DECLARE_REGISTER, XX, "", "DECLARE_REGISTER" ,"")
DefineCAST(C_TYPE_INT, XX, "", "TYPE_INT" ,"")
#define C_TYPE_INT_unsigned_byte 1
#define C_TYPE_INT_signed_byte 2
#define C_TYPE_INT_unsigned_short 3
#define C_TYPE_INT_signed_short 4
#define C_TYPE_INT_unsigned_word 5
#define C_TYPE_INT_signed_word 6
#define C_TYPE_INT_unsigned_long 7
#define C_TYPE_INT_signed_long 8
#define C_TYPE_INT_unsigned_long_long 9
#define C_TYPE_INT_signed_long_long 10
#define C_TYPE_INT_boolean 11
DefineCAST(C_TYPE_REAL, XX, "", "TYPE_REAL" ,"")
#define C_TYPE_REAL_float 11 // eg 4 bytes
#define C_TYPE_REAL_double 12 // 8
#define C_TYPE_REAL_long_double 13 // 16
// (no such thing as long long double)
DefineCAST(C_REALS_LONG, XX, "", "REALS_LONG" ,"")
DefineCAST(C_REALS_NORMAL, XX, "", "REALS_NORMAL" ,"")
DefineCAST(C_TYPE_STRING, XX, "", "TYPE_STRING" ,"")
#define C_TYPE_STRING_imp_bounded 12
#define C_TYPE_STRING_imp_star 13
#define C_TYPE_STRING_c_bounded 14
#define C_TYPE_STRING_c_star 15
DefineCAST(C_TYPE_RECORDFORMAT, XX, "", "TYPE_RECORDFORMAT" ,"")
DefineCAST(C_TYPE_RECORD_VARIANT, XX, "", "TYPE_RECORD_VARIANT" ,"")
DefineCAST(C_FORMAT, XX, "", "FORMAT" ,"")
DefineCAST(C_TYPE_ARRAY_OF, XX, "", "TYPE_ARRAY_OF" ,"")
DefineCAST(C_TYPE_POINTER_TO, XX, "", "TYPE_POINTER_TO" ,"")
DefineCAST(C_TYPE_ROUTINE, XX, "", "TYPE_ROUTINE" ,"")
DefineCAST(C_TYPE_FN, XX, "", "TYPE_FN" ,"")
DefineCAST(C_TYPE_MAP, XX, "", "TYPE_MAP" ,"")
DefineCAST(C_ALIAS, XX, "", "ALIAS" ,"")
DefineCAST(C_TYPE_PARAMETERS, XX, "", "TYPE_PARAMETERS" ,"")
DefineCAST(C_TYPE_SWITCH, XX, "", "TYPE_SWITCH" ,"")
DefineCAST(C_TYPE_RECORD_FIELD, XX, "", "TYPE_RECORD_FIELD" ,"")
DefineCAST(C_TYPE_GENERAL_NAME, XX, "", "TYPE_GENERAL_NAME" ,"")
DefineCAST(C_TYPE_PREDICATE, XX, "", "TYPE_PREDICATE" ,"")
DefineCAST(C_COMREG_XTYPE, XX, "", "COMREG_XTYPE" ,"")
// 68K-Memptr subtypes:
#define C_COMREG_XTYPE_readonly 1
#define C_COMREG_XTYPE_writeonly 2
#define C_COMREG_XTYPE_volatile 4
DefineCAST(C_TYPE_LABEL, XX, "", "TYPE_LABEL" ,"")
DefineCAST(C_COMREG, XX, "", "COMREG" ,"")
#define C_COMREG_DECLN0 0
#define C_COMREG_DECLN1 1
#define C_COMREG_DECLN2 2
#define C_COMREG_FPP_PROCEDURE_DECLARATION 3
#define C_COMREG_nnb 4 // name, names, bounds
DefineCAST(C_STORAGE, XX, "", "STORAGE" ,"")
// Storage and linkage codes may be OR-ed.
// 4 bits of storage type
#define C_STORAGE_default (1U<<3U)
#define C_STORAGE_extern (2U<<3U)
#define C_STORAGE_static (3U<<3U)
#define C_STORAGE_auto (4U<<3U) // block-local off stack - %begin blocks and procedures
#define C_STORAGE_const (5U<<3U)
#define C_STORAGE_param (6U<<3U)
#define C_STORAGE_register (7U<<3U)
#define C_STORAGE_SHIFT 3U
#define C_STORAGE_MASK 7U
#define storage(N) (((N)>>C_STORAGE_SHIFT)&C_STORAGE_MASK)
// C_LINKAGE types are for procedures
// 3 bits of linkage type
#define C_LINKAGE_internal 1U
#define C_LINKAGE_extern_imp 2U
#define C_LINKAGE_extern_system 3U // eg. calls to C
#define C_LINKAGE_extern_dynamic 4U
#define C_LINKAGE_extern_prim 5U
#define C_LINKAGE_extern_perm 6U
#define C_LINKAGE_spare 7U
#define C_LINKAGE_SHIFT 0U
#define C_LINKAGE_MASK 7U
#define linkage(N) (((unsigned int)(N)>>C_LINKAGE_SHIFT)&C_LINKAGE_MASK)
// we have two spare bits (or really 26 spare bits) - maybe reserve some for a register number?>
#define spare_field(N) ((unsigned int)(N)>>(unsigned int)(C_STORAGE_SHIFT+C_LINKAGE_SHIFT))
DefineCAST(C_CALLBACK, XX, "", "CALLBACK" ,"")
DefineCAST(C_SEQ, XX, "", "SEQ" ,"")
DefineCAST(C_NULL_STATEMENT, XX, "", "NULL_STATEMENT" ,"")
DefineCAST(C_ADD_SEMI, XX, "", "ADD_SEMI" ,"")
DefineCAST(C_ADD_COMMA_BEFORE, XX, "", "ADD_COMMA_BEFORE" ,"")
DefineCAST(C_C, XX, "", "C" ,"")
DefineCAST(C_COMMENT, XX, "", "COMMENT" ,"")
DefineCAST(C_AST_OBJECT, XX, "", "AST_OBJECT" ,"")
DefineCAST(C_PTRIDX, XX, "", "PTRIDX" ,"")
DefineCAST(C_IMPMINUSMINUS, XX, " -- ", "IMPMINUSMINUS" ,"")
DefineCAST(C_IMPPLUSPLUS, XX, " ++ ", "IMPPLUSPLUS" ,"")
DefineCAST(C_TEMPNAME, XX, "", "TEMPNAME" ,"")
DefineCAST(C_CONST_REAL, XX, "", "CONST_REAL" ,"")
DefineCAST(C_CONST_INT, XX, "", "CONST_INT" ,"")
DefineCAST(C_CONST_BIGINT, XX, "", "CONST_BIGINT" ,"")
DefineCAST(C_CONST_STRING, XX, "", "CONST_STRING" ,"")
DefineCAST(C_BRACKET, XX, "", "BRACKET" ,"")
DefineCAST(C_ABS, XX, "", "ABS" ,"")
DefineCAST(C_BINMINUS, 4, " - ", "BINMINUS" ,"")
DefineCAST(C_BINPLUS, 4, " + ", "BINPLUS" ,"")
DefineCAST(C_IDIV, 3, " / ", "IDIV" ,"")
DefineCAST(C_BITNOT, 2, " ~", "BITNOT" ,"")
DefineCAST(C_BITAND, 8, " & ", "BITAND" ,"")
DefineCAST(C_BITEXOR, 9, "^", "BITEXOR" ,"")
DefineCAST(C_BITOR, 10, "|", "BITOR" ,"")
DefineCAST(C_MUL, 3, "*", "MUL" ,"")
DefineCAST(C_RDIV, 13, " / ", "RDIV" ,"")
DefineCAST(C_SHL, 5, "<<", "SHL" ,"")
DefineCAST(C_SHR, 5, ">>", "SHR" ,"")
DefineCAST(C_UNARY_MINUS, 2, " -", "UNARY_MINUS" ,"")
DefineCAST(C_UNARY_PLUS, 2, " +", "UNARY_PLUS" ,"")
DefineCAST(C_IEXP, XX, "", "IEXP" ,"")
DefineCAST(C_REXP, XX, "", "REXP" ,"")
DefineCAST(C_LOGNOT, 2, " !", "LOGNOT" ,"")
DefineCAST(C_LOGAND, 11, " && ", "LOGAND" ,"")
DefineCAST(C_LOGOR, 12, " || ", "LOGOR" ,"")
DefineCAST(C_COMP_LT_EQ, 6, "<=", "COMP_LT_EQ" ,"")
DefineCAST(C_COMP_LT, 6, " < ", "COMP_LT" ,"")
DefineCAST(C_COMP_GT_EQ, 6, ">=", "COMP_GT_EQ" ,"")
DefineCAST(C_COMP_GT, 6, " > ", "COMP_GT" ,"")
DefineCAST(C_COMP_EQ, 7, "==", "COMP_EQ" ,"")
DefineCAST(C_COMP_NOTEQ, 7, "!=", "COMP_NOTEQ" ,"")
DefineCAST(C_COMP_EQ_ADDRESS, 7, "==", "COMP_EQ_ADDRESS" ,"")
DefineCAST(C_COMP_NOTEQ_ADDRESS, 7, "!=", "COMP_NOTEQ_ADDRESS" ,"")
DefineCAST(C_LVALUE, XX, "", "LVALUE" ,"")
DefineCAST(C_ASSIGN_VALUE, XX, "", "ASSIGN_VALUE" ,"")
DefineCAST(C_JAM_TRANSFER, XX, "", "JAM_TRANSFER" ,"")
DefineCAST(C_ASSIGN_ADDRESS, XX, "", "ASSIGN_ADDRESS" ,"")
DefineCAST(C_ASSIGN_PLUS, XX, "", "ASSIGN_PLUS" ,"")
DefineCAST(C_ASSIGN_MINUS, XX, "", "ASSIGN_MINUS" ,"")
DefineCAST(C_ASSIGN_PLUSPLUS, XX, "", "ASSIGN_PLUS" ,"")
DefineCAST(C_ASSIGN_MINUSMINUS, XX, "", "ASSIGN_MINUS" ,"")
DefineCAST(C_FUNCTION_CALL, XX, "", "FUNCTION_CALL" ,"")
DefineCAST(C_INIT, XX, "", "INIT" ,"")
DefineCAST(C_INIT_REPEATS, XX, "", "INIT_REPEATS" ,"")
DefineCAST(C_EXPR_LIST, XX, "", "EXPR_LIST" ,"")
DefineCAST(C_BRACKETED_LIST, XX, "", "BRACKETED_LIST" ,"")
DefineCAST(C_PARAMETER_LIST, XX, "", "PARAMETER_LIST" ,"")
DefineCAST(C_INDEX_LIST, XX, "", "INDEX_LIST" ,"")
DefineCAST(C_BOUNDS, XX, "", "BOUNDS" ,"")
DefineCAST(C_BOUNDSPAIR, XX, "", "BOUNDSPAIR" ,"")
DefineCAST(C_ACCESS_ARRAY_ELEMENT, XX, "", "ACCESS_ARRAY_ELEMENT" ,"")
DefineCAST(C_ACCESS_RECORD_FIELD, XX, "", "RECORD_FIELD" ,"")
DefineCAST(C_ADDRESS, XX, "", "ADDRESS" ,"")
DefineCAST(C_ACCESS_THROUGH_PERCENTNAME, XX, "", "ACCESS_THROUGH_PERCENTNAME" ,"")
DefineCAST(C_NAME, XX, "", "NAME" ,"")
DefineCAST(C_SCALAR, XX, "", "SCALAR" ,"")
DefineCAST(C_CONCAT, XX, "", "CONCAT" ,"")
DefineCAST(C_STR_RES, XX, "", "STR_RES" ,"")
DefineCAST(C_COND_STR_RES, XX, "", "COND_STR_RES" ,"")
DefineCAST(C_STR_MATCH, XX, "", "STR_MATCH" ,"")
DefineCAST(C_STR_ASSIGN, XX, "", "STR_ASSIGN" ,"")
DefineCAST(C_STRING_LITERAL, XX, "", "STRING_LITERAL" ,"")
DefineCAST(C_ON_EVENT_BLOCK, XX, "", "ON_EVENT_BLOCK" ,"")
DefineCAST(C_ONE_FAULT, XX, "", "ONE_FAULT" ,"")
DefineCAST(C_FAULT_GROUP, XX, "", "FAULT_GROUP" ,"")
DefineCAST(C_SIGNAL, XX, "", "SIGNAL" ,"")
DefineCAST(C_MONITOR, XX, "", "MONITOR" ,"")
DefineCAST(C_STOP, XX, "", "STOP" ,"")
DefineCAST(C_GOTO, XX, "", "GOTO" ,"")
DefineCAST(C_SWITCH_LABEL_COLON, XX, "", "SWITCH_LABEL_COLON" ,"")
DefineCAST(C_SWITCH_LABEL_DEST, XX, "", "SWITCH_LABEL_DEST" ,"")
DefineCAST(C_SWITCH_LABEL_DEFAULT, XX, "", "SWITCH_LABEL_DEFAULT" ,"")
DefineCAST(C_ALPHANUMERIC_LABEL_COLON, XX, "", "ALPHANUMERIC_LABEL_COLON" ,"")
DefineCAST(C_NAME_LABEL_DEST, XX, "", "NAME_LABEL_DEST" ,"")
DefineCAST(C_NUMERIC_LABEL_COLON, XX, "", "NUMERIC_LABEL_COLON" ,"")
DefineCAST(C_NUMERIC_LABEL_DEST, XX, "", "NUMERIC_LABEL_DEST" ,"")
DefineCAST(C_MAIN_PROGRAM_BLOCK, XX, "", "MAIN_PROGRAM_BLOCK" ,"")
DefineCAST(C_NESTED_BLOCK, XX, "", "NESTED_BLOCK" ,"")
DefineCAST(C_PROCEDURE_BLOCK, XX, "", "PROCEDURE_BLOCK" ,"")
DefineCAST(C_STATEMENT_BLOCK, XX, "", "STATEMENT_BLOCK" ,"")
DefineCAST(C_RESULT, XX, "", "RESULT" ,"") // #1 is assop (missing lhs) ... -1 for "return" with no result value.
DefineCAST(C_END_OF_PERM, XX, "", "END_OF_PERM" ,"")
DefineCAST(C_END_OF_PRIM, XX, "", "END_OF_PRIM" ,"")
DefineCAST(C_END_OF_LIST, XX, "", "END_OF_LIST" ,"")
DefineCAST(C_START_OF_LIST, XX, "", "START_OF_LIST" ,"")
DefineCAST(C_END_OF_MCODE, XX, "", "END_OF_MCODE" ,"")
DefineCAST(C_START_OF_MCODE, XX, "", "START_OF_MCODE" ,"")
DefineCAST(C_TRUSTED_PROGRAM, XX, "", "TRUSTED_PROGRAM" ,"")
DefineCAST(C_MAIN_EP, XX, "", "MAIN_EP" ,"")
DefineCAST(C_CONTROL, XX, "", "CONTROL" ,"")
DefineCAST(C_DIAGNOSE, XX, "", "DIAGNOSE" ,"")
DefineCAST(C_OPTIONS, XX, "", "OPTIONS" ,"")
DefineCAST(C_68K_AT, XX, "", "68K_AT" ,"")
DefineCAST(C_SPEC_ALIAS, XX, "", "SPEC_ALIAS" ,"")
DefineCAST(C_SPEC68K, XX, "", "SPEC68K" ,"")
DefineCAST(C_68K_ENTRY_ADDRESS, XX, "", "68K_ENTRY_ADDRESS" ,"")
DefineCAST(C_SPEC, XX, "", "SPEC" ,"")
DefineCAST(C_SHORT_ROUTINE, XX, "", "SHORT_ROUTINE" ,"")
DefineCAST(C_IF, XX, "", "IF" ,"")
DefineCAST(C_UNLESS, XX, "", "UNLESS" ,"")
DefineCAST(C_THEN_ELSE, XX, "", "THEN_ELSE" ,"")
DefineCAST(C_WHILE, XX, "", "WHILE" ,"")
DefineCAST(C_UNTIL, XX, "", "UNTIL" ,"")
DefineCAST(C_IMP_FOR, XX, "", "IMP_FOR" ,"")
DefineCAST(C_FOREVER, XX, "", "FOREVER" ,"") // #1 is <block>
DefineCAST(C_BREAK, XX, "", "BREAK" ,"")
DefineCAST(C_CONTINUE, XX, "", "CONTINUE" ,"")
DefineCAST(C_MACHINE_CODE_INSTR, XX, "", "MACHINE_CODE_INSTR" ,"")
DefineCAST(C_PRINTSTRING, XX, "", "PRINTSTRING" ,"")
DefineCAST(C_INCLUDEFILE, XX, "", "INCLUDEFILE" ,"")
DefineCAST(C_INCLUDEMODULE, XX, "", "INCLUDEMODULE" ,"")
DefineCAST(C_unused2, XX, "", "unused2" ,"")
DefineCAST(C_spare1, XX, "", "spare1" ,"") // top-level of a %recordformat ... %or ... %or ...
// first item is the first recordformat definition,
// second is the index to the next definition, etc.
DefineCAST(C_spare2, XX, "", "spare2" ,"")
// list of fields in a top-level recordformat or a sub-record.
// First item is a SEQ of (astp of <XTYPE>, astp of <RECFMT-ELMNT>), second is link to next C_RECORDFORMATFIELD item.
// Compiling these (in the middle of compiling the record format itself) should output the fields at the proper place.
// Be careful about recursion when compiling the saved links!
DefineCAST(C_FOLDremoved, XX, "", "FOLD" ,"")
// #1 expr - C_FOLD not being used. Only needed in C_SWITCH_LABEL_COLON where folding is already done implicitly.
// need to rething C_FOLD - use Constant_c() at compile() stage instead. symbol table info lost by the time we get to out()
}
int C_TYPE_REAL_default_real_size = C_TYPE_REAL_float; // for %realslong and %realsnormal
const char *StorageName[16] = {
"error", "error", "error", "error", "error", "error", "error", "error",
"default", "extern", "static", "auto", "const", "param", "error", "error"
};
const char *LinkageName[8] = {
"error", "internal", "extern_imp", "extern_system", "extern_dynamic", "extern_prim", "extern_perm", "error"
};
// This is for escaping Imp variable names that would clash with C keywords.
// For now I'm just using case tricks to get the same effect.
// I think these are the only keywords I have to worry about.
// Library variables are a separate issue.
char *c_keywords[] = {
"asm", "auto", "bool", "break", "case", "char",
"const", "continue", "default", "do", "double", "else",
"enum", "extern", "false", "float", "for", "goto",
"if", "inline", "int", "long", "register", "return",
"short", "signed", "sizeof", "static", "struct", "switch",
"true", "typedef", "union", "unsigned", "void", "volatile",
"while",
NULL
};
int str_to_int(char *s) {
unsigned long long int i = 0ULL;
for (;;) {
int c = *s++;
if (c == '\0') return (int)i;
i = i * 10U + (c - '0');
}
}
int octstr_to_int(char *s) {
unsigned long long int i = 0ULL;
for (;;) {
int c = *s++;
if (c == '\0') return (int)i;
i = i * 8U + (c - '0');
}
}
int binstr_to_int(char *s) {
unsigned long long int i = 0ULL;
for (;;) {
int c = *s++;
if (c == '\0') return (int)i;
i = i * 2U + (c - '0');
}
}
char *CAstOPName(int castop);
void showtype(int astp) {
C("/*");
C("%s", CAstOPName(AstOP(astp)));
C("*/");
}
//#define diagnose(a) diagnose_inner(a,__LINE__)
#define diagnosewalk(astp) diagnosewalk_inner(astp, 0, 999, __LINE__)
#define diagnose(a) diagnosewalk_inner(a, 0, 2, __LINE__)
#define diagnoseline(a) diagnosewalk_inner(a, 0, 2, line)
void diagnosewalk_inner(int astp, int depth, int depth_wanted, int line);
void xxdiagnose_inner(int astp, int line) {
fprintf(stderr, "created at %d: diagnose(%d) (from line %d) -> \n", sourceline(astp), astp, line);
//fprintf(stderr, "/*** diagnose from %d: ***/ ",line);
if (astp == -1) {
fprintf(stderr, "-1 /*NULL*/\n");
return;
}
int op = AstOP(astp);
if (op < C_BASE) {
if (op < MAX_PHRASE) {
fprintf(stderr,"/*AST_%s@%d*/\n", phrasename[op],line);
} else if (AST__KW) {
fprintf(stderr,"/*AST__KW@%d*/\n", line);
} else {
fprintf(stderr,"/*AST_%d*/\n", op);
}
} else {
if (op == C_SEQ) { // a sequence of C_ records
while (op == C_SEQ) {
fprintf(stderr,"C_SEQ: ");
//diagnose_inner(leftchild(astp),line);
diagnoseline(leftchild(astp));
fprintf(stderr, " ");
astp = rightchild(astp); op = AstOP(astp);
}
} else {
fprintf(stderr,"C_");
if (op >= C_BASE && op <= C_LAST) {
fprintf(stderr,"%s",CAST[op-C_BASE].name);
} else {
fprintf(stderr,"#%d",op);
}
fprintf(stderr," from line %d", line);
}
fprintf(stderr,"<end of diagnose>\n");
}
}
char *CAstOPName(int castop);
// Append an item to a linked list of type <ctype>:
#define append_to_type(ctype, list, item) append_to_type_inner(ctype, list, item, __LINE__)
void append_to_type_inner(int ctype, int *list, int item, int line) { // meant to be appending two lists, but seems to be appending a bare item to the list in places
int stopper = 0;
if (*list == -1) {
if (item == -1) return;
*list = ctuple(ctype, item, -1);
return;
}
if (item == -1) return; // end of list should already be -1.
int head = *list;
while (rightchild(head) != -1) {
if (AstOP(head) != ctype) {
fprintf(stderr, "Cannot append an AstOP: %s\n", CAstOPName(AstOP(head)));
fprintf(stderr, "to a list of ctype: %s\n", CAstOPName(ctype));
assert(AstOP(head) == ctype);
}
head = rightchild(head); stopper += 1;
if (stopper == 16*1024) {
// I put this in 'just in case', and was (pleasantly?) surprised when it did actually catch a loop. So it stays.
warn("Is it really likely that there are 16K items in a list, or do we have a loop? Called from line %d", line);
}
}
assert(head != -1);
assert(rightchild(head) == -1);
if (AstOP(item) == ctype) {
rightchild(head) = item;
} else {
rightchild(head) = ctuple(ctype, item, -1);
}
}
// Append an item to the default type of linked list, using C_SEQ links:
#define append_to(list, item) append_to_inner(list, item, __LINE__)
void append_to_inner(int *list, int item, int line) {
append_to_type_inner(C_SEQ, list, item, line);
}
//#define sym_init(s) sym_init_inner(s, __LINE__)
//static void sym_init_inner(symbol *Sym, int line) {
// fault("Legacy code at line %d\n", line);
//}
//FILE *coverage;
// We get a callback at the close of every scope for local objects that are expiring.
void compile_callback(char *tablename, char *entryname, int entrydata, void *userdata) {
//fprintf(stderr, "Callback: %s %s %d %p\n", tablename, entryname, entrydata, userdata);
// for now, only interested in %switch statements
if (strcmp(tablename, "Switches") == 0) append_to((int *)userdata, ctuple(C_CALLBACK, str_to_pool(tablename), str_to_pool(entryname), entrydata));
}
int seqlist = -1; // for use in callback
int compile_init(void) {
//coverage = fopen("/home/gtoal/src/compilers101/new-parser/imps/COVERAGE.txt", "a");
//if (!coverage) coverage = fopen("/home/gtoal/src/compilers101/new-parser/imps/COVERAGE.txt", "w");
// Once %include is handled properly, we might pre-load all compilations with '%include "prims.inc"'
Init_CAST();
OUTFILE = stdout; // for now
NULLFILE = fopen("/dev/null", "w");
if (CAST[MAX_C-1].idx != C_LAST) {
fprintf(stderr, "Probably forgot to add the string to the CAST[] array for the latest op to be added.\n");
assert(CAST[MAX_C-1].idx == C_LAST /* Did you forget to add an element to the CAST[] array? */);
// could also check the indexes of all the array elements in case
// any get swapped over when I finally get around to tidying C_* ...
}
if (imp_option_trace >= 3) C("#define USE_IMP_TRACING %d\n", imp_option_trace);
C("#include <perms.h>\n");
C_Zero = ctuple(C_CONST_INT, str_to_pool("0"), 0);
C_One = ctuple(C_CONST_INT, str_to_pool("1"), 1);
install_callback(&compile_callback, &seqlist);
}
int compile_terminate(void) {
remove_callback();
//if (coverage) fclose(coverage); coverage = NULL;
if (NULLFILE) fclose(NULLFILE); NULLFILE = NULL;
}
void fault (const char *format, ...) /* Does not return */
{
va_list args;
int retval;
fprintf(stderr, "\n* ");
va_start (args, format);
retval = vfprintf (stderr, format, args);
va_end (args);
fprintf(stderr, "\n");
exit(0);
}
void warn (const char *format, ...) /* Returns */
{
va_list args;
int retval;
fprintf(stderr, "\n? ");
va_start (args, format);
retval = vfprintf (stderr, format, args);
va_end (args);
fprintf(stderr, "\n");
}
char *CAstOPName(int castop) {
#define MAX_OPNames 2
static int next = 0;
static char Mess[MAX_OPNames][128]; // as many as are likely to be evaluated in a single parameter list!
next = (next+1)%MAX_OPNames;
if (castop >= C_BASE && castop <= C_LAST) {
sprintf(Mess[next], "C_%s", CAST[castop-C_BASE].name);
} else if (castop >= 0 && castop < MAX_PHRASE) {
sprintf(Mess[next], "AST_%s (NOT a C_* object)", phrasename[castop]);
} else sprintf(Mess[next], "Bad C_AST op #%d (did you give an astp as param, not an astop?)", castop);
return Mess[next];
#undef MAX_OPNames
}
int hack(char *s, int line) {
fault("TO DO: %s at line %d", s, line);
return 0;
}
#define TO_DO(s) hack(s,__LINE__)
#define IGNORABLE_TO_DO(s) ctuple(C_TO_DO, str_to_pool(s), __LINE__)
int CPRIO(int c_astop) {
return CAST[c_astop-C_BASE].prio;
}
char *COPERATOR(int c_astop) {
if (CAST[c_astop-C_BASE].op[0] == '\0') {
warn("No operator string for %s", CAstOPName(c_astop));
}
return CAST[c_astop-C_BASE].op;
}
#define name_to_cstr(name) S_inner(name, __LINE__)
char *S_inner(int name_c, int line) {
if (name_c == -1) fault("name_to_cstr() was called with a parameter of -1");
if (AstOP(name_c) != C_NAME) {
fprintf(stderr, "* Found this instead of a C_NAME: ");
diagnose(name_c);
fprintf(stderr, " ( called from line %d ) ", line);
assert(AstOP(name_c) == C_NAME); // #1 = stringpool index, #2 = astp of <NAME> or perhaps -1.
}
return pool_to_str(leftchild(name_c));
}
int Typed(int castp, int typep) {
Typefield(castp) = typep; // this is a new hidden field I recently added to all ast objects,
return castp; // to allow me to return a type with the compiled object.
}
// If operands are all constant, then fold the expression and return a CONST ctuple,
// otherwise return -1 to let the caller know the expression is not constant.
// We only fold integer expressions so that they can be used in situations such as
// array bounds or switch labels.
//REMOVED: static int switch_hack = 0;
#define IntConstant_c(castp) IntConstant_c_inner(castp, __LINE__)
int IntConstant_c_inner(int castp, int line) {
// parameter must be a C_* tree Returns a folded C_CONST_... record or -1 if not foldable.
// final (non-internal) result *should* be a C_INT_CONST tuple, or -1 if not a constant.
// IntConstant_c() does not print the folded constant expression, it merely passes up
// the replacement simplified expression to the caller.
int castop = CAstOP(castp);
if (castp == -1) {
warn("constant(-1) at line %d?", line);
return castp;
}
//fprintf(stderr, "IntConstant_c(%s@%d):%d at line %d\n", CAstOPName(castop), castp, castop, line);
switch (castop) {
case C_NAME: // *** UNLESS *** it is a constinteger and the value is known.
{
int name = castp;
if (name == -1) return -1;
char *names = name_to_cstr(name);
int lvalue_decl = lookup("Declarations", names);
if (lvalue_decl == -1) return -1;
if (debug_scope) fprintf(stderr, "Successfully looked up %s -> %d\n", names, lvalue_decl);
if (AstOP(lvalue_decl) == C_DECLARE_SCALAR) {
// Now look for a "%const %integer" etc.
// #1 name #2 %sex #3 pointer to(ie %name) (or -1) #4 arrayname #5 C_TYPE... #6 initialisation
int storage_class, percent_name, arrayname, base_xtype, initialisation;
detuple(lvalue_decl, C_DECLARE_SCALAR, /*name*/NULL, &storage_class, &percent_name, &arrayname, &base_xtype, &initialisation);
if (percent_name != -1 || arrayname != -1) {
//fprintf(stderr, "Eliminated because either %%name or %%arrayname\n");
return -1;
}
if (AstOP(base_xtype) != C_TYPE_INT) {
//fprintf(stderr, "Eliminated because not C_TYPE_INT (was %d)\n", AstOP(base_xtype));
return -1;
}
if (leftchild(storage_class) != C_STORAGE_const) return -1;
int subtype, init, folded, percent_name2;
detuple(base_xtype, C_TYPE_INT, NULL, &subtype, &init, &folded, &percent_name2);
//fprintf(stderr, "subtype %d\n", subtype);
//fprintf(stderr, "initialisation %d\n", initialisation);
//fprintf(stderr, "init %d\n", init);
//fprintf(stderr, "folded %d\n", folded);
// decl init: #1 = type of assignment to use (empty ctuple of type C_ASSIGN_VALUE or C_JAM_TRANSFER), #2 = EXPR_LIST.
// #3 lower bound or -1, #4 upper bound or -1
int expr;
if (initialisation == -1) return -1;
detuple(initialisation, C_INIT, NULL, &expr, NULL, NULL);
if (AstOP(expr) == C_EXPR_LIST) {
int cnst = IntConstant_c(leftchild(expr));
if (cnst != -1) {
assert(AstOP(cnst) == C_CONST_INT);
// #1 string rep #2 int val (32 bits) #3 unfolded expr
child(cnst,3) = castp;
}
return cnst;
}
return -1;
#ifdef NEVER
// #1 <name or -1> #2 precision/signedness #3 initialisation C_AST or -1 #4 canonical folded value of %const, or -1
#define C_TYPE_INT_unsigned_byte 1
#define C_TYPE_INT_signed_byte 2
#define C_TYPE_INT_unsigned_short 3
#define C_TYPE_INT_signed_short 4
#define C_TYPE_INT_unsigned_word 5 <--
#define C_TYPE_INT_signed_word 6
#define C_TYPE_INT_unsigned_long 7 <--
#define C_TYPE_INT_signed_long 8
#define C_TYPE_INT_unsigned_long_long 9 <--
#define C_TYPE_INT_signed_long_long 10 <--
#endif
}
//fprintf(stderr, "which is NOT a C_DECLARE_SCALAR\n");
return -1;
}
case C_INIT:
return IntConstant_c(rightchild(castp));
case C_EXPR_LIST:
assert(rightchild(castp) == -1); // a %constinteger nl=10 has only one expression on the RHS.
// - we're not handling const arrays here yet.
return IntConstant_c(leftchild(castp));
case C_SCALAR:
{
/* Can only be part of a constant expression if it is a constinteger and we can determine the value... */
C("/*SCALAR VARIABLE*/");
}
return -1;
case C_CONST_STRING:
{
return -1; // wrong place for this conversion
char *s = pool_to_str(leftchild(castp));
int value = 0;
for (;;) {
int c = *s++;
if (c == '\0') break;
value = (value << 8) | (c&255);
if (!isprint(c&255)) fault("Bad ASCII constant: '%s'", pool_to_str(leftchild(castp)));
}
char num[64];
sprintf(num, "%d", value);
return ctuple(C_CONST_INT, str_to_pool(num), value); // for now
}
case C_CONST_REAL: // although real expressions can be folded, they're not needed for switch labels or the few other places where we are folding.
return -1;
//case C_FOLD:
case C_BRACKET:
return IntConstant_c(leftchild(castp));
case C_CONST_INT:
{
// folding a constant like 'A' or 0x'CAFE' converts it into a plain decimal number e.g. suitable for use as a switch label!
return castp; // already good. The 'switch hack' with negative numbers has been removed.
}
case C_ABS:
case C_UNARY_MINUS:
case C_UNARY_PLUS:
case C_BITNOT:
case C_LOGNOT:
{
int lhs = leftchild(castp);
if ((lhs=IntConstant_c(lhs)) >= 0) {
int sum;
char str[24];
// FOLD!
switch (castop) {
case C_ABS: sum = abs(rightchild(lhs)); break;
case C_UNARY_MINUS: sum = -rightchild(lhs); break;
case C_UNARY_PLUS: sum = +rightchild(lhs); break;
case C_BITNOT: sum = ~rightchild(lhs); break;
case C_LOGNOT: sum = !rightchild(lhs); break;
}
sprintf(str, "%0d", sum);
return ctuple(C_CONST_INT, str_to_pool(str), sum);
} else {
return -1;
}
}
// BINARY OPERATIONS:
case C_MUL:
case C_IDIV:
//case C_RDIV:
case C_SHL:
case C_SHR:
case C_IEXP:
//case C_REXP:
case C_LOGAND:
case C_LOGOR:
case C_COMP_LT_EQ:
case C_COMP_LT:
case C_COMP_GT_EQ:
case C_COMP_GT:
case C_COMP_EQ:
case C_COMP_NOTEQ:
case C_BINPLUS:
case C_BINMINUS:
case C_BITEXOR:
case C_BITOR:
case C_BITAND:
{
int lhs = leftchild(castp);
int rhs = rightchild(castp);
if ((lhs=IntConstant_c(lhs)) >= 0 && (rhs=IntConstant_c(rhs)) >= 0) {
int sum;
char str[24];
// FOLD!
switch (castop) {
case C_BINPLUS: sum = rightchild(lhs) + rightchild(rhs); break;
case C_BINMINUS: sum = rightchild(lhs) - rightchild(rhs); break;
case C_BITEXOR: sum = rightchild(lhs) ^ rightchild(rhs); break;
case C_BITOR: sum = rightchild(lhs) | rightchild(rhs); break;
case C_BITAND: sum = rightchild(lhs) & rightchild(rhs); break;
case C_MUL: sum = rightchild(lhs) * rightchild(rhs); break;
case C_IDIV: sum = (int)(rightchild(lhs) / rightchild(rhs)); break;
//case C_RDIV: sum = rightchild(lhs) / rightchild(rhs); break;
case C_SHL: sum = rightchild(lhs) << rightchild(rhs); break;
case C_SHR: sum = rightchild(lhs) >> rightchild(rhs); break;
#define iexp(n,p) ({ int tot = 1; int mul = p; while (mul-- > 0) tot *= n; tot; })
case C_IEXP: sum = iexp(rightchild(lhs), rightchild(rhs)); break;
//case C_REXP: sum = rexp(rightchild(lhs), rightchild(rhs)); break;
case C_LOGAND: sum = rightchild(lhs) && rightchild(rhs); break;
case C_LOGOR: sum = rightchild(lhs) || rightchild(rhs); break;
case C_COMP_LT_EQ: sum = rightchild(lhs) <= rightchild(rhs); break;
case C_COMP_LT: sum = rightchild(lhs) < rightchild(rhs); break;
case C_COMP_GT_EQ: sum = rightchild(lhs) >= rightchild(rhs); break;
case C_COMP_GT: sum = rightchild(lhs) > rightchild(rhs); break;
case C_COMP_EQ: sum = rightchild(lhs) == rightchild(rhs); break;
case C_COMP_NOTEQ: sum = rightchild(lhs) != rightchild(rhs); break;
}
sprintf(str, "%0d", sum);
return ctuple(C_CONST_INT, str_to_pool(str), sum);
} else {
return -1;
}
}
default:
fprintf(stderr, "MISSING FOLD OPERATOR %s (%d) IN IntConstant_c(): @C_AST:%d at line %d\n",
CAstOPName(castop), castop, castp, line);
// and these silently cause failure:
case C_FUNCTION_CALL:
case C_CONCAT:
case C_COND_STR_RES:
case C_ACCESS_THROUGH_PERCENTNAME:
case C_COMP_EQ_ADDRESS:
case C_COMP_NOTEQ_ADDRESS:
case C_STRING_LITERAL:
case C_PARAMETER_LIST:
case C_BRACKETED_LIST:
case C_INDEX_LIST:
case C_COMREG:
case C_AST_OBJECT:
return -1;
}
}
#include "ast_to_str.c" // code to convert an AST pointer to a string. (getstr())
// Should parameterise it to allow selecting just the canonical text vs
// literal text + whitespace vs literal text only vs canonical text + whitespace...
#define STRING_LITERAL_to_C_int_const(astp,vp) STRING_LITERAL_to_C_int_const_inner(astp,vp,__LINE__)
char *STRING_LITERAL_to_C_int_const_inner(int litp, int *valuep, int line) {
#define value (*valuep)
if (AstOP(litp) != C_STRING_LITERAL) {
//diagnose_inner(litp,line);
diagnoseline(litp);
assert(AstOP(litp) == C_STRING_LITERAL);
}
int stringpool_index;
detuple(litp, C_STRING_LITERAL, &stringpool_index);
char *str_lit = pool_to_str(stringpool_index);
//fprintf(stderr, "STRING_LITERAL_to_C_int_const_inner: %s\n", str_lit);
static char quoted_literal[1024+10], *q; // enough for 255 escaped '\'s
value = 0;
q = quoted_literal;
*q++ = '\'';
while (*str_lit != '\0') {
int c = *str_lit++;
value = (value << 8) | (c&255);
if (c == '\'') {
*q++ = '\\';
*q++ = c;
} else if (c == '\\') {
*q++ = '\\';
*q++ = '\\';
} else if (c == '\n') {
*q++ = '\\';
*q++ = 'n';
} else if (c == '\r') {
*q++ = '\\';
*q++ = 'r';
} else if (c == '\t') {
*q++ = '\\';
*q++ = 't';
} else if (c == '\v') {
*q++ = '\\';
*q++ = 'v';
} else if (c == '\b') {
*q++ = '\\';
*q++ = 'b';
} else if (c == '\f') {
*q++ = '\\';
*q++ = 'f';
} else if (c == '\a') {
*q++ = '\\';
*q++ = 'a';
} else if (c == '\e') {
*q++ = '\\';
*q++ = 'e';
} else {
*q++ = c;
}
}
*q++ = '\''; *q = '\0';
#undef value
return quoted_literal;
}
char *STRING_LITERAL_to_C_string(int litp) {
char *str_lit = pool_to_str(litp);
static char quoted_literal[1024+10], *q; // enough for 255 escaped '\'s
char *lit = str_lit;
for (;;) {
char *lit2 = strstr(lit, "\'\'");
if (lit2 == NULL) break;
memmove(lit2, lit2+1, strlen(lit2+1)+1); // safe move with overlapping - remove one of a set of doubled quotes
lit = lit2+1;
}
// there's some redundant code handling single-quoted strings in places. And I haven't even started on double-quoted strings yet.
q = quoted_literal;
*q++ = '"';
while (*str_lit != '\0') {
int c = *str_lit++;
if (c == '"') {
*q++ = '\\';
*q++ = c;
} else if (c == '\\') {
*q++ = '\\';
*q++ = '\\';
} else if (c == '\n') {
*q++ = '\\';
*q++ = 'n';
} else if (c == '\r') {
*q++ = '\\';
*q++ = 'r';
} else if (c == '\t') {
*q++ = '\\';
*q++ = 't';
} else if (c == '\v') {
*q++ = '\\';
*q++ = 'v';
} else if (c == '\b') {
*q++ = '\\';
*q++ = 'b';
} else if (c == '\f') {
*q++ = '\\';
*q++ = 'f';
} else if (c == '\a') {
*q++ = '\\';
*q++ = 'a';
} else if (c == '\e') {
*q++ = '\\';
*q++ = 'e';
} else {
*q++ = c;
}
}
*q++ = '"'; *q = '\0';
return quoted_literal;
}
void UNUSED(char *what) {
fprintf(stderr, "(void)compile(%s) *was* called.\n", what);
exit(0);
}
void C(const char *format, ...) {
va_list args;
int retval;
va_start (args, format);
retval = vfprintf (OUTFILE, format, args);
va_end (args);
// to do: test retval and report error eg on output filesystem full
(void)retval;
}
#define STATEMENT_BLOCK(astp) STATEMENT_BLOCK_inner(astp, __LINE__)
int STATEMENT_BLOCK_inner(int astp, int line) {
// Conditionally wrap a sequence of statements with C braces '{ ... }'
// so that it looks like a single statement, for use in flow control constructs
// including if, while, etc. Not a scope block as far as Imp is concerned.
// Must insert a null statement (i.e. output a semicolon) if block is empty.
// in hindsight - this call is all that is needed, we don't need C_STATEMENT_BLOCK as well -
// by the time it is output, we can just use a standard C block. No conditionals needed.
if (astp == -1) return ctuple(C_NULL_STATEMENT); // outputs a semicolon
if (AstOP(astp) == C_STATEMENT_BLOCK) return astp; // already wrapped
//if (AstOP(astp) == C_SEQ && leftchild(astp) == -1 && rightchild(astp) == -1) return ctuple(C_NULL_STATEMENT);
while (astp != -1 && AstOP(astp) == C_SEQ && rightchild(astp) == -1) astp = leftchild(astp);
if (AstOP(astp) == C_SEQ) {
//if (rightchild(astp) != -1) {
// return ctuple(C_STATEMENT_BLOCK, ctuple(C_SEQ, ctuple(C_C, str_to_pool("/* INSTRUCTION SEQUENCE */")), ctuple(C_SEQ, astp, -1)));
return ctuple(C_STATEMENT_BLOCK, astp);
//}
}
return astp; // single instructions *should* come through here. and don't need to be wrapped.
// return ctuple(C_STATEMENT_BLOCK, ctuple(C_SEQ, ctuple(C_C, str_to_pool("/* SINGLE INSTRUCTION */")), ctuple(C_SEQ, astp, -1)));
}
#define Declare(name, decl) Declare_inner(name, decl, __LINE__)
void Declare_inner(int name, int decl, int line) {
//
//
//
char *names = name_to_cstr(name);
if (strncmp(CAstOPName(AstOP(decl)), "C_TYPE_", 7) != 0) {
// We should only be adding type information to the symbol tables.
warn("Declare(%s, %s) at scope %d <- %d at line %d\n", names, CAstOPName(AstOP(decl)), current_scope, decl, line);
}
//void *lookup_with_scope(char *table_name, char *entry_name, int *scope_level)
int prev_scope_level = -1;
int previous_declaration = lookup_with_scope("Declarations", names, &prev_scope_level);
if (previous_declaration == -1) { // or previous_declaration != -1 and declaration is at an enclosing level, and the previous declaration was also a recordformat
if (AstOP(decl) == C_DECLARE_RECORDFORMAT) { // #1 recordformat (C_TYPE_RECORDFORMAT) #2 C_SPEC or -1
//
// TO DO:
// Because Imp77 allows %recordformat RF(%integer I, %record (RF) %name next)
// without a preceding %recordformatspec RF, we need to explicitly add one when generating
// C code, because C does not allow typedef struct RF {int i; RF *next; } RF
// when RF has not already been spec'd by: typedef struct RF RF;
//
// Related:
// recordformat RF can only contain a %record(RF)%name xxx, not a record(RF) xxx
// (unless RF refers to a record format of the same name but an enclosing scope,
// in which case it is not referring to itself)
}
}
if (previous_declaration != -1 && prev_scope_level == current_scope) {
warn("Possible duplicate declaration %s - but may just have been a %%spec followed by a body, so let's check...", names);
// unless the previous declaration is a %spec for this one.
// Also the params have to match up.
if (AstOP(decl) == AstOP(previous_declaration)) {
// OK so far - replace spec with actual
if (AstOP(decl) == C_DECLARE_RECORDFORMAT) { // #1 recordformat (C_TYPE_RECORDFORMAT) #2 C_SPEC or -1
int new_decl = child(decl,1); // C_TYPE_RECORDFORMAT = #1 <record name or -1> #2 record format name #3 field list of C_TYPE_RECORD_FIELD
int old_spec = child(previous_declaration,1);
if (child(old_spec,3) == -1) {
// Good. previous was a spec.
fprintf(stderr, "Good. previous decl of this name was a %%spec\n");
if (strcmp(name_to_cstr(child(new_decl,2)), name_to_cstr(child(old_spec,2)))==0) { // compare C_NAME strings. C_NAME tuples won't be the same. string pool indexes *should* be the same but seems they're not. A problem for another day.
// format names match :-)
fprintf(stderr, "... and the names match\n");
// so re-use original spec placeholder
// ... and there is a problem. By updating the original spec in-place,
// the C generator outputs the patched version twice - the unwanted copy replacing the spec.
// So I am updating the code so that the spec is *marked* as the spec, and the body
// version is added rather than replacing the spec. Any searches for the procedure or record format
// will match the second version since the entries with a scope are scanned (I hope) in reverse order. (confirm?)
// (at least the scopes themselves are definitely examined most recent first, obviously.)
// I think the 'proper' solution would have been to have a 'spec' field in C_DECLARE_RECORDFORMAT, and
// add that to the code body list but don't store it in the symbol table data. Unfortunately, the concept
// of having a _DECL tuple which points to the C_TYPE_ tuple for any given type was only implemented
// for %recordformats so far, *not* for %routines. This *may* have to change to make all data types
// consistent. But so far I think recordformats and procedures are the only objects with matching %specs
// that need to be handled in this manner.
// OK... the fact that we can't add the same name twice in the current scope settles the matter: we need
// to add C_TYPE_DECLARE_PROCEDURE <C_TYPE_ROUTINE> <is_spec?> or -1
// ^ (also C_TYPE_FN/C_TYPE_MAP/C_TYPE_PREDICATE)
// and modify C_DECLARE_RECORDFORMAT (renamed as C_TYPE_DECLARE_FORMAT) to add an <is_spec> or -1 parameter.
//int added_successfully = add_entry("Declarations", names, decl); // returns FALSE if already exists in this scope.
//if (!added_successfully) {
// fault("failure to add declaration should not have happened");
// }
//return;
// removed...
child(old_spec,3) = child(new_decl,3);
fprintf(stderr, "%s updated in situ.\n", names);
return;
} else {
diagnose(child(new_decl,2));
diagnose(child(old_spec,2));
fault("record format names differ. So why did lookup() think they matched? this: %s prev: %s", name_to_cstr(child(new_decl,2)), name_to_cstr(child(old_spec,2)));
}
} else { // not a recordformat - might be a procedure...
//fault("duplicate record format declaration. child(old_spec,3) = %d\n", child(old_spec,3));
}
} else {
// else check other types - base xtypes or maybe strings - but I think only records can be spec'ed, so probably all are errors (name already declared)
// (except maybe procedures which also have %specs)
}
fprintf(stderr, ":=) decl and spec match - %s\n", CAstOPName(AstOP(decl)));
int added_successfully = add_entry("Declarations", names, decl); // returns FALSE if already exists in this scope.
if (!added_successfully) {
// to do: fault("failure to add declaration should not have happened");
}
} else {
warn("name previously declared for different type");
}
} else {
int added_successfully = add_entry("Declarations", names, decl); // returns FALSE if already exists in this scope.
if (!added_successfully) {
fault("failure to add declaration should not have happened");
}
}
}
int NameOf(int astp) {
for (;;) {
if (AstOP(astp) == C_NAME) return astp;
if (AstOP(astp) == C_BRACKETED_LIST ||
AstOP(astp) == C_PARAMETER_LIST ||
AstOP(astp) == C_INDEX_LIST) { // #1 object this hangs off #2 actual parameter #3 rest of actual parameter list (another C_PARAMETER_LIST)
astp = child(astp,1);
if (astp != -1) continue;
} else if (AstOP(astp) == C_ACCESS_RECORD_FIELD) {
// <parent> _ <whatever> -> -1 slot for parent, then <whatever>. Both C_ objects
astp = child(astp,1);
if (astp != -1) continue;
}
fprintf(stderr, "NameOf(%d) <%s>: Can't find the corresponding <NAME>", astp, CAstOPName(AstOP(astp)));
diagnose(astp);
return -1;
}
}
int new_switch(char *name, int declp, int low, int high);
void mark_switch_case_used(char *names, int val);
void mark_switch_default_used(char *names);
int is_pointer(int astp) { // MUST BE CALLED DURING 'compile()', not 'out', due to symbol table lifetime.
for (;;) {
if (AstOP(astp) == C_TYPE_POINTER_TO) {
return TRUE;
}
if (AstOP(astp) == C_ADDRESS) {
return TRUE;
}
//if (AstOP(astp) == C_ACCESS_RECORD_FIELD) { // No - type of LVALUE is type of the evential subfield.
// int ispointer;
// detuple(astp, C_ACCESS_RECORD_FIELD, NULL, NULL, &ispointer);
// return ispointer;
//}
if (AstOP(astp) == C_DECLARE_SCALAR) {
int pointer_to, arrayname;
// #1 name #2 %sex #3 pointer to(ie %name) (or -1) #4 arrayname #5 C_TYPE... #6 initialisation
// an 'arrayname' is always 1-D (at least as a parameter). Treat it as a dopevector container for now (ie like a struct)
detuple(astp, C_DECLARE_SCALAR, NULL, NULL, &pointer_to, &arrayname, NULL, NULL);
if (pointer_to != -1 || arrayname != -1) {
//fprintf(stderr, "TRUE: is_pointer(C_DECLARE_SCALAR): "); diagnose(astp);
return TRUE;
} else {
//fprintf(stderr, "FALSE: is_pointer(C_DECLARE_SCALAR): "); diagnose(astp);
return FALSE;
}
}
if (AstOP(astp) == C_DECLARE_ARRAY) {
//fprintf(stderr, "PUNT: is_pointer(C_DECLARE_ARRAY): "); diagnose(astp);
// #1 name #2 %sex #3 <BOUNDS> #4 C_TYPE... #5 init
astp = child(astp,4);
continue;
}
if (AstOP(astp) == C_TYPE_MAP) {
//fprintf(stderr, "TRUE: is_pointer(C_TYPE_MAP): "); diagnose(astp);
return TRUE;
}
if (AstOP(astp) == C_BRACKETED_LIST ||
AstOP(astp) == C_PARAMETER_LIST ||
AstOP(astp) == C_INDEX_LIST
) { // #1 object this hangs off #2 actual parameter #3 rest of actual parameter list (another C_PARAMETER_LIST)
//fprintf(stderr, "PUNT: is_pointer(C_PARAMETER_LIST): "); diagnose(astp);
astp = child(astp,1);
continue;
}
if (AstOP(astp) == C_TYPE_ARRAY_OF) {
/*
#define C_TYPE_ARRAY_OF 11102 // #1 <name or -1>
// #2 C_type of array element
// #3 dimensionality
// #4 dopevector or -1
// #5 array type (ie one of Hamish's funny ones)
// #6 bounds: lower bound upper bound <more bounds>
// #7 init data depends on column-major or row-major implementation...
*/
//fprintf(stderr, "PUNT: is_pointer(C_TYPE_ARRAY_OF): "); diagnose(astp);
astp = child(astp,2);
continue;
}
if (AstOP(astp) == C_TYPE_POINTER_TO) {
// #1 <name or -1> #2 object pointed to (<C_TYPE_...>) { %name variable or parameter }
//fprintf(stderr, "TRUE: is_pointer(C_TYPE_POINTER_TO): "); diagnose(astp);
return TRUE;
//astp = child(astp,2);
//return FALSE;
}
if (AstOP(astp) == C_NAME) {
int name_c = astp;
char *names = name_to_cstr(name_c);
int decl_c = lookup("Declarations", names);
//fprintf(stderr, "Looking up declaration %s returned %d\n", names, decl_c);
if (decl_c == -1) {
//fprintf(stderr, "FALSE: is_pointer(NAME): -1\n");
return FALSE;
}
//fprintf(stderr, "PUNT: is_pointer(NAME): "); diagnose(decl_c);
astp = decl_c;
continue;
}
//fprintf(stderr, "FALSE: is_pointer(other): "); diagnose(astp);
return FALSE;
}
}
#define get_address_of(astp) get_address_of_inner(astp, __LINE__)
int get_address_of_inner(int astp, int line) {
if (AstOP(astp) == C_ADDRESS) {
//fprintf(stderr, "C_ADDRESS(C_ADDRESS(...)) at line %d\n", line);
return astp;
}
if (is_pointer(astp)) {
//fprintf(stderr, "C_ADDRESS(already a pointer) at line %d\n", line);
return astp;
}
return ctuple(C_ADDRESS, astp);
}
#ifdef USE_INCLUDED_EXPRESSIONS_C
#include "expressions.c"
#else
/*
replacement code and data structures for Imp expression evaluation...
ctuples for an operator are a pair of <C_ and descriptor> - the descriptor
may be a declaration symbol but it could also be the same information for
an expression, constructed bottom-up, to allow type-checking at the top,
or appropriate casting for assignments/jam transfers etc.
Calls to:
ctuple(C_FUNCTION_CALL, name, param)
are now being replaced by calls to:
build_call(C_FUNCTION_CALL, name, param)
which modifies the param list as the function call AST is built, depending on whether address or value is wanted.
What we should be doing... a <NAME> should never make it through to the finished CAST.
A name in the AST should be evaluated by one of these:
Evaluate_NAME:
Evaluate_Expression
Evaluate_Value
Evaluate_Address
Evaluate_RT_Call(RT)
Evaluate_Fn_or_Pred_Call(FN)
Evaluate_Map_Call(MAP)
Evaluate_Array_Element(RA)
Evaluate_Array_NameElement(RA)
Evaluate_ArrayName(RA)
Evaluate_Parameters(FPP, APP) (linked list of formal and actual parameters which would be stepped through together)
Evaluate_Value_Assignment(Dest, Source, assignment_type)
Evaluate_Address_Assignment(Dest, Source, assignment_type)
Evaluate_Fn_or_Pred_Result(Source, assignment_type)
Evaluate_Map_Result(Source)
Evaluate_Procedure_as_a_parameter
*/
#define CAstOP(x) AstOP(x)
#ifdef NEVER
int debug_new_exprs = 1;
char *CAstOPName(int castop) {
return CAST[castop-C_BASE].name;
}
#endif
char *AstOPName(int astop) {
return phrasename[astop];
}
void debug_record_type(int astp, int depth);
void output_c_expression(int castp) {
if (debug_new_exprs) fprintf(stderr, "output_c_expression: @C_AST:%d\n", castp);
if (castp < 0) {
return;
}
int castop = CAstOP(castp);
switch (castop) {
default:
fprintf(stderr, "MISSING CAST OPERATOR C_%s IN output_c_expression: @C_AST:%d\n",
CAstOPName(castop),
castp);
return;
}
}
int samename(int name1, int name2) {
char *names1, *names2;
if (name1 == name2) {
fprintf(stderr, "%s vs %s - fast match\n", name_to_cstr(name1),name_to_cstr(name2));
return 1;
}
names1 = name_to_cstr(name1); names2 = name_to_cstr(name2);
if (strcmp(names1,names2) == 0) {
fprintf(stderr, "%s vs %s - match\n", names1,names2);
return 1;
} else {
fprintf(stderr, "%s vs %s - no match\n", names1,names2);
return 0;
}
}
int same(int astp1, int astp2) {
// Initially just check it is a simple type such as C_TYPE_INT and the names match.
// Later tweaks can handle more complex expressions.
// Note must return FALSE if it is a proc/fn/map with side-effects.
if (AstOP(astp1) == C_NAME && AstOP(astp2) == C_NAME) {
// just the text name, no extra info. #1 = stringpool index, #2 = astp of <NAME> or perhaps -1.
if (leftchild(astp1) == -1 || leftchild(astp2) == -1) {
if (rightchild(astp1) == -1 || rightchild(astp2) == -1) return FALSE;
return rightchild(astp1) == rightchild(astp2);
} else {
if (leftchild(astp1) == leftchild(astp2)) return TRUE; // assuming stringpool works
//fprintf(stderr, "Compare %s vs %s\n", pool_to_str(leftchild(astp1)), pool_to_str(leftchild(astp2)));
if (strcmp(pool_to_str(leftchild(astp1)), pool_to_str(leftchild(astp2))) == 0) return TRUE; // assuming stringpool doesn't work :-(
}
}
return FALSE;
}
int build_call(int op, int name, int param) {
#ifdef NEVER
// We need to get the type information for the parameters to procedure 'name'
// and modify the param list depending on whether the parameter takes a value or a %name
//
char *names = name_to_cstr(name);
int decl_c = lookup("Declarations", names);
// #1 name #2 spare #3 parameter list (C_TYPE_PARAMETERS) #4 body #5 alias or -1
int name2, result_type, fpp, spec_or_body, alias, sex, linkage;
int storage_class, linkage_class;
if (AstOP(decl_c) == C_TYPE_ROUTINE ||
AstOP(decl_c) == C_TYPE_FN ||
AstOP(decl_c) == C_TYPE_MAP ||
AstOP(decl_c) == C_TYPE_PREDICATE)
detuple(decl_c, AstOP(decl_c), &name2, &result_type, &fpp, &spec_or_body, &alias, &sex);
else {
diagnose(decl_c);
fault("build_call: passed a bad CAST type.");
}
assert(AstOP(name2) == C_NAME);
fprintf(stderr, "Build %s call: type=%s name=%s/%s\n", CAstOPName(AstOP(decl_c)), CAstOPName(op), names,name_to_cstr(name2));
// Now we loop though fpp and match up the actual parameters...
while (fpp != -1) {
int thisparam, paramname; // not used to generate code, but we'll use it in diagnostics
detuple(fpp, C_TYPE_PARAMETERS, ¶mname, &thisparam, &fpp);
fprintf(stderr, " param %s: \n",paramname == -1 ? "" : name_to_cstr(paramname));
diagnose(thisparam);
}
#endif
return ctuple(op, name, param);
}
int cform_assignment(int astp) {
int left1, left2, right, constright, newop, newop2;
detuple(astp, C_ASSIGN_VALUE, &left1, &right);
if (AstOP(right) == C_BINPLUS) {
detuple(right, C_BINPLUS, &left2, &right);
newop = C_ASSIGN_PLUS; newop2 = C_ASSIGN_PLUSPLUS;
} else if (AstOP(right) == C_BINMINUS) {
detuple(right, C_BINMINUS, &left2, &right);
newop = C_ASSIGN_MINUS; newop2 = C_ASSIGN_MINUSMINUS;
} else return astp;
if (same(left1,left2)) {
if (AstOP(right) == C_BRACKET) right = leftchild(right);
constright = IntConstant_c(right);
if (constright != -1 && AstOP(constright) == C_CONST_INT && child(constright,2) == 1) { // #1 string rep #2 int val (32 bits)
return ctuple(newop2, left1);
}
return ctuple(newop, left1, right); // if right is redundantly bracketed, safe to remove the backets
} else if (same(left1,right)) {
if (AstOP(left2) == C_BRACKET) left2 = leftchild(left2);
constright = IntConstant_c(left2);
if (constright != -1 && AstOP(constright) == C_CONST_INT && child(constright,2) == 1) {
return ctuple(newop2, left1);
}
return ctuple(newop, left1, left2); // if right is a const int == 1 safe to mod to PLUSPLUS/MINUSMINUS (newop2)
}
return astp;
}
#define VALUE_WANTED 0
#define ADDRESS_WANTED 1
int recompile_record_field(int recordtype_c, int list_of_fields, int field_c, int is_pointer) {
int i;
int rfname, first_decln, this_decl, more_decls;
if (list_of_fields != -1) {
assert(AstOP(list_of_fields) == C_TYPE_RECORD_FIELD);
this_decl = list_of_fields;
for (;;) {
int field_name, field_type, percent_name, next_field;;
detuple(this_decl, C_TYPE_RECORD_FIELD, &field_name, NULL, &field_type, &percent_name, &next_field);
//for (i = 0; i < depth*3; i++) fprintf(stderr, " ");
fprintf(stderr, " %s %s%s\n", name_to_cstr(field_name), percent_name==-1?"":"*", CAstOPName(AstOP(field_type)));
if (samename(field_name, rightchild(field_c))) {
// build a ctuple with '->' or '.' and the field.
return ctuple(C_ACCESS_RECORD_FIELD, recordtype_c, field_c, is_pointer); // still do do: stuff following record field...
}
if (AstOP(field_type) == C_TYPE_RECORDFORMAT) {
// Follow actual records, *not* recordnames...
//if (percent_name == -1) debug_record_type(field_type, depth+1);
}
if (next_field == -1) break;
// looks like there aren't any more.
// more_decls was a list of C_SEQ items containing a single C_TYPE_RECORD_FIELD in each,
// when in fact it should have been built using a C_TYPE_RECORD_FIELD list instead.
}
warn("Field not present in record format");
return -1; // not found!
}
/// otherwise we need to locate the list of fields from the record declaration:
detuple(recordtype_c, C_TYPE_RECORDFORMAT, NULL, &rfname, &first_decln); // #1 <record name or -1> #2 record format name #3 field list of C_TYPE_RECORD_FIELD
//for (i = 0; i < depth*3; i++) fprintf(stderr, " ");
//fprintf(stderr, "Record: %s depth=%d first_decln=%d\n", name_to_cstr(rfname), depth, first_decln);
more_decls = first_decln;
while (AstOP(more_decls) == C_SEQ) {
detuple(more_decls, C_SEQ, &this_decl, &more_decls);
//for (i = 0; i < depth*3; i++) fprintf(stderr, " ");
fprintf(stderr, " %s\n", CAstOPName(AstOP(this_decl)));
if (AstOP(this_decl) != C_TYPE_RECORD_FIELD) {
diagnose(this_decl); // -> C_TYPE_RECORDFORMAT why?
return -1;
//assert(AstOP(this_decl) == C_TYPE_RECORD_FIELD);
}
// C_TYPE_RECORD_FIELD =
// #1 field name
// #2 field offset if known relative to start of current record, or -1 (for later)
// #3 type: field type could be a basic type, or a C_TYPE_RECORD_VARIANT list
// #4 %name?
// #5 next <C_TYPE_RECORD_FIELD> or -1
for (;;) {
int field_name, field_type, percent_name, next_field;;
detuple(this_decl, C_TYPE_RECORD_FIELD, &field_name, NULL, &field_type, &percent_name, &next_field);
//for (i = 0; i < depth*3; i++) fprintf(stderr, " ");
fprintf(stderr, " %s %s%s\n", name_to_cstr(field_name), percent_name==-1?"":"*", CAstOPName(AstOP(field_type)));
if (samename(field_name, rightchild(field_c))) {
// build a ctuple with '->' or '.' and the field.
return ctuple(C_ACCESS_RECORD_FIELD, recordtype_c, field_c, is_pointer); // still do do: stuff following record field...
}
if (AstOP(field_type) == C_TYPE_RECORDFORMAT) {
// Follow actual records, *not* recordnames...
//if (percent_name == -1) debug_record_type(field_type, depth+1);
}
if (next_field == -1) break;
// looks like there aren't any more.
// more_decls was a list of C_SEQ items containing a single C_TYPE_RECORD_FIELD in each,
// when in fact it should have been built using a C_TYPE_RECORD_FIELD list instead.
}
if (more_decls == -1) break;
}
}
#define compile_expression(astp, extra_parameter, address_wanted) compile_expression_inner(astp, extra_parameter, address_wanted, __LINE__)
int compile_expression_inner(int astp, int extra_parameter, int address_wanted, int line);
// The evaluate function below is OK for assignments (left and right sides) but it is *not* yet suitable for evaluation of parameters,
// because Proc(1, fred) is ambiguous: 'fred' could be a call to parameterless function fred, or it could be passing a pointer to the
// function Fred, to be called within the body of Proc. Without the type info for Proc's parameter list, we don't know which to generate.
// This can probably be handled transparently in 'build_call()'. If not, then we need another procedure to evaluate parameters.
#define evaluate_subfield(astp, fieldlist) evaluate_subfield_inner(astp, fieldlist, __LINE__)
int evaluate_subfield_inner(int astp, int fieldlist, int line); // alt 1: <NAME> <Opt-PARAMETERS-OR-POINTERINDEX> <Opt-SUBFIELD>
#define evaluate_recordfield(astp, recordtype) evaluate_recordfield_inner(astp, recordtype, __LINE__)
int evaluate_recordfield_inner(int astp, int fieldtype, int line); // alt 1: <NAME> <Opt-PARAMETERS-OR-POINTERINDEX> <Opt-SUBFIELD>
// This is a top-level <NAME> object which may or may not have a record field hanging off it. If it does, that field will be
// evaluated using evaluate_recordfield.
int evaluate_toplevel_lvalue_inner(int astp, int line) { // alt 1: <NAME> <Opt-PARAMETERS-OR-POINTERINDEX> <Opt-SUBFIELD>
#define evaluate_toplevel_lvalue(astp) evaluate_toplevel_lvalue_inner(astp, line)
int address_wanted = 0; // TEMP. Might have to reintroduce this (or 'value_wanted') as a parameter.
int astop = AstOP(astp); assert(astop == AST_SUBFIELD || astop == AST_RECORDFIELD || astop == AST_LVALUE);
int alt = Alt0(astp); assert(alt == 0);
int count = AST[astp+AST_count_offset]; assert(count == 3);
int name_c, param_c, lvalue_c, lvalue_decl, field_ast;
char *name_s;
name_c = compile_expression(child(astp,1), -1, VALUE_WANTED); assert(AstOP(name_c) == C_NAME);
param_c = compile_expression(child(astp,2), -1, VALUE_WANTED);
field_ast = child(astp,3); // don't compile yet
lvalue_c = name_c;
name_s = name_to_cstr(lvalue_c);
// top-level lvalue object
lvalue_decl = lookup("Declarations", name_s); // locate name using lookup(), get type of name
if (AstOP(lvalue_decl) == C_TYPE_PARAMETERS) {
// one extra level of indirection before we know what the type is...
// a type passed in as a parameter is *almost* the same as a local declaration of a variable of that type
lvalue_decl = child(lvalue_decl,2); // - I forget what is significantly different, but can come back to it later.
}
if (AstOP(lvalue_decl) == C_DECLARE_SCALAR) {
// #1 name #2 %sex #3 pointer to(ie %name) (or -1) #4 arrayname #5 C_TYPE... #6 initialisation
int name, storage_class, percent_name, arrayname, base_xtype;
detuple(lvalue_decl, C_DECLARE_SCALAR, &name, &storage_class, &percent_name, &arrayname, &base_xtype, NULL);
// Q: Is there a 'scalar access' tuple or was I just using C_NAME?
// A: Sort of... I *have* just been using C_NAME for simple scalars.
// However there are C_LVALUE and C_SYMBOL tuples available that I could use.
// (They were both used for some purpose or other before but they stopped being
// used at some point during development and are now free for reuse.)
// So... I'll save C_LVALUE for use as an actual LVALUE and will rename
// C_SYMBOL as C_SCALAR for use with simple variables. It would be preferable
// to using C_NAME all over the place as C_NAME is really for any kind of tag/variable name.
lvalue_c = ctuple(C_SCALAR, name, storage_class, percent_name, arrayname, base_xtype);
// NOTE something like ian(3) (where 'ian' is an integer arrsay name variable) might come through here rather than via C_DECLARE_ARRAY
} else if (AstOP(lvalue_decl) == C_DECLARE_ARRAY) {
// #1 name #2 %sex #3 <BOUNDS> #5 C_TYPE... #5 init
int name, storage_class, bounds, base_xtype, initialisation;
detuple(lvalue_decl, C_DECLARE_ARRAY, &name, &storage_class, &bounds, &base_xtype, &initialisation);
// TO DO: Handle the array indexing here, and set up lvalue_decl as the type of the indexed object
AstOP(param_c) = C_INDEX_LIST; // now we know that the bracketed part of name(...) is array indexing
lvalue_c = ctuple(C_ACCESS_ARRAY_ELEMENT, name_c, param_c);
Typefield(lvalue_c) = base_xtype;
} else if (AstOP(lvalue_decl) == C_TYPE_ROUTINE ||
AstOP(lvalue_decl) == C_TYPE_FN ||
AstOP(lvalue_decl) == C_TYPE_MAP ||
AstOP(lvalue_decl) == C_TYPE_PREDICATE) {
// C_TYPE_ROUTINE - #1 name #2 -1 (void) #3 parameter list (C_TYPE_PARAMETERS) #4 body or spec or -1 #5 alias or -1 #6 %sex
// C_TYPE_FN - #1 name #2 result type #3 parameter list (C_TYPE_PARAMETERS) #4 body or spec or -1 #5 alias or -1 #6 %sex
// C_TYPE_MAP - #1 name #2 result type #3 parameter list (C_TYPE_PARAMETERS) #4 body or spec or -1 #5 alias or -1 #6 %sex
// C_TYPE_PREDICATE - #1 name #2 -1 (void) #3 parameter list (C_TYPE_PARAMETERS) #4 body or spec or -1 #5 alias or -1 #6 %sex
int name, base_xtype, param_list, body, alias, storage_class;
detuple(lvalue_decl, AstOP(lvalue_decl), &name, &base_xtype, ¶m_list, &body, &alias, &storage_class);
// Caution: what if param_c is a ++ or -- tuple?
if (param_c != -1) AstOP(param_c) = C_PARAMETER_LIST; // now we know the (...) is a parameter list not array indexes.
fprintf(stderr, "Procedure call %s has been generated using the new lvalue code.\n", name_s);
lvalue_c = build_call(C_FUNCTION_CALL, lvalue_c, param_c);
if (AstOP(lvalue_decl) == C_TYPE_ROUTINE) {
// This is just a procedure call. No result value. Cannot have a record field.
// Might as well handle it here and be done with it.
if (AstOP(param_c) == C_PTRIDX || AstOP(param_c) == C_IMPPLUSPLUS || AstOP(param_c) == C_IMPMINUSMINUS)
fault("%%routine %s cannot be modified by pointer indexing", name_s);
if ((Alt0(field_ast) != 1))
fault("%%routine %s cannot have record fields attached", name_s);
return Typed(lvalue_c, lvalue_decl);
}
// otherwise a fn/map/pred call *or* passing a fn/map/pred as a parameter!
if (AstOP(param_c) == C_PTRIDX || AstOP(param_c) == C_IMPPLUSPLUS || AstOP(param_c) == C_IMPMINUSMINUS) {
warn("Unimplemented feature - pointer indexing of %s", name_s);
}
} else {
// lvalue_decl is already a base type such as C_TYPE_INT (amost certainly got here via a parameter type)
Typefield(lvalue_c) = lvalue_decl;
}
if (Alt0(field_ast) != 1) { // not the null option
fprintf(stderr, "Looking for a record field to evaluate...\n");
// scalars, array elements, fn calls and map calls can all return a %record or %recordname object,
// which we can recursively attach a subfield to. Need to check the type of the parent object here,
// especially since it is needed in order to confirm the field name is valid.
// NOTE: field_ast is an *Opt-RECORDFIELD* not a *RECORDFIELD*. The actual recordfield is the 3rd item in the AST tuple:
int field_c = evaluate_recordfield(child(field_ast,3), lvalue_decl); // top-level record field hangs off a typed object, not a field list
lvalue_decl = Typefield(field_c);
child(field_c,1) = lvalue_c;
child(field_c,3) = -1; // need an is_pointer parameter;
lvalue_c = field_c;
}
lvalue_c = Typed(lvalue_c, lvalue_decl);
//fprintf(stderr, "// >>>>-------------------- RETURNING -------------------\n");
//diagnosewalk(lvalue_c);
//fprintf(stderr, "// ====---------------------- C-CODE --------------------\n");
//{FILE *push = stdout; stdout = stderr;out(lvalue_c);stdout = push;}
//fprintf(stderr, "\n// <<<<---------------------- DONE ----------------------\n");
return lvalue_c;
}
// This record field hangs off the top-level lvalue object. The presence or absence of the named field
// has to be checked against the top-level recordformat of the parent object, and the passed-back-up
// result type-matched to it also.
// It is up to the parent as to whether this is a "." field or a "->" one.
// This record field may be an array element or a fn/map call, and if that element or fn/map result is
// a record, it may have a record field hanging off it as well, depending on the value of <Opt-SUBFIELD>.
// If it does, that field will be evaluated by evaluate_subfield, and the list of allowed subfields
// has to be passed to that procedure in a field list as a parameter.
int evaluate_recordfield_inner(int astp, int recordtype, int line) { // alt 1: <NAME> <Opt-PARAMETERS-OR-POINTERINDEX> <Opt-SUBFIELD>
int address_wanted = 0; // TEMP. Might have to reintroduce this as a parameter.
int recordformat, fieldlist, variantlist, field_or_variant_list;
// #1 name #2 %sex #3 pointer to(ie %name) (or -1) #4 arrayname #5 C_TYPE... #6 initialisation
detuple(recordtype, C_DECLARE_SCALAR, NULL, NULL, NULL, NULL, &recordformat, NULL);
// #1 <record name or -1> #2 record format name #3 field list of C_TYPE_RECORD_FIELD (or C_TYPE_RECORD_VARIANTs ?)
detuple(recordformat, C_TYPE_RECORDFORMAT, NULL, NULL, &field_or_variant_list);
// ^^^^^^^^^^
// TO DO: if fieldlist is showing up as a C_TYPE_RECORDFORMAT then we're probably looking at a variant record, which is not yet handled.
// As mentioned in a comment at the top of this file, the best solution might be to put the variant details in the record format declaration
// (C_DECLARE_RECORDFORMAT), but to merge all the variants in the stored/retrieved recordformat (C_TYPE_RECORDFORMAT) itself.
// The conversion to C doesn't really use the fact that there's a variant involved after it has output the declaration.
// As a *short term* hack to get through the test suite, I'll ... (do what???)
// ***NOTE*** C_TYPE_RECORD_VARIANT is not currently set up by anything. It *should* be an alternative to a C_TYPE_RECORD_FIELD
if (AstOP(field_or_variant_list) == C_TYPE_RECORDFORMAT) {
// first of a sequence of various record formats - as a hack, I'll merge them all here...? Although it would make more sense to merge at source
fprintf(stderr, "C_TYPE_RECORDFORMAT third field: ");diagnosewalk(field_or_variant_list);
// third field: @ 14920 { 2242}: C_TYPE_RECORDFORMAT [line=6999] [type=-1] [#1] = -1, [#2] = 15289 (C_SEQ), [#3] = 13829 (C_SEQ)
// the recordformat name field should not be a C_SEQ. I'm getting confused as to what the heck is in here.
fault("needs a fix");
#ifdef NEVER
int combined_field_list = -1;
variantlist = field_or_variant_list;
for (;;) {
detuple(recordformat, C_TYPE_RECORDFORMAT, NULL, NULL, &fieldlist);
append(combined_field_list, fieldlist);
detuple(variantlist, C_TYPE_RECORDFORMAT, NULL, NULL, &variantlist);
}
fieldlist = combined_field_list;
#endif
} else if (AstOP(field_or_variant_list) == C_SEQ) {
// normal list of fields
fieldlist = field_or_variant_list;
} else {
fault("Unexpected AST type for a record format\n");
}
//int astop = AstOP(astp); assert(astop == AST_SUBFIELD || astop == AST_RECORDFIELD || astop == AST_LVALUE);
//int alt = Alt0(astp); assert(alt == 0);
//int count = AST[astp+AST_count_offset]; assert(count == 3);
int name_c, param_c, lvalue_c, lvalue_decl, field_ast;
char *name_s;
// '<NAME>' below is the field we're trying to compile. Don't get distracted by the other
// parts of the object. We'll handle those recursively, later. For now we just want to confirm that
// <NAME> is a field of the parent record, and determine what type it is.
// alt 1: <NAME> <Opt-PARAMETERS-OR-POINTERINDEX> <Opt-SUBFIELD>
name_c = compile_expression(child(astp,1), -1, VALUE_WANTED); assert(AstOP(name_c) == C_NAME);
param_c = compile_expression(child(astp,2), -1, VALUE_WANTED);
field_ast = child(astp,3); // don't compile yet
lvalue_c = name_c;
name_s = name_to_cstr(lvalue_c);
int this_decl, next = fieldlist;
int field_name, field_type, percent_name, next_field;
for (;;) {
char *field_s;
// It looks like we have a C_SEQ of recordfields. What we should have is a single recordfield
// which contains a 'next' pointer to the next recordfield. If the generation of this data
// is fixed, this code here has to be fixed too, to agree with it. Meanwhile I've set up an
// assertion (below) to catch changes.
detuple(next, C_SEQ, &lvalue_decl, &next); assert(AstOP(lvalue_decl) == C_TYPE_RECORD_FIELD);
detuple(lvalue_decl, C_TYPE_RECORD_FIELD, &field_name, NULL, &field_type, &percent_name, &next_field); assert(next_field == -1);
field_s = name_to_cstr(field_name);
if (strcmp(name_s, field_s) == 0) break; // found!
if (next == -1) {
diagnosewalk(fieldlist);
fault("%s is not a field of this record", name_s);
}
}
fprintf(stderr, "Record field %s identified as a %s\n", name_s, CAstOPName(AstOP(field_type)));
// return the record field here - parent will be filled in by caller.
lvalue_c = ctuple(C_ACCESS_RECORD_FIELD, -/*parent*/1, field_name, -/*PENDING*/1); // #1 parent #2 child #3 is pointer? ('->' vs '.')
// TO DO!!!: now add subfield
return Typed(lvalue_c, field_type);
}
int evaluate_subfield_inner(int astp, int fieldlist, int line) { // alt 1: <NAME> <Opt-PARAMETERS-OR-POINTERINDEX> <Opt-SUBFIELD>
// If fieldlist is -1, we are evaluating a record field from some parent record, *not* a top-level lvalue object.
int address_wanted = 0; // TEMP. Might have to reintroduce this as a parameter.
int astop = AstOP(astp); assert(astop == AST_SUBFIELD || astop == AST_RECORDFIELD || astop == AST_LVALUE);
int alt = Alt0(astp); assert(alt == 0);
int count = AST[astp+AST_count_offset]; assert(count == 3);
int name_c, param_c, lvalue_c, lvalue_decl, field_ast;
char *name_s;
name_c = compile_expression(child(astp,1), -1, VALUE_WANTED); assert(AstOP(name_c) == C_NAME);
param_c = compile_expression(child(astp,2), -1, VALUE_WANTED);
field_ast = child(astp,3); // don't compile yet
lvalue_c = name_c;
name_s = name_to_cstr(lvalue_c);
assert(AstOP(fieldlist) == C_SEQ);
int this_decl, next = fieldlist;
int field, field_type, percent_name, next_field;
do {
char *field_s;
// It looks like we have a C_SEQ of recordfields. What we should have is a single recordfield
// which contains a 'next' pointer to the next recordfield. If the generation of this data
// is fixed, this code here has to be fixed too, to agree with it. Meanwhile I've set up an
// assertion (below) to catch changes.
detuple(fieldlist, C_SEQ, &lvalue_decl, &next); assert(AstOP(lvalue_decl) == C_TYPE_RECORD_FIELD);
detuple(lvalue_decl, C_TYPE_RECORD_FIELD, &field, NULL, &field_type, &percent_name, &next_field); assert(next_field == -1);
field_s = name_to_cstr(field);
if (strcmp(name_s, field_s) == 0) break; // found!
if (next == -1) fault("%s is not a field of this record", name_s);
} while (next != -1);
fprintf(stderr, "Record field %s identified as a %s\n", name_s, CAstOPName(AstOP(field_type)));
// return the record field here - parent will be filled in by caller.
lvalue_c = ctuple(C_ACCESS_RECORD_FIELD, -/*parent*/1, field, -/*PENDING*/1); // #1 parent #2 child #3 is pointer? ('->' vs '.')
return Typed(lvalue_c, field_type);
#ifdef ABSOLUTELY_NEVER
// decode astp into <NAME> <Opt-PARAMETERS-OR-POINTERINDEX> <Opt-SUBFIELD>
// evaluate scalar or fn call or array element <Opt-PARAMETERS-OR-POINTERINDEX> into lvalue_c and get type of that evaluation
// if <Opt-SUBFIELD> (and type was a record), evaluate field recusively and plug in lvalue_c to C_ACCESS_RECORD_FIELD, make C_ACCESS_RECORD_FIELD new lvalue_c
// I realised rather late that recordfields have to be right-associative, i.e. the top of the tree is
// the final recordfield node in a tree of recordfield nodes. This is because the type of the whole
// expression is governed by the type of the final recordfield.
// It's easy enough to build the tree that way, but then the complication becomes the leftmost part
// of the variable which may be a function or map and will still require the '*' indirection or
// not depending on the assignment type. Also the address of this conglomeration is the address
// of the rightmost element regardless of how we got there... So although the '&' is applied to the
// top-level, we don't know whether it is needed or not until we get all the way to the bottom, eg
// with record_next_int vs record_next_intname
int name_c = compile_expression(child(astp,1), -1, VALUE_WANTED);
assert(AstOP(name_c) == C_NAME);
int lvalue_c = name_c;
char *names = name_to_cstr(lvalue_c);
int lvalue_decl = lookup("Declarations", names);
int ispointer;
// (top level) RECORD FIELD:
if (fieldlist != -1) {
// this is a record field, not a top-level object
// scan through C_SEQ 'extra_parameter' looking for a match against <name>, then
// evaluate any function calls or array elements in that context (though usually
// it will be a scalar or another record indirection)
// evaluate_lvalue_or_field(int astp, int parent_p, int decl) ?
}
HACKY_RESTART: // come back here if the object's type information is behind a C_TYPE_PARAMETERS tuple.
// in rewrite, use a recursive call and wrap in a pointer tuple.
ispointer = FALSE; // SHOULD reflect whether lvalue_c is a pointer to a struct or a struct itself.
if (lvalue_decl == -1) {
// Should not get here if evaluating a record field name. Should be handled by recompile_record_field()
warn("Undeclared variable or record field %s", names);
// make this a 'fault' later, after all the test suite programs have declared the variables they use :-)
diagnosewalk(name_c);
return name_c; // undeclared variable - we'll just pass 'name' through unaltered and ignore any params, indexes or subfields.
}
int param_c = compile_expression(child(astp,2), -1, VALUE_WANTED);
// could be a map parameter list *or* array indexes. They look the same so need type info to disambiguate.
// C_PTRIDX or C_IMPPLUSPLUS or C_IMPMINUSMINUS or C_PARAMETER_LIST or -1 (all -1, ...)
int field_ast = child(astp,3); // not yet compiled. We need to know context in order to compile (ie address_wanted or value_wanted?)
int field_c = -1;
int recordfields = -1; // this will hold the data structure representing the record type if the main lvalue
// we are evaluating is a record. lvalue_decl should return us a C_TYPE_RECORDFORMAT, which we will use to recognise the field and subfields.
if ((param_c == -1) && (Alt0(field_ast) == 1)) { // remember, not yet compiled, so we're looking at the parse alternatives, not the returned ctuple
// This *can* fall out in the wash by following the path below, but we'll
// special-case simple variables for speed and simplicity...
// could be fn or map ...
if (AstOP(lvalue_decl) == C_DECLARE_SCALAR) {
// #1 name #2 %sex #3 pointer to(ie %name) (or -1) #4 arrayname #5 C_TYPE... #6 initialisation
// perform type-checking here. output procedure doesn't care, just wants the name
if (address_wanted) { // BUG: see tests/test191.imp and decide if intname == lvalue is address_wanted or value_wanted on LHS...
if (child(lvalue_decl,3) != -1) {
diagnosewalk(name_c);
return name_c; // it's already a %name
}
name_c = ctuple(C_ACCESS_THROUGH_PERCENTNAME, name_c);
diagnosewalk(name_c);
return name_c;
}
if (child(lvalue_decl,3) != -1) {
name_c = ctuple(C_ACCESS_THROUGH_PERCENTNAME, name_c); // value of a %name wanted
diagnosewalk(name_c);
return name_c;
}
return name_c;
} else if (AstOP(lvalue_decl) == C_BRACKETED_LIST) {
fault("C_BRACKETED_LIST not yet handled.");
diagnosewalk(name_c);
return name_c;
} else if (AstOP(lvalue_decl) == C_PARAMETER_LIST) {
fault("C_PARAMETER_LIST not yet handled.");
diagnosewalk(name_c);
return name_c;
} else if (AstOP(lvalue_decl) == C_INDEX_LIST) {
fault("C_INDEX_LIST not yet handled.");
diagnosewalk(name_c);
return name_c;
} else if (AstOP(lvalue_decl) == C_TYPE_ROUTINE ||
AstOP(lvalue_decl) == C_TYPE_FN ||
AstOP(lvalue_decl) == C_TYPE_MAP ||
AstOP(lvalue_decl) == C_TYPE_PREDICATE) {
// #1 name #2 spare #3 parameter list (C_TYPE_PARAMETERS) #4 body or spec or -1 #5 alias or -1 #6 %sex
lvalue_c = build_call(C_FUNCTION_CALL, lvalue_c, ctuple(C_PARAMETER_LIST, lvalue_c, -1, -1));
if (address_wanted) {
if (AstOP(lvalue_decl) == C_TYPE_MAP) return lvalue_c; // it's already a %name
// What we haven't yet handled properly is passing a procedure name as a parameter
// which C allows to have a '&' in front of the name but doesn't insist on it.
// But we should not interpret one of these as a *call* to the procedure.
lvalue_c = ctuple(C_ACCESS_THROUGH_PERCENTNAME, lvalue_c);
diagnosewalk(lvalue_c);
return lvalue_c;
}
if (AstOP(lvalue_decl) == C_TYPE_MAP) {
lvalue_c = ctuple(C_ACCESS_THROUGH_PERCENTNAME, lvalue_c); // value of a %name wanted
diagnosewalk(lvalue_c);
return lvalue_c;
}
diagnosewalk(lvalue_c);
return lvalue_c;
} else if (AstOP(lvalue_decl) == C_DECLARE_ARRAY) {
warn("C_DECLARE_ARRAY not yet handled.");
// I don't think a DECLARE_* tuple should find its way here. DECLAREs should only be used
// to output the actual declaration. The type information should be separately stored in a C_TYPE_* tuple.
// So remove this branch later if it never happens.
/* (btw What would evaluate a bare arrayname without attached indexing
is arrayname == array, or passing an array as a parameter) */
diagnosewalk(name_c);
return name_c;
} else if (AstOP(lvalue_decl) == C_TYPE_PARAMETERS) {
lvalue_decl = child(lvalue_decl,2);
warn("C_TYPE_PARAMETERS not yet handled - retrying as a %s", CAstOPName(AstOP(lvalue_decl)));
// #1 name #2 C_TYPE_... #3 next <C_TYPE_PARAMETERS> or -1
goto HACKY_RESTART;
} else if (AstOP(lvalue_decl) == C_TYPE_INT) {
diagnosewalk(name_c);
return name_c;
} else if (AstOP(lvalue_decl) == C_TYPE_POINTER_TO) {
//if (value_wanted) {
if (!address_wanted) {
name_c = ctuple(C_ACCESS_THROUGH_PERCENTNAME, name_c);
diagnosewalk(name_c);
return name_c;
} else {
diagnosewalk(name_c);
return name_c;
}
} else {
warn("Simple variable type info for %s", names);
diagnose(lvalue_decl);
}
//if (value_wanted) {
if (!address_wanted) {
diagnosewalk(name_c);
return name_c;
}
name_c = ctuple(C_ACCESS_THROUGH_PERCENTNAME, name_c); // Should I be returning, instead, a ctuple(C_OBJECT, name_c, lvalue_decl) ???
// I.e. a new construct of both value and type information???
diagnosewalk(name_c);
return name_c;
}
if (param_c != -1) {
// C_PTRIDX or C_IMPPLUSPLUS or C_IMPMINUSMINUS or C_PARAMETER_LIST (etc) or -1 (all -1, ...)
// Either a fn/map or an array access...
if (leftchild(param_c) != -1) {
fprintf(stderr, "Inserting a %s record as the parent of a %s.\n", CAstOPName(AstOP(lvalue_c)), CAstOPName(AstOP(param_c)));
fprintf(stderr, "unfortunately the leftchild(param_c) is already set to:");
diagnose(param_c);
assert(leftchild(param_c) == -1);
}
if (AstOP(param_c) == C_PTRIDX) {
// TO DO!
warn("Imp 68K 'ptr[offset]' pointer indexing not yet implemented");
diagnosewalk(name_c);
return name_c;
} else if (AstOP(param_c) == C_IMPPLUSPLUS) {
// TO DO!
warn("Imp 68K 'ptr++offset' pointer indexing not yet implemented");
diagnosewalk(name_c);
return name_c;
} else if (AstOP(param_c) == C_IMPMINUSMINUS) {
// TO DO!
warn("Imp 68K 'ptr--offset' pointer indexing not yet implemented");
diagnosewalk(name_c);
return name_c;
} else if ( AstOP(param_c) == C_PARAMETER_LIST ||
AstOP(param_c) == C_BRACKETED_LIST ||
AstOP(param_c) == C_INDEX_LIST
) {
if (AstOP(lvalue_decl) == C_TYPE_FN) {
AstOP(param_c) = C_PARAMETER_LIST;
lvalue_c = build_call(C_FUNCTION_CALL, lvalue_c, param_c);
// fn and params: #1 = proc name (C_NAME), #2 = C_PARAMETER_LIST
// #1 object this hangs off #2 actual parameter #3 rest of actual parameter list (another C_PARAMETER_LIST)
if (address_wanted) warn("Cannot take address of %%function %s", names);
if (Alt0(field_ast) == 1) { // remember, not yet compiled, so we're looking at the parse alternatives, not the returned ctuple
diagnosewalk(lvalue_c);
return lvalue_c;
}
} else if (AstOP(lvalue_decl) == C_TYPE_PREDICATE) {
AstOP(param_c) = C_PARAMETER_LIST;
lvalue_c = build_call(C_FUNCTION_CALL, lvalue_c, param_c);
// fn and params: #1 = proc name (C_NAME), #2 = C_PARAMETER_LIST
// #1 object this hangs off #2 actual parameter #3 rest of actual parameter list (another C_PARAMETER_LIST)
if (address_wanted) warn("Cannot take address of %%predicate %s", names);
if (Alt0(field_ast) == 1) { // remember, not yet compiled, so we're looking at the parse alternatives, not the returned ctuple
diagnosewalk(lvalue_c);
return lvalue_c;
}
} else if (AstOP(lvalue_decl) == C_TYPE_ROUTINE) {
AstOP(param_c) = C_PARAMETER_LIST;
lvalue_c = build_call(C_FUNCTION_CALL, lvalue_c, param_c);
// #1 name #2 spare #3 parameter list (C_PARAMETER_LIST) #4 body or spec or -1 #5 alias or -1 #6 %sex
// #1 object this hangs off #2 actual parameter #3 rest of actual parameter list (another C_PARAMETER_LIST)
if (address_wanted) warn("Cannot take address of %%routine %s", names);
if (Alt0(field_ast) == 1) { // remember, not yet compiled, so we're looking at the parse alternatives, not the returned ctuple
diagnosewalk(lvalue_c);
return lvalue_c;
}
} else if (AstOP(lvalue_decl) == C_TYPE_MAP) {
AstOP(param_c) = C_PARAMETER_LIST;
lvalue_c = build_call(C_FUNCTION_CALL, lvalue_c, param_c);
// map with no parameters
// fn and params: #1 = proc name (C_NAME), #2 = C_PARAMETER_LIST
// #1 object this hangs off #2 actual parameter #3 rest of actual parameter list (another C_PARAMETER_LIST)
#ifdef NEVER
if (value_wanted) {
AstOP(lvalue_decl) = C_TYPE_FN; // subtle hack. I'll explain later.
} else {
param_c = ctuple(C_ACCESS_THROUGH_PERCENTNAME, lvalue_c);
}
#else
// Needs work. Sort out the ASSIGN_* stuff first.
//if (value_wanted) lvalue_c = ctuple(C_ACCESS_THROUGH_PERCENTNAME, lvalue_c);
if (!address_wanted) lvalue_c = ctuple(C_ACCESS_THROUGH_PERCENTNAME, lvalue_c);
#endif
if (Alt0(field_ast) == 1) { // remember, not yet compiled, so we're looking at the parse alternatives, not the returned ctuple
diagnosewalk(lvalue_c);
return lvalue_c;
}
} else if (AstOP(lvalue_decl) == C_DECLARE_SCALAR) {
// test for some kind of %name
int pointer_to, arrayname;
detuple(lvalue_decl, C_DECLARE_SCALAR, NULL, NULL, &pointer_to, &arrayname, NULL, NULL);
if (pointer_to != -1) lvalue_c = ctuple(C_ACCESS_THROUGH_PERCENTNAME, lvalue_c);
} else if (AstOP(lvalue_decl) == C_DECLARE_ARRAY) {
AstOP(param_c) = C_INDEX_LIST;
} else if (AstOP(lvalue_decl) == C_TYPE_PARAMETERS) {
warn("Parameter %s is not handled.", names);
diagnosewalk(name_c);
return name_c;
} else {
warn("Type of object (%s) for %s(...) not handled.", CAstOPName(AstOP(lvalue_decl)), names);
diagnosewalk(name_c);
return name_c;
}
leftchild(param_c) = lvalue_c; // first field of all 4 options is the object they hang off:
// C_PTRIDX or C_IMPPLUSPLUS or C_IMPMINUSMINUS or C_PARAMETER_LIST
} else {
warn("Unexpected AstOP when evaluating an lvalue: %s", CAstOPName(AstOP(param_c)));
diagnosewalk(name_c);
return name_c; // temporary.
}
lvalue_c = /* updated */ param_c;
}
if (Alt0(field_ast) == 1) { // remember, not yet compiled, so we're looking at the parse alternatives, not the returned ctuple
// NOT A RECORD WITH A FIELD.
diagnosewalk(lvalue_c);
return lvalue_c;
}
// Whatever the object was that the _field is hanging off, it is now in lvalue_c.
// NOW SUBFIELDS
// SHOULD USE recompilerecordfield() INSTEAD!
int recordformat = -1, is_spec = -1, formatname = -1; //, fieldlist = -1;
if (AstOP(lvalue_decl) == C_DECLARE_SCALAR) { // (Need another test for when lvalue is an array element)
// #1 name #2 %sex #3 pointer to(ie %name) (or -1) #4 arrayname #5 C_TYPE... #6 initialisation
int storage_class, percent_name, arrayname, base_xtype, initialisation;
detuple(lvalue_decl, C_DECLARE_SCALAR, /*name*/NULL, &storage_class, &percent_name, &arrayname, &base_xtype, NULL);
// if (arrayname != -1) ispointer = TRUE; should this test percent_name instead? fiux after basic record subfields are working
// Surely it is a bad object if it is really an arrayname...
if (AstOP(base_xtype) == C_DECLARE_RECORDFORMAT) {
// ************ POSSIBLE THAT THE WRONG CTUPLE TYPE WAS STORED? SHOULD BE C_TYPE_RECORDFORMAT ?
// C_DECLARE_RECORDFORMAT: // #1 recordformat (C_TYPE_RECORDFORMAT) #2 C_SPEC or -1
detuple(base_xtype, C_DECLARE_RECORDFORMAT, &recordformat, &is_spec);
} else {
warn("base_xtype is not a C_DECLARE_RECORDFORMAT. base_xtype = ");
diagnose(base_xtype);
return -1;
}
// zxcv *TO DO*
if (recordformat != -1) {
// #1 <record name or -1> #2 record format name #3 field list of C_TYPE_RECORD_FIELD
detuple(recordformat, C_TYPE_RECORDFORMAT, NULL, &formatname, &fieldlist);
//fprintf(stderr, "YES!!! I have a C_TYPE_RECORDFORMAT %s\n", name_to_cstr(formatname));
} else {
fprintf(stderr, "lvalue_decl: "); diagnose(lvalue_decl);
return -1;
}
} else if (AstOP(lvalue_decl) == C_DECLARE_ARRAY) { // (Need another test for when lvalue is an array element)
fault("elements of record arrays not yet handled.");
}
// ***************************************************************************************************************************
// *** if extra_parameter is not -1, use it to handle the subfield rather than looking up the format name in Declarations. ***
// ***************************************************************************************************************************
//fprintf(stderr, "fieldlist: "); diagnosewalk(fieldlist); // can't call this as we have a C_SEQ of fields... debug_record_type(fieldlist, 0);
//fprintf(stderr, "finally calling compile_expression() with the record field list as the extra parameter...\n");
field_c = compile_expression(field_ast, fieldlist, VALUE_WANTED); // C_ACCESS_RECORD_FIELD (-1(parent), field, -1 (ispointer?)) or -1
// ^ This is where the type information needs to be inserted for subfields.
// #1 parent #2 child #3 is pointer? ('->' vs '.')
child(field_c,1) = lvalue_c; // Need a recursive call using the type information for this record field in order to get elements which are array members.
child(field_c,3) = ispointer;
//fprintf(stderr, "lvalue_decl: "); diagnose(lvalue_decl);
//fprintf(stderr, "\nlvalue_c: "); diagnose(lvalue_c);
//fprintf(stderr, "\nfield_c: "); diagnose(field_c);
//fprintf(stderr, "\n");
//diagnosewalk(field_c);
return field_c;
#endif // ABSOLUTELY_NEVER
}
int compile_expression_inner(int astp, int extra_parameter, int address_wanted, int line) {
if (debug_new_exprs) fprintf(stderr, "compile_expression(@AST:%d, %d, %s) from line %d\n", astp, extra_parameter, (address_wanted ? "GET ADDRESS" : "GET VALUE"), line);
if (astp < 0) {
fprintf(stderr, "compile_expression: -1 from line %d\n", line);
return -1;
}
int value_wanted = !address_wanted;
int astop = AstOP(astp);
int alt = Alt0(astp);
int count = AST[astp+AST_count_offset];
int *A_child = &AST[astp+AST_child1_offset]; // An index into a child of the AREC, *not* a child of the AST.
// (for printing terminals with RECONSTITUTE, although it may be better
// to pass astp and let RECONSTITUTE apply AST_child1_offset)
if (astop >= C_BASE) {
fprintf(stderr, "? redundant compile_expression(C_%s,%d,%d) called from line %d\n", CAstOPName(astop), -1, VALUE_WANTED, line);
return astp; // already compiled.
}
switch (astop) {
case AST_BASIC_UI: //^\\ P<BASIC-UI> =
if (alt == 0) { //^\\ <LVALUE> <OPT-ASSIGN>;
int lvalue_c;
int assign_c = compile(child(astp,2));
if (assign_c == -1) {
assign_c = compile_expression(child(astp,1), -1, VALUE_WANTED);
} else if (AstOP(assign_c) == C_ASSIGN_VALUE) {
leftchild(assign_c) = compile_expression(child(astp,1), -1, VALUE_WANTED);
assign_c = cform_assignment(assign_c);
} else if (AstOP(assign_c) == C_ASSIGN_ADDRESS) {
leftchild(assign_c) = compile_expression(child(astp,1), -1, ADDRESS_WANTED); // ptr == var
} else if (AstOP(assign_c) == C_STR_RES) {
leftchild(assign_c) = compile_expression(child(astp,1), -1, VALUE_WANTED);
} else if (AstOP(assign_c) == C_JAM_TRANSFER) {
leftchild(assign_c) = compile_expression(child(astp,1), -1, VALUE_WANTED);
} else {
warn("Assignment is of unexpected type %s", CAstOPName(AstOP(assign_c)));
}
return ctuple(C_ADD_SEMI, assign_c);
}
case AST_OPT_ASSIGN: //^\\ P<OPT-ASSIGN> =
if (alt == 0) { //^\\ '-' '>' <STRING-RESOLUTION-EXPR>,
return ctuple(C_STR_RES, -1, compile_expression(child(astp,3), -1, VALUE_WANTED));
} else if (alt == 1) { //^\\ <ASSOP-EXPR>,
int assop_expr = compile_expression(leftchild(astp), -1, VALUE_WANTED);
assert(AstOP(assop_expr == C_ASSIGN_ADDRESS || AstOP(assop_expr) == C_ASSIGN_VALUE || AstOP(assop_expr) == C_JAM_TRANSFER));
assert(leftchild(assop_expr) == -1);
return assop_expr; // FOUND YOU, YOU BASTARD!
} else if (alt == 2) { //^\\ ;
return -1;
}
// These two parse identically but subfields are separated out from simple fields so they can be evaluated differently:
case AST_SUBFIELD: //^\\ P<SUBFIELD> =
//^\\ <NAME> <Opt-PARAMETERS-OR-POINTERINDEX> <Opt-SUBFIELD>;
if (extra_parameter == -1) {
fault("Cannot evaluate subfield without 'extra_parameter'...\n");
} else {
//fprintf(stderr, "Should be good for evaluating a <SUBFIELD>...\n");
return evaluate_subfield(astp, extra_parameter);
}
case AST_RECORDFIELD: //^\\ P<RECORDFIELD> =
//^\\ <NAME> <Opt-PARAMETERS-OR-POINTERINDEX> <Opt-RECORDFIELD>;
if (extra_parameter == -1) {
fault("Cannot evaluate recordfield without 'extra_parameter'...\n");
} else {
//fprintf(stderr, "Should be good for evaluating a <RECORDFIELD>...\n");
return evaluate_recordfield_inner(astp, extra_parameter, line);
}
case AST_LVALUE: //^\\ P<LVALUE> =
{ //^\\ <NAME> <Opt-PARAMETERS-OR-POINTERINDEX> <Opt-RECORDFIELD>;
int lvalue_c = evaluate_toplevel_lvalue(astp);
//fprintf(stderr, " lvalue: ");
//diagnosewalk(lvalue_c);
//fprintf(stderr, "--- end of lvalue\n");
return lvalue_c;
}
//^\\ # These pointer arithmetic elements are for Hamish's PDP9/15 Imp (old): INDP == INDEX0++P
//^\\ # and for Hamish's 68000 Imp: %if tp[1]_mode # litmode %then lo = minint %else lo = tp[1]_val
//^\\ # I hope this grammar definition causes the right precedence level...
//^\\ #
//^\\ # They can also be used in LVALUEs.
case AST_Opt_PARAMETERS_OR_POINTERINDEX://^\\ P<Opt-PARAMETERS-OR-POINTERINDEX> =
if (alt == 0) { //^\\ <immediate:return !in_const_initialiser_list;> '[' <EXPR> ']',
return ctuple(C_PTRIDX, -1, compile_expression(child(astp,3), -1, VALUE_WANTED));
} else if (alt == 1) { //^\\ <immediate:return !in_const_initialiser_list;> '+' '+' <EXPR>,
return ctuple(C_IMPPLUSPLUS, -1, compile_expression(child(astp,4), -1, VALUE_WANTED));
} else if (alt == 2) { //^\\ <immediate:return !in_const_initialiser_list;> '-' '-' <EXPR>,
return ctuple(C_IMPMINUSMINUS, -1, compile_expression(child(astp,4), -1, VALUE_WANTED));
} else if (alt == 3) { //^\\ <OPT-ACTUAL-PARAMETERS>;
return compile_expression(child(astp,1), -1, VALUE_WANTED); // C_PARAMETER_LIST or -1
}
//^\\ # Procedure application, i.e. actual parameters to routine or function call
case AST_OPT_ACTUAL_PARAMETERS://^\\ P<OPT-ACTUAL-PARAMETERS> =
if (alt == 0) { //^\\ <immediate:return !in_const_initialiser_list;> '(' <EXPR> <REST-OF-ACTUAL-PARAMETERS> ')',
int expr, rest;
// COULD BE '[' IF ARRAY RATHER THAN PROC. TO DO. We'll get to that later...
expr = compile_expression(child(astp,3), -1, VALUE_WANTED);
rest = compile_expression(child(astp,4), -1, VALUE_WANTED);
//cps(")");
return ctuple(C_BRACKETED_LIST, -1, expr, rest); // #1 object this hangs off #2 actual parameter #3 rest of actual parameter list (another C_PARAMETER_LIST)
} else if (alt == 1) { //^\\ ;
return -1; // no parameters
}
case AST_Opt_SUBFIELD: //^\\ P<Opt-SUBFIELD> =
//^\\ <immediate:return !in_const_initialiser_list;> '_' <SUBFIELD>,
//^\\ ;
case AST_Opt_RECORDFIELD: //^\\ P<Opt-RECORDFIELD> =
if (alt == 0) { //^\\ <immediate:return !in_const_initialiser_list;> '_' <RECORDFIELD>,
// ^
// <lvalue> at this point could maybe be a new grammar type - it's not really an lvalue and
// to build the CAST properly we need to pass information down from the top rather than building
// up from below. Might be able to make this work without too much redesign if I passed the
// uncompiled AST back up rather than the compiled CAST and postponed the calls to compile()
// until later.
// As far as I remember, my intention was that 'recordfield' was for use at the top-level, hanging off an LVALUE
// and a 'subfield' was a second- or more level record field, hanging off a parent record - the difference being
// that in the first case the parent is found by a lookup() and in the latter case, the record struct (describing
// the fields within the record) has been passed down from the parent.
int field = compile_expression(child(astp,3), /* the lvalue. At this stage we're just recording the name and mirroring the AST.
Declaration/recordfield checking and CAST comes later because the children
on the RHS require type information from the parents to be passed down. */
extra_parameter,
VALUE_WANTED);
//if (astop == AST_Opt_SUBFIELD) fprintf(stderr, "Subfield: ");
//else if (astop == AST_Opt_RECORDFIELD) fprintf(stderr, "Recordfield: ");
//else fprintf(stderr, "BUG: ");
//diagnose(field);
//fprintf(stderr, "--- end of field (2nd field in C_ACCESS_RECORD_FIELD)\n");
return ctuple(C_ACCESS_RECORD_FIELD, // need to make '_' in parent be followed by <LVALUE>
-1 /* to be filled in by parent*/,
field,
-1 /* is pointer? */); // don't know at this point if parent is record or recordname
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_SCALAR_ASSIGN: //^\\ P<SCALAR-ASSIGN> =
{
if (alt == 0) { //^\\ '=',
return ctuple(C_ASSIGN_VALUE, -1, -1);
} else if (alt == 1) { //^\\ '<' '-';
return ctuple(C_JAM_TRANSFER, -1, -1);
}
}
//^\\ # Need <EXPR> instead of <CEXPR> to catch = tostring(i) because cexpr only got tostring
//^\\ # Need '== <EXPR>' instead of '== <LVALUE>' to catch '== length(s)', i.e. a %map although it looks like a fn call.
//^\\ # - the latter being more of a failing of LVALUE that here.
//^\\ # Removed:
//^\\ # '==' <LVALUE>,
//^\\ # '=' <CEXPR>,
//^\\ # These will be improved once we have semantic checks...
//^\\ #
//^\\ # ONLY used now for initialising arrays. Should move to <Opt-Init-assign-array>
// **** NOT MAYBE TRUE. Is it being used for for-loop control?
// Idiot. It is also used in %result == lvalue ...
case AST_ASSOP:
{
if (alt == 0) { //^\\ '=' '=',
return ctuple(C_ASSIGN_ADDRESS, -1, -1);
} else if (alt == 1) { //^\\ <SCALAR-ASSIGN>;
int assign = compile_expression(leftchild(astp), -1, VALUE_WANTED); // SCALAR-ASSIGN now returns a ctuple
// P<SCALAR-ASSIGN> = '=' | '<' '-' ;
// now returns a ctuple of C_ASSIGN_VALUE or C_JAM_TRANSFER
if (AstOP(assign) == C_ASSIGN_VALUE) {
return assign;
} else if (AstOP(assign) == C_JAM_TRANSFER) {
return assign;
} else { //BUG
diagnose(assign);
fault("Internal error - unexpected C AST type %s at line %d", CAstOPName(AstOP(assign)), __LINE__);
}
}
}
//^\\ P<ASSOP-EXPR> =
//^\\ '=' '=' <LVALUE>,
//^\\ <SCALAR-ASSIGN> <EXPR>;
case AST_ASSOP_EXPR:
if (alt == 0) { // '=' '=' <LVALUE>,
// much simplified. Except where it isn't.
int result = compile_expression(child(astp, 3), -1, VALUE_WANTED);
result = get_address_of(result);
return ctuple(C_ASSIGN_ADDRESS, -1, result);
} else if (alt == 1) { // <SCALAR-ASSIGN> <EXPR>;
int assign_c = compile_expression(leftchild(astp), -1, VALUE_WANTED); // C_ASSIGN_VALUE or C_JAM_TRANSFER
int expr_c = compile_expression(rightchild(astp), -1, VALUE_WANTED);
assert(rightchild(assign_c) == -1);
rightchild(assign_c) = expr_c;
//fprintf(stderr, "RHS Expr:");
//diagnosewalk(expr_c);
//fprintf(stderr, "--- end of RHS Expr\n");
//fprintf(stderr, "Debug: expr_c <- ");diagnosewalk(expr_c);
//fprintf(stderr, "Debug: assigning @%d to rightchild(%d)\n", expr_c, assign_c);
return assign_c;
}
//^\\ # handling precedence with the grammar rather than in the usual Edinburgh-style where
//^\\ # we would parse without precedence and correct later by manipulating the AST, e.g. by
//^\\ # using the shunting-yard algorithm. I'm trading off run-time speed for code simplicity.
//^\\ # A <CEXPR> does not parse differently from an <EXPR> - it just checks after building the tree that all the
//^\\ # elements were constant and can be folded.
case AST_CEXPR: //^\\ P<CEXPR> = <guard...> <EXPR> <cancel guard...> ;
{
int expr = compile_expression(child(astp,2), -1, VALUE_WANTED);
int constval = IntConstant_c(expr);
if (constval == -1) {
if (AstOP(expr) != C_CONST_STRING) {
char source[1024];
getstr(child(astp,2), source);
warn("%s is not an integer constant", source); diagnose(astp);
}
return expr;
}
return constval;
}
// expr =
// <rest-of-expr#1>
// /
// /
// <mediumprec-expr#1>
// plus
// rest-of-expr#1 =
//
// <rest-of-expr#2>
// /
// /
// <op-low>
// / \
// / \
// -1 <mediumprec-expr#2>
// becomes
// expr =
// <op-low>
// / \
// / \
// <mediumprec-expr#1> <mediumprec-expr#2>
//
//^\\ P<EXPR> =
//^\\ <DOTTED-STRING-EXPR>,
//^\\ <MEDIUMPREC-EXPR> <REST-OF-EXPR>;
case AST_EXPR:
{
if (alt == 0) return compile_expression(leftchild(astp), -1, VALUE_WANTED); // <DOTTED-STRING-EXPR>, // because "." operator removed from regular exprs!
int left_operand = compile_expression(leftchild(astp), -1, VALUE_WANTED); // <MEDIUMPREC-EXPR>
int top_op = compile_expression(rightchild(astp), -1, VALUE_WANTED); // <REST-OF-EXPR>
int left_op = top_op;
if (top_op == -1) return left_operand;
while (leftchild(left_op) != -1) left_op = leftchild(left_op); leftchild(left_op) = left_operand;
return top_op;
}
case AST_REST_OF_EXPR:
{
if (alt == 1) return -1;
int left_op = compile_expression(leftchild(astp), -1, VALUE_WANTED); // <OP-LOW> an empty ctuple(-1,-1)
int right_operand = compile_expression(rightchild(astp), -1, VALUE_WANTED); // <MEDIUMPREC-EXPR>
int top_op = compile_expression(child(astp, 3), -1, VALUE_WANTED); // <REST-OF-EXPR>
int hole_op = top_op;
rightchild(left_op) = right_operand;
if (top_op == -1) return left_op;
while (leftchild(hole_op) != -1) hole_op = leftchild(hole_op); leftchild(hole_op) = left_op;
return top_op;
}
case AST_REAL_EXP: //^\\ P<REAL-EXP> =
if (alt == 0) { //^\\ '*' '*',
return ctuple(C_REXP, -1, -1);
} else if (alt == 1) { //^\\ '\' <!eq>,
return ctuple(C_REXP, -1, -1);
} else if (alt == 2) { //^\\ '^';
return ctuple(C_REXP, -1, -1);
}
case AST_INTEGER_EXP: //^\\ '*' '*' '*' '*', '\' '\', '^' '^';
return ctuple(C_IEXP, -1, -1);
//^\\ # highest precedence, right-associative (only exponentiation)
//^\\ #
//^\\ # I found this expression the 68000 Imp compiler:
//^\\ #
//^\\ # y = |r|+0.5/10.0^m; !modulus, rounded
//^\\ #
//^\\ # which I parse as:
//^\\ #
//^\\ # y = |r|+( 0.5 / (10.0^m)); !modulus, rounded
//^\\ #
//^\\ # I presume this is a clever way to round the last digit of a decimal,
//^\\ # but damn, how it works is beyond me.
//^\\ # Typical Hamish code! Brilliant (I presume) but obscure and uncommented.
//^\\ #
case AST_OP_HIGH_RIGHTASSOC:
if (alt == 0) { //^\\ <INTEGER-EXP>,
return compile_expression(leftchild(astp), -1, VALUE_WANTED);
} else if (alt == 1) { //^\\ <REAL-EXP>;
return compile_expression(leftchild(astp), -1, VALUE_WANTED);
}
case AST_RIGHTASSOC_EXPR_with_OP:
if (alt == 0) { //^\\ <UNARY-EXPR> <OP-HIGH-RIGHTASSOC>;
int left_operand = compile_expression(leftchild(astp), -1, VALUE_WANTED);
int op = compile_expression(rightchild(astp), -1, VALUE_WANTED);
leftchild(op) = left_operand;
return op;
}
//^\\ # <OP> is only used in <CEXPR>s now and will be removed entirely
//^\\ # once CEXPRs are recoded to use the same grammar as EXPRs.
//^\\ #
//^\\ # Note that none of these options eliminates the possibility of implementing
//^\\ # conditional compilation the EMAS Imp80 way using
//^\\ #
//^\\ # %if <CEXPR> %start
//^\\ # ! conditional code
//^\\ # %finish
//^\\ #
//^\\ # (Though I've always had questions about that on EMAS if there's a
//^\\ # label inside the block - the ability to use that construct for
//^\\ # conditional compilation depends on whether that label is ever
//^\\ # jumped to from code outside the block! - doing it properly requires
//^\\ # full flow control analysis and a transitive closure on the flow graph!)
//^\\ #
//^\\ # highest precedence, left-associative
case AST_OP_HIGH_LEFTASSOC:
if (alt == 0) { //^\\ '<' '<',
return ctuple(C_SHL, -1, -1);
} else if (alt == 1) { //^\\ '>' '>';
return ctuple(C_SHR, -1, -1);
}
//^\\ # middle-precedence operators. All left-associative.
case AST_OP_MED: //^\\ P<OP-MED> =
if (alt == 0) { //^\\ '*',
return ctuple(C_MUL, -1, -1);
} else if (alt == 1) { //^\\ '/' '/',
return ctuple(C_IDIV, -1, -1);
} else if (alt == 2) { //^\\ '/',
return ctuple(C_RDIV, -1, -1);
} else if (alt == 3) { //^\\ '&';
return ctuple(C_BITAND, -1, -1);
}
//^\\ # fortunately unary backslash is unambiguous with ERCC style exponentiation binary operator
case AST_UNARY_NOT: //^\\ P<UNARY-NOT> =
if (alt == 0) { //^\\ '\',
return ctuple(C_BITNOT, -1);
} else if (alt == 1) { //^\\ '~';
return ctuple(C_BITNOT, -1);
}
//^\\ # lowest precedence operators. All left-associative.
case AST_OP_LOW: //^\\ P<OP-LOW> =
if (alt == 0) { // '+',
return ctuple(C_BINPLUS, -1, -1);
} else if (alt == 1) { // '-',
return ctuple(C_BINMINUS, -1, -1);
} else if (alt == 2) { // '!' '!',
return ctuple(C_BITEXOR, -1, -1);
} else if (alt == 3) { // '!';
return ctuple(C_BITOR, -1, -1);
}
return TO_DO("OP_LOW dropping through by accident?");
// '.' removed.
case AST_MEDIUMPREC_EXPR: //^\\ P<MEDIUMPREC-EXPR> =
//^\\ <HIGHPREC-EXPR> <REST-OF-MEDIUMPREC-EXPR>;
{
int left_operand = compile_expression(leftchild(astp), -1, VALUE_WANTED); // <HIGHPREC-EXPR>
int top_op = compile_expression(rightchild(astp), -1, VALUE_WANTED); // <REST-OF-MEDIUMPREC-EXPR>
if (top_op == -1) return left_operand;
int hole_op = top_op;
while (leftchild(hole_op) != -1) hole_op = leftchild(hole_op); leftchild(hole_op) = left_operand;
return top_op;
}
case AST_REST_OF_MEDIUMPREC_EXPR: //^\\ P<REST-OF-MEDIUMPREC-EXPR> =
//^\\ <OP-MED> <HIGHPREC-EXPR> <REST-OF-MEDIUMPREC-EXPR>,
//^\\ ;
{
if (alt == 1) return -1;
int left_op = compile_expression(leftchild(astp), -1, VALUE_WANTED); // <OP-MED> - returns an empty C_op tuple, with left and right both -1
int right_operand = compile_expression(rightchild(astp), -1, VALUE_WANTED); // <HIGHPREC-EXPR>
int top_op = compile_expression(child(astp, 3), -1, VALUE_WANTED); // <REST-OF-MEDIUMPREC-EXPR>
rightchild(left_op) = right_operand; // leftchild already -1
if (top_op == -1) return left_op; // left operand will be filled in by parents
int hole_op = top_op;
while (leftchild(hole_op) != -1) hole_op = leftchild(hole_op); leftchild(hole_op) = left_op;
return top_op;
}
case AST_HIGHPREC_EXPR:
{ // P<HIGHPREC-EXPR> = <RIGHT-ASSOC-EXPR> <REST-OF-HIGHPREC-EXPR>;
int left_operand = compile_expression(leftchild(astp), -1, VALUE_WANTED); // <RIGHT-ASSOC-EXPR>
int top_op = compile_expression(rightchild(astp), -1, VALUE_WANTED); // <REST-OF-HIGHPREC-EXPR>
if (top_op == -1) return left_operand;
int hole_op = top_op;
while (leftchild(hole_op) != -1) hole_op = leftchild(hole_op); leftchild(hole_op) = left_operand;
return top_op;
}
case AST_REST_OF_HIGHPREC_EXPR:
{
if (alt == 1) return -1;
int left_op = compile_expression(leftchild(astp), -1, VALUE_WANTED); // <OP-HIGH-LEFTASSOC>
int right_operand = compile_expression(rightchild(astp), -1, VALUE_WANTED); // <RIGHT-ASSOC-EXPR>
int top_op = compile_expression(child(astp, 3), -1, VALUE_WANTED); // <REST-OF-HIGHPREC-EXPR>
rightchild(left_op) = right_operand;
if (top_op == -1) return left_op;
int hole_op = top_op;
while (leftchild(hole_op) != -1) hole_op = leftchild(hole_op); leftchild(hole_op) = left_op;
return top_op;
}
case AST_RIGHT_ASSOC_EXPR:
{
int top_op = compile_expression(leftchild(astp), -1, VALUE_WANTED); // <REST-OF-RIGHTASSOC-EXPR>
int rightmost_operand = compile_expression(rightchild(astp), -1, VALUE_WANTED); // <UNARY-EXPR>
if (top_op == -1) return rightmost_operand; // <UNARY-EXPR> only, nothing on the left of expr.
int hole_op = top_op;
while (rightchild(hole_op) != -1) hole_op = rightchild(hole_op); rightchild(hole_op) = rightmost_operand;
return top_op;
}
case AST_REST_OF_RIGHTASSOC_EXPR:
{
if (alt == 1) return -1;
int top_op = compile_expression(leftchild(astp), -1, VALUE_WANTED); // <REST-OF-RIGHTASSOC-EXPR>
int right_operand = compile_expression(rightchild(astp), -1, VALUE_WANTED);
if (right_operand == -1) return top_op; // nothing on the left of expr.
rightchild(top_op) = right_operand;
return top_op;
}
case AST_UNARY_EXPR:
{
int op = compile_expression(leftchild(astp), -1, VALUE_WANTED); // <Opt-UNARY-OP>
int operand = compile_expression(rightchild(astp), -1, VALUE_WANTED); // <OPERAND>
if (op == -1) return operand;
leftchild(op) = operand;
return op;
}
//^\\ # You would think that unary operators always have the highest precedence,
//^\\ # but not so - here's a tricky one...
//^\\ #
//^\\ # I = -1 >> 1
//^\\ #
//^\\ # This always has the value 0, regardless of integer size, because a unary minus
//^\\ # in front of a constant is *NOT* interpreted as a negative constant, but rather
//^\\ # the positive constant (1 in this example), preceded by a unary negation operator.
//^\\ #
//^\\ # It gets worse... unary negation is implemented as binary subtraction with
//^\\ # an inserted '0' left operand, i.e.
//^\\ #
//^\\ # 0 - 1 >> 1
//^\\ #
//^\\ # This appears to have been specified at the lexical level and no implicit bracketing is mentioned
//^\\ # Shifts have higher precedence than subtraction, so this becomes:
//^\\ #
//^\\ # 0 - (1 >> 1)
//^\\ #
//^\\ # which evaluates to 0.
//^\\ #
//^\\ # The 68000 Imp compiler includes this statement which I hope is correct! dict(firstpos)_val = -cad>>1
//^\\ #
//^\\ # Some versions of Imp (I think Imp80) forbid a unary '+' before constants,
//^\\ # so A + +3 would be illegal (although A + -3 would not)
//^\\ #
//^\\ # and none of this applies to binary-not (\) so \3 really is higher
//^\\ # priority than '>>' and \3 >> 1 does what you would expect. I hope.
//^\\ #
case AST_Opt_UNARY_OP:
{
if (alt == 0) { //^\\ '+',
return ctuple(C_UNARY_PLUS, -1);
} else if (alt == 1) { //^\\ '-',
return ctuple(C_UNARY_MINUS, -1);
} else if (alt == 2) { //^\\ <UNARY-NOT>,
return compile_expression(leftchild(astp), -1, VALUE_WANTED);
} else if (alt == 3) { //^\\ ;
return -1;
}
}
//^\\ # The old form of modulus (!X!) is for really ancient compilers such as Hamish's Pdp15 Imp.
//^\\ # Unfortunately there are obscure cases where an ambiguous parse results:
//^\\ #
//^\\ # putact(condop!!polarity!!1+polarity<<7,item,0)
//^\\ #
//^\\ # Does that mean
//^\\ # putact(condop !! polarity !! 1 + polarity<<7, item, 0)
//^\\ # or
//^\\ # putact(condop ! !polarity! ! 1 + polarity<<7, item, 0)
//^\\ #
//^\\ # I need to check but I *hope* that the grammar here causes the first of the above to be selected.
//^\\ # If not, we'll need a command-line option here to force the version of Imp being used.
//^\\ #
//^\\ # I just hope that there's no version of Imp that ever supported factorials with a postfix '!'
//^\\ #
case AST_OPERAND: //^\\ P<OPERAND> =
{
if (alt == 0) { //^\\ <REAL-CONST>,
return compile_expression(leftchild(astp), -1, VALUE_WANTED);
} else if (alt == 1) { //^\\ <INT-CONST>,
return compile_expression(leftchild(astp), -1, VALUE_WANTED);
} else if (alt == 2) { //^\\ <STR-CONST>,
return compile_expression(leftchild(astp), -1, VALUE_WANTED);
} else if (alt == 3) { //^\\ <LVALUE>,
return compile_expression(leftchild(astp), -1, VALUE_WANTED);
} else if (alt == 4) { //^\\ '(' <EXPR> ')',
return ctuple(C_BRACKET, compile_expression(rightchild(astp),0,VALUE_WANTED), -1, VALUE_WANTED);
} else if (alt == 5) { //^\\ '|' <EXPR> '|',
return ctuple(C_ABS, compile_expression(rightchild(astp),0,VALUE_WANTED), -1, VALUE_WANTED);
} else if (alt == 6) { //^\\ '!' <EXPR> '!';
return ctuple(C_ABS, compile_expression(rightchild(astp),0,VALUE_WANTED), -1, VALUE_WANTED);
}
}
//^\\ # Roughly...
//^\\ # # P<basedconst> = "[0-9][0-9]*_[0-9A-Z][0-9A-Z]*"
//^\\ # btw regexps are a planned future enhancement to the parser.
case AST_INT_CONST: //^\\ P<INT-CONST> = <SAVED-INT-CONST>;
return compile_expression(leftchild(astp), -1, VALUE_WANTED);
case AST_SAVED_INT_CONST: //^\\ P<SAVED-INT-CONST> =
{
int i;
if (alt == 0) { //^\\ <DIGIT-SEQ> '_' <alphanumeric-SEQ>,
// TO DO: return C_ objects for all consts.
int base_c = compile_expression(leftchild(astp), -1, VALUE_WANTED);
int val_c = compile_expression(child(astp, 3), -1, VALUE_WANTED);
int rc, base, value;
char num[68];
// TO DO: digit seqs - remove leading zeroes...
rc = sscanf(pool_to_str(leftchild(base_c)), "%d", &base);
if (base == 2) {
sprintf(num, "0b%s", pool_to_str(leftchild(val_c)));
return ctuple(C_CONST_INT, str_to_pool(num), binstr_to_int(pool_to_str(leftchild(val_c))));
} else if (base == 8) {
sprintf(num, "0%s", pool_to_str(leftchild(val_c)));
return ctuple(C_CONST_INT, str_to_pool(num), octstr_to_int(pool_to_str(leftchild(val_c))));
} else if (base == 10) {
sprintf(num, "%s", pool_to_str(leftchild(val_c)));
return ctuple(C_CONST_INT, str_to_pool(num), str_to_int(pool_to_str(leftchild(val_c))));
} else if (base == 16) {
char *s = pool_to_str(leftchild(val_c));
value = 0;
while (*s != '\0') {
int c = (*s++)&255;
if ('0' <= c && c <= '9') {
value = (value << 4) | (c-'0');
} else if ('a' <= c && c <= 'f') {
value = (value << 4) | (c-'a'+10);
} else if ('A' <= c && c <= 'F') {
value = (value << 4) | (c-'A'+10);
} else {
fault("Bad HEX constant: %s_%s", leftchild(base_c), leftchild(val_c));
}
}
sprintf(num, "0x%s", pool_to_str(leftchild(val_c)));
//fprintf(stderr, "*** Creating C_CONST_INT 16_ <%s,%d>\n", num, value);
return ctuple(C_CONST_INT, str_to_pool(num), value);
} else {
warn("Unimplemented base conversion %0d", base);
return ctuple(C_CONST_INT, str_to_pool("BAD BASE"), 999888);
}
} else if (alt == 1) { //^\\ <DIGIT-SEQ>,
int digits = compile_expression(leftchild(astp), -1, VALUE_WANTED);
int value, rc;
rc = sscanf(pool_to_str(leftchild(digits)), "%d", &value);
if ((rc != 1) || (errno != 0)) {
long long bigint;
errno = 0;
rc = sscanf(pool_to_str(leftchild(digits)), "%lld", &bigint);
if ((rc != 1) || (errno != 0)) {
fault("Invalid integer %s - %s", pool_to_str(leftchild(digits)), strerror(errno));
} else {
// Older IMP compilers would have converted this to a double (%longreal)
// and passed it back up as a real constant. But we'll support %longinteger like EMAS3...
return ctuple(C_CONST_BIGINT, leftchild(digits), (int)((bigint>>32LL)&0xFFFFFFFFLL), (int)(bigint&0xFFFFFFFFLL));
}
}
fprintf(stderr, "Debug@%d: creating C_CONST_INT tuple: digits=%d leftchild(digits)=%d value=%d\n", __LINE__, digits, leftchild(digits), value);
return ctuple(C_CONST_INT, leftchild(digits), value);
} else if (alt == 2) { //^\\ <OLDSTYLE-BASE>,
return compile_expression(leftchild(astp), -1, VALUE_WANTED);
} else if (alt == 3) { //^\\ <sqstring>; // BIP
char *s;
int value;
int sqstring = compile_expression(leftchild(astp), -1, VALUE_WANTED); // saved in canonical form
// fprintf(stderr, "INFO: type of sqstring is %s\n", CAstOPName(AstOP(sqstring))); - C_STRING_LITERAL
// if (strlen(str_lit) == 0 || strlen(str_lit) > 4) fault("Bad quoted constant: '%s'", str_lit);
// more likely old-style string, in which case this would not be the place to complain.
// However if that is the case, we should return a C_CONST_STRING instead...
s = STRING_LITERAL_to_C_int_const(sqstring, &value); // remove doubled quotes ('') from sqstring. Enclose string in single quotes.
//fprintf(stderr, "STRING_LITERAL_to_C_int_const: %s (%d)\n", s, value);
return ctuple(C_CONST_INT, str_to_pool(s), value); // value should be valid if form was 'x' or 'xxxx' or M'xxxx' ...
}
}
default:
fprintf(stderr, "MISSING AST OPERATOR AST_%s IN compile_expression(@AST:%d, %s)\n",
AstOPName(astop),
astp, (address_wanted ? "GET ADDRESS" : "GET VALUE"));
// pending relocation from compile()?
case AST_REST_OF_ACTUAL_PARAMETERS:
case AST_STRING_RESOLUTION_EXPR:
// These ones we know we have to call back for:
case AST_NAME:
case AST_DIGIT_SEQ:
case AST_REAL_CONST:
case AST_STR_CONST:
case AST_alphanumeric_SEQ:
case AST_DOTTED_STRING_EXPR:
case AST_OLDSTYLE_BASE:
case AST_sqstring:
return compile_inner(astp, extra_parameter, line);
}
}
#ifdef NEVER_USED
int generate_expression(int astp, int address_wanted) {
int castp;
if (debug_new_exprs) fprintf(stderr, "generate_expression(@AST:%d, %s)\n", astp, (address_wanted ? "GET ADDRESS" : "GET VALUE"));
castp = compile_expression(astp, -1, address_wanted);
output_c_expression(castp);
}
#endif
//0x0041e9b8 in compile_expression_inner (astp=89345, extra_parameter=-1, address_wanted=0, line=3503) at ./expressions.c:255
//255 leftchild(assign_c) = compile_expression(child(astp,1), -1, VALUE_WANTED);
#endif // USE_INCLUDED_EXPRESSIONS_C
#ifdef USE_INCLUDED_FLOWCONTROL_C
#include "flowcontrol.c"
#else
/*
replacement code and data structures for Imp expression evaluation...
ctuples for an operator are a pair of <C_ and descriptor> - the descriptor
may be a declaration symbol but it could also be the same information for
an expression, constructed bottom-up, to allow type-checking at the top,
or appropriate casting for assignments/jam transfers etc.
*/
#define CAstOP(x) AstOP(x)
int debug_flowcontrol = 1;
#ifdef NEVER
char *CAstOPName(int castop) {
return CAST[castop-C_BASE].name;
}
char *AstOPName(int astop) {
return phrasename[astop];
}
#endif
void output_c_flowcontrol(int castp) {
if (debug_flowcontrol) fprintf(stderr, "output_c_flowcontrol: @C_AST:%d\n", castp);
if (castp < 0) {
return;
}
int castop = CAstOP(castp);
switch (castop) {
default:
fprintf(stderr, "MISSING CAST OPERATOR C_%s IN output_c_flowcontrol: @C_AST:%d\n",
CAstOPName(castop),
castp);
return;
}
}
#define compile_flowcontrol(astp, extra_parameter) compile_flowcontrol_inner(astp, extra_parameter, __LINE__)
int compile_flowcontrol_inner(int astp, int extra_parameter, int line) {
//if (debug_flowcontrol) fprintf(stderr, "compile_flowcontrol(@AST:%d, %d) from line %d\n", astp, extra_parameter, line);
if (astp < 0) {
fprintf(stderr, "compile_flowcontrol: -1 from line %d\n", line);
return -1;
}
int astop = AstOP(astp);
int alt = Alt0(astp);
int count = AST[astp+AST_count_offset];
int *A_child = &AST[astp+AST_child1_offset]; // An index into a child of the AREC, *not* a child of the AST.
// (for printing terminals with RECONSTITUTE, although it may be better
// to pass astp and let RECONSTITUTE apply AST_child1_offset)
if (astop >= C_BASE) {
fprintf(stderr, "? redundant compile(C_%s) called from line %d\n", CAstOPName(astop), line);
return astp; // already compiled.
}
switch (astop) {
case AST_TOP_LEVEL_CONDITION: //^\\ P<TOP-LEVEL-CONDITION> = <CONDITION>;
return compile(leftchild(astp));
case AST_Opt_UNTIL: //^\\ P<Opt-UNTIL> =
if (alt == 0) { //^\\ "until" <TOP-LEVEL-CONDITION>,
return ctuple(C_UNTIL, -1, compile(rightchild(astp)));
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_Percent_IU: //^\\ P<Percent-IU> =
if (alt == 0) { //^\\ "if",
return ctuple(C_IF, -1, -1, -1, -1); // #1 'then' statement to be executed #2 cond #3 'else' statement to be executed
} else if (alt == 1) { //^\\ "unless";
return ctuple(C_UNLESS, -1, -1, -1, -1); // #1 'then' statement to be executed #2 cond #3 'else' statement to be executed
}
//^\\ # Added old-style while/until for: %UNTIL NEXTINSYM=NL %THEN %CYCLE
//^\\ # and %WHILE NEXTINSYM#NL %THEN SKIPINSYM
case AST_CYCLE_S: //^\\ P<CYCLE-S> =
if (alt == 0) { //^\\ "cycle" <Opt-CYCPARM> <S> <INTERNALS> "repeat" <Opt-UNTIL> <S>,
int cycle = compile(child(astp,2)); // Either I=1,2,3 style or -1 (plain %cycle)
int body = compile(child(astp,4));
int until = compile(child(astp,6)); // Either "until <COND>" (C_UNTIL) or -1.
if (cycle == -1) { // starts with a plain %cycle
if (until != -1) { // ends in a %until <cond>
child(until, 1) = body;
return until;
} else { // ends in a plain %repeat
return ctuple(C_FOREVER, body);
}
}
assert(AstOP(cycle) == C_IMP_FOR); // old syntax for-loop.
child(cycle, 1) = body;
return cycle;
} else if (alt == 1) { //^\\ <Percent-WUF> "cycle" <S> <INTERNALS> "repeat" <Opt-UNTIL> <S>,
int wuf = compile(child(astp,1)); // while/until/for - no null option
int block = compile(child(astp,4));
int opt_until = compile(child(astp,6));
if (opt_until != -1) {
fault("A %%cycle starting with %%while, %%until, or %%for must not end with %%repeat %%until.");
}
leftchild(wuf) = STATEMENT_BLOCK(block);
return wuf;
} else if (alt == 2) { //^\\ <Percent-WU> "then" "cycle" <S> <INTERNALS> "repeat" <Opt-UNTIL> <S>,
int wu = compile(child(astp,1)); // while/until - no null option
int block = compile(child(astp,5));
int opt_until = compile(child(astp,7));
assert(AstOP(wu) == C_WHILE || AstOP(wu) == C_UNTIL);
assert(leftchild(wu) == -1);
if (opt_until != -1) {
fault("A %%cycle starting with %%while, %%until, or %%for must not end with %%repeat %%until.");
}
if (block != -1 && AstOP(block) != C_SEQ) block = ctuple(C_SEQ, block, -1);
leftchild(wu) = STATEMENT_BLOCK(block);
return wu;
} else if (alt == 3) { //^\\ <Percent-WU> "then" <UI>;
int wu = compile(child(astp,1)); // while/until - no null option
int block = STATEMENT_BLOCK(compile(child(astp,3)));
assert(AstOP(wu) == C_WHILE || AstOP(wu) == C_UNTIL);
assert(leftchild(wu) == -1);
block = ctuple(C_SEQ, block, -1);
leftchild(wu) = block;
return wu;
}
case AST_IF_S: //^\\ P<IF-S> =
if (alt == 0) { //^\\ <Percent-IU> <TOP-LEVEL-CONDITION> <THEN-S>;
// We note the condition as an extra field after re-evaluating it as a constant, so that
// we can do conditiona compilation the EMAS way. HOWEVER that should only be done if
// a compile-time flag allows it, *and* when we're not allowing it, we need to check
// the scope level so that we don't allow %if statements outside a block.
// *** NOTE *** The current implementation does not handle declarations made within the
// then/else blocks of conditional start/finish statements. Need to work out a way to
// only execute declarations for the TRUE arm. Unfortunately we are handling declarations
// at compile() time, not out() time. So some restructuring definitely needed...
// The snswer is going to be related to calling compile() of the then/else blocks only
// if the constant condition was true.
int if_or_unless = compile(child(astp,1)); assert(AstOP(if_or_unless) == C_IF || AstOP(if_or_unless) == C_UNLESS);
int cond = compile(child(astp,2)); assert(cond != -1);
int then_else = compile(child(astp,3)); assert(child(if_or_unless, 1) == -1); assert(child(if_or_unless, 2) == -1);
int then, else_c;
if (AstOP(then_else) == C_THEN_ELSE) {
detuple(then_else, C_THEN_ELSE, &then, &else_c);
} else {
then = child(if_or_unless, 1);
else_c = child(if_or_unless, 3);
}
if (AstOP(if_or_unless) == C_UNLESS) {
cond = ctuple(C_LOGNOT, cond);
AstOP(if_or_unless) = C_IF;
}
assert(AstOP(if_or_unless) == C_IF);
child(if_or_unless, 2) = cond;
child(if_or_unless, 4) = IntConstant_c(cond);
child(if_or_unless, 1) = STATEMENT_BLOCK(then);
if (else_c != -1) else_c = STATEMENT_BLOCK(else_c);
child(if_or_unless, 3) = else_c;
return if_or_unless;
}
break;
//^\\ # /home/gtoal/gtoal.com/athome/edinburgh/APM-gdmr/I/LIB.imp
//^\\ # contains:
//^\\ # %elseif 'A'<=sym<='Z' %start
//^\\ #
//^\\ # which is a form of Hamish's that is equivalent to
//^\\ #
//^\\ # %finish %else %if 'A'<=sym<='Z' %start
//^\\ #
//^\\ # or the more concise
//^\\ #
//^\\ # %else %if 'A'<=sym<='Z'
//^\\ #
//^\\ # An identical issue is: %elsestart
//^\\ # in APM-gdmr/ETHER/PROFILE.imp
//^\\ #
// it is either finishing a start or an elseif...start ...
case AST_FINISH_S: //^\\ P<FINISH-S> =
if (alt == 0) { //^\\ "else" <Percent-IU> <TOP-LEVEL-CONDITION> <Opt-start> <S> <INTERNALS> <FINISH-S>,
// \_____________________________________________________________/
// |
// statement
int then_block = STATEMENT_BLOCK(compile(child(astp,6)));
int finish = compile(child(astp,7));
int if_or_unless = compile(child(astp,2)); assert(AstOP(if_or_unless) == C_IF || AstOP(if_or_unless) == C_UNLESS);
int cond = compile(child(astp,3)); assert(cond != -1);
int statement = if_or_unless;
if (AstOP(if_or_unless) == C_UNLESS) { // convert %unless to %if %not ...
cond = ctuple(C_LOGNOT, cond);
AstOP(if_or_unless) = C_IF;
}
assert(AstOP(if_or_unless) == C_IF);
child(if_or_unless, 1) = then_block;
child(if_or_unless, 2) = cond;
child(if_or_unless, 4) = IntConstant_c(cond);
if (finish != -1) finish = STATEMENT_BLOCK(finish);
child(if_or_unless, 3) = finish; // the else part
if (finish != -1 && AstOP(finish) == C_THEN_ELSE) { assert(leftchild(finish) == -1);
assert(leftchild(finish) == -1);
int else_c = rightchild(finish);
if (else_c != -1) else_c = STATEMENT_BLOCK(else_c);
child(if_or_unless, 3) = else_c;
}
return ctuple(C_THEN_ELSE, -1, statement);
} else if (alt == 1) { //^\\ "else" <Opt-start> <S> <INTERNALS> "finish" <S>,
int block = STATEMENT_BLOCK(compile(child(astp,4)));
return ctuple(C_THEN_ELSE, -1, block);
} else if (alt == 2) { //^\\ "finish" <Opt-ELSE-S>;
int opt_else = compile(rightchild(astp));
if (opt_else == -1) return -1; // plain finish returns -1
assert(AstOP(opt_else) == C_THEN_ELSE);
return opt_else;
}
case AST_Opt_start: //^\\ P<Opt-start> = "start", ;
// cps("{");
return -1; // syntactic sugar
//^\\ # see the comments on <FINISH-S> above.
case AST_Opt_ELSE_S: //^\\ P<Opt-ELSE-S> =
// returns a C_ELSE or -1
if (alt == 0) { //^\\ "else" "start" <S> <INTERNALS> "finish" <S>,
int block = STATEMENT_BLOCK(compile(child(astp,4)));
return ctuple(C_THEN_ELSE, -1, block);
} else if (alt == 1) { //^\\ "else" <IF-S>,
// may decide to add an 'else if' to preserve indentation. Meanwhile...
int block = compile(child(astp,2));
int else_c = ctuple(C_THEN_ELSE, -1, block);
return else_c;
} else if (alt == 2) { //^\\ "else" <UI> <S>,
int rest = STATEMENT_BLOCK(compile(child(astp,2)));
return ctuple(C_THEN_ELSE, -1, rest);
} else if (alt == 3) { //^\\ <S>;
return -1;
}
case AST_THEN_S: //^\\ P<THEN-S> =
if (alt == 0) { //^\\ <OPT-then> "start" <S> <INTERNALS> <FINISH-S>,
int block = STATEMENT_BLOCK(compile(child(astp,4)));
int finish = compile(child(astp,5));
if (finish == -1) {
return ctuple(C_THEN_ELSE, block, -1);
}
if (AstOP(finish) == C_THEN_ELSE) { // #1 "then" block (may be -1) #2 "else" block (may be -1).
assert(leftchild(finish) == -1);
leftchild(finish) = block;
// rightchild(finish) is any potential "else" part. Or -1 if none.
return finish;
}
} else if (alt == 1) { //^\\ "then" <UI> <Opt-ELSE-S>;
int then = STATEMENT_BLOCK(compile(child(astp,2)));
int else_c = compile(child(astp,3));
if (else_c == -1) {
return ctuple(C_THEN_ELSE, then, -1);
}
if (AstOP(else_c) == C_THEN_ELSE) { // #1 "then" block (may be -1) #2 "else" block (may be -1).
assert(leftchild(else_c) == -1);
leftchild(else_c) = then;
return else_c;
}
return ctuple(C_THEN_ELSE, then, else_c);
}
case AST_OPT_then: //^\\ P<OPT-then> = "then", ;
return -1; // syntactic sugar
case AST_ONE_SWITCH_DECL: //^\\ P<ONE-SWITCH-DECL> = <NAME> <Opt-NAME-LIST> '(' <CEXPR> ':' <CEXPR> ')'; // should be <CEXPR>s!!!
if (alt == 0) {
int name = compile(child(astp,1)); assert(AstOP(name) == C_NAME);
{
char orig[1024];
orig[0] = '\0'; getstr(child(astp,4), orig);
//fprintf(stderr, "LOW: %s\n", orig);
orig[0] = '\0'; getstr(child(astp,6), orig);
//fprintf(stderr, "HIGH: %s\n", orig);
}
int lower_bound = compile(child(astp,4)); //fprintf(stderr, "lower bound: ");diagnose(lower_bound);
assert(AstOP(lower_bound) == C_CONST_INT);
int upper_bound = compile(child(astp,6)); //fprintf(stderr, "\nupper bound: ");diagnose(upper_bound);
assert(AstOP(upper_bound) == C_CONST_INT);
int boundspair = ctuple(C_BOUNDSPAIR, lower_bound, upper_bound, lower_bound, upper_bound, -1);
int more_names = compile(child(astp,2)); assert(more_names == -1 || AstOP(more_names) == C_SEQ);
int this_switch;
int results = -1;
int low = rightchild(lower_bound); //fprintf(stderr, "low val: %d\n",low);
int high = rightchild(upper_bound); //fprintf(stderr, "high val: %d\n",high);
for (;;) {
this_switch = ctuple(C_DECLARE_SWITCH, name, boundspair, -1);
//fprintf(stderr, "*** ADDING SWITCH %s\n", S(name));
int switch_table = new_switch(pool_to_str(leftchild(name)), this_switch, low, high);
child(this_switch,3) = switch_table;
Declare(name, this_switch);
append_to(&results, ctuple(C_SEQ, this_switch, -1));
if (more_names == -1) break;
detuple(more_names, C_SEQ, &name, &more_names);
}
return results;
}
//^\\ # rest of %switch list
//^\\ # This reminds me, isn't there an optional %label declaration in Imp? Haven't seen an example yet,
//^\\ # I need to check the manuals to make sure I'm not confusing this with C...
case AST_REST_OF_SWLIST: //^\\ P<REST-OF-SWLIST> =
if (alt == 0) { //^\\ ',' <ONE-SWITCH-DECL> <REST-OF-SWLIST>,
int next_switch = compile(child(astp,2));
int more_switches = compile(child(astp,3));
return ctuple(C_SEQ, next_switch, more_switches);
} else if (alt == 1) { //^\\ ;
return -1;
}
break;
//^\\ # the version without "for" is to support an old-style statement, %WHILE <cond> %THEN <ui>
case AST_Percent_WU: //^\\ P<Percent-WU> =
if (alt == 0) { //^\\ "while" <TOP-LEVEL-CONDITION>,
int cond = compile(rightchild(astp));
// #1 statement to be executed #2 cond
return ctuple(C_WHILE, -1 /* body */, cond);
} else if (alt == 1) { //^\\ "until" <TOP-LEVEL-CONDITION>;
int cond = compile(rightchild(astp));
// #1 statement to be executed #2 cond #3 reserved for obscure and semi-illegal case
// of (%while <cond1> %cycle or %for <forctl> %cycle)/%repeat %until <cond2> ...
return ctuple(C_UNTIL, -1 /* body */, cond /*ctuple(C_LOGNOT, cond) now reversed in out() */, -1);
}
case AST_Percent_WUF: //^\\ P<Percent-WUF> =
if (alt == 0) { //^\\ "while" <TOP-LEVEL-CONDITION>,
int cond = compile(rightchild(astp));
// #1 statement to be executed #2 cond
return ctuple(C_WHILE, -1 /* body */, cond);
} else if (alt == 1) { //^\\ "until" <TOP-LEVEL-CONDITION>,
int cond = compile(rightchild(astp));
// #1 statement to be executed #2 cond #3 reserved for obscure and semi-illegal case
// of (%while <cond1> %cycle or %for <forctl> %cycle)/%repeat %until <cond2> ...
return ctuple(C_UNTIL, -1 /* body */, cond /*ctuple(C_LOGNOT, cond) now reversed in out() */, -1);
} else if (alt == 2) { //^\\ "for" <NAME> <SCALAR-ASSIGN> <EXPR> ',' <EXPR> ',' <EXPR>;
int name = compile(child(astp, 2));
int assop = compile(child(astp, 3));
int initial = compile(child(astp, 4));
int step = compile(child(astp, 6));
int final = compile(child(astp, 8));
return ctuple(C_IMP_FOR, -1 /*body*/, name, assop, initial, step, final, IntConstant_c(initial), IntConstant_c(step), IntConstant_c(final));
}
case AST_Opt_CYCPARM: //^\\ P<Opt-CYCPARM> =
if (alt == 0) { //^\\ <NAME> <SCALAR-ASSIGN> <EXPR> ',' <EXPR> ',' <EXPR>,
int name = compile(child(astp, 1));
int assop = compile(child(astp, 2));
int initial = compile(child(astp, 3));
int step = compile(child(astp, 5));
int final = compile(child(astp, 7));
return ctuple(C_IMP_FOR, -1 /*body*/, name, assop, initial, step, final, IntConstant_c(initial), IntConstant_c(step), IntConstant_c(final));
} else if (alt == 1) { //^\\ ;
return -1; // plain cycle start.
}
//^\\ # reversed conditions and 1-line cycles - UNTIL has to be handled differently TO DO
case AST_REST_OF_SS1: //^\\ P<REST-OF-SS1> =
if (alt == 0) { //^\\ <Percent-IU> <TOP-LEVEL-CONDITION> <S>,
int if_or_unless = compile(leftchild(astp));
int cond = compile(rightchild(astp));
if (AstOP(if_or_unless) == C_UNLESS) {
AstOP(if_or_unless) = C_IF; // C_UNLESS should never percolate up to the top level...
cond = ctuple(C_LOGNOT, cond); // Maybe a good place to apply De-Morgan?
}
assert(AstOP(if_or_unless) == C_IF);
assert(leftchild(if_or_unless) == -1);
assert(rightchild(if_or_unless) == -1);
rightchild(if_or_unless) = cond;
return if_or_unless;
} else if (alt == 1) { //^\\ <Percent-WUF> <S>,
return compile(leftchild(astp));
} else if (alt == 2) { //^\\ <S>,
return -1;
} else if (alt == 3) { //^\\ ;
return -1;
}
default:
fprintf(stderr, "MISSING AST OPERATOR AST_%s IN compile_flowcontrol(@AST:%d)\n",
AstOPName(astop),
astp);
return compile_inner(astp, extra_parameter, line);
}
}
int generate_flowcontrol(int astp) {
int castp;
if (debug_flowcontrol) fprintf(stderr, "generate_flowcontrol(@AST:%d)\n", astp);
castp = compile_flowcontrol(astp, 0);
output_c_flowcontrol(castp);
}
#endif // USE_INCLUDED_FLOWCONTROL_C
void debug_record_type(int astp, int depth) { // DEBUG THE FIELDS
int i;
int rfname, first_decln;
detuple(astp, C_TYPE_RECORDFORMAT, NULL, &rfname, &first_decln); // #1 <record name or -1> #2 record format name #3 field list of C_TYPE_RECORD_FIELD
for (i = 0; i < depth*3; i++) fprintf(stderr, " ");
fprintf(stderr, "Record: %s depth=%d first_decln=%d\n", name_to_cstr(rfname), depth, first_decln);
int this_decl, more_decls = first_decln;
while (AstOP(more_decls) == C_SEQ) {
detuple(more_decls, C_SEQ, &this_decl, &more_decls);
for (i = 0; i < depth*3; i++) fprintf(stderr, " ");
fprintf(stderr, " %s\n", CAstOPName(AstOP(this_decl)));
if (AstOP(this_decl) != C_TYPE_RECORD_FIELD) {
diagnose(this_decl); // -> C_TYPE_RECORDFORMAT why?
return;
//assert(AstOP(this_decl) == C_TYPE_RECORD_FIELD);
}
// C_TYPE_RECORD_FIELD =
// #1 field name
// #2 field offset if known relative to start of current record, or -1 (for later)
// #3 type: field type could be a basic type, or a C_TYPE_RECORD_VARIANT list
// #4 %name?
// #5 next <C_TYPE_RECORD_FIELD> or -1
for (;;) {
int field_name, field_type, percent_name, next_field;;
detuple(this_decl, C_TYPE_RECORD_FIELD, &field_name, NULL, &field_type, &percent_name, &next_field);
for (i = 0; i < depth*3; i++) fprintf(stderr, " ");
fprintf(stderr, " %s %s%s\n", name_to_cstr(field_name), percent_name==-1?"":"*", CAstOPName(AstOP(field_type)));
if (AstOP(field_type) == C_TYPE_RECORDFORMAT) {
// Follow actual records, *not* recordnames...
//if (percent_name == -1) debug_record_type(field_type, depth+1);
}
if (next_field == -1) break;
// looks like there aren't any more.
// more_decls was a list of C_SEQ items containing a single C_TYPE_RECORD_FIELD in each,
// when in fact it should have been built using a C_TYPE_RECORD_FIELD list instead.
}
if (more_decls == -1) break;
}
}
int compile_inner(int astp, int extra_parameter, int line) {
int i;
int astop = AstOP(astp);
if (astop >= C_BASE) {
fprintf(stderr, "? redundant compile(C_%s) called from line %d\n", CAstOPName(astop), line);
return astp; // already compiled.
}
int alt = Alt0(astp);
int count = AST[astp+AST_count_offset];
int *A_child = &AST[astp+AST_child1_offset]; // An index into a child of the AREC, *not* a child of the AST.
// (for printing terminals with RECONSTITUTE, although it may be better
// to pass astp and let RECONSTITUTE apply AST_child1_offset)
if (astp < 0) {
if (debug_ast) {
fprintf(stderr, "compile: -1 from line %d\n", line);
}
return -1;
}
#ifdef SHOW_AST_INCLUDED
if (debug_ast) {
fprintf(stderr, "compile: %d@%d: op{1}=", astop, astp);
print_astop_name(astp);
fprintf(stderr, " (%d), count=%d [", astop, count);
{int i;
for (i = 1; i <= count; i++) {
int arg = child(astp, i);
int castop = AstOP(arg);
char def[12];
sprintf(def, "<%d>", castop);
fprintf(stderr, "[A] Arg%0d: op{2}=%s@%d ",
i,
(castop >= C_BASE && castop <= C_LAST)
? CAST[castop-C_BASE].name
: def,
child(astp,i)
);
}
}
fprintf(stderr, "] from line %d\n", line);
}
#endif
switch (astop) {
// ##### # ##### #######
// ##### # # # # ##### # # # # # # #
// # # # # # # # # # # # # #
// ##### # # # # # # # #### # # ##### #
// # # # # # # # # # ####### # #
// # # # # # # # # # # # # # # #
// ##### #### # ###### ##### ##### # # ##### #
// The first draft of this code output the translation into C as it walked
// the Imp AST. The final version will not output any code from this procedure -
// rather it will convert the Imp AST into a C AST and pass the completed C AST
// to another procedure ('out') to generate and output the C code.
// We are not there yet, and this procedure is still a mix of the two styles -
// some statements are output on the fly, others are passed back as ctuples to
// be printed later. (Or currently, by higher level statements in the grammar).
// However the code below is fairly cleanly split into two sections, and as
// 'on-the-fly' rules are converted to 'return-c-ast' rules, they'll be moved
// over the separator below (the word 'display' in banner type).
// These AST_* entries should never be called. Need to adjust compile() so that
// whenever it was going to return one of these, it returns a C_STRING_LITERAL or a C_CONST_STRING as appropriate.
// The next design issue to think about is scoping and name-table handling. I *think* it can
// all be done in 'compile()' as the tree is built - I don't *think* we need to track the scope level
// during the output phase. But the code at the moment is still a bit mixed with calls to alter the
// scope level appearing in the out() procedure. I'll start taking those out now as I move the
// code over from the old C_SYMBOL types to the new type system, unless I hit any problems that
// require the scope level to be followed during output as well.
case AST_stropped: //^\\ B<stropped> = 0;
{
char LITERAL[1024];
warn("compile(AST_stropped) called from line %d", line);
LITERAL[0] = '\0'; sRECONSTITUTE(A[A_child[1]+A_literal_offset], LITERAL);
//fprintf(stderr, "C_STRING_LITERAL: stropped=|%s|\n", LITERAL);
return ctuple(C_STRING_LITERAL, str_to_pool(LITERAL)); // return the string contents with outer quotes and quoted quotes removed
}
//^\\ #
//^\\ # single-quoted string
case AST_sqstring: //^\\ B<sqstring> = 1;
{
char LITERAL[1024], *lit, *lit2;
LITERAL[0] = '\0';
sRECONSTITUTE(A[A_child[1]+A_literal_offset], LITERAL);
// \___________________________/
// wait... is |
// this
//
// already a stringpool index?
lit = strchr(LITERAL, '\'');
if (lit == NULL) fault("Corrupt string <%s> from line %d", LITERAL, line); // or print NULL ?
lit += 1;
memmove(LITERAL, lit, strlen(lit)+1); // safe move with overlapping - remove one of a set of double quotes
lit2 = strrchr(LITERAL, '\'');
if (lit == NULL) fault("Corrupt string <%s> from line %d", LITERAL, line);
*lit2 = '\0';
lit = LITERAL;
for (;;) {
lit2 = strstr(lit, "\'\'");
if (lit2 == NULL) break;
memmove(lit2, lit2+1, strlen(lit2+1)+1); // safe move with overlapping - remove one of a set of double quotes
//*lit2 = '\\'; // map '' to \'
lit = lit2+1;
}
//fprintf(stderr, "C_STRING_LITERAL: dqstring=|%s|\n", LITERAL);
return ctuple(C_STRING_LITERAL, str_to_pool(LITERAL)); // return the string contents with outer quotes and quoted quotes removed
}
//^\\ #
//^\\ # double-quoted string
case AST_dqstring: //^\\ B<dqstring> = 2;
{
char LITERAL[1024];
LITERAL[0] = '\0'; sRECONSTITUTE(A[A_child[1]+A_literal_offset], LITERAL);
// LITERAL is currently an Imp-style double-quoted string.
// Before storing, we need to undo Imp-style double-quoting, and
// of course, remove the enclosing quotes.
char STRING[1024], *s, *t;
s = LITERAL; t = STRING;
while (*s != '"' && *s != '\0') {
s += 1; // advance to first quote
}
if (*s == '"') {
*t++ = *s++; // copy the opening "
}
while (*s != '\0') {
int c = *s;
if (c=='\n') {
*t++ = '\\'; *t++ = 'n';
s += 1;
} else if (c=='\\') {
*t++ = '\\'; *t++ = '\\';
s += 1;
} else if (c=='"' && s[1]=='"') {
*t++ = '\\'; *t++ = '"';
s += 2;
} else {
*t++ = c;
s += 1;
}
}
*t = '\0';
//fprintf(stderr, "C_STRING_LITERAL: sqstring=|%s|\n", LITERAL);
return ctuple(C_STRING_LITERAL, str_to_pool(STRING));
// return the string contents with outer quotes and quoted quotes removed
}
case AST__LIT:
{
char LITERAL[1024];
LITERAL[0] = '\0';
sRECONSTITUTE(A[A_child[1]+A_literal_offset], LITERAL);
// \___________________________/
// wait... is |
// this
//
// already a stringpool index?
//fprintf(stderr, "C_STRING_LITERAL: AST__LIT=|%s|\n", LITERAL);
return ctuple(C_STRING_LITERAL, str_to_pool(LITERAL));
}
//^\\ #
case AST_NL: //^\\ B<NL> = 3;
{
char LITERAL[1024];
warn("compile(AST_NL) called from line %d", line);
LITERAL[0] = '\0'; sRECONSTITUTE(A[A_child[1]+A_literal_offset], LITERAL);
//fprintf(stderr, "C_STRING_LITERAL: AST_NL=|%s|\n", LITERAL);
return ctuple(C_STRING_LITERAL, str_to_pool(LITERAL)); // return the string contents with outer quotes and quoted quotes removed
}
//^\\ #
case AST_char: //^\\ B<char> = 4;
{
char LITERAL[1024];
warn("compile(AST_char) called from line %d", line);
LITERAL[0] = '\0'; sRECONSTITUTE(A[A_child[1]+A_literal_offset], LITERAL);
//fprintf(stderr, "C_STRING_LITERAL: AST_char=|%s|\n", LITERAL);
return ctuple(C_STRING_LITERAL, str_to_pool(LITERAL)); // return the string contents with outer quotes and quoted quotes removed
}
//^\\ #
//^\\ # All parsers need an <EOF> phrase.
//^\\ #
case AST_EOF: //^\\ B<EOF> = 5;
{
return ctuple(C_STRING_LITERAL, str_to_pool("BUG:AST_EOF")); // return the string contents with outer quotes and quoted quotes removed
}
case AST__KW:
{
warn("AST__KW called from line %d", line);
return ctuple(C_STRING_LITERAL, str_to_pool("BUG:AST__KW")); // return the string contents with outer quotes and quoted quotes removed
}
/* GRAMMAR HANDLING STARTS HERE */
//^\\ # %signal 3,4,position,"Set input fails" %unless position=0
case AST_OPSTRING: //^\\ P<OPSTRING> =
if (alt == 0) { //^\\ ',' <STRING-EXPR>,
int sexpr = compile(rightchild(astp));
return ctuple(C_SEQ, ctuple(C_ADD_COMMA_BEFORE, sexpr), -1);
} else if (alt == 1) { //^\\ ;
int sexpr = ctuple(C_STRING_LITERAL, str_to_pool("_imp_str_literal(\"\")"));
return ctuple(C_SEQ, ctuple(C_ADD_COMMA_BEFORE, sexpr), -1);
}
//^\\ # single optional ", expr" for use with %signal event (, subevent)?
case AST_OPEXPR: //^\\ P<OPEXPR> =
if (alt == 0) { //^\\ ',' <OPT-EXPR> <OPSTRING>,
int expr1 = compile(rightchild(astp));
int expr2 = compile(child(astp,3));
return ctuple(C_SEQ, expr1, expr2);
} else if (alt == 1) { //^\\ ;
int expr1 = ctuple(C_ADD_COMMA_BEFORE, C_Zero);
int sexpr = ctuple(C_STRING_LITERAL, str_to_pool("_imp_str_literal(\"\")"));
int expr2 = ctuple(C_SEQ, ctuple(C_ADD_COMMA_BEFORE, sexpr), -1);
return ctuple(C_SEQ, expr1, expr2);
}
case AST_OPT_EXPR: //^\\ P<OPT-EXPR> =
if (alt == 0) { //^\\ <EXPR>,
return ctuple(C_ADD_COMMA_BEFORE, compile(leftchild(astp)));
} else if (alt == 1) { //^\\ ;
int defaultexpr = C_Zero;
return ctuple(C_ADD_COMMA_BEFORE, defaultexpr);
}
case AST_STR_ASSIGN: //^\\ P<STR-ASSIGN> =
if (alt == 0) { //^\\ <STRING-LVALUE>;
return compile(leftchild(astp));
}
//^\\ # No bracketed expressions, only '.' operator allowed, although once again,
//^\\ # Hamish has an idiosyncratic extension where strings in a printstring are
//^\\ # separated by semi-colons - I think it is some approximation to C's printf?
//^\\ #
//^\\ # Correction... later discovered it was a whacky extension to support
//^\\ # multiple calls to the same procedure, especially when using overloading.
//^\\ # Documented in https://gtoal.com/imp77/reference-manual/Imp-M68K-V3.html
//^\\ #
case AST_STRING_EXPR: //^\\ P<STRING-EXPR> =
if (alt == 0) { //^\\ <STRING-RVALUE> <REST-OF-STRING-EXPR>;
int rhs = compile(rightchild(astp));
if (rhs != -1) {
assert(AstOP(rhs) == C_CONCAT);
leftchild(rhs) = compile(leftchild(astp));
return rhs;
} else {
return compile(leftchild(astp));
}
}
case AST_STR_MATCH: //^\\ P<STR-MATCH> =
if (alt == 0) { //^\\ '(' <STRING-EXPR> ')';
return compile(rightchild(astp));
}
case AST_STRING_RESOLUTION: //^\\ P<STRING-RESOLUTION> =
if (alt == 0) { //^\\ <LVALUE> '-' '>' <STRING-RESOLUTION-EXPR>;
return ctuple(C_COND_STR_RES, compile(leftchild(astp)), compile(child(astp,4)));
}
case AST_REST_OF_ORC: //^\\ P<REST-OF-ORC> =
if (alt == 0) { //^\\ "or" <SC> <REST-OF-ORC>,
int comp = ctuple(C_LOGOR, -1, -1);
int sc = compile(rightchild(astp));
int rest = compile(child(astp,3));
int rhs = sc;
if (rest != -1) {
leftchild(rest) = sc;
rhs = rest;
}
rightchild(comp) = rhs; // leftchild will be filled in by parent
return comp;
} else if (alt == 1) { //^\\ ;
return -1;
}
//^\\ # ping-pong. Can't allow -> (a).b.c.(d) or -> a.(b).(c).d
case AST_OPT_STR_ASSIGN: //^\\ P<OPT-STR-ASSIGN> =
if (alt == 0) { //^\\ '.' <STR-ASSIGN> <OPT-STR-MATCH>,
return ctuple(C_STR_ASSIGN, compile(rightchild(astp)), compile(child(astp,3)));
} else if (alt == 1) { //^\\ ;
return -1;
}
//^\\ # gt changed signal to allow 2 exprs. Mouses Imp77 adds an optional string!
//^\\ # 68000: %signal 5,,holeend,"HEAPPUT: heap corrupt" %if holeend>lhb_limit
case AST_OPEXPR2: //^\\ P<OPEXPR2> =
if (alt == 0) { //^\\ ',' <OPT-EXPR> <OPEXPR>,
int expr1 = compile(rightchild(astp));
int expr2 = compile(child(astp,3));
return ctuple(C_SEQ, expr1, expr2);
} else if (alt == 1) { //^\\ ;
int defaultexpr = ctuple(C_ADD_COMMA_BEFORE, C_Zero);
int expr1 = ctuple(C_ADD_COMMA_BEFORE, C_Zero);
int sexpr = ctuple(C_STRING_LITERAL, str_to_pool("_imp_str_literal(\"\")"));
int expr2 = ctuple(C_SEQ, ctuple(C_ADD_COMMA_BEFORE, sexpr), -1);
return ctuple(C_SEQ, defaultexpr, ctuple(C_SEQ, expr1, expr2));
}
case AST_OPT_STR_MATCH: //^\\ P<OPT-STR-MATCH> =
if (alt == 0) { //^\\ '.' <STR-MATCH> <OPT-STR-ASSIGN>,
return ctuple(C_STR_MATCH, compile(rightchild(astp)), compile(child(astp,3)));
} else if (alt == 1) { //^\\ ;
return -1;
}
//^\\ # Current Imp77 restricts string resolution to -> a.("test").b with a and b being optional.
//^\\ # Older Emas implementations allowed multiple parts I'm fairly sure, eg -> a.("match1").b.("match2").c
//^\\ #
//^\\ # Also, behaviour changed re initial ("match") with no assignment variable before it -
//^\\ # used to be that "match" had to start the string, but now there can be text before
//^\\ # it, and a null match has to be coded as -> a.("match").b %and a = ""
//^\\ #
//^\\ # So if we need to distinguish between these variations, do it in compile()
//^\\ #
case AST_STRING_RESOLUTION_EXPR://^\\ P<STRING-RESOLUTION-EXPR> =
if (alt == 0) { //^\\ <STR-MATCH> <OPT-STR-ASSIGN>,
return ctuple(
C_STR_MATCH,
compile(leftchild(astp)),
compile(rightchild(astp)));
} else if (alt == 1) { //^\\ <STR-ASSIGN> <OPT-STR-MATCH>;
return
ctuple(
C_STR_ASSIGN,
compile(leftchild(astp)),
compile(rightchild(astp))
);
}
break;
case AST_STRING_LVALUE: //^\\ P<STRING-LVALUE> =
if (alt == 0) { //^\\ <LVALUE>;
return compile(leftchild(astp)); // may need the C_AST_OBJECT treatment?
}
case AST_STRING_RVALUE: //^\\ P<STRING-RVALUE> =
if (alt == 0) { //^\\ <STRING-LVALUE>,
return compile(leftchild(astp));
} else if (alt == 1) { //^\\ <STR-CONST>,
return compile(leftchild(astp));
} else if (alt == 2) { //^\\ '(' <STRING-EXPR> ')';
return compile(rightchild(astp)); // don't bother with C_BRACKETS as only one operator possible.
}
case AST_REST_OF_STRING_EXPR: //^\\ P<REST-OF-STRING-EXPR> =
if (alt == 0) { //^\\ '.' <STRING-RVALUE> <REST-OF-STRING-EXPR>,
int lhs = compile(rightchild(astp));
int rhs = compile(child(astp,3));
if (rhs == -1) return ctuple(C_CONCAT, -1, lhs);
leftchild(rhs) = lhs;
return ctuple(C_CONCAT, -1, rhs);
// since concatenation is linear, don't care about left/right assoc
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_REST_OF_ANDC: //^\\ P<REST-OF-ANDC> =
if (alt == 0) { //^\\ "and" <SC> <REST-OF-ANDC>,
int comp = ctuple(C_LOGAND, -1, -1);
int sc = compile(rightchild(astp));
int rest = compile(child(astp,3));
int rhs = sc;
if (rest != -1) {
leftchild(rest) = sc;
rhs = rest;
}
rightchild(comp) = rhs; // leftchild will be filled in by parent
return comp;
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_DOTTED_STRING_EXPR: //^\\ P<DOTTED-STRING-EXPR> =
if (alt == 0) { //^\\ <STRING-RVALUE> <?DOT> <REST-OF-STRING-EXPR>;
int rhs = compile(child(astp,3));
if (rhs != -1) {
assert(AstOP(rhs) == C_CONCAT);
leftchild(rhs) = compile(leftchild(astp));
return rhs;
} else {
return compile(leftchild(astp));
}
}
case AST_OPT_DOUBLE_SIDED: //^\\ P<OPT-DOUBLE-SIDED> =
if (alt == 0) { //^\\ <COMP> <EXPR>,
int comp = compile(leftchild(astp));
int expr = compile(rightchild(astp));
rightchild(comp) = expr;
return comp;
} else if (alt == 1) { //^\\ ;
return -1;
}
break;
case AST_LABEL: //^\\ P<LABEL> =
if (alt == 0) { //^\\ <NAME> '(' <EXPR> ')',
int name_c = compile(child(astp,1));
int expr_c = compile(child(astp,3));
int decl_c;
int index_table;
decl_c = lookup("Declarations", name_to_cstr(NameOf(name_c))); // ALSO NEED TO CHECK SCOPE LEVEL!!! It could be an out-of-block jump to a parent for example.
fprintf(stderr, "Looking up switch label dest for jump - declaration was at %d\n", decl_c);
assert(AstOP(decl_c) == C_DECLARE_SWITCH);
index_table = child(decl_c, 3); // #1 name #2 boundspair #index of switch info table
int sw_low = switchmap[index_table+0]; // switchmap[index_table+0] = lower bound
int sw_high = switchmap[index_table+1]; // switchmap[index_table+1] = upper bound
int sw_default_used = switchmap[index_table+2]; // switchmap[index_table+2] = default used?
int *sw_case_used = &switchmap[index_table+3-sw_low]; // switchmap[index_table+3 ... ] = case label used (low:high inclusive) ?
//fprintf(stderr, "Low %d High %d\n", sw_low, sw_high);
return ctuple(C_SWITCH_LABEL_DEST, name_c, expr_c, decl_c, sw_low, sw_high); // TO DO!!! hook in declaration tuple here. (which in turn leads to the index of used cases)
} else if (alt == 1) { //^\\ <NAME>,
int name_c = compile(child(astp,1));
return ctuple(C_NAME_LABEL_DEST, name_c);
} else if (alt == 2) { //^\\ <DIGIT-SEQ>;
int name_c = compile(child(astp,1));
return ctuple(C_NUMERIC_LABEL_DEST, name_c); // digit-seq needs to be compiled and returned as a literal like a C_NAME
}
//^\\ # '<>' is a really obscure form but it definitely was used in the past.
//^\\ # I'll post a reference as soon as I locate one.
//^\\ #
case AST_NOT_EQUALS: //^\\ P<NOT-EQUALS> =
if (alt == 0) { //^\\ '#',
} else if (alt == 1) { //^\\ '\' '=',
} else if (alt == 2) { //^\\ '<' '>';
}
return ctuple(C_COMP_NOTEQ, -1, -1);
case AST_NOT_EQUALS_ADDRESS: //^\\ P<NOT-EQUALS-ADDRESS> =
if (alt == 0) { //^\\ '#' '#',
return ctuple(C_COMP_NOTEQ_ADDRESS, -1, -1);
} else if (alt == 1) { //^\\ '\' '=' '=';
return ctuple(C_COMP_NOTEQ_ADDRESS, -1, -1);
}
//^\\ # Ordering is important, eg '##' must come before '#'
//^\\ #
//^\\ # I really pity people who use the sort of grammar that requires
//^\\ # eliminating shift-reduce conflicts before they can parse anything :-)
//^\\ #
//^\\ '=' '=',
//^\\ '=',
//^\\ <NOT-EQUALS-ADDRESS>,
//^\\ <NOT-EQUALS>,
//^\\ '<' '=',
//^\\ '<',
//^\\ '>' '=',
//^\\ '>';
case AST_COMP: //^\\ P<COMP> =
if (alt == 0) { //^\\ '=' '=',
return ctuple(C_COMP_EQ_ADDRESS, -1, -1);
} else if (alt == 1) { //^\\ '=',
return ctuple(C_COMP_EQ, -1, -1);
} else if (alt == 2) { //^\\ <NOT-EQUALS-ADDRESS>,
return compile(leftchild(astp));
} else if (alt == 3) { //^\\ <NOT-EQUALS>,
return compile(leftchild(astp));
} else if (alt == 4) { //^\\ '<' '=',
return ctuple(C_COMP_LT_EQ, -1, -1);
} else if (alt == 5) { //^\\ '<',
return ctuple(C_COMP_LT, -1, -1);
} else if (alt == 6) { //^\\ '>' '=',
return ctuple(C_COMP_GT_EQ, -1, -1);
} else if (alt == 7) { //^\\ '>';
return ctuple(C_COMP_GT, -1, -1);
}
//^\\ # <NAME> <OPT-ACTUAL-PARAMETERS> added by gt for predicates
//^\\ # RESTOFSC handles double-sided conditions such as '0' <= ch <= '9'
case AST_SC: //^\\ P<SC> =
if (alt == 0) { //^\\ <STRING-RESOLUTION>,
int str_res = compile(leftchild(astp));
assert(str_res != -1);
return str_res;
} else if (alt == 1) { //^\\ <EXPR> <COMP> <EXPR> <OPT-DOUBLE-SIDED>,
// We may need to insert an explicit C_BRACKET around double-sided conditions?
// It depends on whether these are being translated properly - "&&" is higher precedence than "||".
// Also do we need to worry about the DeMorganned version when && is turned into || and vice-versa?
// I *think* this is OK.
// allimpc1.c:2747:31: warning: suggest parentheses around ‘&&’ within ‘||’ [-Wparentheses]
// if (Q == 0 || A[P] == 1 && 1 == Qu) goto L33;
// ~~~~~~~~~~^~~~~~~~~~
int cond, first_cond;
// to do: double-sided
int expr1 = compile(leftchild(astp)); // <EXPR>
int comp1 = compile(rightchild(astp)); // <COMP>
int expr2 = compile(child(astp,3)); // <EXPR>
int comp2 = compile(child(astp,4)); // <OPT-DOUBLE-SIDED>
leftchild(comp1) = expr1;
rightchild(comp1) = expr2;
if (comp2 != -1) { // May need to use a temporary for shared expr if it is expensive or has side-effects
leftchild(comp2) = expr2;
return ctuple(C_LOGAND, comp1, comp2);
} else {
assert(comp1 != -1);
return comp1;
}
} else if (alt == 2) { //^\\ <NAME> <OPT-ACTUAL-PARAMETERS>,
// TO DO: check that <NAME> is a %predicate, and that any declared parameters match the invocation.
int name = compile(child(astp,1)); // C_NAME
int param = compile(child(astp,2)); // #1 object this hangs off #2 actual parameter #3 rest of actual parameter list (another C_PARAMETER_LIST)
if (param == -1) {
// predicate with no parameters I presume, since we don't have booleans
} else {
// predicate with parameters I presume, since we don't have arrays of booleans
// this may not be necessary.
leftchild(param) = name;
}
return (build_call(C_FUNCTION_CALL, name, param)); // fn and params: #1 = proc name (C_NAME), #2 = C_PARAMETER_LIST
} else if (alt == 3) { //^\\ '(' <CONDITION> ')',
return ctuple(C_BRACKET, compile(rightchild(astp)));
} else if (alt == 4) { //^\\ "not" <SC>;
return ctuple(C_LOGNOT, compile(rightchild(astp)));
}
fault("Not reached");
//^\\ # Imp does not let you mix and/or without explicit brackets. They do not have a precedence relationship
case AST_REST_OF_COND: //^\\ P<REST-OF-COND> =
if (alt == 0) { //^\\ "and" <SC> <REST-OF-ANDC>,
int comp = ctuple(C_LOGAND, -1, -1);
int sc = compile(rightchild(astp));
int rest = compile(child(astp,3));
int rhs = sc;
if (rest != -1) {
leftchild(rest) = sc;
rhs = rest;
}
rightchild(comp) = rhs; // leftchild will be filled in by parent
return comp;
} else if (alt == 1) { //^\\ "or" <SC> <REST-OF-ORC>,
int comp = ctuple(C_LOGOR, -1, -1);
int sc = compile(rightchild(astp));
int rest = compile(child(astp,3));
int rhs = sc;
if (rest != -1) {
leftchild(rest) = sc;
rhs = rest;
}
rightchild(comp) = rhs; // leftchild will be filled in by parent
return comp;
} else if (alt == 2) { //^\\ ;
return -1;
}
break;
case AST_TOP_LEVEL_CONDITION: //^\\ P<CONDITION> =
{
int condition = compile(leftchild(astp));
if (AstOP(condition) == C_COMP_NOTEQ) {
int rhs = IntConstant_c(rightchild(condition));
if (rhs != -1 && child(rhs,2) == 0) {
return leftchild(condition);
}
} else if (AstOP(condition) == C_COMP_EQ) {
int rhs = IntConstant_c(rightchild(condition));
if (rhs != -1 && child(rhs,2) == 0) {
return ctuple(C_LOGNOT, leftchild(condition));
}
}
return condition;
}
case AST_CONDITION: //^\\ P<CONDITION> =
if (alt == 0) { //^\\ <SC> <REST-OF-COND>;
int expr = compile(rightchild(astp));
int sc = compile(leftchild(astp));
if (expr == -1) {
expr = sc;
assert(expr != -1);
} else leftchild(expr) = sc;
return expr;
}
//^\\ # Another Hamishism... %integer %array %name fred(1:*)
//^\\ # which in Imp77 would be %integer %array (1) fred
//^\\ # (reject the '*' in other contexts)
//^\\ #
case AST_UPPERBOUND: //^\\ P<UPPERBOUND> =
if (alt == 0) { //^\\ '*',
return ctuple(C_STRING_LITERAL, str_to_pool("*"));
} else if (alt == 1) { //^\\ <EXPR>,
return compile(leftchild(astp));
} else if (alt == 2) { //^\\ <BASE-XTYPE> <NAME>;
int base_xtype = compile(leftchild(astp));
int name = compile(rightchild(astp));
return ctuple(C_COMREG, base_xtype, name); // not used yet
}
// Should really split *BOUND into *BOUND-DECL and *BOUND-VALUE to distinguish "(%integer low: %integer high)" from "(1:10)"
case AST_LOWERBOUND: //^\\ P<LOWERBOUND> =
if (alt == 0) { //^\\ <EXPR>,
return compile(leftchild(astp));
} else if (alt == 1) { //^\\ <BASE-XTYPE> <NAME>;
int base_xtype = compile(leftchild(astp));
int name = compile(rightchild(astp));
return ctuple(C_COMREG, base_xtype, name); // not used yet
}
case AST_REST_OF_ACTUAL_PARAMETERS://^\\ P<REST-OF-ACTUAL-PARAMETERS> =
if (alt == 0) { //^\\ ',' <EXPR> <REST-OF-ACTUAL-PARAMETERS>,
int expr = compile(child(astp,2));
int rest = compile(child(astp,3));
return ctuple(C_PARAMETER_LIST, -1, expr, rest); // #1 object this hangs off #2 actual parameter #3 rest of actual parameter list (another C_PARAMETER_LIST)
} else if (alt == 1) { //^\\ ;
return -1;
}
//^\\ # Note: a <DIGIT-SEQ> can be both an integer constant and a real constant.
//^\\ # Imp77 supports constants like this: %constlongreal PI = 16_3.243F6A89
//^\\ # which are not handled here yet. (We also have EMAS-style R'xxxxxxxx' to handle)
//^\\ #
//^\\ # # P<realconst> = "[0-9][0-9]*\.[0-9][0-9]*E[0-9][0-9]*" |
//^\\ # # "[0-9][0-9]*\.[0-9][0-9]*" |
//^\\ # # "[0-9][0-9]*@[0-9][0-9]*"
//^\\ #
case AST_REAL_CONST: //^\\ P<REAL-CONST> =
if (alt == 0) { //^\\ <SAVED-REAL-CONST>;
char RealConst[1024];
getstr(leftchild(astp), RealConst);
return ctuple(C_CONST_REAL, str_to_pool(RealConst));
}
case AST_STR_CONST:
if (alt == 0) { //^\\ <SAVED-STR-CONST>;
char StringConst[1024];
getstr(leftchild(astp), StringConst);
return ctuple(C_CONST_STRING, str_to_pool(StringConst));
}
case AST_NAME: //^\\ P<NAME> =
if (alt == 0) { //^\\ <letter> <!SQUO-STRING> <opt-letter-or-digit-seq>;
// It is important that the parser does not stop looking when it hits something
// like M'CNST' and pass back M as a name. This is actually an integer constant
// as is X'DEAD' etc. The negative guard ensures that you don't make that mistake.
int letter = compile(child(astp,1)); assert(AstOP(letter) == C_STRING_LITERAL);
char *letter_str = pool_to_str(child(letter,1));
int rest = compile(child(astp,3));
if (rest == -1) {
return ctuple(C_NAME, child(letter,1), astp);
} else {
assert(AstOP(rest) == C_STRING_LITERAL);
char *rest_str = pool_to_str(child(rest,1));
char str[strlen(letter_str)+strlen(rest_str)+1];
sprintf(str, "%s%s", letter_str, rest_str);
return ctuple(C_NAME, str_to_pool(str), astp);
}
}
// ROCL = Rest Of Constant List
case AST_ROCL: //^\\ P<ROCL> =
{
if (alt == 0) { //^\\ ',' <stupid> <ARRAY-INITIALISER> <ROCL>,
int initialiser = compile(child(astp, 3));
int constexpr_c = child(initialiser,1);
int repeats = child(initialiser,2);
int rest_of_const_list_c = compile(child(astp, 4));
if (repeats != -1) {
return ctuple(C_EXPR_LIST, ctuple(C_INIT_REPEATS, constexpr_c, -1, -1, repeats), rest_of_const_list_c);
}
return ctuple(C_EXPR_LIST, constexpr_c, rest_of_const_list_c); // <CEXPR> then <ROCL>. Handle <REPEATS> later.
} else if (alt == 1) { //^\\ ;
return -1;
}
}
case AST_ARRAY_INITIALISER: //^\\ P<ARRAY-INITIALISER> = <CEXPR> <REPEATS>;
{
int constexpr_c = compile(child(astp,1));
int repeats = compile(child(astp,2));
return ctuple(C_COMREG, constexpr_c, repeats);
}
case AST_Opt_Init_assign: //^\\ P<Opt-Init-assign> =
{
if (alt == 0) { //^\\ <ASSOP-EXPR>,
// A fix may be needed. See the old code for <ASSOP-EXPR> which
// has recently been simplified. Breaking this:
int assop_expr_c = compile(leftchild(astp));
if (!(AstOP(assop_expr_c) == C_INIT ||
AstOP(assop_expr_c) == C_ASSIGN_ADDRESS ||
AstOP(assop_expr_c) == C_ASSIGN_VALUE ||
AstOP(assop_expr_c) == C_JAM_TRANSFER)) {
fprintf(stderr, "assop_expr_c = %d (%d); ", assop_expr_c, AstOP(assop_expr_c));
diagnose(assop_expr_c);
fflush(stderr);
assert(AstOP(assop_expr_c) == C_INIT ||
AstOP(assop_expr_c) == C_ASSIGN_ADDRESS ||
AstOP(assop_expr_c) == C_ASSIGN_VALUE ||
AstOP(assop_expr_c) == C_JAM_TRANSFER);
}
if (AstOP(assop_expr_c) == C_INIT) return assop_expr_c; // already built...
int assign_c = assop_expr_c;
int expr_c = rightchild(assop_expr_c);
return ctuple(C_INIT, assign_c, ctuple(C_EXPR_LIST, expr_c, -1), -1 /* low bound */, -1 /* high bound */);
} else if (alt == 1) { //^\\ ;
return -1;
}
}
//^\\ # An initialised array declaration does not need a %C following the '=' before the list of initial values.
//^\\ # this is a stupid hack to get around comments in the middle of array declarations :-(
//^\\ # note that it gobbles the newline
//^\\ # This has to handle: "== nil(*)" from %ownrecord(i tc f)%namearray tc refs(1:maxtc) == nil(*)
//^\\ # Turns out <SCALAR-ASSIGN> didn't include '==' so switched to <ASSOP> instead
//^\\ P<Opt-Init-assign-array> =
//^\\ <ASSOP> <stupid> <ARRAY-INITIALISER> <ROCL>,
//^\\ ;
case AST_Opt_Init_assign_array:
{
if (alt == 0) { // <ASSOP> <stupid> <ARRAY-INITIALISER> <ROCL>,
int assop_c = compile(child(astp,1)); // empty C_ASSIGN_VALUE or C_JAM_TRANSFER I hope. Not yet confirmed.
if (AstOP(assop_c) == C_ASSIGN_ADDRESS) {
fault("* UNIMPLEMENTED FEATURE: %name %array initialisation");
}
if (AstOP(assop_c) == C_JAM_TRANSFER) {
fault("* UNIMPLEMENTED FEATURE: Jam transfer ('<-') initialisation");
}
int initialiser = compile(child(astp,3));
int constexpr_c = child(initialiser,1);
int repeats = child(initialiser,2);
int rest_of_const_list_c = compile(child(astp,4));
if (repeats != -1) {
// #1 value #2 lower bound #3 upper bound #4 number of repeats
constexpr_c = ctuple(C_EXPR_LIST, ctuple(C_INIT_REPEATS, constexpr_c, -1, -1, repeats), rest_of_const_list_c);
return ctuple(C_INIT, assop_c, constexpr_c, -1 /* low bound */, -1 /* high bound */);
}
// join all values to one object:
constexpr_c = ctuple(C_EXPR_LIST, constexpr_c, rest_of_const_list_c);
// The assop_c *should* be applied to each item in the initialisation array.
// For now it is always treated as a simple assignment (and %namearray
// initialisations would be a problem if implemented)
return ctuple(C_INIT, assop_c, constexpr_c, -1 /* low bound */, -1 /* high bound */);
} else if (alt == 1) { //^\\ ;
return -1;
}
}
case AST_DIGIT_SEQ: //^\\ P<DIGIT-SEQ> =
{
int digit = compile(leftchild(astp));
int rest = compile(rightchild(astp));
if (rest < 0) return digit;
char *digits = pool_to_str(leftchild(rest));
int len = strlen(digits);
char seq[len+2];
sprintf(seq, "%s%s", pool_to_str(leftchild(digit)), digits);
return ctuple(C_STRING_LITERAL, str_to_pool(seq));
// potentially dreadfully N^2 in space
}
//^\\ # # P<digit> = "[0-9]";
//^\\ #
case AST_digit: //^\\ P<digit> = '0','1','2','3','4','5','6','7','8','9';
{
char tostring[2];
tostring[0] = alt+'0'; tostring[1] = '\0';
return ctuple(C_STRING_LITERAL, str_to_pool(tostring));
}
case AST_rest_of_number: //^\\ P<rest-of-number> =
{
int i;
if (alt == 0) { //^\\ <DIGIT-SEQ>,
return compile(leftchild(astp));
} else if (alt == 1) { //^\\ ;
return -1;
}
}
case AST_alphanumeric_SEQ: //^\\ P<alphanumeric-SEQ> =
{
// <alphanumeric> <Opt-alphanumeric-SEQ>;
int letter_or_digit = compile(leftchild(astp));
int rest = compile(rightchild(astp));
if (rest == -1) return letter_or_digit;
int len = strlen(pool_to_str(leftchild(rest)));
char seq[len+2];
sprintf(seq, "%s%s", pool_to_str(leftchild(letter_or_digit)), pool_to_str(leftchild(rest)));
return ctuple(C_STRING_LITERAL, str_to_pool(seq));
}
case AST_alphanumeric: //^\\ P<alphanumeric> =
// <letter>,
// <digit>;
return compile(leftchild(astp));
case AST_Opt_alphanumeric_SEQ://^\\ P<Opt-alphanumeric-SEQ> =
{
int i;
if (alt == 1) return -1;
// <alphanumeric> <Opt-alphanumeric-SEQ>,
int letter_or_digit = compile(leftchild(astp));
int rest = compile(rightchild(astp));
if (rest == -1) return letter_or_digit;
int len = strlen(pool_to_str(leftchild(letter_or_digit)))
+ strlen(pool_to_str(leftchild(rest)));
char seq[len+1];
sprintf(seq, "%s%s", pool_to_str(leftchild(letter_or_digit)),
pool_to_str(leftchild(rest)));
return ctuple(C_STRING_LITERAL, str_to_pool(seq));
}
//^\\ #
//^\\ # I'm taking the long way to handle alphanumerics and variable names, for now
//^\\ # At some point (soon) I hope to add regular expression matching, to shorten
//^\\ # these rules and speed up parsing. But this works, quite reliably.
//^\\ #
//^\\ # # P<letter> = "[A-Z]";
//^\\ #
case AST_letter: //^\\ P<letter> = 'A','B','C','D','E','F','G','H','I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z';
{
char tostring[2];
tostring[0] = alt+'A'; tostring[1] = '\0';
return ctuple(C_STRING_LITERAL, str_to_pool(tostring));
}
//^\\ # <sqstring> has to be checked for length and content depending on prefix.
//^\\ #
//^\\ # # P<lettercharconst> = <squote> <schar> <squote> |
//^\\ # # "[RHX]" <squote> <hexchars> <squote> |
//^\\ # # "B" <squote> <binchars> <squote> |
//^\\ # # "K" <squote> <octchars> <squote> |
//^\\ # # "[CMD]" <squote> <mchars> <squote>;
//^\\ #
case AST_OLDSTYLE_BASE: //^\\ P<OLDSTYLE-BASE> =
{
int i;
if (alt == 0) { //^\\ <letter> <sqstring>;
int letter = compile(leftchild(astp));
int sqstring = compile(rightchild(astp)); // BIP - needs cleaning
char *let_lit = pool_to_str(leftchild(letter));
char *str_lit = pool_to_str(leftchild(sqstring));
char c_const[35]; // extended this if we ever support long long int
int value = 0;
if (let_lit[1] != '\0') fault("Bad ASCII constant: %s'%s'", let_lit, str_lit);
if (let_lit[0] == 'M') {
// remove doubled quotes from sqstring
char *lit = str_lit;
for (;;) {
char *lit2 = strstr(lit, "\'\'");
if (lit2 == NULL) break;
//memmove(lit2, lit2+1, strlen(lit2+1)+1); // safe move with overlapping - remove one of a set of double quotes
*lit2 = '\\'; // map '' to \'
lit = lit2+1;
}
char *s = str_lit;
for (;;) {
int c = *s++;
if (c == '\0') break;
value = (value << 8) | (c&255);
if (!isprint(c&255)) fault("Bad ASCII constant: %s'%s'", let_lit, str_lit);
}
//sprintf(c_const, "'%s'", str_lit); // TO DO: escape any quotes in 'aaaa' and M'aaaa' forms.
char *q = c_const;
s = str_lit;
*q++ = '\'';
for (;;) {
int c = *s++;
if (c == '\0') break;
if (c == '\'') {
*q++ = '\\';
*q++ = c;
} else {
*q++ = c;
}
}
*q++ = '\'';
*q = '\0';
//fprintf(stderr, "*** Creating C_CONST_INT M L <%s,%d>\n", c_const, value);
return ctuple(C_CONST_INT, str_to_pool(c_const), value); // extended format now includes value
} else if (let_lit[0] == 'X' && strlen(str_lit) <= 8) {
sprintf(c_const, "0x%s", str_lit);
// check hex(sqstring);
char *s = str_lit;
while (*s != '\0') {
int c = (*s++)&255;
if ('0' <= c && c <= '9') {
value = (value << 4) | (c-'0');
} else if ('a' <= c && c <= 'f') {
value = (value << 4) | (c-'a'+10);
} else if ('A' <= c && c <= 'F') {
value = (value << 4) | (c-'A'+10);
} else {
fault("Bad HEX constant: %s'%s'", let_lit, str_lit);
}
}
//fprintf(stderr, "*** Creating C_CONST_INT X L <%s,%d>\n", c_const, value);
return ctuple(C_CONST_INT, str_to_pool(c_const), value); // extended format now includes value
} else if (let_lit[0] == 'X' && strlen(str_lit) <= 16) {
long long int value = 0LL;
sprintf(c_const, "0x%s", str_lit);
// check hex(sqstring);
char *s = str_lit;
while (*s != '\0') {
int c = (*s++)&255;
if ('0' <= c && c <= '9') {
value = (value << 4LL) | (long long)(c-'0');
} else if ('a' <= c && c <= 'f') {
value = (value << 4LL) | (long long)(c-'a'+10);
} else if ('A' <= c && c <= 'F') {
value = (value << 4LL) | (long long)(c-'A'+10);
} else {
fault("Bad HEX constant: %s'%s'", let_lit, str_lit);
}
}
//fprintf(stderr, "*** Creating C_CONST_INT X LL <%s,%lld>\n", c_const, value);
return ctuple(C_CONST_BIGINT, str_to_pool(c_const), (long)((value>>32LL)&0xFFFFFFFFLL), (long)(value&0xFFFFFFFFLL)); // extended format now includes value
} else if (let_lit[0] == 'R' && strlen(str_lit) <= 8) {
warn("Hex %real constant not correctly implemented yet");
sprintf(c_const, "0x1.%sfp0", str_lit); // THIS IS NOT CORRECT. MAY NEED SOME DECODING OF EMAS-STYLE R'xxxxxxxx'... TO DO!
// check hex(sqstring);
char *s = str_lit;
while (*s != '\0') {
int c = (*s++)&255;
if ('0' <= c && c <= '9') {
value = (value << 4) | (c-'0');
} else if ('a' <= c && c <= 'f') {
value = (value << 4) | (c-'a'+10);
} else if ('A' <= c && c <= 'F') {
value = (value << 4) | (c-'A'+10);
} else {
fault("Bad REAL-HEX constant: %s'%s'", let_lit, str_lit);
}
}
return ctuple(C_CONST_INT, str_to_pool(c_const), value); // extended format now includes value
} else if (let_lit[0] == 'K' && strlen(str_lit) <= 11) {
sprintf(c_const, "0%s", str_lit);
// check octal(sqstring);
char *s = str_lit;
while (*s != '\0') {
int c = (*s++)&255;
if ('0' <= c && c <= '7') {
value = (value << 3) | (c-'0');
} else {
fault("Bad OCTAL constant: %s'%s'", let_lit, str_lit);
}
}
return ctuple(C_CONST_INT, str_to_pool(c_const), value); // extended format now includes value
} else if (let_lit[0] == 'B' && strlen(str_lit) <= 32) {
sprintf(c_const, "0b%s", str_lit);
// check binary(sqstring);
char *s = str_lit;
while (*s != '\0') {
int c = (*s++)&255;
if ('0' <= c && c <= '1') {
value = (value << 1) | (c-'0');
} else {
fault("Bad BINARY constant: %s'%s'", let_lit, str_lit);
}
}
return ctuple(C_CONST_INT, str_to_pool(c_const), value); // extended format now includes value
} else {
// %CONSTLONGLONGREAL TEN=R'41A00000000000000000000000000000' <-- unhandled.
// https://www.geeksforgeeks.org/ieee-standard-754-floating-point-numbers/
// https://en.wikipedia.org/wiki/Double-precision_floating-point_format
// https://en.wikipedia.org/wiki/Quadruple-precision_floating-point_format _Float128, or __float128 in
// https://gcc.gnu.org/onlinedocs/libquadmath/
warn("Invalid constant type: %s'%s'", let_lit, str_lit); // really a fault() but we'll continue compiling to see how far we get...
return C_Zero;
}
}
}
case AST_LABEL_COLON: //^\\ P<LABEL-COLON> =
if (alt == 0) { //^\\ <immediate:saved = at_startofstatement; at_startofstatement = TRUE; return TRUE;> ':',
// cps(": ;");// ';' only really needed if label is followed by '}' ...
return TO_DO("P<LABEL-COLON>");
} else if (alt == 1) { //^\\ <immediate:at_startofstatement = saved; return FALSE;>;
return -1;
}
//^\\ # #P<LABEL-COLON> =
//^\\ # # ':';
//^\\ # SS is the primary entry point.
//^\\ #
case AST_SS: //^\\ P<SS> =
if (alt == 0) { //^\\ <EXTERNALS> <LAST-ITEMS-IN-FILE>;
push_scope_level(); makespace(blocktype, current_scope+1); blocktype(current_scope) = BLOCKTYPE_EXTERNAL;
int ss_c = compile(leftchild(astp));
seqlist = -1; pop_scope_level(); assert(seqlist == -1); // end of scope 0 which is top-level scope, *not* a block scope. nothing to insert here at end of block.
return ss_c;
}
case AST_opt_letter_or_digit_seq: //^\\ P<opt-letter-or-digit-seq> = <letter> <opt-letter-or-digit-seq>, <digit> <opt-letter-or-digit-seq>, ;
{
// The recursive nature of this string construction is unfortunately rather expensive
// in time and space. Queued for the 'optimisation rewrite' some distant time in the future...
if (alt == 2) return -1;
int let_or_dig = compile(child(astp,1)); assert(AstOP(let_or_dig) == C_STRING_LITERAL);
char *let_or_dig_str = pool_to_str(child(let_or_dig,1));
int rest = compile(child(astp,2));
if (rest == -1) return let_or_dig;
assert(AstOP(rest) == C_STRING_LITERAL);
char *rest_str = pool_to_str(child(rest,1));
char str[strlen(let_or_dig_str)+strlen(rest_str)+1];
sprintf(str, "%s%s", let_or_dig_str, rest_str);
return ctuple(C_STRING_LITERAL, str_to_pool(str), astp);
}
//^\\ # More than one newline (or semicolon)
case AST_BLANKS: //^\\ P<BLANKS> = <S> <BLANKS>, ;
//for (i = 1; i <= count; i++) (void)compile(child(astp,i));
return -1; // syntactic sugar
//^\\ # The last items in a file.
//^\\ # the final EOF below is only for begin/endofprogram which *can* be followed by code but shouldn't
case AST_LAST_ITEMS_IN_FILE: //^\\ P<LAST-ITEMS-IN-FILE> =
if (alt == 0) { //^\\ "end" "of" "file" <BLANKS> <EOF>,
} else if (alt == 2) { //^\\ <BLANKS> <EOF>;
}
return -1;
case AST_program:UNUSED("AST_program"); //^\\ P<program> =
if (alt == 0) { //^\\ "programme",
} else if (alt == 1) { //^\\ "program";
}
return -1;
//^\\ # I haven't specified any phrases to be external-only. There might be some,
//^\\ # but I'll leave it to compile() to reject them.
case AST_EXTERNALS: //^\\ P<EXTERNALS> =
if (alt == 0) { //^\\ "end" "of" "perm" <S> <EXTERNALS>,
return compile(child(astp,5));
// C_END_OF_PERM and C_END_OF_PRIM can be used to turn on listing again... or they can just be ignored.
int more_c = compile(child(astp,5));
assert(more_c == -1 || AstOP(more_c) == C_SEQ);
// TO DO: there may be an extra "push_scope_level();" needed here to distinguish between
// prims and top-level user declarations...
return ctuple(C_SEQ, ctuple(C_END_OF_PERM), more_c);
} else if (alt == 1) { //^\\ "end" "of" "prim" <S> <EXTERNALS>,
int more_c = compile(child(astp,5));
assert(more_c == -1 || AstOP(more_c) == C_SEQ);
// to be honest I'm not even sure there *is* an "endofprim" in the language!
return ctuple(C_SEQ, ctuple(C_END_OF_PRIM), more_c);
} else if (alt == 2) { //^\\ <EXTERNAL-OR-INTERNAL> <EXTERNALS>,
int one_c = compile(leftchild(astp));
int more_c = compile(rightchild(astp));
assert(more_c == -1 || AstOP(more_c) == C_SEQ);
return ctuple(C_SEQ, one_c, more_c);
} else if (alt == 3) { //^\\ ;
return -1;
}
//^\\ # I cleaned up label handling, we can afford the overhead of backtracking over one <NAME>...
//^\\ # - this isn't the 70's any more. Labels are not valid outside blocks.
case AST_INTERNALS: //^\\ P<INTERNALS> =
if (alt == 0) { //^\\ <OPT-LABEL-DEFINITION> <INTERNAL> <INTERNALS>,
int labels = compile(leftchild(astp));
if (labels == -1) {
int statement = compile(rightchild(astp));
int more_statements = compile(child(astp,3));
if (more_statements == -1) {
//diagnose(statement);
if (statement == -1) {
//warn("A: An <INTERNAL> statement returned -1. Something not yet implemented? A null statement?");
}
return ctuple(C_SEQ, statement, -1);
}
if (statement == -1) {
//warn("b: An <INTERNAL> statement returned -1. Something not yet implemented? A null statement?");
// unfortunately we can't look at the creation_line as it is only inserted for C_* AST records, not AST_* ones. Or -1.
// Am I missing a C_SEQ here? Should add an assert (sometime when I'm not in the middle of tracking something else down)
// (I'm thinking of the error where the last item in a sequence as C_IF rather than -1. Found in backgs.imp test)
return more_statements;
}
return ctuple(C_SEQ, statement, more_statements);
} else {
int statement = compile(rightchild(astp));
int more_statements = compile(child(astp,3));
int labelled_statement;
if (statement == -1) {
labelled_statement = ctuple(C_SEQ, ctuple(C_ADD_SEMI, labels), -1);
} else {
labelled_statement = ctuple(C_SEQ, labels, statement);
}
if (more_statements == -1) return labelled_statement;
assert(AstOP(more_statements) == C_SEQ);
return ctuple(C_SEQ, labelled_statement, more_statements);
}
} else if (alt == 1) { //^\\ <OPT-LABEL-DEFINITION>;
// probably *only* this label that requires a ';' after it before the '}' block end...
int opt_lab = compile(leftchild(astp));
if (opt_lab == -1) {
//warn("c: An <INTERNAL> statement returned -1. Most likely an unlabelled null statement, eg end of a block?");
return -1;
}
return ctuple(C_SEQ, ctuple(C_ADD_SEMI, opt_lab), -1);
//return opt_lab;
//return ctuple(C_SEQ, opt_lab, -1);
}
//^\\ # top-level begin/end block can either be %begin/%endofprogram,
//^\\ # or %begin/%end/%endoffile. However in some cases things can
//^\\ # be placed between the %end and the %endoffile.
//^\\ #
//^\\ # I've also seen %routine xxx/%endofprogram in FMACS/BOOT.imp
//^\\ #
//^\\ # There's a %begin/%end without an %endoffile in FMACS/FIRST4.imp
case AST_outer_level_end: //^\\ P<outer-level-end> = "end" "of" <program>, "end";
return -1; // syntactic sugar
//^\\ # these are allowed at the external level and also inside procedures/main program.
//^\\ # The phrases that are internal-only include these as the final alternative,
//^\\ # hence why the empty statement can only occur as the last item in this list.
//^\\ #
//^\\ # If using this grammar as a 'SOAP' replacement, you'll want to allow syntactically
//^\\ # incorrect statements also, and if so, those should be handled here after the <S> rule.
//^\\ #
case AST_EXTERNAL_OR_INTERNAL://^\\ P<EXTERNAL-OR-INTERNAL> =
if (alt == 0) { //^\\ "begin" <S> <INTERNALS> <outer-level-end> <S>,
push_scope_level(); makespace(blocktype, current_scope+1); blocktype(current_scope) = BLOCKTYPE_MAIN_PROGRAM;
int block_c = compile(child(astp,3)); // <INTERNALS>
//fprintf(stderr, "\nDuring parsing: begin/end internals contains:"); diagnose(block_c);
//fprintf(stderr, ", leftchild of block_c follows:"); diagnose(leftchild(block_c));
//fprintf(stderr, "<-- was that as expected?\n");
seqlist = -1; pop_scope_level(); // top-level begin/endofprogram block.
assert(block_c == -1 || AstOP(block_c) == C_SEQ);
append_to(&block_c, seqlist); seqlist = -1; // TO DO: other blocks
int stmnt = ctuple(C_MAIN_PROGRAM_BLOCK, block_c, -1);
return ctuple(C_SEQ, stmnt, -1);
} else if (alt == 1) { //^\\ <Percent-SEX> <RT> <spec> <NAME> <Opt-ALIAS> <FPP> <S>,
// %spec. NOT a body.
int sex = compile(child(astp,1)); // <Percent-SEX>
if (sex == -1) {
// static or extern or auto or default?
if (current_scope < 1) {
sex = ctuple(C_STORAGE, C_STORAGE_static); // unmarked "%routine" at outer level is a static in C - spec or actual body
// (unmarked data declarations aren't allowed)
} else {
// sex = ctuple(C_STORAGE, C_LINKAGE_internal);
sex = ctuple(C_STORAGE, C_STORAGE_auto); // unmarked "%routine" at outer level is a static in C - spec or actual body
}
}
int rt = compile(child(astp,2)); // <RT> - may be one of 4 forms... rt/fn/map/predicate. Fields mostly in same place
int spec = compile(child(astp,3)); // <spec>
int name = compile(child(astp,4)); // <NAME>
int alias = compile(child(astp,5)); // <Opt-ALIAS>
push_scope_level(); makespace(blocktype, current_scope+1); blocktype(current_scope) = BLOCKTYPE_FPP;
int fpp = compile(child(astp,6)); // <FPP>
seqlist = -1; pop_scope_level(); assert(seqlist == -1); // no opportunity for anything to need to be inserted here.
leftchild(rt) = name;
// rightchild(rt) filled in by <RT>.
child(rt, 3) = fpp; // #1 C_TYPE_... #2 next <C_TYPE_PARAMETERS> or -1
assert(child(rt, 4) == -1); // Should already be -1.
child(rt, 4) = spec; // this is a spec.
child(rt, 5) = alias;
child(rt, 6) = sex;
Declare(name, rt);
int stmnt = ctuple(C_ADD_SEMI, rt);
return ctuple(C_SEQ, stmnt, -1);
} else if (alt == 2) { //^\\ <Percent-SEX> <RT> <NAME> <Opt-ALIAS> <FPP> <S> <INTERNALS> <outer-level-end> <S>,
// <Percent-SEX> <RT> <NAME> <Opt-ALIAS> <FPP> <S> <INTERNALS> <outer-level-end> <S>,
int sex = compile(child(astp,1)); // <Percent-SEX>
if (sex == -1) {
// static or extern or auto or default?
if (current_scope < 1) {
sex = ctuple(C_STORAGE, C_STORAGE_static); // unmarked "%routine" at outer level is a static in C - spec or actual body
// (unmarked data declarations aren't allowed)
} else {
// sex = ctuple(C_STORAGE, C_LINKAGE_internal);
sex = ctuple(C_STORAGE, C_STORAGE_default); // unmarked "%routine" at outer level is a static in C - spec or actual body
}
}
int rt = compile(child(astp,2)); // <RT> - may be one of 4 forms... rt/fn/map/predicate. Fields mostly in same place
int name = compile(child(astp,3)); // <NAME>
int alias = compile(child(astp,4)); // <Opt-ALIAS>
// A little bit of a 'TO DO' to ensure correct scope for procedure name, then its parameters, then its body...
leftchild(rt) = name;
// rightchild(rt) filled in by <RT>.
child(rt, 3) = -1; // #1 C_TYPE_... #2 next <C_TYPE_PARAMETERS> or -1
assert(child(rt, 4) == -1); // not a spec. -1 is temporary until it is plugged in below.
child(rt, 5) = alias;
child(rt, 6) = sex;
Declare(name, rt); // has to be declared before the body is compiled, so that recursive calls work.
push_scope_level(); makespace(blocktype, current_scope+1); blocktype(current_scope) = BLOCKTYPE_ROUTINE;
int fpp = compile(child(astp,5)); // <FPP> // procedure's params are local to the procedure
child(rt, 3) = fpp; // #1 C_TYPE_... #2 next <C_TYPE_PARAMETERS> or -1
int body = compile(child(astp,7)); // <FPP>
seqlist = -1; pop_scope_level(); // CALLBACK MAY POPULATE seqlist !!!
// end of a proc/fn/map
if (seqlist != -1) { // seqlist contains any end-of-procedure code such as handling missing switch labels.
if (AstOP(body) != C_SEQ) {
body = ctuple(C_SEQ, body, seqlist);
} else {
append_to(&body, seqlist);
}
}
child(rt, 4) = ctuple(C_PROCEDURE_BLOCK, body, rt);
seqlist = -1;
return ctuple(C_SEQ, rt, -1);
} else if (alt == 3) { //^\\ <OPT-68K> <Percent-SEX> <RT> <NAME> <Opt-ALIAS> <FPP> <S>,
int sex = compile(child(astp,2)); // <Percent-SEX>
if (sex == -1) sex = ctuple(C_STORAGE, C_LINKAGE_internal);
int rt = compile(child(astp,3)); // <RT> - may be one of 4 forms... rt/fn/map/predicate. Fields mostly in same place
int name = compile(child(astp,4)); // <NAME>
int alias = compile(child(astp,5)); // <Opt-ALIAS>
int fpp = compile(child(astp,6)); // <FPP>
leftchild(rt) = name;
// rightchild(rt) filled in by <RT>.
child(rt, 3) = fpp; // #1 C_TYPE_... #2 next <C_TYPE_PARAMETERS> or -1
child(rt, 4) = -1; // spec, so no body yet
child(rt, 5) = alias;
child(rt, 6) = sex;
// TO DO: Add to symbol table. check for previous declaration (not spec) at this scope
Declare(name, rt);
int stmnt = ctuple(C_ADD_SEMI, rt);
return ctuple(C_SEQ, stmnt, -1);
} else if (alt == 4) { //^\\ <DECLARATION-S>,
int stmnt = compile(leftchild(astp));
return ctuple(C_SEQ, stmnt, -1);
} else if (alt == 5) { //^\\ "record" "format" <RECFMT-spec-OR-BODY> <S>,
//cps("/* record format... */");
int actual_format = compile(child(astp,3));
int is_spec = child(actual_format, 3) == -1 ? ctuple(C_SPEC) : -1;
int name;
// NOTE!!! when we get a record format spec X in imp,
// we need to issue "typedef struct X X" in C,
// so the typedef can be used in a forward declaration.
// When we declare a record format, we need to overwrite any preceding spec rather than create a second one later.
// But be careful that they are both at the same scope. If the format declaration is in a block that is nested following the
// spec, it is not the same format.
detuple(actual_format, C_TYPE_RECORDFORMAT, NULL, &name, NULL);
//fprintf(stderr, "Declaring record format ");if (is_spec != -1) fprintf(stderr, "spec ");
//fprintf(stderr, "with 'actual format' of %d\n", actual_format);
int format_decl = ctuple(C_DECLARE_RECORDFORMAT, actual_format, is_spec); // <RECFMT-spec-OR-BODY>
// C_TYPE_RECORDFORMAT = #1 <record name or -1> #2 record format name #3 field list of C_TYPE_RECORD_FIELD
fprintf(stderr, "variant debugging ... record format contents at point of declaration:\n");diagnosewalk(actual_format);
Declare(name, actual_format); // this enters the record definition in the name table
return ctuple(C_SEQ, format_decl, -1); // and this causes the record format declaration to be output
} else if (alt == 6) { //^\\ "switch" <ONE-SWITCH-DECL> <REST-OF-SWLIST> <S>,
int first_sw_decl = compile(child(astp,2));assert(AstOP(first_sw_decl) == C_SEQ);
int more_sw_decls = compile(child(astp,3));assert(more_sw_decls == -1 || AstOP(more_sw_decls) == C_SEQ);
append_to(&first_sw_decl, more_sw_decls);
return ctuple(C_SEQ, first_sw_decl, -1);
} else if (alt == 7) { //^\\ "include" <STR-CONST>,
int incfile = compile(rightchild(astp));
int stmnt = ctuple(C_INCLUDEFILE, incfile);
return ctuple(C_SEQ, stmnt, -1);
} else if (alt == 8) { //^\\ "option" <STR-CONST>,
int command_line_options = compile(rightchild(astp));
int stmnt = ctuple(C_OPTIONS, command_line_options);
return ctuple(C_SEQ, stmnt, -1);
} else if (alt == 9) { //^\\ "from" <NAME> "include" <NAME> <Opt-NAME-LIST>,
//NAME_TARGET = &ThrowAway; sym_init(&ThrowAway);
int modulename = compile(rightchild(astp));
int first_name = compile(child(astp,4));
int more_names = compile(child(astp,5));
int names = ctuple(C_SEQ, first_name, more_names);
int stmnt = ctuple(C_INCLUDEMODULE, modulename, names);
return ctuple(C_SEQ, stmnt, -1);
} else if (alt == 10) { //^\\ "end" "of" "list" <S>,
OUTFILE = NULLFILE;
int stmnt = ctuple(C_END_OF_LIST);
return ctuple(C_SEQ, stmnt, -1);
} else if (alt == 11) { //^\\ "list" <S>,
OUTFILE = stdout;
int stmnt = ctuple(C_START_OF_LIST);
return ctuple(C_SEQ, stmnt, -1);
} else if (alt == 12) { //^\\ "end" "of" "mcode" <S>,
int stmnt = ctuple(C_END_OF_MCODE);
return ctuple(C_SEQ, stmnt, -1);
} else if (alt == 13) { //^\\ "mcode" <S>,
int stmnt = ctuple(C_START_OF_MCODE);
return ctuple(C_SEQ, stmnt, -1);
} else if (alt == 14) { //^\\ "trusted" "program" <S>,
int stmnt = ctuple(C_TRUSTED_PROGRAM);
return ctuple(C_SEQ, stmnt, -1);
} else if (alt == 15) { //^\\ "main" "ep" <NAME> <S>,
int name = compile(child(astp,3));
int stmnt = ctuple(C_MAIN_EP, name);
return ctuple(C_SEQ, stmnt, -1);
} else if (alt == 16) { //^\\ "control" <INT-CONST> <S>,
int control = compile(rightchild(astp));
int stmnt = ctuple(C_CONTROL, control);
return ctuple(C_SEQ, stmnt, -1);
} else if (alt == 17) { //^\\ "diagnose" <INT-CONST> <S>,
int diagnose = compile(rightchild(astp));
int stmnt = ctuple(C_DIAGNOSE, diagnose);
return ctuple(C_SEQ, stmnt, -1);
} else if (alt == 18) { //^\\ "reals" "long" <S>,
//DEFAULT_REAL_SIZE = _long;
C_TYPE_REAL_default_real_size = C_TYPE_REAL_double;
int stmnt = ctuple(C_REALS_LONG);
return ctuple(C_SEQ, stmnt, -1);
} else if (alt == 19) { //^\\ "reals" "normal" <S>,
//DEFAULT_REAL_SIZE = word;
C_TYPE_REAL_default_real_size = C_TYPE_REAL_float;
return ctuple(C_SEQ, ctuple(C_REALS_NORMAL), -1);
} else if (alt == 20) { //^\\ <COMMENT>,
return ctuple(C_SEQ, compile(leftchild(astp)), -1);
} else if (alt == 21) { //^\\ '?' <EXPR> <S>; // "? expr" used to test new cleaner compile() code.
debug_structures = 1;
int dbg = ctuple(C_DEBUG, compile(rightchild(astp)));
debug_structures = 0;
return ctuple(C_SEQ, dbg, -1);
} else if (alt == 22) { //^\\ '?' '?' <CEXPR> <S>; // ?? displays folded version of const expr
int dbg = ctuple(C_DEBUG, compile(child(astp, 3)));
return ctuple(C_SEQ, dbg, -1);
} else if (alt == 23) { //^\\ '?' <LVALUE> '=' <EXPR> <S>;
int dbg = ctuple(C_DEBUG,
ctuple(C_ASSIGN_VALUE, compile(child(astp,2)), compile(child(astp,4)))
); // 'address wanted' param is for assignments, procedure parameters etc
return ctuple(C_SEQ, dbg, -1);
} else if (alt == 24) { //^\\ '?' <LVALUE> '=' '=' <LVALUE> <S>;
int lvalue, rvalue;
lvalue = compile(child(astp,2));
rvalue = compile(child(astp,5));
int dbg = ctuple(C_DEBUG, ctuple(C_ASSIGN_ADDRESS, lvalue, rvalue));
return ctuple(C_SEQ, dbg, -1);
} else if (alt == 25) { //^\\ <IF-S>,
return compile(leftchild(astp));
} else if (alt == 26) { //^\\ <S>;
return -1;
}
break;
//^\\ # These are all extensions used by 68000 Imp:
//^\\ #
//^\\ # %begin
//^\\ # %recordformat f(%byte ldte,lsap,rdte,rsap)
//^\\ # @#ldte %record(f)cur
//^\\ # ( I have no idea what "@#ldte " means. )
//^\\ #
//^\\ # @400(a5) %record(*)%namearray in(0:7)
//^\\ # @16_3F00-192 %routine closeinput
//^\\ # @724(a5) %integername heapfront
//^\\ #
//^\\ # '@' <68K-code-address> before a routine name is an external spec in 68000 Imp, and
//^\\ # <Opt-68K-code-address> after an external %spec is a perm routine spec in 68000 Imp.
//^\\ # as in: %integerfnspec(16_1124) REM(%integer a,b) { found in APM-gdmr/I/GGPERM.imp }
//^\\ #
case AST_OPT_68K: //^\\ P<OPT-68K> =
if (alt == 0) { //^\\ '@' <68K-stuff>,
return ctuple(C_68K_AT, compile(child(astp,2)));
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_68K_stuff: //^\\ P<68K-stuff> =
if (alt == 0) { //^\\ '-' <INT-CONST> '(' <NAME> ')',
} else if (alt == 1) { //^\\ <INT-CONST> '(' <NAME> ')',
} else if (alt == 2) { //^\\ <INT-CONST> '-' <INT-CONST>,
} else if (alt == 3) { //^\\ <INT-CONST>,
} else if (alt == 4) { //^\\ '#' <NAME>;
}
return -1; /*TEMP*/
return TO_DO("<68K-stuff>");
//^\\ # this is for 68000 Imp:
//^\\ #
//^\\ # %externalrealfnspecalias READ %alias "readreal"
//^\\ # %externalintegerfnspecalias READ
//^\\ # I have no idea what a "specalias" is :-( CORRECTION: I do now... this form of alias
//^\\ # is Hamish's way of overloading procedure declarations. It has some complex conditions -
//^\\ # see the section "Overloading" in https://gtoal.com/imp77/reference-manual/Imp-M68K-V3.html
//^\\ #
//^\\ # %integerarrayspec(16_C00000) frame(0:32767)
//^\\ # %integerfnspec(16_1124) REM(%integer a,b)
//^\\ # %bytespec(16_7fffc)status
//^\\ #
//^\\ # I think these extensions are also covered with a *different* extension in the same compiler :-(
//^\\ # i.e.
//^\\ # @16_7fffc %byte status ???
//^\\ #
case AST_spec: //^\\ P<spec> =
if (alt == 0) { //^\\ "specalias",
//set_x(&GlobalSym, is_spec);
return ctuple(C_SPEC_ALIAS);
} else if (alt == 1) { //^\\ "spec" <Opt-68K-code-address>;
//set_x(&GlobalSym, is_spec);
int have68kstuff = compile(rightchild(astp));
if (have68kstuff != -1) {
return ctuple(C_SPEC68K, have68kstuff);
} else {
return ctuple(C_SPEC);
}
}
case AST_Opt_68K_code_address://^\\ P<Opt-68K-code-address> =
if (alt == 0) { //^\\ '(' <INT-CONST> ')',
return ctuple(C_68K_ENTRY_ADDRESS, compile(rightchild(astp)));
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_OPT_spec: //^\\ P<OPT-spec> =
if (alt == 0) { //^\\ <spec>,
return compile(leftchild(astp));
} else if (alt == 1) { //^\\ ;
return -1;
}
//^\\ # All labels come through here. Because of an interaction with comments,
//^\\ # we use some parse-time code in phrase <LABEL-COLON> to modify how line reconstruction
//^\\ # handles the comments. btw Numeric labels are a historical form...
case AST_OPT_LABEL_DEFINITION://^\\ P<OPT-LABEL-DEFINITION> =
if (alt == 0) { //^\\ <NAME> '(' <CEXPR> ')' <LABEL-COLON> <OPT-LABEL-DEFINITION>,
int name_c = compile(child(astp,1)); assert(AstOP(name_c) == C_NAME);
int cexpr_c = compile(child(astp,3)); assert(AstOP(cexpr_c) == C_CONST_INT);
int sw_c = ctuple(C_SWITCH_LABEL_COLON, name_c, cexpr_c);
int more_labs = compile(child(astp,6));assert(more_labs == -1 || AstOP(more_labs) == C_SEQ);
char *names = pool_to_str(leftchild(name_c));
int val = child(cexpr_c,2);
//fprintf(stderr, "*** switch index appears to be %d: cexpr = ", val); diagnose(cexpr_c);fprintf(stderr, "\n");
mark_switch_case_used(names, val);
return ctuple(C_SEQ, sw_c, more_labs);
} else if (alt == 1) { //^\\ <NAME> '(' '*' ')' <LABEL-COLON> <OPT-LABEL-DEFINITION>,
int name_c = compile(leftchild(astp));
int sw_c = ctuple(C_SWITCH_LABEL_DEFAULT, name_c);
int more_labs = compile(child(astp,6));assert(more_labs == -1 || AstOP(more_labs) == C_SEQ);
mark_switch_default_used(pool_to_str(leftchild(name_c)));
return ctuple(C_SEQ, sw_c, more_labs);
} else if (alt == 2) { //^\\ <NAME> <LABEL-COLON> <OPT-LABEL-DEFINITION>,
//cps("\n");
int name_c = compile(child(astp,1)); // out(name_c);
// ignore <LABEL-COLON>
int more_labs = compile(child(astp,3));assert(more_labs == -1 || AstOP(more_labs) == C_SEQ);
// Add to a declaration list for this scope? Imp9 uses separate namespace from variable names. May need to
// output a '__label__' declaration at the start of this block.
// The goto ('->') must be to a label set in the same block as the jump.
// Cannot jump into a cycle/repeat or start finish block but you *can* jump out of them. But not out of a begin/end block.
return ctuple(C_SEQ, ctuple(C_ALPHANUMERIC_LABEL_COLON, name_c), more_labs);
} else if (alt == 3) { //^\\ <DIGIT-SEQ> <LABEL-COLON> <OPT-LABEL-DEFINITION>,
// READY TO HANDLE AS C_NUMERIC_LABEL_DEST:
int num_c = compile(leftchild(astp)); // fortunately negative no's not possible here. // cps("L__");
int more_labs = compile(child(astp,3));assert(more_labs == -1 || AstOP(more_labs) == C_SEQ);
// Add to a declaration list for this scope? Imp9 uses separate namespace from variable names. May need to
// output a '__label__' declaration at the start of this block.
// The goto ('->') must be to a label set in the same block as the jump.
// Cannot jump into a cycle/repeat or start finish block but you *can* jump out of them. But not out of a begin/end block.
return ctuple(C_SEQ, ctuple(C_NUMERIC_LABEL_COLON, num_c), more_labs);
} else if (alt == 4) { //^\\ ;
return -1;
}
//^\\ # fault statements can only appear in the outer block of a program;
//^\\ # they cannot appear in external routines. This should be checked
//^\\ # by the compile() procedure.
case AST_FAULT_S: //^\\ P<FAULT-S> =
if (alt == 0) { //^\\ "fault" <FAULT-ACTION> <MORE-FAULTS> <S>;
int fault_action = compile(child(astp,2));
int more_faults = compile(child(astp,3));
return ctuple(C_FAULT_GROUP, fault_action, more_faults);
}
case AST_MORE_FAULTS: //^\\ P<MORE-FAULTS> =
if (alt == 0) { //^\\ ',' <FAULT-ACTION> <MORE-FAULTS>,
int fault_action = compile(child(astp,2));
int more_faults = compile(child(astp,3));
return ctuple(C_FAULT_GROUP, fault_action, more_faults);
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_FAULT_ACTION: //^\\ P<FAULT-ACTION> =
if (alt == 0) { //^\\ <FAULT-LIST> '-' '>' <LABEL>;
int fault_list = compile(child(astp,1));
int label = compile(child(astp,4));
return ctuple(C_ONE_FAULT, compile(child(astp,4)), compile(leftchild(astp)));
}
// I coded up the grammar as '<digit-seq>' for the fault numbers, but
// are they actual const expressions? Could a symbolic constinteger
// be used here. (digit-seq is a string literal)
case AST_FAULT_LIST: //^\\ P<FAULT-LIST> =
if (alt == 0) { //^\\ <DIGIT-SEQ> <MORE-NUMBERS>;
int first = compile(child(astp,1));
int rest = compile(child(astp,2));
return ctuple(C_SEQ, first, rest);
}
break;
case AST_MORE_NUMBERS: //^\\ P<MORE-NUMBERS> =
if (alt == 0) { //^\\ ',' <DIGIT-SEQ> <MORE-NUMBERS>,
int first = compile(child(astp,2));
int rest = compile(child(astp,3));
return ctuple(C_SEQ, first, rest);
} else if (alt == 1) { //^\\ ;
return -1;
}
break;
//^\\ # The "spec" form below is for old EMAS Imp procedure parameters:
//^\\ #
//^\\ # %routine integrate(%realname y, %real a,b, %integer n, %c
//^\\ # %realfn f)
//^\\ # %spec f(%real x)
//^\\ #
//^\\ # the fully-qualified form (%realfnspec f(%real x)) is also valid but comes in via the <EXTERNAL> route.
//^\\ #
//^\\ # There are other types of %spec related to parameters to procedures as well -
//^\\ # %recordspec for sure. Not so sure if there is an arrayspec.
//^\\ # They are only allowed in the body of a procedure.
//^\\ #
//^\\ # (Btw in the older compilers, all declarations in a block had to precede any code.)
//^\\ #
//^\\ # strictly speaking the <UI> <REST-OF-SS1> form, <UI> "while" <SC>, should only
//^\\ # allow a single <UI>, not the <UI> <AUI> form. (EMAS Imp)
//^\\ # (page 4.4 of https://history.dcs.ed.ac.uk/archive/docs/Edinburgh_IMP_Language_Manual.pdf )
// INTERNALs that end in "}" do not need a ";" after them
// however since this is INTERNAL not INTERNAL-S we know that the semicolon is currently
// handled at a parent level. Need to change that parent to use a new INTERNAL-S?
// and handle a top-level <INTERNALS> with a '{}' bracketing as appropriate...
case AST_INTERNAL: //^\\ P<INTERNAL> =
if (alt == 0) { //^\\ <NESTED-BLOCK>,
return compile(leftchild(astp));
} else if (alt == 1) { //^\\ <UI> <REST-OF-SS1>,
// P<REST-OF-SS1> = <Percent-IU> <CONDITION> <S> | <Percent-WUF> <S> | <S> | ;
// <UI> <REST-OF-SS1>,
// ^
// |
// <Percent-IU> <CONDITION> <S> | <Percent-WUF> <S> | <S> | ;
//
int ui = compile(leftchild(astp)); // <UI>
int rest_of_ss1 = compile(rightchild(astp)); // <REST-OF-SS1>
if (rest_of_ss1 != -1) {
int check = AstOP(rest_of_ss1);
assert(check == C_IMP_FOR || check == C_IF || check == C_UNLESS || check == C_WHILE || check == C_UNTIL);
if (leftchild(rest_of_ss1) != -1) {
diagnose(rest_of_ss1);
assert(leftchild(rest_of_ss1) == -1);
}
leftchild(rest_of_ss1) = STATEMENT_BLOCK(ui);
return rest_of_ss1;
}
return ui;
} else if (alt == 2) { //^\\ '*' <UCI>,
char UCI[1024];
getstr(child(astp,2), UCI);
return ctuple(C_MACHINE_CODE_INSTR, str_to_pool(UCI));
} else if (alt == 3) { //^\\ <CYCLE-S>,
return compile(leftchild(astp));
} else if (alt == 4) { //^\\ <FAULT-S>,
return compile(leftchild(astp));
} else if (alt == 5) { //^\\ "on" <OPT-event> <EVENT-LIST> <REST-OF-EVENT-LIST> "start" <S> <INTERNALS> "finish" <S>,
// "on" <OPT-event> <EVENT-LIST> <REST-OF-EVENT-LIST> "start" <S> <INTERNALS> "finish" <S>,
// P<EVENT-LIST> = '*', <CEXPR>;
// P<REST-OF-EVENT-LIST> = ',' <CEXPR> <REST-OF-EVENT-LIST>, ;
int event_list = compile(child(astp,3));
assert(AstOP(event_list) == C_SEQ);
if (AstOP(leftchild(event_list)) == C_SEQ) {
int lost_right = rightchild(event_list);
event_list = leftchild(event_list); append_to(&event_list, lost_right);
}
assert(AstOP(leftchild(event_list)) != C_SEQ);
int event_rest = compile(child(astp,4)); assert(event_rest == -1 || AstOP(event_rest) == C_SEQ);
append_to(&event_list, event_rest);
int block = STATEMENT_BLOCK(compile(child(astp,7)));
return ctuple(C_ON_EVENT_BLOCK, event_list, block);
} else if (alt == 6) { //^\\ "spec" <NAME> <FPP> <S>,
return TO_DO("P<INTERNAL> = \"spec\" <NAME> <FPP> <S>,");
} else if (alt == 7) { //^\\ "short" "routine",
return ctuple(C_SHORT_ROUTINE);
} else if (alt == 8) { //^\\ <EXTERNAL-OR-INTERNAL>;
return compile(leftchild(astp));
}
//^\\ # unlike with old-style parsers, the whole of the block content ends up in an AST item.
//^\\ #
//^\\ # Unfortunately there is a problem caused by 68000 Imp: some files contain only
//^\\ # begin/end with no endoffile. Some are begin/end;endoffile instead of begin/endofprogram
//^\\ # A few are routine blah/endofprogram !
//^\\ # One had begin/endofprogram followed by more routines.
//^\\ # (and see elsewhere for 68000's external routine specs which are of the form
//^\\ # @address %routine blah
//^\\ # - with no %spec keyword, but no routine body either..)
//^\\ #
case AST_NESTED_BLOCK: //^\\ P<NESTED-BLOCK> =
if (alt == 0) { //^\\ "begin" <S> <INTERNALS> "end" <S>;
// Imp77 allows a %begin/%end block to do a %return which is equivalent to
// a jump to the end of the block. I haven't yet worked out a good mechanism
// to handle this neatly. Maybe I can take advantage of the 'end of procedure'
// code below, that handles switches? (called by pop_scope_level() )
push_scope_level(); makespace(blocktype, current_scope+1); blocktype(current_scope) = BLOCKTYPE_NESTED_BEGIN;
int block_c = compile(child(astp,3));
// NOTE: any undefined defaults for %switch declarations at this level need to be output at the end
// of the block. May need to insert an explicit return before the default statements (which
// will output 'switch label not set' error messages. Also if it is a fn/map, print an error
// that the end of the function has been reached without a %result.
// *** ONLY *** applies to procedure bodies and begin/end blocks (ie Imp scopes). Not to start/finish
// groups or any other structure that might generate a C "{}" grouping.
seqlist = -1; pop_scope_level();
assert(block_c == -1 || AstOP(block_c) == C_SEQ);
append_to(&block_c, seqlist);
seqlist = -1;
return ctuple(C_NESTED_BLOCK, block_c);
}
//^\\ # compound statements - blah %and blah %and blah - a short form of startfinish block
case AST_AUI: //^\\ P<AUI> =
if (alt == 0) { //^\\ "and" <UI>,
int ui = compile(child(astp,2));
if (AstOP(ui) == C_SEQ) return ui;
//fprintf(stderr, "************ Was I right in thinking this could never happen? *************\n"); // No, see CHARSPEC :-(
return ctuple(C_SEQ, ui, -1 /* end of seq */);
} else if (alt == 1) { //^\\ ;
return -1;
}
//^\\ # the compound statement form ends in UIs which change control flow, ie
//^\\ # you cannot say: %if whatever %then blah %and ->lab %and this will never happen
//^\\ # tempted to add %caption here ;-) But that may be a step too far.
//^\\ # "%monitor 9" would be trapped by "%fault 9 -> lab"
// Currently I've put a ';' at the end of each UI but it's not ideal. Preferably
// would remove them and put it in level above; also need to know if UI ends in '}'
// to handle it properly. Current code outputs a few extra ';'s. I don't think they
// break the program logic however. Extra ';'s are not just from <UI>.
// UI's are the workhorse of Imp. Almost everything of importance comes through here.
// currently generated, *AND* temporarily returned to a higher level. While being debugged.
// ***NEW*** Return C_SEQ for all <UI>s? (for consistency, and easier block vs statement handling)
case AST_UI: //^\\ P<UI> =
if (alt == 0) { //^\\ <BASIC-UI> <AUI>,
int aui_rest = compile(child(astp,2));
return ctuple(C_SEQ, compile(child(astp,1)), aui_rest /* which may be -1 */); // moved to expressions.c.
} else if (alt == 1) { //^\\ "print" "text" <sqstring> <AUI>,
int str = compile(child(astp,3));
int print = ctuple(C_PRINTSTRING, str);
int aui_rest = compile(child(astp,4));
return ctuple(C_SEQ, print, aui_rest /* which may be -1 */);
} else if (alt == 2) { //^\\ '-' '>' <LABEL>,
return ctuple(C_GOTO, compile(child(astp,3)));
} else if (alt == 3) { //^\\ "return",
int ret = ctuple(C_SEQ, ctuple(C_RESULT, -1), -1);
// TO DO: although return(expr) can insert the imp_leave implicitly, a plain "return" from a procedure
// will not, and we need to insert an explicit one here. Hence >= 3 rather than > 3 ...
if (imp_option_trace >= 3) ret = ctuple(C_SEQ, ctuple(C_C, str_to_pool("_imp_leave();")), ret); // maybe later, command-line switch dependent..?
return ret;
} else if (alt == 4) { //^\\ "true",
int ret = ctuple(C_SEQ, ctuple(C_RESULT, ctuple(C_ASSIGN_VALUE, -1, C_One)), -1);
if (imp_option_trace > 3) ret = ctuple(C_SEQ, ctuple(C_C, str_to_pool("_imp_leave();")), ret); // maybe later, command-line switch dependent..?
return ret;
} else if (alt == 5) { //^\\ "false",
int ret = ctuple(C_SEQ, ctuple(C_RESULT, ctuple(C_ASSIGN_VALUE, -1, C_Zero)), -1);
if (imp_option_trace > 3) ret = ctuple(C_SEQ, ctuple(C_C, str_to_pool("_imp_leave();")), ret); // maybe later, command-line switch dependent..?
return ret;
} else if (alt == 6) { //^\\ "result" <ASSOP-EXPR>,
int assop_expr = compile(child(astp,2));
assert(AstOP(assop_expr == C_ASSIGN_ADDRESS || AstOP(assop_expr) == C_ASSIGN_VALUE || AstOP(assop_expr) == C_JAM_TRANSFER));
assert(leftchild(assop_expr) == -1);
assert(rightchild(assop_expr) != -1);
int ret = ctuple(C_SEQ, ctuple(C_RESULT, assop_expr), -1);
if (imp_option_trace > 3) ret = ctuple(C_SEQ, ctuple(C_C, str_to_pool("_imp_leave();")), ret); // maybe later, command-line switch dependent..?
return ret;
} else if (alt == 7) { //^\\ "monitorstop",
int mon = ctuple(C_MONITOR, -1);
int stop = ctuple(C_SEQ, ctuple(C_STOP), -1);
int ret = stop;
if (imp_option_trace >= 3) ret = ctuple(C_SEQ, ctuple(C_C, str_to_pool("_imp_leave();")), ret); // maybe later, command-line switch dependent..?
return ctuple(C_SEQ, mon, ret);
} else if (alt == 8) { //^\\ "monitor" <DIGIT-SEQ> <AUI>
int num = compile(child(astp,2));
int mon = ctuple(C_MONITOR, num);
int aui = compile(child(astp,3));
return ctuple(C_SEQ, mon, aui);
} else if (alt == 9) { //^\\ "monitor" <AUI>,
int aui = compile(child(astp,2));
int mon = ctuple(C_MONITOR, -1);
return ctuple(C_SEQ, mon, aui);
} else if (alt == 10) { //^\\ "stop",
int ret = ctuple(C_SEQ, ctuple(C_STOP), -1);
if (imp_option_trace >= 3) ret = ctuple(C_SEQ, ctuple(C_C, str_to_pool("_imp_leave();")), ret); // maybe later, command-line switch dependent..?
return ret;
} else if (alt == 11) { //^\\ "signal" <OPT-event> <CEXPR> <OPEXPR2>,
int first_c = compile(child(astp,3));
int second_c = compile(child(astp,4)); // <expr, C_SEQ> -> <expr, C_SEQ> -> <string expr>
return ctuple(C_SIGNAL, ctuple(C_SEQ, first_c, second_c));
//return ctuple(C_SEQ, ctuple(C_SIGNAL, ctuple(C_SEQ, first_c, second_c))); // added a C_SEQ to text fix %signal problem in comment at top
} else if (alt == 12) { //^\\ "exit",
return ctuple(C_BREAK); // for now ignore Hamish extension to take a number and break from multiple cycles.
} else if (alt == 13) { //^\\ "continue";
return ctuple(C_CONTINUE);
}
// do the C_GOTO, C_BREAK, C_CONTINUE above all need a C_SEQ too???
//^\\ # I added an old record declaration syntax for examples out of ai2logo.i
//^\\ #
//^\\ # %OWNRECORDARRAY INDEX42( 0:1022) (PIC DIR)
//^\\ #
//^\\ # %SYSTEMROUTINESPEC FINFO(%STRING(15) S,%INTEGER LEV,%C
//^\\ # %RECORDNAME R, %INTEGERNAME FLAG)
//^\\ #
//^\\ # %RECORD R(F)
//^\\ #
//^\\ # I'm not sure where/if this is handled:
//^\\ #
//^\\ # %record(f)%array portinfo(1:31)
//^\\ #
//^\\ # I need to get the old Imp manuals out and check a couple of things, in particular
//^\\ # %recordformatspec and %arrayformatspec ...
//^\\ #
//^\\ # The grammar below allows some initialisations that the compilers don't support
//^\\ # but it's cleaner to reject them in compile()
//^\\ #
//^\\ # I had to add initialisations with pointers for these examples from
//^\\ # 68000 Imp: %bytename b == length(s)
//^\\ # %ownrecord(i tc f)%namearray tc refs(1:maxtc) == nil(*)
//^\\ #
//^\\ # These are 68000 syntax which is rejected by Imp77:
//^\\ # %conststring(1) %array(1:max params) parameters="B","W","L"
//^\\ # %string(255) %array(0:maxfiles) list
//^\\ #
//^\\ # The equivalent Imp77 syntax would be
//^\\ #
//^\\ # %conststring(1) %array parameters(1:max params)="B","W","L"
//^\\ # %string(255) %array list(0:maxfiles)
//^\\ #
//^\\ # Finally here's a one-off hack for a construct I've only seen *once*
//^\\ # in APM-gdmr/I/PRIM22.imp ...
//^\\ # %constchar snl=char<10>
//^\\ #
//^\\ # The "register" below is for ICL/4-75 Imp9: %REGISTER SC(6)
//^\\ #
case AST_DECLARATION_S: //^\\ P<DECLARATION-S> =
//sym_init(&GlobalSym);
//sym_init(&ParentRECFM);
// WOW, this has developed into quite a mess.
if (alt == 0) { //^\\ <OPT-68K> <XOWN> <XTYPE> <OWNDEC> <S>,
// outer-level declarations... somewhat limited.
// Gather all the information from sub-phrases here! P<DECLARATION-S> = (Alt 0) <OPT-68K> <XOWN> <XTYPE> <OWNDEC> <S>,
int Declarations = -1;
int Hamish = compile(child(astp,1)); // <OPT-68K> = '@' <68K-stuff>, ; // 68k stuff of no interest for now
int xown = compile(child(astp,2)); // <XOWN> = "own", "external", "extrinsic", "constant", "const";
int storage_class_enum = child(xown, 1); // 'own', 'external', or 'constant'
int storage_class;
//int spec1 = child(xown, 2); // 'is_spec' or 0 NO!!!!!
if (storage_class_enum == own) {
storage_class = ctuple(C_STORAGE, C_STORAGE_static);
} else if (storage_class_enum == external) {
//storage_class = ctuple(C_STORAGE, (spec1 == is_spec ? C_STORAGE_extern : C_STORAGE_default));
storage_class = ctuple(C_STORAGE, C_STORAGE_default);
/* ^ %extrinsic */ /* (change the const once the old code is removed) */
} else if (storage_class_enum == constant) {
storage_class = ctuple(C_STORAGE, C_STORAGE_const);
} else {
storage_class = ctuple(C_STORAGE, C_STORAGE_default);
}
// P<XTYPE> = <OPT-68K-qualifier> <BASE-XTYPE> <OPT-name>;
// | | \"%name"?
// <68K-register>, \
// \ "integer", "real", "label", "byte" <Opt-INTEGER>, "mite" <Opt-INTEGER>,
// \ "short" <Opt-INTEGER>, "half" <Opt-INTEGER>, "string" <Opt-STRLEN>, "record" <Opt-RFREF>;
// \
// "register" '(' <NAME> ')';
// <68K-memptr>*,
// \
// \
// "read" "only" , "write" "only", "volatile"
// ;
int reg_name, mem_attr, base_xtype, percent_name;
detuple(compile(child(astp,3)), C_COMREG_XTYPE, ®_name, &mem_attr, &base_xtype, &percent_name);
if (percent_name == -1) {
//fprintf(stderr, "... got percent_name == -1\n");
} else if (AstOP(percent_name) == C_TYPE_POINTER_TO) {
//fprintf(stderr, "... got AstOP(percent_name) == C_TYPE_POINTER_TO\n");
} else {
fprintf(stderr, "* Unexpected %s for %%name AST: ", CAstOPName(AstOP(percent_name))); diagnose(percent_name);
}
// <BASE-XTYPE> ->
// "integer", "real", "label", "byte" <Opt-INTEGER>, "mite" <Opt-INTEGER>,
// "short" <Opt-INTEGER>, "half" <Opt-INTEGER>, "string" <Opt-STRLEN>, "record" <Opt-RFREF>;
// all of which return one or other C_TYPE_... (only leftchild is common to all - always 'name')
// and will be -1 until plugged in by a higher level.
if (base_xtype == -1) {
// warn("1: base_xtype == -1 - not sure what to do next... but I'll put in something stupid for now...");
base_xtype = ctuple(C_TYPE_INT, -1, C_TYPE_INT_signed_word, -1, -1, -1);
}
if (leftchild(base_xtype) != -1 && AstOP(base_xtype) != C_TO_DO) {
diagnose(base_xtype);
//assert(leftchild(base_xtype) == -1); /*TEMP*/
}
int owndec = compile(child(astp,4)); // <OWNDEC>
assert(AstOP(owndec) == C_COMREG && child(owndec,1) >= 0 && child(owndec,1) <= 2);
// OWNDEC is now passed back via a COMREG to this level. Two options:
// P<OWNDEC> =
// <OPT-arrayname> <OPT-spec> <SINGLE-OWNDEC> <REST-OF-OWNDEC>,
// "array" <OPT-format> <OPT-spec> <BPAIR> <NAME> <Opt-Init-assign-array>,
// "array" <OPT-format> <OPT-spec> <NAME> <BPAIR> <Opt-Init-assign-array>;
if (child(owndec,1) == 0) { // Alt 0
int alt, arrayname, spec2, one_owndec, more_owndecs;
detuple(owndec, C_COMREG, &alt, &arrayname, &spec2, &one_owndec, &more_owndecs);
// generate a 'pointer to' 'array of' ...
// C_SEQ of single-owndec
// single-owndec is in format: ctuple(C_COMREG, name, opt_alias, opt_init);
if (spec2 != -1 && AstOP(spec2) == C_SPEC /*%spec*/) storage_class = ctuple(C_STORAGE, C_STORAGE_extern);
for (;;) {
int name = child(one_owndec,1);
int opt_alias = child(one_owndec,2); // not yet handled in C. A couple of options available.
int initialisation = child(one_owndec,3); // if present. Otherwise -1.
// except rather than outputting it, we need to create a
// C_DECLARE_SCALAR: #1 name #2 %sex #3 pointer to(ie %name) (or -1) #4 arrayname #5 C_TYPE... #6 initialisation
// which is added to the list of declarations that this phrase could generate and returned at the end of processing.
// C_DECLARE_SCALAR causes the declaration to be output. Distinct from outputting an FPP.
int this_declaration = ctuple(C_DECLARE_SCALAR, name, storage_class, percent_name, -/*arrayname*/1, base_xtype, initialisation);
Declare(name, this_declaration);
this_declaration = ctuple(C_ADD_SEMI, this_declaration);
append_to(&Declarations, ctuple(C_SEQ, this_declaration, -1)); // and insert 'this_declaration' into symbol table.
if (more_owndecs == -1) break;
detuple(more_owndecs, C_SEQ, &one_owndec, &more_owndecs);
//one_owndec = leftchild(more_owndecs);
//more_owndecs = rightchild(more_owndecs);
}
return Declarations;
} else { // Alts 1,2
// 1: "array" <OPT-format> <OPT-spec> <BPAIR> <NAME> <Opt-Init-assign-array>,
// 2: "array" <OPT-format> <OPT-spec> <NAME> <BPAIR> <Opt-Init-assign-array>;
int alt, is_format, spec, bounds, name, bounds_or_name, name_or_bounds, initialisation;
// return ctuple(C_COMREG, alt, is_format, is_spec, bounds, name, initialisation);
detuple(owndec, C_COMREG, &alt, &is_format, &spec, &bounds_or_name, &name_or_bounds, &initialisation);
name = (alt == 1 ? bounds_or_name:name_or_bounds);
bounds = (alt == 1 ? name_or_bounds:bounds_or_name);
// #1 name #2 %sex #3 <BOUNDS> #4 base C_TYPE... #5 initialisation
int this_declaration = ctuple(C_DECLARE_ARRAY, name, storage_class, bounds, base_xtype, initialisation);
Declare(name, this_declaration);
return this_declaration;
}
} else if (alt == 1) {
// regular declarations (no %own etc). Not at external level - always in a begin/end block or procedure
// <OPT-68K> <XTYPE> <DECLN> <S>,
// |
// '@' <68K-stuff>, ;
int Hamish = compile(child(astp,1)); // <OPT-68K> = '@' <68K-stuff>, ; // 68k stuff of no interest for now
// P<68K-stuff> = '-' <INT-CONST> '(' <NAME> ')',
// <INT-CONST> '(' <NAME> ')',
// <INT-CONST> '-' <INT-CONST>,
// <INT-CONST>,
// '#' <NAME>;
int reg_name, mem_attr, base_xtype, percent_name;
detuple(compile(child(astp,2)), C_COMREG_XTYPE, ®_name, &mem_attr, &base_xtype, &percent_name);
if (percent_name == -1) {
//fprintf(stderr, "... got percent_name == -1\n");
} else if (AstOP(percent_name) == C_TYPE_POINTER_TO) {
//fprintf(stderr, "... got AstOP(percent_name) == C_TYPE_POINTER_TO\n");
} else {
warn("* Unexpected %s for %%name AST: ", CAstOPName(AstOP(percent_name))); diagnose(percent_name);
}
// <BASE-XTYPE> ->
// "integer", "real", "label", "byte" <Opt-INTEGER>, "mite" <Opt-INTEGER>,
// "short" <Opt-INTEGER>, "half" <Opt-INTEGER>, "string" <Opt-STRLEN>, "record" <Opt-RFREF>;
// all of which return one or other C_TYPE_... (only leftchild is common to all - always 'name')
// and will be -1 until plugged in by a higher level.
// However I think I may want to remove the name from this field altogether and just leave
// it as pure type information, with the name being promoted to the parent DECLARATION level.
if (base_xtype == -1) {
warn("2: base_xtype == -1 - not sure what to do next... but I'll put in something stupid for now...");
// #1 <name or -1> #2 string type {Imp or C} #3 initialisation C_AST or -1 #4 canonical folded value of %const, or -1 #5 max length
base_xtype = ctuple(C_TYPE_STRING, -1, C_TYPE_STRING_imp_star, -1, -1, -1, -1);
} else if (leftchild(base_xtype) != -1) {
//diagnose(leftchild(base_xtype)); // <-- AST_char ??? why? now returning an AST__KW. So... broken.
//assert(leftchild(base_xtype) == -1); /*TEMP*/
}
int decln = compile(child(astp,3));
// P<DECLN> = <OPT-arrayname> <OPT-spec> <NAME-or-STAR-68K> <OPT-68K-Bounds> <Opt-Init-assign> <Opt-Assign-NAME-LIST>,
// | | | | | |
// | | | | | ',' <NAME> <Opt-Init-assign> <Opt-Assign-NAME-LIST>,
// | | | | <ASSOP-EXPR>, ;
// | | | <BPAIR68K>, ;
// | | | |
// | | | '(' <LOWERBOUND> ':' <UPPERBOUND> <REST-OF-BPLIST68K> ')';
// | | '*', <NAME>;
// | <spec>, ;
// | |
// | "specalias", "spec" <Opt-68K-code-address>;
// |
// "array" <Opt-DIMENSIONS> "name",
// | |
// | '(' <INT-CONST> ')', ;
// |
// "array" <OPT-68K-Bounds> "name", ;
// |
// <BPAIR68K>, ;
// |
// '(' <LOWERBOUND> ':' <UPPERBOUND> <REST-OF-BPLIST68K> ')';
// A bunch of this syntax is for Hamish's Imp extensions on the 68000 APM. I'll ignore those
// and just implement the Imp77 subset for now, and come back to those after the translator
// is otherwise complete. I did find the doc where these extensions are described..:
// https://gtoal.com/imp77/reference-manual/Imp-M68K-V3.html
int opt_arrayname, opt_spec, name_or_star, opt_68k_bounds, initialisation, opt_assign_name_list;
int storage_class = ctuple(C_STORAGE, C_STORAGE_default); // needs to be auto, static or extern (spec, not declaration)
int Declarations = -1;
assert(decln != -1);
int decln_type = child(decln, 1);
if (decln_type == C_COMREG_DECLN0) {
detuple(decln, C_COMREG, &decln_type, &opt_arrayname, &opt_spec, &name_or_star, &opt_68k_bounds, &initialisation, &opt_assign_name_list);
for (;;) {
int this_declaration = ctuple(C_DECLARE_SCALAR, name_or_star, storage_class, percent_name, -/*arrayname*/1, base_xtype, initialisation);
Declare(name_or_star, this_declaration);
this_declaration = ctuple(C_ADD_SEMI, this_declaration);
append_to(&Declarations, ctuple(C_SEQ, this_declaration, -1));
if (opt_assign_name_list == -1) break;
detuple(opt_assign_name_list, C_COMREG, &name_or_star, &initialisation, &opt_assign_name_list);
}
// Now return list of individual declarations in Declarations...
return Declarations;
} else if (decln_type == C_COMREG_DECLN1) {
int decln_type, spec, format, name, names_and_bounds, names_and_bounds_seq, name_list, bounds, more;
detuple(decln, C_COMREG, &decln_type, &spec, &format, &names_and_bounds_seq);
assert(decln_type == C_COMREG_DECLN1);
detuple(names_and_bounds_seq, C_SEQ, &names_and_bounds, &more);
detuple(names_and_bounds, C_COMREG, &decln_type, &name, &name_list, &bounds);
assert(decln_type == C_COMREG_nnb);
if (more != -1 && AstOP(more) != C_SEQ) {
//fprintf(stderr, "More (@%d) != C_SEQ: ", more);
//diagnosewalk(more);
//fflush(stderr);
assert(more == -1 || AstOP(more) == C_SEQ);
}
for (;;) { // loop over arrays with different bounds
int onedec;
// %byte %integer %array inbuff(0 : 500)
for (;;) { // loop over arrays with the same bounds
// #1 name #2 %sex #3 <BOUNDS> #4 C_TYPE... #5 init
int this_declaration = ctuple(C_DECLARE_ARRAY, name, storage_class, bounds, base_xtype, -1);
Declare(name, this_declaration);
append_to(&Declarations, ctuple(C_SEQ, this_declaration, -1));
if (name_list == -1) {
break;
}
//this_declaration = ctuple(C_ADD_COMMA_AFTER, this_declaration);
detuple(name_list, C_SEQ, &name, &name_list);
}
if (more == -1) break;
//detuple(opt_assign_name_list, C_COMREG, &name_or_star, &initialisation, &opt_assign_name_list);
detuple(more, C_SEQ, &onedec, &more); // does this now get moved to the end of this loop?
detuple(onedec, C_COMREG, &decln_type, &name, &name_list, &bounds); // NOTE: ideally, name and namelist would just be a single namelist seq.
assert(decln_type == C_COMREG_nnb);
}
// Now return list of individual declarations in Declarations...
return Declarations;
} else if (decln_type == C_COMREG_DECLN2) {
// 1 and 2 *were* same layout, 2 is for 68K syntax. Make this like the one above when it is done.
int decln_type, spec, format, name, name_list, bounds, more;
detuple(decln, C_COMREG, &decln_type, &spec, &format, &name, &name_list, &bounds, &more);
// %byte %integer %array inbuff(0 : 500)
for (;;) { // #1 name #2 %sex #3 <BOUNDS> #4 C_TYPE... #5 init
int this_declaration = ctuple(C_DECLARE_ARRAY, name, storage_class, bounds, base_xtype, -1);
Declare(name, this_declaration);
if (more != -1) this_declaration = ctuple(C_ADD_COMMA_AFTER, this_declaration);
append_to(&Declarations, ctuple(C_SEQ, this_declaration, -1));
if (name_list != -1) {
detuple(name_list, C_SEQ, &name, &name_list);
continue; // another one like this one!
}
/*TO DO*/
/*if (more == -1)*/ break;
// more is a <REST-OF-ARLIST> and is currently returning -1 for everything. Hook in here once it knows what to return.
//detuple(opt_assign_name_list, C_COMREG, &name_or_star, &initialisation, &opt_assign_name_list);
}
// Now return list of individual declarations in Declarations...
return Declarations;
} else fault("internal error");
return Declarations;
} else if (alt == 2) { //^\\ <OPT-68K> <OPT-XOWN> "record" "array" <RADEC> <REST-OF-RADEC> <S>,
int Declarations = -1;
int Hamish = compile(child(astp,1)); // <OPT-68K> = '@' <68K-stuff>, ; // 68k stuff of no interest for now
int xown = compile(child(astp,2)); // <XOWN> = "own", "external", "extrinsic", "constant", "const";
int storage_class_enum = child(xown, 1); // 'own', 'external', or 'constant'
int storage_class;
//int spec1 = child(xown, 2); // 'is_spec' or 0 NO!!!
if (storage_class_enum == own) {
storage_class = ctuple(C_STORAGE, C_STORAGE_static);
} else if (storage_class_enum == external) {
//storage_class = ctuple(C_STORAGE, (spec1 == is_spec ? C_STORAGE_extern : C_STORAGE_default));
storage_class = ctuple(C_STORAGE, C_STORAGE_default);
/* ^ %extrinsic */ /* (change the const once the old code is removed) */
} else if (storage_class_enum == constant) {
storage_class = ctuple(C_STORAGE, C_STORAGE_const);
} else {
storage_class = ctuple(C_STORAGE, C_STORAGE_default);
}
// P<RDEC> = <NAME> <Opt-NAME-LIST> '(' <RECFMT-REF> ')';
// P<REST-OF-RDEC> = ',' <RDEC> <REST-OF-RDEC>, ;
int rdec = compile(child(astp,5));
int more_rdecs = compile(child(astp,6));
for (;;) {
int name, more_names, bpair, format;
detuple(rdec, C_COMREG, &name, &more_names, &bpair, &format);
for (;;) {
// declare using: storage_class ... name ... format ...;
// #1 name #2 %sex #3 pointer to(ie %name) (or -1) #4 arrayname #5 C_TYPE... #6 initialisation
//int this_declaration = ctuple(C_DECLARE_SCALAR, name, storage_class, -1/*%name*/, -1/*arrayname*/, format, -1);
// #1 name #2 %sex #3 <BOUNDS> #4 C_TYPE... #5 init
int this_declaration = ctuple(C_DECLARE_ARRAY, name, storage_class, bpair, format, -1);
Declare(name, this_declaration);
this_declaration = ctuple(C_ADD_SEMI, this_declaration);
append_to(&Declarations, this_declaration);
if (more_names == -1) break;
detuple(more_names, C_COMREG, &name, &more_names);
}
if (more_rdecs == -1) break;
detuple(more_rdecs, C_SEQ, &rdec, &more_rdecs);
}
return Declarations;
} else if (alt == 3) { //^\\ <OPT-68K> <OPT-XOWN> "record" <RDEC> <REST-OF-RDEC> <S>,
int Declarations = -1;
int Hamish = compile(child(astp,1)); // <OPT-68K> = '@' <68K-stuff>, ; // 68k stuff of no interest for now
int xown = compile(child(astp,2)); // <XOWN> = "own", "external", "extrinsic", "constant", "const";
int storage_class_enum = child(xown, 1); // 'own', 'external', or 'constant'
int storage_class;
//int spec1 = child(xown, 2); // 'is_spec' or 0 NO!!!
if (storage_class_enum == own) {
storage_class = ctuple(C_STORAGE, C_STORAGE_static);
} else if (storage_class_enum == external) {
//storage_class = ctuple(C_STORAGE, (spec1 == is_spec ? C_STORAGE_extern : C_STORAGE_default));
storage_class = ctuple(C_STORAGE, C_STORAGE_default);
/* ^ %extrinsic */ /* (change the const once the old code is removed) */
} else if (storage_class_enum == constant) {
storage_class = ctuple(C_STORAGE, C_STORAGE_const);
} else {
storage_class = ctuple(C_STORAGE, C_STORAGE_default);
}
// P<RDEC> = <NAME> <Opt-NAME-LIST> '(' <RECFMT-REF> ')';
// P<REST-OF-RDEC> = ',' <RDEC> <REST-OF-RDEC>, ;
int rdec = compile(child(astp,4));
int more_rdecs = compile(child(astp,5));
for (;;) {
int name, more_names, format;
detuple(rdec, C_COMREG, &name, &more_names, &format);
for (;;) {
// declare using: storage_class ... name ... format ...;
// #1 name #2 %sex #3 pointer to(ie %name) (or -1) #4 arrayname #5 C_TYPE... #6 initialisation
int this_declaration = ctuple(C_DECLARE_SCALAR, name, storage_class, -/*%name*/1, -/*arrayname*/1, format, -1);
Declare(name, this_declaration);
this_declaration = ctuple(C_ADD_SEMI, this_declaration);
append_to(&Declarations, this_declaration);
if (more_names == -1) break;
detuple(more_names, C_COMREG, &name, &more_names);
}
if (more_rdecs == -1) break;
detuple(more_rdecs, C_SEQ, &rdec, &more_rdecs);
}
return Declarations;
} else if (alt == 4) { //^\\ "const" "char" <NAME> '=' 'C' 'H' 'A' 'R' '<' <INT-CONST> '>' <S>,
return TO_DO("decl type alt 4 - Hamish's char extension");
} else if (alt == 5) { //^\\ "register" <NAME> '(' <INT-CONST> ')' <S>;
int name = compile(child(astp,2));
int number = compile(child(astp,4));
return ctuple(C_DECLARE_REGISTER, name, number); //TO_DO("decl type alt 5 - Hamish's register extension");
}
case AST_OPT_XOWN: //^\\ P<OPT-XOWN> =
if (alt == 0) { //^\\ <XOWN>,
return compile(leftchild(astp));
} else if (alt == 1) { //^\\ ;
return -1;
}
//^\\ # old-style record array declaration
case AST_RADEC: //^\\ P<RADEC> =
if (alt == 0) { //^\\ <NAME> <Opt-NAME-LIST> <BPAIR> '(' <RECFMT-REF> ')';
int name = compile(child(astp,1));
int more_names = compile(child(astp,2));
int bpair = compile(child(astp,3));
int format = compile(child(astp,5));
return ctuple(C_COMREG, name, more_names, bpair, format);
}
case AST_REST_OF_RADEC: //^\\ P<REST-OF-RADEC> =
if (alt == 0) { //^\\ ',' <RADEC>,
return compile(rightchild(astp));
} else if (alt == 1) { //^\\ ;
return -1;
}
//^\\ # old-style record declaration
case AST_RDEC: //^\\ P<RDEC> =
if (alt == 0) { //^\\ <NAME> <Opt-NAME-LIST> '(' <RECFMT-REF> ')';
int name = compile(child(astp,1));
int more_names = compile(child(astp,2));
int format = compile(child(astp,4));
return ctuple(C_COMREG, name, more_names, format);
}
case AST_REST_OF_RDEC: //^\\ P<REST-OF-RDEC> =
if (alt == 0) { //^\\ ',' <RDEC> <REST-OF-RDEC>,
int one_rdec = compile(leftchild(astp));
int more_rdecs = compile(rightchild(astp));assert(more_rdecs == -1 || AstOP(more_rdecs) == C_SEQ);
return ctuple(C_SEQ, one_rdec, more_rdecs);
} else if (alt == 1) { //^\\ ;
return -1;
}
//^\\ # %on %event * %start or %on %event 1,2,3,etc %start
case AST_EVENT_LIST: //^\\ P<EVENT-LIST> =
if (alt == 0) { //^\\ '*',
int num;
int start = -1;
int this;
int each;
char eachs[3];
for (each = 1; each <= 15; each++) {
sprintf(eachs, "%0d", each);
num = ctuple(C_CONST_INT, str_to_pool(eachs), each);
this = ctuple(C_SEQ, num, -1);
append_to(&start, this);
}
return start;
} else if (alt == 1) { //^\\ <CEXPR>;
int cexpr = compile(child(astp,1));
return ctuple(C_SEQ, cexpr, -1);
}
break;
case AST_S: //^\\ P<S> =
if (alt == 0) { //^\\ <NL>,
return TO_DO("P<S> = <NL>,");
} else if (alt == 1) { //^\\ ';';
return TO_DO("P<S> = ';';");
}
//^\\ # Most comments are handled in the line reconstruction phase.
//^\\ # Comments starting with %COMMENT are an exception.
//^\\ # Some older compilers treated '!' comments like %COMMENT,
//^\\ # with "%c" at the end of a comment causing continuation!
//^\\ # This phrase does not allow ';' in a comment to terminate
//^\\ # the comment, but some versions of Imp (I think PDP15)
//^\\ # did, so that will have to be handled with a command-line
//^\\ # option and a parse-time phrase if it ever is needed.
//^\\ #
case AST_COMMENT: //^\\ P<COMMENT> =
//(void)compile(rightchild(astp));
if (alt == 0) { //^\\ "comment" <Parsed-OldStyle-Comment>,
return compile(child(astp,2));
} else if (alt == 1) { //^\\ '!' <Parsed-OldStyle-Comment>;
return compile(child(astp,2));
}
// I'm a little worried that comments with unmatched quotes might fail to parse.
case AST_Parsed_OldStyle_Comment://^\\ P<Parsed-OldStyle-Comment> =
{
char COMMENT[1024];
getstr(astp, COMMENT); // shortcut. May have to deal with canonicalisation issues.
int len = strlen(COMMENT);
if (len > 0 && COMMENT[len-1] == '\n') {
COMMENT[len-1] = '\0';
}
fprintf(stderr, "// COMMENT! %s\n", COMMENT);
return ctuple(C_COMMENT, str_to_pool(COMMENT));
if (alt == 0) { //^\\ <char> <Parsed-OldStyle-Comment>,
return TO_DO("P<Parsed-OldStyle-Comment> = <char> <Parsed-OldStyle-Comment>,");
} else if (alt == 1) { //^\\ <dqstring> <Parsed-OldStyle-Comment>,
return TO_DO("P<Parsed-OldStyle-Comment> = <dqstring> <Parsed-OldStyle-Comment>,");
} else if (alt == 2) { //^\\ <sqstring> <Parsed-OldStyle-Comment>,
return TO_DO("P<Parsed-OldStyle-Comment> = <sqstring> <Parsed-OldStyle-Comment>,");
} else if (alt == 3) { //^\\ <letter> <Parsed-OldStyle-Comment>,
return TO_DO("P<Parsed-OldStyle-Comment> = <letter> <Parsed-OldStyle-Comment>,");
} else if (alt == 4) { //^\\ <digit> <Parsed-OldStyle-Comment>,
return TO_DO("P<Parsed-OldStyle-Comment> = <digit> <Parsed-OldStyle-Comment>,");
} else if (alt == 5) { //^\\ <stropped> <Parsed-OldStyle-Comment>,
return TO_DO("P<Parsed-OldStyle-Comment> = <stropped> <Parsed-OldStyle-Comment>,");
} else if (alt == 6) { //^\\ <NL>;
return TO_DO("P<Parsed-OldStyle-Comment> = <NL>;");
}
}
case AST_NL_or_SEMI: //^\\ P<NL-or-SEMI> =
//for (i = 1; i <= count; i++) (void)compile(child(astp,i));
if (alt == 0) { //^\\ <NL>,
return TO_DO("P<NL-or-SEMI> = <NL>,");
} else if (alt == 1) { //^\\ <semi>;
return TO_DO("P<NL-or-SEMI> = <semi>;");
}
case AST_semi: //^\\ P<semi> =
//for (i = 1; i <= count; i++) (void)compile(child(astp,i));
if (alt == 0) { //^\\ ';';
return TO_DO("P<semi> = ';';");
}
case AST_SAVED_STR_CONST: //^\\ P<SAVED-STR-CONST> =
//for (i = 1; i <= count; i++) (void)compile(child(astp,i));
if (alt == 0) { //^\\ <OPT-DQ-LETTER> <dqstring>,
return TO_DO("P<SAVED-STR-CONST> = <OPT-DQ-LETTER> <dqstring>,");
} else if (alt == 1) { //^\\ <sqstring>;
return TO_DO("P<SAVED-STR-CONST> = <sqstring>;");
}
//^\\ # current line reconstruction doesn't support this. Letters come through as part of <alphanumeric>s.
case AST_OPT_DQ_LETTER: //^\\ P<OPT-DQ-LETTER> =
//for (i = 1; i <= count; i++) (void)compile(child(astp,i));
if (alt == 0) { //^\\ 'E',
return TO_DO("P<OPT-DQ-LETTER> = 'E',");
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_NUMERIC_CONST: //^\\ P<NUMERIC-CONST> =
if (alt == 0) { //^\\ <INT-CONST>,
} else if (alt == 1) { //^\\ <REAL-CONST>;
}
return compile(leftchild(astp));
//^\\ # <CONST> is somewhat generic and should be replaced with the more specific version when possible
case AST_CONST: //^\\ P<CONST> =
if (alt == 0) { //^\\ <INT-CONST>,
return compile(leftchild(astp));
} else if (alt == 1) { //^\\ <REAL-CONST>,
return compile(leftchild(astp));
} else if (alt == 2) { //^\\ <STR-CONST>;
return compile(leftchild(astp));
}
case AST_DOT: //^\\ P<DOT> =
//for (i = 1; i <= count; i++) (void)compile(child(astp,i));
if (alt == 0) { //^\\ '.';
return TO_DO("P<DOT> = '.';");
}
break;
case AST_OPT_DOT: //^\\ P<OPT-DOT> =
//for (i = 1; i <= count; i++) (void)compile(child(astp,i));
if (alt == 0) { //^\\ <DOT>,
return TO_DO("P<OPT-DOT> = <DOT>,");
} else if (alt == 1) { //^\\ ;
return -1;
}
break;
case AST_SAVED_REAL_CONST: //^\\ P<SAVED-REAL-CONST> =
//for (i = 1; i <= count; i++) (void)compile(child(astp,i));
if (alt == 0) { //^\\ <DIGIT-SEQ> <OPT-DOT> <EXPONENT>,
return TO_DO("P<SAVED-REAL-CONST> = <DIGIT-SEQ> <OPT-DOT> <EXPONENT>,");
} else if (alt == 1) { //^\\ <rest-of-number> <FRACPT> <OPT-EXPONENT>,
return TO_DO("P<SAVED-REAL-CONST> = <rest-of-number> <FRACPT> <OPT-EXPONENT>,");
} else if (alt == 2) { //^\\ <DIGIT-SEQ> '.' <OPT-EXPONENT>;
// 'rest-of-number' should be renamed OPT-DIGIT-SEQ
return TO_DO("P<SAVED-REAL-CONST> = <DIGIT-SEQ> '.' <OPT-EXPONENT>;");
}
case AST_FRACPT: //^\\ P<FRACPT> =
//for (i = 1; i <= count; i++) (void)compile(child(astp,i));
if (alt == 0) { //^\\ '.' <DIGIT-SEQ>;
return TO_DO("P<FRACPT> = '.' <DIGIT-SEQ>;");
}
case AST_OPT_FRACPT: //^\\ P<OPT-FRACPT> =
//for (i = 1; i <= count; i++) (void)compile(child(astp,i));
if (alt == 0) { //^\\ <FRACPT>,
return TO_DO("P<OPT-FRACPT> = <FRACPT>,");
} else if (alt == 1) { //^\\ ;
return -1;
}
break;
case AST_OPT_Plus_Minus: //^\\ P<OPT-Plus-Minus> =
//for (i = 1; i <= count; i++) (void)compile(child(astp,i));
if (alt == 0) { //^\\ '+',
return TO_DO("P<OPT-Plus-Minus> = '+',");
} else if (alt == 1) { //^\\ '-',
return TO_DO("P<OPT-Plus-Minus> = '-',");
} else if (alt == 2) { //^\\ ;
return -1;
}
break;
case AST_EXPONENT: //^\\ P<EXPONENT> =
//for (i = 1; i <= count; i++) (void)compile(child(astp,i));
if (alt == 0) { //^\\ '@' <OPT-Plus-Minus> <DIGIT-SEQ>;
return TO_DO("<EXPONENT> = '@' <OPT-Plus-Minus> <DIGIT-SEQ>;");
}
break;
case AST_OPT_EXPONENT: //^\\ P<OPT-EXPONENT> =
//for (i = 1; i <= count; i++) (void)compile(child(astp,i));
if (alt == 0) { //^\\ <EXPONENT>,
return TO_DO("P<OPT-EXPONENT> = <EXPONENT>,");
} else if (alt == 1) { //^\\ ;
return -1;
}
//^\\ # # P<NAME> =
//^\\ # # <alphanumeric> <!SQUO-STRING> <rest-of-name>;
//^\\ # # P<rest-of-name> =
//^\\ # # <NAME>,
//^\\ # # ;
case AST_SQUO_STRING: //^\\ P<SQUO-STRING> =
//for (i = 1; i <= count; i++) (void)compile(child(astp,i));
if (alt == 0) { //^\\ <sqstring>;
return TO_DO("P<SQUO-STRING> = <sqstring>;");
}
//^\\ # A UCI is a machine code instruction.
//^\\ # (Hamish's PDP15 imp machine code syntax (which is not introduced by '*') is definitely not supported.)
//^\\ #
//^\\ # Machine-specific machine-code removed. May cause problems with ';' and quoted chars in machine code
//^\\ #
case AST_UCI: //^\\ P<UCI> =
// Handled by the level above.
//for (i = 1; i <= count; i++) (void)compile(child(astp,i));
if (alt == 0) { //^\\ <NL-or-SEMI>,
} else if (alt == 1) { //^\\ <char> <UCI>,
} else if (alt == 2) { //^\\ <dqstring> <UCI>,
} else if (alt == 3) { //^\\ <sqstring> <UCI>,
} else if (alt == 4) { //^\\ <stropped> <UCI>;
}
return TO_DO("<UCI>");
case AST_eq:UNUSED("AST_eq"); //^\\ P<eq> =
if (alt == 0) { //^\\ '=';
return -1;
}
case AST_Opt_NAME_LIST: //^\\ P<Opt-NAME-LIST> =
if (alt == 0) { //^\\ ',' <NAME> <Opt-NAME-LIST>,
int name = compile(child(astp,2));
int more_names = compile(child(astp,3));
return ctuple(C_SEQ, name, more_names);
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_REST_OF_EVENT_LIST: //^\\ P<REST-OF-EVENT-LIST> =
if (alt == 0) { //^\\ ',' <CEXPR> <REST-OF-EVENT-LIST>,
int cexpr = compile(child(astp,2));
int rest = compile(child(astp,3));
return ctuple(C_SEQ, cexpr, rest);
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_OPT_event: //^\\ P<OPT-event> = "event", ;
return -1; // syntactic sugar
case AST_FPP: //^\\ P<FPP> =
if (alt == 0) { //^\\ '(' <FORMAL-PARAMETER-DECLARATION> <REST-OF-FORMAL-PARAMETER-LIST> ')',
// C_BRACKETED_LIST -> #1 name #2 C_TYPE_... #3 next <C_BRACKETED_LIST> or -1
int param = compile(child(astp,2));
int more_params = compile(child(astp,3));
return ctuple(C_TYPE_PARAMETERS, -/*name*/1, param, more_params);
// don't know yet if bracketed list is procedure parameters or array indices.
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_REST_OF_FORMAL_PARAMETER_LIST://^\\ P<REST-OF-FORMAL-PARAMETER-LIST> =
if (alt == 0) { //^\\ <Opt-Comma> <FORMAL-PARAMETER-DECLARATION> <REST-OF-FORMAL-PARAMETER-LIST>,
// C_TYPE_PARAMETERS -> #1 C_TYPE_... #2 next <C_TYPE_PARAMETERS> or -1
int param = compile(child(astp,2));
int more_params = compile(child(astp,3));
return ctuple(C_TYPE_PARAMETERS, -/*name*/1, param, more_params);
} else if (alt == 1) { //^\\ ;
return -1;
}
//^\\ # %routine y (%integer %name %array (1) %name b)
//^\\ # %routine r10(%integer%array%name a(1:10),%integer k)
case AST_FORMAL_PARAMETER_DECLARATION://^\\ P<FORMAL-PARAMETER-DECLARATION> =
if (alt == 0) { //^\\ <XTYPE> <OPT-arrayname> <NAME> <OPT-68K-Bounds> <Opt-NAME-LIST>,
// <XTYPE> <OPT-arrayname> <NAME> <OPT-68K-Bounds> <Opt-NAME-LIST>
// I.e. this type of parameter can be an array name but not an actual array (unless embedded in a record, and with constant bounds)
int reg_name;
int mem_attr;
int base_xtype;
int percent_name = -1;
{ // #1 68K-register-name #2 68K-memptr (bitmask, default 0) #3 <C_TYPE_...> #4 %name?
int xtype = compile(child(astp,1)); // <XTYPE> -> ctuple(C_COMREG_XTYPE, reg_name, mem_attr, base_xtype, percent_name);
reg_name = child(xtype,1);
mem_attr = child(xtype,2);
base_xtype = child(xtype,3);
percent_name = child(xtype,4);
assert(percent_name == -1 || AstOP(percent_name) == C_TYPE_POINTER_TO);
// <BASE-XTYPE> ->
// "integer", "real", "label", "byte" <Opt-INTEGER>, "mite" <Opt-INTEGER>,
// "short" <Opt-INTEGER>, "half" <Opt-INTEGER>, "string" <Opt-STRLEN>, "record" <Opt-RFREF>;
// all of which return one or other C_TYPE_... (only leftchild is common to all - always 'name')
if (base_xtype == -1) {
warn("base_xtype == -1 still pending.");
base_xtype = ctuple(C_TYPE_INT, -1, C_TYPE_INT_signed_word, -1, -1, -1);
}
}
int is_arrayname = compile(child(astp,2)); // <OPT-arrayname>
int name = compile(child(astp,3)); // <NAME>
int bounds = compile(child(astp,4)); // <OPT-68K-Bounds>
int more_names = compile(child(astp,5)); // <Opt-NAME-LIST> ... C_SEQ(C_NAME, ...)
// convert more_names into a C_TYPE_PARAMETERS list
int param = base_xtype;
int Declarations = -1;
int this_declaration;
if (percent_name != -1) {
param = ctuple(C_TYPE_POINTER_TO, percent_name, param); // ADDED TODAY
//warn("FPP marked as %%name");
}
for (;;) {
// #1 name #2 C_TYPE_... #3 next <C_TYPE_PARAMETERS> or -1
this_declaration = ctuple(C_TYPE_PARAMETERS, name, param, -/*more_names*/1); // C_BRACKETED_LIST -> #1 name #2 C_TYPE_... #3 next <C_TYPE_PARAMETERS> or -1
Declare(name, this_declaration);
if (more_names != -1) this_declaration = ctuple(C_ADD_COMMA_AFTER, this_declaration);
append_to(&Declarations, ctuple(C_SEQ, this_declaration, -1)); // do I need to add commas?
if (more_names == -1) break;
detuple(more_names, C_SEQ, &name, &more_names);
if (AstOP(name) != C_NAME) {
fprintf(stderr, "BROKEN 'name' - %s", CAstOPName(AstOP(name))); diagnose(name);
assert(AstOP(name) == C_NAME);
}
assert(more_names == -1 || AstOP(more_names) == C_SEQ);
}
return Declarations;
} else if (alt == 1) { //^\\ <RT> <OPT-name> <NAME> <Opt-NAME-LIST> <FPP>,
// not at all sure why %name is allowed after <RT> in param list.
int rt = compile(child(astp,1));
int opt_percent_name = compile(child(astp,2));
int name = compile(child(astp,3));
int opt_name_list = compile(child(astp,4));
int params = compile(child(astp,5));
// I suspect we need a new C_ something.
// Is this going to be a C_PROCEDURE_DECLARATION or C_FPP_something?
/*TEMP*/
//return ctuple(C_COMREG, C_COMREG_FPP_PROCEDURE_DECLARATION, rt, opt_percent_name, name, opt_name_list, params);
// #1 name #2 spare #3 parameter list (C_TYPE_PARAMETERS) #4 body #5 alias or -1 #6 %sex
// TO DO: handle <Opt-NAME-LIST>
return ctuple(C_TYPE_ROUTINE, name, -1, params, -1, -1, ctuple(C_STORAGE, C_STORAGE_param | C_LINKAGE_internal)); // CALLER will add ',' between parameters.
// a procedure as a formal parameter to another procedure
} else if (alt == 2) { //^\\ "name" <Opt-68K-reg> <NAME> <Opt-NAME-LIST>; (as a formal parameter to a procedure)
int reg68k = compile(child(astp,2));
int name = compile(child(astp,3));
int more_names = compile(child(astp,4));
int this_declaration;
int Declarations = -1;
int storage_class = ctuple(C_STORAGE, C_STORAGE_param | C_LINKAGE_internal);
int percent_name = -1; // Not sure if we should use this or treat the base xtype '%name' as a unique entity like a struct or a string
int base_xtype = ctuple(C_TYPE_GENERAL_NAME, name /* not really used here. Only in decl. */, reg68k); // general %name
// #1 name #2 register (68K only) or -1 ; <much like a dope vector, it is implemented as a C_TYPE_STRUCT>
int initialisation = -1; // not relevant for a procedure's parameter
// when we have decltype name,name,name - they get passed back as a SEQ group to the level above, which then
// builds a PARAMETER_LIST of single declarations or a SEQ group like this. Unfortunstely at the moment, if it
// is a SEQ group, we are not inserting commas between the items. The solution is to pass back a PARAMETER_LIST
// with everything instead.
for (;;) {
// C_DECLARE_SCALAR: #1 name #2 %sex #3 pointer to(ie %name) (or -1) #4 arrayname #5 C_TYPE... #6 initialisation
this_declaration = ctuple(C_DECLARE_SCALAR, name, storage_class, percent_name, -/*arrayname*/1, base_xtype, initialisation);
// This is a %name passed as a parameter.
Declare(name, this_declaration); // *** NOTE THAT storage_class IS SET TO C_STORAGE_param ***
// however we need to be really careful with the parameters to procedure parameters
if (more_names != -1) this_declaration = ctuple(C_ADD_COMMA_AFTER, this_declaration);
append_to(&Declarations, ctuple(C_SEQ, this_declaration, -1)); // we are missing commas here. e.g. %routine fancy32(%name param1, param2, param3)
// easy enough to change C_SEQ above to C_PARAMETER_LIST but that's not enough. parent needs to append items from both sources.
if (more_names == -1) break;
detuple(more_names, C_SEQ, &name, &more_names);
}
return Declarations;
}
//^\\ # More Hamish idiosyncracy!:
//^\\ #
//^\\ # @16_1114%record(*)%map ZNEW(%name(d0) v)
//^\\ # - APM-gdmr/I/VPERM19.imp
//^\\ # d0 being a register
//^\\ #
case AST_Opt_68K_reg: //^\\ P<Opt-68K-reg> =
if (alt == 0) { //^\\ '(' <NAME> ')',
return compile(child(astp,2));
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_OPT_name: //^\\ P<OPT-name> =
if (alt == 0) { //^\\ "name",
//set_form(&GlobalSym, name);
return ctuple(C_TYPE_POINTER_TO, -1, -1); // #1 <name or -1> #2 object pointed to (<C_TYPE_...>) { %name variable or parameter }
} else if (alt == 1) { //^\\ ;
return -1;
}
//^\\ # added predicate - gt
case AST_RT: //^\\ P<RT> =
if (alt == 0) { //^\\ "routine",
//p(1);
//set_form(&GlobalSym, routine);
//set_type(&GlobalSym, no_return_type);
//C_TYPE_ROUTINE: #1 name #2 spare #3 parameter list (C_TYPE_PARAMETERS) #4 spec or body #5 alias or -1 #6 %sex
return ctuple(C_TYPE_ROUTINE, -1, -1 /*void*/, -1, -1, -1, -1);
} else if (alt == 1) { //^\\ "predicate",
//p(1);
//set_form(&GlobalSym, predicate);
//set_type(&GlobalSym, integer);
//C_TYPE_PREDICATE: #1 name #2 spare #3 parameter list (C_TYPE_PARAMETERS) #4 body #5 alias or -1
return ctuple(C_TYPE_PREDICATE, -1, -1 /*boolean*/, -1, -1, -1, -1);
} else if (alt == 2) { //^\\ <XTYPE> <FN-MAP>;
int xtype = compile(child(astp,1));
int reg_name, mem_attr, base_xtype, percent_name;
detuple(xtype, C_COMREG_XTYPE, ®_name, &mem_attr, &base_xtype, &percent_name);
if (percent_name == -1) {
// We don't have %namefn in Imp - we use %map instead - so this should not be present.
} else if (AstOP(percent_name) == C_TYPE_POINTER_TO) {
//fprintf(stderr, "... got AstOP(percent_name) == C_TYPE_POINTER_TO\n");
warn("%%namefn is not allowed in Imp. Use %%map instead.");
} else {
fprintf(stderr, "* Unexpected %s for %%name AST: ", CAstOPName(AstOP(percent_name))); diagnose(percent_name);
}
// <BASE-XTYPE> ->
// "integer", "real", "label", "byte" <Opt-INTEGER>, "mite" <Opt-INTEGER>,
// "short" <Opt-INTEGER>, "half" <Opt-INTEGER>, "string" <Opt-STRLEN>, "record" <Opt-RFREF>;
// all of which return one or other C_TYPE_... (only leftchild is common to all - always 'name')
// and will be -1 until plugged in by a higher level.
if (base_xtype == -1) {
// warn("4: base_xtype == -1 - not sure what to do next... but I'll put in something stupid for now...");
base_xtype = ctuple(C_TYPE_INT, -1, C_TYPE_INT_signed_word, -1, -1, -1);
}
if (leftchild(base_xtype) != -1 && AstOP(base_xtype) != C_TO_DO) {
diagnose(base_xtype);
assert(leftchild(base_xtype) == -1);
}
int fnmap = compile(child(astp,2));
child(fnmap,2) = base_xtype; // function result type
return fnmap;
}
break;
//^\\ # note map is equivalent to "name function"
case AST_FN_MAP: //^\\ P<FN-MAP> =
if (alt == 0) { //^\\ <FN>,
//C_TYPE_FN: #1 name #2 result type #3 parameter list (C_TYPE_PARAMETERS) #4 body #5 alias or -1
return ctuple(C_TYPE_FN, -1, -1, -1, -1, -1, -1);
} else if (alt == 1) { //^\\ "map";
//C_TYPE_MAP: #1 name #2 result type #3 parameter list (C_TYPE_PARAMETERS) #4 body #5 alias or -1
return ctuple(C_TYPE_MAP, -1, -1, -1, -1, -1, -1);
}
break;
case AST_FN: //^\\ P<FN> = "fn", "function";
break;
//^\\ # Confirmed that label is used. Found one in 68000 code for labels used in embeddded machine code:
//^\\ # %label f1,f2,f3,f4,f5,f6,f7,b0,b1,b2,b3,b4,b5,b6,b7,end
//^\\ #
//^\\ # IMP: %long %integer -> C: long long int
//^\\ #
//^\\ # Plain "long" added here by making <BTYPE> optional.
//^\\ # (BTYPE being integer/real/longreal)
//^\\ #
case AST_longlong: //^\\ P<longlong> = "long" "long", "long";
return ctuple(C_COMREG, alt);
/*
#define C_TYPE_INT 11097 // #1 name #2 precision/signedness #3 initialisation C_AST or -1 #4 canonical folded value of %const, or -1
#define C_TYPE_INT_unsigned_byte 1
#define C_TYPE_INT_signed_byte 2
#define C_TYPE_INT_unsigned_short 3
#define C_TYPE_INT_signed_short 4
#define C_TYPE_INT_unsigned_word 5
#define C_TYPE_INT_signed_word 6
#define C_TYPE_INT_unsigned_long_long 7
#define C_TYPE_INT_signed_long_long 8
#define C_TYPE_REAL 11098 // #1 name #2 precision #3 initialisation C_AST or -1 #4 canonical folded value of %const, or -1
#define C_TYPE_REAL_float 9
#define C_TYPE_REAL_double 10
#define C_TYPE_REAL_long_double 11
#define C_TYPE_STRING 11099 // #1 name #2 string type {Imp or C} #3 initialisation C_AST or -1 #4 canonical folded value of %const, or -1 #4 max length
#define C_TYPE_STRING_imp_bounded 12
#define C_TYPE_STRING_imp_star 13
#define C_TYPE_STRING_c_bounded 14
#define C_TYPE_STRING_c_star 15
*/
case AST_BASE_XTYPE: //^\\ P<BASE-XTYPE> =
if (alt == 0) { //^\\ "integer",
//set_type(&GlobalSym, integer);
//set_precision(&GlobalSym, word);
return ctuple(C_TYPE_INT, -1, C_TYPE_INT_signed_word, -1, -1, -1); // #1 name
// #2 precision/signedness
// #3 initialisation C_AST or -1
// #4 canonical folded value of %const, or -1
} else if (alt == 1) { //^\\ "real",
//set_type(&GlobalSym, real);
//set_precision(&GlobalSym, DEFAULT_REAL_SIZE);
return ctuple(C_TYPE_REAL, -1, C_TYPE_REAL_default_real_size, -1, -1, -1); // #1 name
// #2 precision
// #3 initialisation C_AST or -1
// #4 canonical folded value of %const, or -1
} else if (alt == 2) { //^\\ "label",
//set_form(&GlobalSym, _label);
return ctuple(C_TYPE_LABEL); // no longer: #1: name - only required for forward declaration of alphanumeric labels to be used in assembly code
} else if (alt == 3) { //^\\ <longlong> <Opt-BTYPE>, // real, integer, long real or <none> - returns an appropriate ctuple
int longlong = leftchild(compile(child(astp,1))); // 0 - longlong, 1 - long
int type = compile(child(astp,2));
//set_precision(&GlobalSym, _long);
if (longlong == 0) {
if (type == -1) return ctuple(C_TYPE_INT, -1, C_TYPE_INT_signed_long_long, -1, -1, -1);
// IMP: %long %integer -> C: long long int (64 bits)
// %long %long %integer -> C: __int128 (128 bits)
// %long %real is 64 bits (double), %long %long %real is 128 bits (C: "long double" or "__float128")
if (AstOP(type) == C_TYPE_INT && child(type,2) == C_TYPE_INT_signed_word) child(type,2) = C_TYPE_INT_signed_long_long; // %long %long %integer
else if (AstOP(type) == C_TYPE_REAL && child(type,2) == C_TYPE_REAL_float) child(type,2) = C_TYPE_REAL_long_double;
else if (AstOP(type) == C_TYPE_REAL && child(type,2) == C_TYPE_REAL_double) child(type,2) = C_TYPE_REAL_long_double;
} else {
if (AstOP(type) == C_TYPE_REAL && child(type,2) == C_TYPE_REAL_float) child(type,2) = C_TYPE_REAL_double; // %long %real
else if (AstOP(type) == C_TYPE_INT && child(type,2) == C_TYPE_INT_signed_word) child(type,2) = C_TYPE_INT_signed_long; // %long %integer
}
if (type == -1) return ctuple(C_TYPE_INT, -1, C_TYPE_INT_signed_word, -1, -1, -1);
return type;
} else if (alt == 4) { //^\\ "byte" <Opt-INTEGER>,
//(void)compile(rightchild(astp));
//set_precision(&GlobalSym, byte); // to do: signedness
return ctuple(C_TYPE_INT, -1, C_TYPE_INT_unsigned_byte, -1, -1, -1); // #1 name
// #2 precision/signedness
// #3 initialisation C_AST or -1
// #4 canonical folded value of %const, or -1
} else if (alt == 5) { //^\\ "mite" <Opt-INTEGER>,
//(void)compile(rightchild(astp));
//set_precision(&GlobalSym, byte); // to do: signedness
return ctuple(C_TYPE_INT, -1, C_TYPE_INT_signed_byte, -1, -1, -1); // #1 name
// #2 precision/signedness
// #3 initialisation C_AST or -1
// #4 canonical folded value of %const, or -1
} else if (alt == 6) { //^\\ "short" <Opt-INTEGER>,
//(void)compile(rightchild(astp));
//set_precision(&GlobalSym, _short); // to do: signedness
return ctuple(C_TYPE_INT, -1, C_TYPE_INT_signed_short, -1, -1, -1); // #1 name
// #2 precision/signedness
// #3 initialisation C_AST or -1
// #4 canonical folded value of %const, or -1
} else if (alt == 7) { //^\\ "half" <Opt-INTEGER>,
//(void)compile(rightchild(astp));
//set_precision(&GlobalSym, _short); // to do: signedness
return ctuple(C_TYPE_INT, -1, C_TYPE_INT_unsigned_short, -1, -1, -1); // #1 name
// #2 precision/signedness
// #3 initialisation C_AST or -1
// #4 canonical folded value of %const, or -1
} else if (alt == 8) { //^\\ "string" <Opt-STRLEN>,
int maxlen = compile(child(astp,2));
if (maxlen == -1) {
return ctuple(C_TYPE_STRING, -1, C_TYPE_STRING_imp_star, -1, -1, -/*percent_name*/1, -/*maxlen*/1);
} else if (AstOP(maxlen) == C_STRING_LITERAL) {
// should be '*'
} else {
// should be an expr...
}
// #1 <name or -1> #2 string type {Imp or C} #3 initialisation C_AST or -1 #4 canonical folded value of %const, or -1 #5 max length
return ctuple(C_TYPE_STRING, -1, C_TYPE_STRING_imp_bounded, -1, -1, -/*percent_name*/1, -/*maxlen*/1);
//#define C_TYPE_STRING 11099
// #1 <name or -1> #2 string type {Imp or C} #3 initialisation C_AST or -1 #4 canonical folded value of %const, or -1 #5 max length
// #define C_TYPE_STRING_imp_bounded 12
// #define C_TYPE_STRING_imp_star 13
// #define C_TYPE_STRING_c_bounded 14
// #define C_TYPE_STRING_c_star 15
} else if (alt == 9) { //^\\ "record" <Opt-RFREF>;
// We are returning something for a BASE-XTYPE. A recordformat type seems appropriate
int record_format = compile(child(astp,2)); // (returns a C_TYPE_RECORDFORMAT or -1)
if (record_format == -1) {
// Old style %record without a format. May be supplied with a %spec later?
// not sure how to distinguish plain "%record" with no format name from "%record(*)". If I even need to?
return ctuple(C_TYPE_RECORDFORMAT, -1, -1, -1);
}
// C_TYPE_RECORDFORMAT = #1 <record name or -1> #2 record format name #3 field list of C_TYPE_RECORD_FIELD
if (child(record_format,3) == -1 && child(record_format,2) != -1) {
// However it may (for now) only hold a name, not the actual fields. Either because we haven't been told the
// fields yet (ie we only have a record spec to allow a record name as a field) or - as in this case - because
// <Opt-RFREF> just returned a name to us, and we have to look that name up in the symbol table to get the fields. TO DO.
// look up fields here.
// fprintf(stderr, "*** Need to look up fields of %s and attach to C_TYPE_RECORD_FIELD record.\n", child(record_format,1) == -1 ? "this record" : name_to_cstr(child(record_format,1)));
}
return record_format; // <Opt-RFREF> returned a record format:
}
break;
//^\\ # does %record(i tc f)%name match <XTYPE>?
//^\\ #
//^\\ # Courtesy of Hamish, two more language extensions:
//^\\ #
//^\\ # Two <OPT-68K-qualifier>s to allow one or both of %writeonly %volatile %byte %integer device
//^\\ #
case AST_XTYPE: //^\\ P<XTYPE> =
if (alt == 0) { //^\\ <OPT-68K-qualifier> <BASE-XTYPE> <OPT-name>;
int q68 = compile(child(astp, 1));
int reg_name = -1;//(q68 == -1 || child(q68, 1) == -1 ? -1 : child(q68, 1)); // or -1 if not present
int mem_attr = -1;//(q68 == -1 || child(q68, 2) == -1 ? -1 : child(q68, 2)); // or -1 if not present
int base_xtype = compile(child(astp, 2)); // a C_TYPE_... tuple
int percent_name = compile(child(astp, 3)); // a C_TYPE_POINTER_TO tuple or -1
int xtype = ctuple(C_COMREG_XTYPE, reg_name, mem_attr, base_xtype, percent_name);
//#define C_COMREG_XTYPE 11112 // only used to pass this info around:
// #1 68K-register-name #2 68K-memptr (bitmask, default 0) #3 <C_TYPE_...>
// #define C_COMREG_XTYPE_readonly 1
// #define C_COMREG_XTYPE_writeonly 2
// #define C_COMREG_XTYPE_volatile 4
// P<XTYPE> = <OPT-68K-qualifier> <BASE-XTYPE> <OPT-name>;
// | | \"%name"?
// <68K-register>, \
// \ "integer", "real", "label", "byte" <Opt-INTEGER>, "mite" <Opt-INTEGER>,
// \ "short" <Opt-INTEGER>, "half" <Opt-INTEGER>, "string" <Opt-STRLEN>, "record" <Opt-RFREF>;
// \
// "register" '(' <NAME> ')';
// <68K-memptr>*,
// \
// \
// "read" "only" , "write" "only", "volatile"
// ;
return xtype;
}
case AST_68K_memptr: //^\\ P<68K-memptr> =
if (alt == 0) { //^\\ "read" "only" <68K-memptr>,
return ctuple(C_COMREG, C_COMREG_XTYPE_readonly);
} else if (alt == 1) { //^\\ "write" "only" <68K-memptr>,
return ctuple(C_COMREG, C_COMREG_XTYPE_writeonly);
} else if (alt == 2) { //^\\ "volatile" <68K-memptr>,
return ctuple(C_COMREG, C_COMREG_XTYPE_volatile);
} else if (alt == 3) { //^\\ ; // shouldn't allow a null option here...
// -1 or ctuple comreg=0?
return -1;
}
case AST_OPT_68K_qualifier: //^\\ P<OPT-68K-qualifier> =
if (alt == 0) { //^\\ <68K-register>,
return compile(child(astp,1)); // just returns the NAME as a stringpool index
} else if (alt == 1) { //^\\ <68K-memptr>,
return compile(child(astp,1)); // returns a C_COMREG
} else if (alt == 2) { //^\\ ;
return -1;
}
break;
//^\\ # C-like register qualifiers (Hamish, again)
//^\\ # %register(a2)%integer r1,r2
//^\\ # %register(a2)%byte%name bn
//^\\ # %register(a3)%short%name sn
case AST_68K_register: //^\\ P<68K-register> =
if (alt == 0) { //^\\ "register" '(' <NAME> ')';
return compile(child(astp,3));
}
//^\\ # '*' added by gt for recordformat(*)
//^\\ # () moved from point of call to here to support old style "%recordname fred" without format. (Uses a formatspec instead)
case AST_Opt_RFREF: //^\\ P<Opt-RFREF> =
if (alt == 0) { //^\\ '(' <RECFMT-REF> ')',
int record_format = compile(child(astp,2)); // <RECFMT-REF> returns C_TYPE_RECORDFORMAT
return record_format;
} else if (alt == 1) { //^\\ '(' '*' ')',
return ctuple(C_TYPE_RECORDFORMAT, -/*record name*/1, -/*recordformat name*/1, -/*list of fields*/1);
} else if (alt == 2) { //^\\ ;
// TO DO: old style "%recordname fred" without format. Needs a formatspec later.
return -1;
return TO_DO("Set to -1 once %format is handled.");
}
break;
//^\\ # RF in the rules below is short for Record Format
case AST_RECFMT_REF: //^\\ P<RECFMT-REF> =
if (alt == 0) { //^\\ <NAME>,
int list_of_fields = -1;
int name = compile(child(astp,1));
//zxcv ... look up the record format DECLARATION here and copy over the list of fields!
char *names = name_to_cstr(name);
int record_format_declaration = lookup("Declarations", names);
if (record_format_declaration != -1) {
//fprintf(stderr, "record format declaration for %s is @%d: ", names, record_format_declaration);
//diagnosewalk(record_format_declaration);
} else {
fprintf(stderr, "I could not find a record format declaration for %s. ", names);
}
// #1 recordformat (C_TYPE_RECORDFORMAT) #2 C_SPEC or -1
int recfmtref = record_format_declaration ;//ctuple(C_TYPE_RECORDFORMAT, -1/*record name*/, name, list_of_fields); // once decls handled and type info available, look up <NAME> ...
//fprintf(stderr, "<RECFMT-REF> <- %d\n", recfmtref);
return recfmtref;
} else if (alt == 1) { //^\\ <RECFMT-DEC> <REST-OF-RECFMT-DEC> <ALT-RECFMT-DEC>;
// parameters to a procedure eg %record(fred)%name x will *not* go through here.
// I think this is for %record (%integer a,b) fred i.e. a record declaration with an anonymous record format
// as of now, I have *no* idea how to hook all this into some sort of consistent data structure :-(
//for (i = 1; i <= count; i++) (void)compile(child(astp,i));
int name = -1; // unnamed inline format
int first_decln = compile(child(astp,1)); // <RECFMT-DEC> a C_SEQ of fields
assert(first_decln != -1);
if (AstOP(first_decln) != C_SEQ) first_decln = ctuple(C_SEQ, first_decln, -1);
int more_declns = compile(child(astp,2)); // <REST-OF-RECFMT-DEC>
assert(more_declns == -1 || AstOP(more_declns) == C_SEQ);
append_to(&first_decln, more_declns);
int alternative_decln = compile(child(astp,3)); // ignore in first draft. TO DO once basic record formats are working.
warn("Was this an example of a declaration of type '%%record (%%integer a,b) fred' ?"); // I want to see one in action...
return ctuple(C_TYPE_RECORDFORMAT, -1, name, first_decln);
}
//^\\ # Imp variant record. NOT the same as C's which is per field. This is per record.
//^\\ # Still to check: a ( ... %or ... ) subgroup in a record definition, where the ...
//^\\ # represents several declarations, with the whole ( ... ) group being a part
//^\\ # of an enclosing record.
//^\\ #
case AST_ALT_RECFMT_DEC: //^\\ P<ALT-RECFMT-DEC> =
if (alt == 0) { //^\\ "or" <RECFMT-DEC> <REST-OF-RECFMT-DEC> <ALT-RECFMT-DEC>,
int name = -1;
int first_decln = compile(child(astp,2)); // <RECFMT-DEC> a C_SEQ of fields
assert(first_decln != -1);
if (AstOP(first_decln) != C_SEQ) first_decln = ctuple(C_SEQ, first_decln, -1);
int more_declns = compile(child(astp,3)); // P<REST-OF-RECFMT-DEC> = ',' <RECFMT-DEC> <REST-OF-RECFMT-DEC>, ;
assert(more_declns == -1 || AstOP(more_declns) == C_SEQ);
append_to(&first_decln, more_declns);
int alternative_decln = compile(child(astp,4)); // ignore in first draft. TO DO once basic record formats are working.
return ctuple(C_TYPE_RECORDFORMAT, -1, name, first_decln);
} else if (alt == 1) { //^\\ ;
return -1;
}
break;
case AST_REST_OF_RECFMT_DEC: //^\\ P<REST-OF-RECFMT-DEC> =
// Returns a C_SEQ list of compiled RECFMT-DECs.
if (alt == 0) { //^\\ ',' <RECFMT-DEC> <REST-OF-RECFMT-DEC>,
int recfmt_dec = compile(child(astp,2));
if (AstOP(recfmt_dec) != C_SEQ) recfmt_dec = ctuple(C_SEQ, recfmt_dec, -1);
int more_recfmt_decs = compile(child(astp,3));
assert(more_recfmt_decs == -1 || AstOP(more_recfmt_decs) == C_SEQ);
append_to(&recfmt_dec, more_recfmt_decs);
return recfmt_dec; // a C_SEQ of <RECFMT-DEC>s
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_RECFMT_DEC: //^\\ P<RECFMT-DEC> =
if (alt == 0) { //^\\ <XTYPE> <RECFMT-ELMNT>,
int xtype = compile(child(astp,1));
int elmnt = compile(child(astp,2)); // P<RECFMT-ELMNT> = <OPT-arrayname> <NAME> <Opt-NAME-LIST>, "array" <ADECLN-in-record>;
int reg_name, mem_attr, base_xtype, percent_name;
detuple(xtype, C_COMREG_XTYPE, ®_name, &mem_attr, &base_xtype, &percent_name);
if (base_xtype != -1) {
if (AstOP(base_xtype) == C_DECLARE_RECORDFORMAT) {
fprintf(stderr, "record field declaration: OOPS - record *declaration* in a record\n");
} else if (AstOP(base_xtype) == C_TYPE_RECORDFORMAT) {
// if this is a record and not a record name, make sure that it is defined and the fields are present.
// if it is a pointer, the record format may not yet be fully defined, but once it is, need to plug in the fields.
fprintf(stderr, "record field declaration: record in a record\n");
// Can't postpone looking it up until it is used in 'out()' as by then the name tables are gone,
// so has to be looked up somewhere in 'compile()' when the field is accessed.
// *HOWEVER* if you only look it up at the point of use, you may be in a scope that is deeper than
// where the format was declared, and therefore find the wrong one! (unless we store the scope along with the name)
// so it's essential to go back and plug those partial references as soon as the actual record format is declared.
// I'm pretty sure that this means that we have to link to the format spec whenever an item of that
// type is declared, and then go back and update that spec in situ when the actual format declaration
// happens, rather than creating a new one.
} else {
//fprintf(stderr, "record field declaration: field type is %s\n", CAstOPName(AstOP(base_xtype)));
}
}
if (child(elmnt,1) == 0) { // subalt
/* elmnt is expected to be either a C_COMREG (ie temporary anonymous ctuple)
containing subalt, opt_arrayname, name, opt_name_list
or a C_COMREG containing subalt and adecln:
case AST_RECFMT_ELMNT: //^\\ P<RECFMT-ELMNT> =
if (alt == 0) { //^\\ <OPT-arrayname> <NAME> <Opt-NAME-LIST>,
int opt_arrayname = compile(child(astp,1)); // TO DO: <XTYPE> must be modified by "%arrayname" (which is a SCALAR type)
int name = compile(child(astp,2));
int opt_name_list = compile(child(astp,3));
return ctuple(C_COMREG, alt, opt_arrayname, name, opt_name_list);
} else if (alt == 1) { //^\\ "array" <ADECLN-in-record>;
int adecln = compile(child(astp,2));
return ctuple(C_COMREG, alt, adecln);
}
*/
int subalt, opt_arrayname, name, opt_name_list;
int Declarations = -1;
detuple(elmnt, C_COMREG, &subalt, &opt_arrayname, &name, &opt_name_list); // P<RECFMT-ELMNT> = <OPT-arrayname> <NAME> <Opt-NAME-LIST>,
if (opt_arrayname != -1) {
warn("Unimplemented %recordarrayname at line %d", __LINE__); // I think a Hamish 68K Imp extension?
}
for (;;) {
int this_declaration = ctuple(C_TYPE_RECORD_FIELD, name, -1, base_xtype, percent_name, -1);
append_to(&Declarations, this_declaration); // uses C_SEQ
if (opt_name_list == -1) break;
detuple(opt_name_list, C_SEQ, &name, &opt_name_list);
}
return Declarations;
} else if (child(elmnt,1) == 1) {
// P<RECFMT-ELMNT> = "array" <ADECLN-in-record>;
// P<ADECLN-in-record> = <NAME> <Opt-NAME-LIST> <BPAIR> <REST-OF-ARLIST-in-record>;
int subalt, adecln;
detuple(elmnt, C_COMREG, &subalt, &adecln);
// TO DO: <XTYPE> must be modified by "%array" to make it an ARRAY type. I think by applying ARRAY_OF to the descriptor
/*
#define C_TYPE_ARRAY_OF 11102 // #1 <name or -1>
// #2 C_type of array element
// #3 dimensionality
// #4 dopevector or -1
// #5 array type (ie one of Hamish's funny ones)
// #6 bounds: lower bound upper bound <more bounds>
// #7 init data depends on column-major or row-major implementation...
*/
int Declarations = -1;
for (;;) {
int name, more_names, bpair, more_adeclns;
detuple(adecln, C_COMREG, &name, &more_names, &bpair, &more_adeclns);
for (;;) {
// is this correct? Or should I be using C_DECLARE_ARRAY ?
int xtype =
ctuple(C_TYPE_ARRAY_OF,
name, // #1 name
base_xtype, // #2 C_type of array element
1, // #3 dimensionality
-1, // #4 dopevector or -1
-1, // #5 array type (ie one of Hamish's funny ones)
bpair, // #6 bounds: lower bound, upper bound, next bounds
-1 // #7 init data depends on column-major or row-major implementation...
);
int this_declaration = ctuple(C_TYPE_RECORD_FIELD, name, -1, xtype, percent_name, -1);
append_to(&Declarations, this_declaration);
if (more_names == -1) break;
detuple(more_names, C_SEQ, &name, &more_names);
}
if (more_adeclns == -1) break; // P<REST-OF-ARLIST-in-record> = ',' <ADECLN-in-record>, ;
detuple(more_adeclns, C_COMREG, &adecln, &more_adeclns);
}
return Declarations;
} else {
fault("Bad <RECFMT-ELMNT>");
}
/* NOT REACHED */
//return ctuple(C_TYPE_RECORD_FIELD, -1, -1, xtype, -1);
return TO_DO("P<RECFMT-DEC> = <XTYPE> <RECFMT-ELMNT>,");
} else if (alt == 1) { //^\\ '(' <RECFMT-DEC> <REST-OF-RECFMT-DEC> <ALT-RECFMT-DEC> ')';
int name = -1;
int first_decln = compile(child(astp,2)); // <RECFMT-DEC> a C_SEQ of fields
int more_declns = compile(child(astp,3)); // P<REST-OF-RECFMT-DEC> = ',' <RECFMT-DEC> <REST-OF-RECFMT-DEC>, ;
//assert(rightchild(first_decln) == -1);
assert(more_declns == -1 || AstOP(more_declns) == C_SEQ);
append_to(&first_decln, more_declns);
int alternative_decln = compile(child(astp,4)); // ignore in first draft. TO DO once basic record formats are working.
return ctuple(C_TYPE_RECORDFORMAT, -1, name, first_decln); // TO DO: I think we need to bracket this in a sub-record declaration
}
break;
//^\\ # Now "name" has been removed from <OPT-arrayname-or-name>, check at the point
//^\\ # of invocation, that "name" still works, now it as been added to <XTYPE>...
//^\\ #
case AST_RECFMT_ELMNT: //^\\ P<RECFMT-ELMNT> =
if (alt == 0) { //^\\ <OPT-arrayname> <NAME> <Opt-NAME-LIST>,
int opt_arrayname = compile(child(astp,1)); // TO DO: <XTYPE> must be modified by "%arrayname" (which is a SCALAR type)
int name = compile(child(astp,2));
int opt_name_list = compile(child(astp,3));
return ctuple(C_COMREG, alt, opt_arrayname, name, opt_name_list);
} else if (alt == 1) { //^\\ "array" <ADECLN-in-record>;
int adecln = compile(child(astp,2));
return ctuple(C_COMREG, alt, adecln);
}
//^\\ # Array declaration
case AST_ADECLN_in_record: //^\\ P<ADECLN-in-record> =
if (alt == 0) { //^\\ <NAME> <Opt-NAME-LIST> <BPAIR> <REST-OF-ARLIST-in-record>;
int name = compile(child(astp,1));
int more_names = compile(child(astp,2));
int bpair = compile(child(astp,3));
int more_adeclns = compile(child(astp,4));
return ctuple(C_COMREG, name, more_names, bpair, more_adeclns);
}
break;
case AST_REST_OF_ARLIST_in_record://^\\ P<REST-OF-ARLIST-in-record> =
if (alt == 0) { //^\\ ',' <ADECLN-in-record>,
return compile(rightchild(astp));
} else if (alt == 1) { //^\\ ;
return -1;
}
break;
//^\\ # List of lower/upper bound pairs, for array declarations.
case AST_BPAIR: //^\\ P<BPAIR> =
if (alt == 0) { //^\\ '(' <LOWERBOUND> ':' <UPPERBOUND> <REST-OF-BPLIST> ')';
int lower = compile(child(astp, 2));
int upper = compile(child(astp, 4));
int rest = compile(child(astp, 5));
int boundspair = ctuple(C_BOUNDSPAIR, lower, upper, IntConstant_c(lower), IntConstant_c(upper), rest);
int dims = 1;
while (rest != -1) {
assert(AstOP(rest) == C_BOUNDSPAIR);
dims += 1;
rest = child(rest,5);
}
return ctuple(C_BOUNDS, dims, boundspair); // #1 dimensionality #2 boundspair list
}
break;
case AST_BPAIR68K: //^\\ P<BPAIR68K> =
{ //^\\ '(' <LOWERBOUND> ':' <UPPERBOUND> <REST-OF-BPLIST68K> ')';
int lower = compile(child(astp, 2));
int upper = compile(child(astp, 4));
int rest = compile(child(astp, 5));
int boundspair = ctuple(C_BOUNDSPAIR, lower, upper, IntConstant_c(lower), IntConstant_c(upper), rest);
int dims = 1;
while (rest != -1) {
assert(AstOP(rest) == C_BOUNDSPAIR);
dims += 1;
rest = child(rest,5);
}
return ctuple(C_BOUNDS, dims, boundspair); // #1 dimensionality #2 boundspair list
}
break;
//^\\ # Multi-dimensional arrays
case AST_REST_OF_BPLIST: //^\\ P<REST-OF-BPLIST> = ',' <EXPR> ':' <EXPR> <REST-OF-BPLIST>, ;
if (alt == 0) {
// ',' <EXPR> ':' <EXPR> <REST-OF-BPLIST>,
int lower = compile(child(astp, 2));
int upper = compile(child(astp, 4));
int rest = compile(child(astp, 5));
int boundspair = ctuple(C_BOUNDSPAIR, lower, upper, IntConstant_c(lower), IntConstant_c(upper), rest);
return boundspair;
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_REST_OF_BPLIST68K: //^\\ P<REST-OF-BPLIST68K> =
if (alt == 0) { //^\\ '(' <LOWERBOUND> ':' <UPPERBOUND> <REST-OF-BPLIST68K> ')';
// ',' <EXPR> ':' <EXPR> <REST-OF-BPLIST>,
int lower = compile(child(astp, 2));
int upper = compile(child(astp, 4));
int rest = compile(child(astp, 5));
int boundspair = ctuple(C_BOUNDSPAIR, lower, upper, IntConstant_c(lower), IntConstant_c(upper), rest);
return boundspair;
} else if (alt == 1) { //^\\ ;
return -1;
}
//^\\ # <Opt-DIMENSIONS> added to handle:
//^\\ #
//^\\ # %routine y (%integer %name %array (1) %name b)
//^\\ #
//^\\ # and <OPT-68K-Bounds> added to handle:
//^\\ #
//^\\ # %routine extract params(%string(255) %name in,out,
//^\\ # %integer %array(1:max params) %name params)
//^\\ #
case AST_OPT_arrayname: //^\\ P<OPT-arrayname> =
if (alt == 0) { //^\\ "array" <Opt-DIMENSIONS> "name",
//set_form(&GlobalSym, arrayname);
int dims = compile(child(astp,2));
// NOT USED YET: MAY NEED REVISION. SEE ALSO C_TYPE_DECLARE_ARRAY
// Possibly should be a scalar with the "arrayname" option set.
return ctuple(C_TYPE_POINTER_TO, -1, // #1 name #2 object pointed to (<C_TYPE_...>) { %name variable or parameter }
ctuple(C_TYPE_ARRAY_OF,
-1, // #1 name
-1, // #2 C_type of array element
dims, // #3 dimensionality
-1, // #4 dopevector or -1
-1, // #5 array type (ie one of Hamish's funny ones)
-1, // #6 bounds: lower bound, upper bound, next bounds
-1 // #7 init data depends on column-major or row-major implementation...
)
);
} else if (alt == 1) { //^\\ "array" <OPT-68K-Bounds> "name",
//set_form(&GlobalSym, arrayname);
int Hamish = compile(child(astp,2)); // Use below when we get to that point...
// NOT USED YET: MAY NEED REVISION. SEE ALSO C_TYPE_DECLARE_ARRAY
// Possibly should be a scalar with the "arrayname" option set.
return ctuple(C_TYPE_POINTER_TO, -1, // #1 name #2 object pointed to (<C_TYPE_...>) { %name variable or parameter }
ctuple(C_TYPE_ARRAY_OF,
-1, // #1 name
-1, // #2 C_type of array element
-1, // #3 dimensionality
-1, // #4 dopevector or -1
-1, // #5 array type (ie one of Hamish's funny ones)
-1, // #6 bounds: lower bound, upper bound, next bounds
-1 // #7 init data depends on column-major or row-major implementation...
)
);
} else if (alt == 2) { //^\\ ;
return -1;
}
//^\\ # for the example from 68000 Imp,
//^\\ # %routine y (%integer %name %array (1) %name b)
case AST_Opt_DIMENSIONS: //^\\ P<Opt-DIMENSIONS> =
if (alt == 0) { //^\\ '(' <INT-CONST> ')',
return compile(child(astp,2));
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_Opt_INTEGER: //^\\ P<Opt-INTEGER> =
if (alt == 0) { //^\\ "integer",
return TO_DO("P<Opt-INTEGER> = \"integer\",");
} else if (alt == 1) { //^\\ ;
return -1;
}
//^\\ # "42(2)" is equivalent to "42, 42". (*) means 'as many more are needed to fill the array' so must come last.
//^\\ # However it looks like <REPFACT> is also used as the string length indicator?!
case AST_Opt_STRLEN: //^\\ P<Opt-STRLEN> =
if (alt == 0) { //^\\ '(' <Opt-STAROREXPR> ')',
return compile(child(astp,2));
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_REPEATS: //^\\ P<REPEATS> =
if (alt == 0) { //^\\ '(' <Opt-STAROREXPR> ')',
return compile(child(astp,2));
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_Opt_STAROREXPR: //^\\ P<Opt-STAROREXPR> =
if (alt == 0) { //^\\ <STAROREXPR>,
return compile(leftchild(astp));
} else if (alt == 1) { //^\\ ;
return -1;
}
//^\\ # Used in switch label. (*) marks a catch-all. (like default: in C)
//^\\ # Or at least SHOULD be used in switch label. Looks like it isn't... currently used in <REPEATS> and <Opt-STRLEN> I think.
case AST_STAROREXPR: //^\\ P<STAROREXPR> =
if (alt == 0) { //^\\ <CEXPR>,
return compile(leftchild(astp));
} else if (alt == 1) { //^\\ '*';
return ctuple(C_STRING_LITERAL, str_to_pool("*"));
}
//^\\ # Opt- added here to allow plain "%long" as a declaration at <XTYPE>
case AST_Opt_BTYPE: //^\\ P<Opt-BTYPE> =
if (alt == 0) { //^\\ "real",
//set_type(&GlobalSym, real);
//set_precision(&GlobalSym, DEFAULT_REAL_SIZE);
return ctuple(C_TYPE_REAL, -1, C_TYPE_REAL_default_real_size, -1, -1, -1); // #1 name
// #2 precision
// #3 initialisation C_AST or -1
// #4 canonical folded value of %const, or -1
} else if (alt == 1) { //^\\ "integer",
//set_type(&GlobalSym, integer);
return ctuple(C_TYPE_INT, -1, C_TYPE_INT_signed_word, -1, -1, -1); // #1 name
// #2 precision/signedness
// #3 initialisation C_AST or -1
// #4 canonical folded value of %const, or -1
} else if (alt == 2) { //^\\ ;
return ctuple(C_TYPE_INT, -1, C_TYPE_INT_signed_word, -1, -1, -1); // #1 name
// #2 precision/signedness
// #3 initialisation C_AST or -1
// #4 canonical folded value of %const, or -1
}
case AST_Opt_Comma:UNUSED("AST_Opt_Comma"); //^\\ P<Opt-Comma> =
if (alt == 0) { //^\\ ',',
return TO_DO("P<Opt-Comma> = ',',");
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_Opt_ALIAS: //^\\ P<Opt-ALIAS> =
if (alt == 0) { //^\\ "alias" <TEXTTEXT>,
return ctuple(C_ALIAS, compile(rightchild(astp)));
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_TEXTTEXT: //^\\ P<TEXTTEXT> =
if (alt == 0) { //^\\ <dqstring>;
return compile(child(astp,1));
}
//^\\ # if we add a "C" type (to reverse the order of parameter evaluation) it would be done here.
//^\\ # I don't think you would write %permroutine since they are built in to the compiler, but
//^\\ # depending on how the compiler is implemented, you might, and if so they would be added here.
//^\\ # I do have a vague recollection of perm routines being matched up with internal code using
//^\\ # a file or declarations containing magic numbers, eg something like:
//^\\ # %perm (5) %routine write(%integer n, sp)
//^\\ # - but that may be a manufactured memory!
//^\\ #
case AST_Percent_SEX: //^\\ P<Percent-SEX> =
// external, _system, dynamic, prim, / perm, / _auto, own, constant
if (alt == 0) { //^\\ "system",
return ctuple(C_STORAGE, C_LINKAGE_extern_system);
//return ctuple(C_COMREG, _system);
} else if (alt == 1) { //^\\ "external",
return ctuple(C_STORAGE, C_LINKAGE_extern_imp);
//return ctuple(C_COMREG, external);
} else if (alt == 2) { //^\\ "dynamic",
return ctuple(C_STORAGE, C_LINKAGE_extern_dynamic);
//return ctuple(C_COMREG, dynamic);
} else if (alt == 3) { //^\\ "prim",
return ctuple(C_STORAGE, C_LINKAGE_extern_prim);
//return ctuple(C_COMREG, prim);
} else if (alt == 4) { //^\\ "perm",
return ctuple(C_STORAGE, C_LINKAGE_extern_perm);
//return ctuple(C_COMREG, perm);
} else if (alt == 5) { //^\\ ;
return -1; // makes it easier for parent layers to identify default option
return ctuple(C_STORAGE, C_LINKAGE_internal);
//return ctuple(C_COMREG, _auto);
}
fault("Check that there has not been another option added to <Percent-SEX>");
case AST_RECFMT_spec_OR_BODY://^\\ P<RECFMT-spec-OR-BODY> =
if (alt == 0) { //^\\ "spec" <NAME>,
int name = compile(child(astp,2));
return ctuple(C_TYPE_RECORDFORMAT, -1, name, -1);
// C_TYPE_RECORDFORMAT = #1 <record name or -1> #2 record format name #3 field list of C_TYPE_RECORD_FIELD
} else if (alt == 1) { //^\\ <NAME> '(' <RECFMT-DEC> <REST-OF-RECFMT-DEC> <ALT-RECFMT-DEC> ')';
int name = compile(child(astp,1));
int first_decln = compile(child(astp,3)); // <RECFMT-DEC> a C_SEQ of fields
int more_declns = compile(child(astp,4)); // P<REST-OF-RECFMT-DEC> = ',' <RECFMT-DEC> <REST-OF-RECFMT-DEC>, ;
assert(more_declns == -1 || AstOP(more_declns) == C_SEQ);
append_to(&first_decln, more_declns);
int alternative_decln = compile(child(astp,5)); // ignore in first draft. TO DO once basic record formats are working.
//fprintf(stderr, "+++ format declaration for %s is %s\n", name_to_cstr(name), CAstOPName(AstOP(first_decln)));
int rectype = ctuple(C_TYPE_RECORDFORMAT, -1, name, first_decln);
//debug_record_type(rectype, 0);
return rectype; // C_TYPE_RECORDFORMAT = #1 <record name or -1> #2 record format name #3 field list of C_TYPE_RECORD_FIELD
}
//^\\ # 68000 Imp has a non-standard syntax for some array declarations, eg
//^\\ #
//^\\ # %conststring(1) %array(1:max params) parameters="B","W","L"
//^\\ # %string(255) %array(0:maxfiles) list
//^\\ #
//^\\ # The equivalent Imp77 syntax would be
//^\\ #
//^\\ # %conststring(1) %array parameters(1:max params)="B","W","L"
//^\\ # %string(255) %array list(0:maxfiles)
//^\\ #
//^\\ # Putting bounds after a %name is also from the 68000:
//^\\ #
//^\\ # %integer%array%name an10(1:10)
//^\\ #
//^\\ # which is likely the same as
//^\\ #
//^\\ # %integer%array(1)%name an10
//^\\ #
//^\\ # in Imp77. We just haven't been told the lower bound...
//^\\ #
//^\\ # meanwhile this broke: %string (64) %array %format sform1(0 : 1022)
//^\\ #
//^\\ # I'm not sure if there is any significant difference nowadays between own declarations and non-own declarations...
//^\\ # they used to be distinguished by only %own declarations allowing initialisations... maybe worth merging the definitions now?
case AST_DECLN: //^\\ P<DECLN> =
if (alt == 0) { //^\\ <OPT-arrayname> <OPT-spec> <NAME-or-STAR-68K> <OPT-68K-Bounds> <Opt-Init-assign> <Opt-Assign-NAME-LIST>,
int opt_arrayname = compile(child(astp,1));
int opt_spec = compile(child(astp,2));
int name_or_star = compile(child(astp,3));
int opt_68k_bounds = compile(child(astp,4));
int initialisation = compile(child(astp,5));
int opt_assign_name_list = compile(child(astp,6));
return ctuple(C_COMREG, C_COMREG_DECLN0, opt_arrayname, opt_spec, name_or_star, opt_68k_bounds, initialisation, opt_assign_name_list);
} else if (alt == 1) { //^\\ "array" <OPT-spec> <OPT-format> <NAME> <Opt-NAME-LIST> <BPAIR> <REST-OF-ARLIST>,
// P<REST-OF-ARLIST> = <NAME> <Opt-NAME-LIST> <BPAIR> <REST-OF-ARLIST>, ;
// the context <DECLN> is called from is: <OPT-68K> <XTYPE> <DECLN> <S>,
// is this where we have the problem with: %integer %array scurl, ecurl(1:20)
// where the second name is ignored?
int spec = compile(child(astp, 2));
int format = compile(child(astp, 3));
int name = compile(child(astp, 4));
int name_list = compile(child(astp, 5));
int bounds = compile(child(astp, 6));
int names_and_bounds = ctuple(C_COMREG, C_COMREG_nnb, name, name_list, bounds);
int more = compile(child(astp, 7));
int names_and_bounds_seq = ctuple(C_SEQ, names_and_bounds, more);
return ctuple(C_COMREG, C_COMREG_DECLN1, spec, format, names_and_bounds_seq /* more */);
} else if (alt == 2) { //^\\ "array" <BPAIR> <OPT-spec> <OPT-format> <NAME> <Opt-NAME-LIST> <REST-OF-ARLIST-68K>;
// the context <DECLN> is called from is: <OPT-68K> <XTYPE> <DECLN> <S>,
int spec = compile(child(astp, 3));
int format = compile(child(astp, 4));
int name = compile(child(astp, 5));
int name_list = compile(child(astp, 6));
int bounds = compile(child(astp, 2));
int names_and_bounds = ctuple(C_COMREG, C_COMREG_nnb, name, name_list, bounds);
int more = compile(child(astp, 7));
int names_and_bounds_seq = ctuple(C_SEQ, names_and_bounds, more);
return ctuple(C_COMREG, C_COMREG_DECLN1, spec, format, names_and_bounds_seq /* more */);
//return ctuple(C_COMREG, C_COMREG_DECLN1B, spec, format, name, name_list, bounds, more);
}
break;
case AST_OWNDEC: //^\\ P<OWNDEC> =
if (alt == 0) { //^\\ <OPT-arrayname> <OPT-spec> <SINGLE-OWNDEC> <REST-OF-OWNDEC>,
int arrayname = compile(child(astp,1));
int is_spec = compile(child(astp,2));
int one_owndec = compile(child(astp,3));
int more_owndecs = compile(child(astp,4)); // C_SEQ of single-owndecs
return ctuple(C_COMREG, alt, arrayname, is_spec, one_owndec, more_owndecs);
} else if (alt == 1) { //^\\ "array" <OPT-format> <OPT-spec> <BPAIR> <NAME> <Opt-Init-assign-array>,
int is_format = compile(child(astp,2));
int is_spec = compile(child(astp,3));
int bounds = compile(child(astp,4));
int name = compile(child(astp,5));
int initialisation = compile(child(astp,6));
return ctuple(C_COMREG, alt, is_format, is_spec, bounds, name, initialisation);
} else if (alt == 2) { //^\\ "array" <OPT-format> <OPT-spec> <NAME> <BPAIR> <Opt-Init-assign-array>;
int is_format = compile(child(astp,2));
int is_spec = compile(child(astp,3));
int name = compile(child(astp,4));
int bounds = compile(child(astp,5));
int initialisation = compile(child(astp,6));
return ctuple(C_COMREG, alt, is_format, is_spec, bounds, name, initialisation);
}
case AST_REST_OF_ARLIST: //^\\ P<REST-OF-ARLIST> =
if (alt == 0) { //^\\ ',' <NAME> <Opt-NAME-LIST> <BPAIR> <REST-OF-ARLIST>,
int name = compile(child(astp, 2));
int name_list = compile(child(astp, 3));
int bounds = compile(child(astp, 4));
int more = compile(child(astp, 5));
int names_and_bounds = ctuple(C_COMREG, C_COMREG_nnb, name, name_list, bounds);
int names_and_bounds_seq = ctuple(C_SEQ, names_and_bounds, more);
return names_and_bounds_seq;
} else if (alt == 1) { //^\\ ;
return -1;
}
break;
case AST_REST_OF_ARLIST_68K: //^\\ P<REST-OF-ARLIST-68K> =
if (alt == 0) { //^\\ ',' <NAME> <Opt-NAME-LIST> <REST-OF-ARLIST-68K>,
return -1; /*TEMP*/
return TO_DO("<REST-OF-ARLIST-68K>");
//for (i = 1; i <= count; i++) (void)compile(child(astp,i));
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_OPT_68K_Bounds: //^\\ P<OPT-68K-Bounds> =
if (alt == 0) { //^\\ <BPAIR68K>,
return compile(child(astp,1));
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_OPT_format: //^\\ P<OPT-format> =
// only in the context of an array declaration
if (alt == 0) { //^\\ "format",
return ctuple(C_FORMAT);
} else if (alt == 1) { //^\\ ;
return -1;
}
break;
//^\\ #
//^\\ # This is the same ugly hack as <Opt-Assign-NAME-LIST> below
//^\\ # The AST handling has to check for and reject the '*' in all contexts except for
//^\\ # 68000-style declarations such as "@16_4000c0 %byte *,acia s,*,acia d"
//^\\ #
//^\\ # Below is a note from inside the 68K compiler that may be relevant:
//^\\ #
//^\\ # ! %record(*) or %string(*) needs %name (or @)
//^\\ # ! %string alone allowed only for %const%string
//^\\ #
case AST_NAME_or_STAR_68K: //^\\ P<NAME-or-STAR-68K> =
if (alt == 0) { //^\\ '*',
return ctuple(C_STRING_LITERAL, str_to_pool("*"));
} else if (alt == 1) { //^\\ <NAME>;
return compile(leftchild(astp));
}
//^\\ # <Opt-Init-assign> added by gt
//^\\ # This hideous hack with '*' for an anonymous entry is yet another of Hamish's idiosyncrasies:
//^\\ #
//^\\ # @16_7fffc %byte status,data,*,control
//^\\ # ^
//^\\ # "/home/gtoal/gtoal.com/athome/edinburgh/APM-gdmr/ETHER/SPY.imp"
//^\\ #
//^\\ # @16_4000c0 %byte *,acia s,*,acia d
//^\\ #
//^\\ # and would appear to just be a lazy way to skip over an address when assigning multiple
//^\\ # individual scalars to addresses...
//^\\ #
//^\\ # Obviously it should not be allowed in any other context - some semantic checking needed here...
//^\\ #
case AST_Opt_Assign_NAME_LIST://^\\ P<Opt-Assign-NAME-LIST> =
if (alt == 0) { //^\\ ',' '*' <Opt-Assign-NAME-LIST>,
// this is an anonymous declaration (see Hamish's V3 document)
// - should set the anonymous bit then treat like a regular declaration...?
return ctuple(C_COMREG, -1, -1, compile(child(astp,3)));
} else if (alt == 1) { //^\\ ',' <NAME> <Opt-Init-assign> <Opt-Assign-NAME-LIST>,
int name = compile(child(astp,2));
int assign = compile(child(astp,3));
int init = compile(child(astp,4));
return ctuple(C_COMREG, name, assign, init);
} else if (alt == 2) { //^\\ ;
return -1;
}
break;
case AST_REST_OF_OWNDEC: //^\\ P<REST-OF-OWNDEC> =
if (alt == 0) { //^\\ ',' <SINGLE-OWNDEC> <REST-OF-OWNDEC>,
int single_owndec_temp = compile(child(astp,2));
int more_owndec_temps = compile(child(astp,3));
return ctuple(C_SEQ, single_owndec_temp, more_owndec_temps);
} else if (alt == 1) { //^\\ ;
return -1;
}
case AST_SINGLE_OWNDEC: //^\\ P<SINGLE-OWNDEC> =
if (alt == 0) { //^\\ <NAME> <Opt-ALIAS> <Opt-Init-assign>;
int name = compile(child(astp,1)); // <NAME>
int opt_alias = compile(child(astp,2)); // <Opt-ALIAS>
int opt_init = compile(child(astp,3));
return ctuple(C_COMREG, name, opt_alias, opt_init);
}
case AST_stupid:UNUSED("AST_stupid"); //^\\ P<stupid> =
// a grammar hack to handle a particularly awkward form of comment :-/
if (alt == 0) { //^\\ <COMMENT>,
} else if (alt == 1) { //^\\ ;
}
//for (i = 1; i <= count; i++) (void)compile(child(astp,i));
break;
//^\\ # extrinsic is an old form meaning roughly "external spec"
case AST_XOWN: //^\\ P<XOWN> =
if (alt == 0) { //^\\ "own",
//set_class(&GlobalSym, own);
return ctuple(C_COMREG, own, 0);
} else if (alt == 1) { //^\\ "external",
//set_class(&GlobalSym, external);
return ctuple(C_COMREG, external, 0);
} else if (alt == 2) { //^\\ "extrinsic",
//set_class(&GlobalSym, external);
//set_x(&GlobalSym, is_spec);
return ctuple(C_COMREG, external, is_spec);
} else if (alt == 3) { //^\\ "constant",
//set_class(&GlobalSym, constant);
return ctuple(C_COMREG, constant, 0);
} else if (alt == 4) { //^\\ "const";
//set_class(&GlobalSym, constant);
return ctuple(C_COMREG, constant, 0);
}
// All the flow-control related grammar rules:
case AST_Opt_UNTIL:
case AST_Percent_IU:
case AST_CYCLE_S:
case AST_IF_S:
case AST_FINISH_S:
case AST_Opt_start:
case AST_Opt_ELSE_S:
case AST_THEN_S:
case AST_OPT_then:
case AST_ONE_SWITCH_DECL:
case AST_REST_OF_SWLIST:
case AST_Percent_WU:
case AST_Percent_WUF:
case AST_Opt_CYCPARM:
case AST_REST_OF_SS1:
return compile_flowcontrol_inner(astp, extra_parameter, line);
// All the expression related grammar rules:
case AST_BASIC_UI:
case AST_OPT_ASSIGN:
case AST_RECORDFIELD:
case AST_LVALUE:
case AST_Opt_PARAMETERS_OR_POINTERINDEX:
case AST_OPT_ACTUAL_PARAMETERS:
case AST_Opt_RECORDFIELD:
case AST_SCALAR_ASSIGN:
case AST_ASSOP:
case AST_ASSOP_EXPR:
case AST_CEXPR:
case AST_EXPR:
case AST_REST_OF_EXPR:
case AST_REAL_EXP:
case AST_INTEGER_EXP:
case AST_OP_HIGH_RIGHTASSOC:
case AST_RIGHTASSOC_EXPR_with_OP:
case AST_OP_HIGH_LEFTASSOC:
case AST_OP_MED:
case AST_OP_LOW:
case AST_MEDIUMPREC_EXPR:
case AST_REST_OF_MEDIUMPREC_EXPR:
case AST_HIGHPREC_EXPR:
case AST_REST_OF_HIGHPREC_EXPR:
case AST_RIGHT_ASSOC_EXPR:
case AST_REST_OF_RIGHTASSOC_EXPR:
case AST_UNARY_EXPR:
case AST_Opt_UNARY_OP:
case AST_OPERAND:
case AST_INT_CONST:
case AST_SAVED_INT_CONST:
{
int object = compile_expression_inner(astp, extra_parameter, 0 /* Not 'address wanted' */, line);
// We should now have a CAST object with no '-1' holes waiting to be filled in. However we may
// not have applied type casts when assigning from an int to a float, for example.
//diagnosewalk(object);
return object;
}
default:
{
fprintf(stderr, "MISSING AST OPERATOR ");
if (astop >= 0 && astop < MAX_PHRASE) {
fprintf(stderr, "AST_%s", phrasename[astop]);
} else if (astop >= C_BASE && astop <= C_LAST) {
fprintf(stderr, "C_%s (NOT an AST_* object)", CAST[astop-C_BASE].name);
} else {
fprintf(stderr, "#%d", astop);
}
fprintf(stderr, " (%d) IN compile(@AST:%d) at line %d\n", astop, astp, line);
exit(1);
return -1;
}
}
}
/////////////////////////////////////////////////////////////////////////////////
#ifdef NEVER
void debug_sym(symbol *Sym, char *info) {
int i;
if (debug_symbols) {
//if (Sym->x & (1<<is_a_formal_param)) return; // don't output formal parameters as if they were declarations...
// however we do have to output them from inside a procedure declaration...
//for (i = 0; i < indent_spaces; i++) {
// fputc(' ', OUTFILE);
//}
fprintf(OUTFILE, "/* %s@%p: seq=%d ", info, Sym, Sym->sequence);
fprintf(OUTFILE, "C %s; ", Class[Sym->class]);
fprintf(OUTFILE, "P %s; ", Precision[Sym->precision]);
fprintf(OUTFILE, "T %s; ", Type[Sym->type]);
fprintf(OUTFILE, "F %s; ", Form[Sym->form]);
if (Sym->x) {
i = 0;
for (;;) {
if (i == (8 * sizeof(i))) break;
// DID NOT WORK! if (((1<<i) == 0) || ((i>0) && ((1<<i) == 1))) break; // Wow. 1<<32 == 1 !!!
if (Sym->x & (1<<i)) {
fprintf(OUTFILE, "%s ", i<x_last_item ? Xx[i] : "BUG");
}
i = i+1;
}
fprintf(OUTFILE, "; ");
}
if (Sym->string_len_ast >= 0) {
fprintf(OUTFILE, "STRLEN@%d; ", Sym->string_len_ast);
}
if (Sym->cache_idx >= 0) { // cached value for folding constant expesssions at compile time.
// Also an index, not actual data value.
fprintf(OUTFILE, "Cache@%d; ", Sym->cache_idx);
}
if (Sym->next_name > 0) {
int n = 0;
fprintf(OUTFILE, "Names@%d; ", Sym->next_name);
while (n < Sym->next_name) {
if (Sym->name_ast[n] >= 0) { // variable name as an ast pointer
fprintf(OUTFILE, "ASTName@%d; ", Sym->name_ast[n]);
}
if (Sym->name_idx[n] >= 0) { // variable name as a stringpool index
//fprintf(OUTFILE, "StrName@%d; ", Sym->name_idx[n]);
fprintf(OUTFILE, "%s; ", name_idx_to_str(Sym, n));
}
n += 1;
}
}
if (Sym->alias_idx[0] >= 0) { // external linkage string (stringpool index)
fprintf(OUTFILE, "Alias@%d; ", Sym->alias_idx[0]);
}
if (Sym->param_list_ast >= 0) { // Procedure formal parameters (index into array of generated AST objects)
fprintf(OUTFILE, "Params@%d; ", Sym->param_list_ast);
}
if (Sym->optional_data_idx >= 0) { // index into array of simple objects specific to datatype with extra information
// for example string length, or value of a const
fprintf(OUTFILE, "Data@%d; ", Sym->optional_data_idx);
}
if (Sym->recordformatid_ast >= 0) { // If this is a structure, then index of structure layout (generated AST object) ie fields and variants
fprintf(OUTFILE, "recordformat@%d; ", Sym->recordformatid_ast);
}
if (Sym->array_dimen >= 0) { // array dimensions (# of BPAIRs)
fprintf(OUTFILE, "Dimen@%d; ", Sym->array_dimen);
}
if (Sym->array_dimen > 0) { // If this is an array, then index of array layout (generated AST object) ie bounds and dimensions
int i;
for (i = 0; i < Sym->array_dimen; i++) {
fprintf(OUTFILE, "[@%d:@%d]; ", Sym->lowerbound_ast[i], Sym->upperbound_ast[i]);
}
}
if (Sym->scope_idx >= 0) { // If this is an array, then index of array layout (generated AST object) ie bounds and dimensions
fprintf(OUTFILE, "Scope@%d; ", Sym->scope_idx);
}
if (Sym->code_ast >= 0) { // code of body (for proc/fn/map for now)
fprintf(OUTFILE, "Code@%d; ", Sym->code_ast);
}
fprintf(OUTFILE, "Scope %d", current_scope);
fprintf(OUTFILE, " */");
}
}
#endif
int ctuple_inner(int line, int c_op, ...) {
int data[16];
va_list ap;
int i, count = 0;
data[0] = 0;
va_start(ap, c_op);
for (;;) {
i = va_arg(ap, int);
if (i == 0x81818181) break; // Inserted by wrapper macro. Can't determine count otherwise.
count += 1;
data[count] = i;
}
va_end(ap);
assert(count <= 15);
if (c_op == C_NAME) {
int name = data[1];
char *names = pool_to_str(name);
// Canonicalisation of names can happen here. We'll set them to lowercase temporarily as a test...
// NOTE that because the stringpool shares common strings, altering one in situ will alter any others
// that initially were identical - even if they were from a different context, such as being in a
// string rather than being a variable name.
//
// This is also where we would escape variable names that match C keywords... using all lowercase
// for variables is bound to cause clashes. All upper case is UGLY. So for the initial implementation
// we'll hackily just put the first character in uppercase and the rest in lowercase.
if (*names != '\0') names += 1;
while (*names != '\0') {
int c = *names;
if (isalpha(c) && isupper(c)) c = tolower(c);
*names = c;
names += 1;
}
}
if (debug_ctuples) {
fprintf(stderr, "line %d: ctuple(C_", line);
if (c_op >= C_BASE && c_op <= C_LAST) {
fprintf(stderr, "%s", CAstOPName(c_op));
} else {
fprintf(stderr, "%d", c_op);
}
switch (c_op) {
case C_STRING_LITERAL:
fprintf(stderr, ", '%s');", pool_to_str(data[1]));
break;
default:
fprintf(stderr, ", [");
for (i = 1; i <= count; i++) {
fprintf(stderr, " %d", data[i]);
}
fprintf(stderr, "])");
}
}
int tup = mktuple(c_op, /*alt*/1, count, data); // local 'data' is copied by mktuple. Safe to deallocate.
sourceline(tup) = line;
Typefield(tup) = -1;
if (debug_ctuples) {
fprintf(stderr, " -> %d; DIAGNOSE: ", tup);
diagnose(tup);
if (c_op == C_MAIN_PROGRAM_BLOCK) {
fprintf(stderr, " CONTAINS: ");
diagnose(leftchild(tup));
}
fprintf(stderr, "END OF DIAGNOSE.\n");
}
return tup;
}
// Note: any destination may be passed as NULL and value will be skipped.
void detuple_inner(int line, int astp, int c_op, int *ptrs, ...) {
va_list ap;
int count = 1, creation_line;
int *ptr;
if (AstOP(astp) != c_op) {
if (c_op < C_BASE || c_op > C_LAST) {
fault("detuple at line %d: params should be astp, C_something...\n", line);
}
if (AstOP(astp) == C_TO_DO) {
fault("Can't unpack - still to implement: %s from line %d", pool_to_str(child(astp, 1)), child(astp, 2));
} else {
diagnose(astp);
fault("AST at %d is a %d (%s), not a %d (%s). (see line %d)", astp, AstOP(astp), CAstOPName(AstOP(astp)), c_op, CAstOPName(c_op), line);
}
}
creation_line = sourceline(astp);
if (debug_cast_creation) {
fprintf(stderr, "ctuple(%s) at %d was created at line %d and extracted at line %d\n", CAstOPName(AstOP(astp)), astp, creation_line, line);
}
if (ptrs) *ptrs = child(astp, count);
//fprintf(stderr, "%p: child(%d,%d) = %d\n", ptrs, astp, count, *ptrs);
va_start(ap, ptrs);
for (;;) {
ptr = va_arg(ap, int *);
if (ptr == &END_MARKER) break; // Inserted by wrapper macro. Can't determine count otherwise.
count += 1;
if (ptr) *ptr = child(astp, count);
//fprintf(stderr, "%p: child(%d,%d) = %d\n", ptr, astp, count, *ptr);
}
va_end(ap);
if (AST[astp+AST_count_offset] != count) {
// *Extremely* useful test!
fault("%s at %d has %d members, not the %d given as parameters. (see line %d)", CAstOPName(AstOP(astp)), astp, AST[astp+AST_count_offset], count, line);
}
}
void diagnosewalk_inner(int astp, int depth, int depth_wanted, int line) {
#define diagnosewalk_(astp) diagnosewalk_inner(astp, depth+1, 999, __LINE__)
int i, spaces;
if (astp < 0 || astp > AST_nextfree) {
fprintf(stderr, "@%7d: ", astp);
for (spaces = depth; spaces > 0; spaces -= 1) fprintf(stderr, " ");
fprintf(stderr, "*** BAD ADDRESS ***\n");
return;
}
int astop = AST[astp+AST_op_offset];
int alt = AST[astp+AST_alt_offset];
int count = AST[astp+AST_count_offset];
int typeinfo = AST[astp+AST_type_info_offset];
int creation_line = AST[astp+AST_line_no_offset];
if (astop < C_BASE || astop > C_LAST) return; //fault("diagnosewalk at line %d: bad astop %d\n", line, astop);
fprintf(stderr, "@%6d {%5d}: ", astp, line);
for (spaces = depth; spaces > 0; spaces -= 1) fprintf(stderr, " ");
fprintf(stderr, "%s ", CAstOPName(astop));
if (AST[astp+0] != 0) {
fprintf(stderr, "[***CORRUPTION*** reserved=%d] ", AST[astp+0]);
}
fprintf(stderr, "[line=%d] [type=%d] ", creation_line, typeinfo);
for (i = 1; i <= count; i++) { // field 0 should be typeinfo
if (child(astp,count) == END_MARKER /* 0x81818181 */) {
fprintf(stderr, "[#%d] = ***MISSING PARAMETER***, ", i);
} else {
int kid = child(astp,i);
if (astop == C_NAME && i == 1) {
fprintf(stderr, "[#%d] = \"%s\"", i, pool_to_str(child(astp,i)));
} else {
fprintf(stderr, "[#%d] = %d", i, child(astp,i));
}
if (kid >= 0 && kid < AST_nextfree) {
int sub = AstOP(kid);
if (sub >= C_BASE && sub <= C_LAST) fprintf(stderr, " (%s)", CAstOPName(sub));
}
fprintf(stderr, ", ");
}
}
if (child(astp,count+1) != END_MARKER /* 0x81818181 */) {
i = count+1;
while (child(astp,i) != END_MARKER /* 0x81818181 */) {
fprintf(stderr, "[#%d] = %d", i, child(astp,i));
{int sub = AstOP(child(astp,i));
if (sub >= C_BASE && sub <= C_LAST) fprintf(stderr, " (%s)", CAstOPName(sub));
}
fprintf(stderr, " ***EXTRA PARAMETER***, ");
i += 1;
}
} else {
fprintf(stderr, " **END**");
}
if (alt != 1) fprintf(stderr, " **CORRUPTION** - All C_* CAST tuples should have alt=1, not alt=%d", alt);
fprintf(stderr, "\n");
if (depth+1 >= depth_wanted) return;
for (i = 1; i <= count; i++) {
int kid = child(astp,i);
if (kid >= 0 && kid < AST_nextfree) {
int sub = AstOP(kid);
if (sub >= C_BASE && sub <= C_LAST) diagnosewalk_(child(astp,i));
}
}
if (depth == 0) fprintf(stderr, "\n");
}
// SHOULD *ONLY* BE CALLED FROM INSIDE out()...
void binary_op(int astop, int left_astp, int right_astp) {
// Checks *priority* and inserts brackets if the Imp priority of the operator
// differs from the C priority.
// Should also check associativity, and insert brackets if the imp associativity of
// the operator is different from the C associativty. But I don't think, offhand, that there are any.
// unary minus may still be a problem (the old -1 >> 1 issue)
if (CPRIO(astop) < CPRIO(AstOP(left_astp))) {
C("(");out(left_astp);C(")");
} else out(left_astp);
C("%s",COPERATOR(astop)); // avoid problem with "%" operator.
if (CPRIO(astop) < CPRIO(AstOP(right_astp))) {
C("(");out(right_astp);C(")");
} else out(right_astp);
}
void unary_op(int astop, int left_astp) {
C(COPERATOR(astop));
if (CPRIO(astop) < CPRIO(AstOP(left_astp))) {
C("(");out(left_astp);C(")");
} else out(left_astp);
}
int can_demorgan(int astp) {
switch (AstOP(astp)) {
// TO DO: predicates
case C_COMP_LT_EQ:
case C_COMP_LT:
case C_COMP_GT_EQ:
case C_COMP_GT:
case C_COMP_EQ:
case C_COMP_NOTEQ:
case C_COMP_EQ_ADDRESS:
case C_COMP_NOTEQ_ADDRESS:
return TRUE;
case C_LOGNOT:
return can_demorgan(leftchild(astp));
case C_LOGAND:
case C_LOGOR:
return can_demorgan(leftchild(astp)) && can_demorgan(rightchild(astp));
case C_BRACKET:
return can_demorgan(leftchild(astp));
default:
if (debug_errors) diagnose(astp);
return FALSE;
}
}
int demorgan(int astp) {
// TO DO: if applying DeMorgan to a statement with an Imp double-sided condition such as %if Longbase <= Value <= Longtail ...
//
// which in C form is:
//
// if (Longbase <= Value && Value <= Longtail) ...
//
// you get an expression which includes: (Longbase > Value || Value > Longtail)
//
// It would be nice in that situation to reverse the text (but not the meaning) of the *first* comparison, ie:
//
// (Value < Longbase || Value > Longtail)
//
// In almost all circumstances, this produces a more natural-reading expression.
//
switch (AstOP(astp)) {
// TO DO: predicates
case C_COMP_LT_EQ:
return ctuple(C_COMP_GT, leftchild(astp), rightchild(astp));
case C_COMP_LT:
return ctuple(C_COMP_GT_EQ, leftchild(astp), rightchild(astp));
case C_COMP_GT_EQ:
return ctuple(C_COMP_LT, leftchild(astp), rightchild(astp));
case C_COMP_GT:
return ctuple(C_COMP_LT_EQ, leftchild(astp), rightchild(astp));
case C_COMP_EQ:
return ctuple(C_COMP_NOTEQ, leftchild(astp), rightchild(astp));
case C_COMP_NOTEQ:
return ctuple(C_COMP_EQ, leftchild(astp), rightchild(astp));
case C_COMP_EQ_ADDRESS:
return ctuple(C_COMP_NOTEQ_ADDRESS, leftchild(astp), rightchild(astp));
case C_COMP_NOTEQ_ADDRESS:
return ctuple(C_COMP_EQ_ADDRESS, leftchild(astp), rightchild(astp));
case C_LOGNOT:
return leftchild(astp);
case C_LOGAND:
return ctuple(C_LOGOR, demorgan(leftchild(astp)), demorgan(rightchild(astp))); // was invert
case C_LOGOR:
return ctuple(C_LOGAND, demorgan(leftchild(astp)), demorgan(rightchild(astp))); // was invert
case C_BRACKET:
{
int nonbracket = leftchild(astp);
while (AstOP(nonbracket) == C_BRACKET) nonbracket = leftchild(nonbracket);
return ctuple(C_BRACKET, demorgan(leftchild(astp)));
}
default:
assert(FALSE);
}
}
#undef IntConstant_c
// no longer to be used. Not safe after compile() is finished. (because of const int name->value mapping and scope handling only valid during compile)
void out_inner(int astp, int line) { // just like compile (and will eventually be merged with compile)
// but for manipulated AST entries created to make generating C easier.
if (astp < 0) {
if (debug_ctuples) warn("out(-1) at line %d", line);
return;
}
int astop = AstOP(astp);
int alt = Alt0(astp);
int count = AST[astp+AST_count_offset];
int *A_child = &AST[astp+AST_child1_offset]; // An index into a child of the AREC, *not* a child of the AST.
if (astop < C_BASE || astop > C_LAST) {
fault("Corrupt AST (astp = %d, astop = %d). What was the last bit of code to call out()? Try looking at line %d", astp, astop, line);
}
// Now proper C_* tuples.
if (debug_structures) {
showtype(astp); C("\n");
}
switch (astop) {
case C_REALS_LONG:
{
C_TYPE_REAL_default_real_size = C_TYPE_REAL_double;
return;
}
case C_REALS_NORMAL:
{
C_TYPE_REAL_default_real_size = C_TYPE_REAL_float;
return;
}
case C_MAIN_PROGRAM_BLOCK: // begin-endofprogram block
{
int block_c = leftchild(astp);
int cleanup_c = rightchild(astp);
C("int _imp_mainep(int _imp_argc, char **_imp_argv) ");
C("{");
if (imp_option_trace >= 3) C("_imp_enter();");
C("\n");
out(block_c); // <INTERNALS>
if (imp_option_trace >= 3) C("_imp_leave();\n");
C("exit(0);\n");
C("return(1);\n");
out(cleanup_c); // not used now, because I moved the switch default stuff to block_c
C("}\n"); // <outer-level-end>
return;
}
case C_NESTED_BLOCK: // begin-end block. back end doesn't really care what kind of block it is, all it wants to do
{ // is output the {}'s. Scoping issues come during compile() so this C_ type may be redundant. Merge with C_STATEMENT_BLOCK?
int block_c = leftchild(astp);
C("\n{\n");
out(block_c);
C("\n}\n");
return;
}
case C_PROCEDURE_BLOCK: // #1 begin-end block #2 C_TYPE_PROC/FN/MAP etc
{
int block_c, proc_c;
detuple(astp, C_PROCEDURE_BLOCK, &block_c, &proc_c);
C("\n{");
if (imp_option_trace >= 3) C("_imp_enter();\n");
out(block_c);
// NOTE: any undefined defaults for %switch declarations at this level need to be output at the end
// of the block. May need to insert an explicit return before the default statements (which
// will output 'switch label not set' error messages. Also if it is a fn/map, print an error
// that the end of the function has been reached without a %result.
// *** ONLY *** applies to procedure bodies and begin/end blocks (ie Imp scopes). Not to start/finish
// groups or any other structure that might generate a C "{}" grouping.
if (imp_option_trace >= 3) C("\n_imp_leave();\n");
if (imp_option_missing_results) {
int astop = AstOP(proc_c);
// examine proc_c for proc/fn/map/predicate and issue runtime error message for fn/map/pred only
// (Could raise a signal instead?)
if (astop == C_TYPE_ROUTINE) {
} else if (astop == C_TYPE_PREDICATE) {
if (imp_option_trace > 0) C("fault(\"Reached end of %%s without a %%%%true/%%%%false\", __PRETTY_FUNCTION__);\n");
} else if (astop == C_TYPE_FN || astop == C_TYPE_MAP) {
if (imp_option_trace > 0) C("fault(\"Reached end of %%s without a %%%%result\", __PRETTY_FUNCTION__);\n");
} else fault("Internal error - unknown function-like %s", CAstOPName(astop));
}
C("}\n");
return;
}
case C_SWITCH_LABEL_COLON:
{
int name_c = leftchild(astp);
int const_c = rightchild(astp); // literal <NAME>s such as 'max' should reduce to a C_CONST_INT if declared as %constinteger max=42 etc
int val = rightchild(const_c);
out(name_c);
C("_");
if (val < 0) {
fprintf(OUTFILE, "M%0d", -val); // 'M' for 'minus'
} else {
if ((AstOP(const_c) == C_CONST_INT)) {
fprintf(OUTFILE, "%0d", val /*, pool_to_str(leftchild(const_c))*/);
} else {
diagnose(const_c);
warn("* Switch label index may not be a constant expression");
//warn("unhandled switch label type");
out(rightchild(astp)); // fallback. should never happen
}
// TO DO: add to "void *" array of switch-label declarations ...
// (but in the right order! - or use C11 designated initialisers?)
// Try to avoid 2-pass code generation... so would have to be
// done during conversion to C AST, not during output tree-walk.
// Some hack with include files may be possible but unlikely to
// look good.
}
C(":\n"); // maybe also ';' ?
return;
}
case C_SWITCH_LABEL_DEFAULT:
{
int name_c = leftchild(astp);
out(name_c);C("_default:\n");
// TO DO: add to declaration array, or at least mark as having been used.
// - default still needed for 'switch not set' error.
return;
}
case C_TO_DO:
C("\n/*TO DO: %s", pool_to_str(leftchild(astp)));C(" at line %d*/\n", rightchild(astp));
return;
case C_CONST_STRING: // #1 canonical STRING_LITERAL
{
char STRING[1024], *s, *t, q;
fprintf(OUTFILE, "_imp_str_literal(");
s = pool_to_str(leftchild(astp)); t = STRING;
while (*s != '"' && *s != '\'' && *s != '\0') {
s += 1; // advance to first quote
}
q = *s;
if (q == '"' || q == '\'') {
s += 1;
*t++ = '"';
}
while (*s != '\0') {
int c = *s;
if (c=='\n') {
*t++ = '\\'; *t++ = 'n';
s += 1;
} else if (c=='\\') {
*t++ = '\\'; *t++ = '\\';
s += 1;
} else if (c==q && s[1]==q) {
*t++ = '\\'; *t++ = q;
s += 2;
} else if (c==q && s[1]!=q) {
*t++ = '"';
s += 1;
} else {
*t++ = c;
s += 1;
}
}
*t = '\0';
fprintf(OUTFILE, "%s)", STRING);
}
return;
case C_CONST_REAL:
fprintf(OUTFILE, "%s", pool_to_str(leftchild(astp)));
return;
case C_CONST_INT:
if (leftchild(astp) == -1) {
// If no pre-computed preferred string representation, just output the value as a simple integer.
fprintf(OUTFILE, "%d", rightchild(astp)); // (May need to insert brackets for negative integers, in some contexts.)
} else {
fprintf(OUTFILE, "%s", pool_to_str(leftchild(astp)));
}
return;
case C_CONST_BIGINT:
if (leftchild(astp) == -1) {
// If no pre-computed preferred string representation, just output the value as a simple integer.
fprintf(OUTFILE, "%lld", ((long long)child(astp,2)<<32LL|(long long)child(astp,3)));
} else {
fprintf(OUTFILE, "%s", pool_to_str(leftchild(astp)));
}
return;
case C_STRING_LITERAL:
fprintf(OUTFILE, "%s", pool_to_str(leftchild(astp)));
return;
case C_COND_STR_RES:
// <LVALUE> '-' '>' <STRING-RESOLUTION-EXPR>;
// return ctuple(C_COND_STR_RES, compile(leftchild(astp)), compile(child(astp,4)));
// An alternative scheme (for later) is to create a varargs proc like strres("left%sright%smore%s", &str1, &str2, &str3) or even "parsef" with regexps?
C("_imp_resolve(");
out(leftchild(astp));
if (AstOP(rightchild(astp)) == C_STR_MATCH) {
C(", NULL");
}
out(rightchild(astp));
C(")");
return;
case C_STR_RES:
// <LVALUE> '-' '>' <STRING-RESOLUTION-EXPR>;
// return ctuple(C_COND_STR_RES, compile(leftchild(astp)), compile(child(astp,4)));
// Unconditional string resolution is just conditional string resolution with an
// error if it fails.
C("if (!_imp_resolve(");
out(leftchild(astp));
if (AstOP(rightchild(astp)) == C_STR_MATCH) {
C(", NULL");
}
out(rightchild(astp));
C(")) _imp_signal(7,0,0)");
return;
case C_STR_MATCH: // <STR-MATCH> <OPT-STR-ASSIGN>,
C(", ");
out(leftchild(astp));
if (rightchild(astp) != -1) {
out(rightchild(astp));
} else C(", NULL");
return;
case C_STR_ASSIGN: // <STR-ASSIGN> <OPT-STR-MATCH>;
C(", ");
out(leftchild(astp));
//if (compile(rightchild(astp)) != -1) {
if (rightchild(astp) != -1) {
out(rightchild(astp));
}
return;
case C_ACCESS_RECORD_FIELD:
{
int parent, child, ispointer;
detuple(astp, C_ACCESS_RECORD_FIELD, &parent, &child, &ispointer);
// we have to rely on the data structure having been built by 'compile()' - by the
// time we get here in 'out', the symbol tables have all gone. It's too late now to
// look up 'parent' and see whether it is a %name, etc.
out(parent);
if (ispointer) {
C("->", child(astp,1));
} else {
C(".", child(astp,1));
}
out(child);
return;
}
return;
case C_SCALAR: // #1 name #2 %sex #3 pointer to(ie %name) (or -1) #4 arrayname #5 C_TYPE...
{
out(leftchild(astp));
return;
}
case C_NAME:
{
int name_idx, name_ast;
detuple(astp, C_NAME, &name_idx, &name_ast);
// #1 = stringpool index, #2 = astp of <NAME>.
if (name_idx < 0) {
fprintf(stderr, "* C_NAME: 1st param is stringpool index %d. 2nd param is astp of name: %d", name_idx, name_ast);
out(compile(name_ast)); // should never happen.
return;
}
C(pool_to_str(name_idx));
return;
}
case C_AST_OBJECT:
{
warn("AST_OBJECTs still making it through to out() ... (from line %d)", line);
int the_object = leftchild(astp);
int c_object = compile(the_object); // variables, literal constants etc
out(c_object);
}
return;
case C_TEMPNAME:
fault("C_TEMPNAMEs still making it through to out() ... (from line %d)", line);
(void)compile(leftchild(astp)); // variables, literal constants etc
return;
case C_LOGNOT:
{
int param = leftchild(astp);
if (AstOP(param) == C_LOGNOT) {
int condition = leftchild(param);
out(condition); // although !! in C canonizes a boolean, with Imp %not %not would just be redundant
} else {
if (can_demorgan(leftchild(astp))) {
out(demorgan(leftchild(astp)));
} else {
unary_op(astop, leftchild(astp));
}
}
}
return;
case C_UNARY_MINUS:
case C_BITNOT:
case C_UNARY_PLUS:
{
int lhs = leftchild(astp);
unary_op(astop, lhs);
return;
}
case C_COMP_EQ_ADDRESS:
case C_COMP_NOTEQ_ADDRESS:
// add C_ADDRESS() to left and right
{
int lhs = get_address_of(leftchild(astp));
int rhs = get_address_of(rightchild(astp));
binary_op(astop, lhs,rhs);
return;
}
case C_SHR:
C("(unsigned)");
case C_BINMINUS:
case C_BINPLUS:
case C_IDIV:
case C_RDIV:
case C_BITAND:
case C_BITEXOR:
case C_BITOR:
case C_MUL:
case C_SHL:
case C_LOGAND:
case C_LOGOR:
// Need to test type of operands, especially for string comparisons which need strcmp
case C_COMP_LT_EQ:
case C_COMP_LT:
case C_COMP_GT:
case C_COMP_GT_EQ:
case C_COMP_EQ:
case C_COMP_NOTEQ:
{
int lhs = leftchild(astp);
int rhs = rightchild(astp);
binary_op(astop, lhs,rhs);
return;
}
case C_IEXP:
C("IEXP("); out(leftchild(astp)); C(","); out(rightchild(astp)); C(")");
return;
case C_REXP:
C("REXP("); out(leftchild(astp)); C(","); out(rightchild(astp)); C(")");
return;
case C_CONCAT: // later optimise with a sprintf equivalent.
C("_imp_join(");out(leftchild(astp)); C(","); out(rightchild(astp)); C(")");
return;
case C_ABS:
C("abs(");out(leftchild(astp));C(")"); return;
case C_BRACKET: // print one bracket but not multiple brackets
while (AstOP(astp) == C_BRACKET) astp = leftchild(astp); // remove redundant brackets...
C("(");out(astp);C(")");
return;
case C_IMPMINUSMINUS:
out(leftchild(astp));C("[-");out(rightchild(astp));C("]");
warn("'--' not checked");
return; // TEMP
case C_IMPPLUSPLUS:
out(leftchild(astp));C("[");out(rightchild(astp));C("]");
warn("'++' not checked");
return; // TEMP
case C_PTRIDX:
out(leftchild(astp));C("[");out(rightchild(astp));C("]");
warn("Pointer indexing not checked");
return; // TEMP
case C_ADD_COMMA_BEFORE:
C(","); out(leftchild(astp));
return;
case C_ADD_COMMA_AFTER:
out(leftchild(astp)); C(",");
return;
case C_JAM_TRANSFER: // TO DO.
case C_ASSIGN_VALUE: // lvalue rvalue
{
int left = leftchild(astp);
int right = rightchild(astp);
out(left); // lvalue, or nothing if -1.
if (left != -1) C(" = "); // only output the '=' if the C_ASSIGN is a complete ctuple.
// otherwise let the parent handle it...
out(right); // simply evaluate RHS of assignment as a value.
return;
}
return;
case C_ASSIGN_PLUS: // lvalue rvalue
{
int left = leftchild(astp);
int right = rightchild(astp);
out(left); C(" += "); out(right);
return;
}
return;
case C_ASSIGN_MINUS: // lvalue rvalue
{
int left = leftchild(astp);
int right = rightchild(astp);
out(left); C(" -= "); out(right);
return;
}
return;
case C_ASSIGN_PLUSPLUS: // lvalue rvalue
{
int left = leftchild(astp);
out(left); C("++ ");
return;
}
return;
case C_ASSIGN_MINUSMINUS: // lvalue rvalue
{
int left = leftchild(astp);
out(left); C("-- ");
return;
}
return;
case C_ASSIGN_ADDRESS: // lvalue == rvalue
// not sure if lvalue will always have '*' applied if needed.
{
int lhs, rhs; // should be a %name variable and default compile() will generate the right thing to assign to.
detuple(astp, C_ASSIGN_ADDRESS, &lhs, &rhs);
assert(lhs != -1);
out(lhs); // HOWEVER if the LHS is a <something>%name it does NOT want a '*' applied to it. Need type info.
C(" = ");
out(rhs);
}
return;
case C_ACCESS_THROUGH_PERCENTNAME: // cancel out *&lvalue
if (AstOP(leftchild(astp)) == C_ADDRESS) {
C("/*{*&}*/");
out(leftchild(leftchild(astp)));
return;
}
C(" *", sourceline(astp)); out(leftchild(astp));
return;
case C_ADDRESS:
{
if (AstOP(leftchild(astp)) == C_BRACKETED_LIST) { // cancel out &*ptr
//C("/*{&*}*/");
out(leftchild(leftchild(astp)));
return;
}
if (AstOP(leftchild(astp)) == C_ACCESS_THROUGH_PERCENTNAME) { // cancel out &*ptr
//C("/*{&*:2}*/");
out(leftchild(leftchild(astp)));
return;
}
C(" &");
//C("/*%s*/", CAstOPName(AstOP(leftchild(astp))));
out(leftchild(astp));
return;
}
case C_ADD_SEMI:
out(leftchild(astp)); C(";");
return;
case C_SEQ:
for (;;) {
/* DEBUGGING: */
if (astp == -1) {
fault("I would have sworn this could not happen.");
}
if (astp == 0) {
fault("Need to work out how the heck astp got set to 0.");
}
if (AstOP(leftchild(astp)) == C_COMREG_XTYPE) {
warn("COMREG_XTYPE from line %d !", line); // or fault?
}
//fprintf(stderr, "AstOP(astp) = %s\n", CAstOPName(AstOP(astp)));
out(leftchild(astp)); // EXPR
astp = rightchild(astp); // Multiple statements. SEQ is also used in recordformat definition.
if (astp == -1) break;
if (AstOP(astp) == C_TO_DO) {
out(astp);
return;
}
if (AstOP(astp) != C_SEQ) {
//fprintf(stderr, "Unexpected AstOP(astp) = %s (from line %d? or %d?)\n", CAstOPName(AstOP(astp)), sourceline(astp), line);
//assert(AstOP(astp) == C_SEQ);
out(astp);
return;
}
}
return;
case C_FUNCTION_CALL: // fn and params: #1 = proc name (C_NAME), #2 = C_PARAMETER_LIST
{
int Proc, params;
detuple(astp, C_FUNCTION_CALL, &Proc, ¶ms);
//C("/* Executing C_FUNCTION_CALL */");
//if (params != -1) warn("C_FUNCTION_CALL being called prematurely from line %d", line); // current code temp using C_PARAMETER_LIST
C("%s", name_to_cstr(Proc));
// I thought the recursive call to out(Proc) was where the second
// set of parameters was being output (for all calls except %predicate)
// but it appears not. Still not sure where that is happening, but
// has to be in expressions.c surely?
//out(Proc); // hopefully a <NAME> for now. Being reworked. Need to check if %map etc. All will be in accompanying type information.
// not sure where other set of arguments are coming from...
//#ifdef NEVER // temporarily removed while checking an indexing issue...
C("(");
if (params != -1) {
int save = global_fpp_hack;
global_fpp_hack = 1;
astp = params; // C_PARAMETER_LIST
int n = 1;
for (;;) {
int param_c = child(astp,2);
if (param_c != -1) {
if (AstOP(param_c) == C_SEQ) {
//C("/* Param_seq %d */", n); n++; // diagnose(param_c);
out(param_c); // EXPR
} else if (AstOP(param_c) == C_PARAMETER_LIST) {
//C("/* Param_list %d */", n); n++; //diagnose(param_c);
out(param_c); // EXPR
} else {
//C("/* Param %d */", n); n++; //diagnose(param_c);
out(param_c); // EXPR
}
}
if (child(astp,3) != -1) C(",");
astp = child(astp,3); // subsequent params - HOWEVER... TODO: use temporaries to force right-to-left evaluation for C externals. (systemroutinespec)
if (astp == -1) break;
if (AstOP(astp) == C_PARAMETER_LIST) continue; // child(astp,1) for subsequent parameters/indexes will be -1.
showtype(astp); break;
}
global_fpp_hack = save;
}
C(")"); // optional parameter list. May be empty.
//#endif
}
return;
case C_ACCESS_ARRAY_ELEMENT: // =ctuple(C_ACCESS_ARRAY_ELEMENT, name_sym_idx, param_c);
{
warn("C_ACCESS_ARRAY_ELEMENT being called prematurely from line %d", line);
int Array, param;
detuple(astp, C_ACCESS_ARRAY_ELEMENT, &Array, ¶m);
// #1 = index of proc name in SymTable, #2 = ast (for now) parameter list, later C_PARAMETER_LIST (#3 in development)
out(Array); // hopefully a <NAME> for now. Being reworked. Bounds etc will be in accompanying type information.
while ((param != -1) &&
((AstOP(param) == C_BRACKETED_LIST /*ditto*/) ||
(AstOP(param) == C_PARAMETER_LIST /*(legacy)*/) ||
(AstOP(param) == C_INDEX_LIST))
) { // optional parameter list. May be empty.
C("["); out(leftchild(param)); C("]"); // actual parameter
param = rightchild(param); // optional parameter list. May be empty.
}
if (param != -1) {
warn("UNEXPECTED PARAM_LIST link: ");diagnose(param);
}
}
return;
case C_SWITCH_LABEL_DEST: // <name, expr>
{
int name_c, index_c, decl_c, low, high;
detuple(astp, C_SWITCH_LABEL_DEST, &name_c, &index_c, &decl_c, &low, &high); // decl_c is -1 until I add it at the point of creating the C_SWITCH_LABEL_DEST. TO DO.
// first we look up the switch label to see if it is in this scope (NOT a higher scope! - cannot jump out of a nested routine for example)
// then we get the lower bound of the switch array, and adjust the index appropriately.
// if the index is outside the low..high range of the switch declaration, signal an error
if (low == 0) {
C("*"); out(name_c); C("["); out(name_c); C("_sw = ");out(index_c); C("]", low);
// ^ saving the index that was used so that missing switch label error message can be output
} else {
C("*"); out(name_c); C("["); out(name_c); C("_sw = (");out(index_c); C(") - %d]", low);
// ^ saving the index that was used so that missing switch label error message can be output
}
}
return;
case C_NAME_LABEL_DEST: // <name>
{
int name_c;
detuple(astp, C_NAME_LABEL_DEST, &name_c);
out(name_c);
}
return;
case C_NUMERIC_LABEL_DEST: // <digit-seq>
{
// for now assume digit seq is always compatible with C
int num_c; // fortunately negative no's not possible here.
detuple(astp, C_NUMERIC_LABEL_DEST, &num_c);
C("L__"); out(num_c);
}
return;
case C_INIT:
{
// #1 type of assignment (treat everything like '=' for now...)
// #2 is CEXPR-LIST
// #3 is lower bound if known. Assume that currently all initialised arrays are one dimensional.
// #4 is upper bound if known
int assign_c = leftchild(astp);
int exprlist_c = rightchild(astp);
int array = FALSE;
C(" = "); // maybe not, depends on assign_c really
if (AstOP(exprlist_c) == C_EXPR_LIST && (child(exprlist_c,2) != -1 || (AstOP(child(exprlist_c,1)) == C_INIT_REPEATS)) ) {
array = TRUE;
C(" {\n");
}
if (AstOP(exprlist_c) < C_BASE) {
warn("Uncompiled expr list?");
exprlist_c = compile(exprlist_c); // added as a test - undo if bad
}
out(exprlist_c);
if (array) {
C("\n}");
}
return;
}
case C_EXPR_LIST:
{
// #1 is the expr (which may be a C_INIT_REPEATS group!)
// #2 is another EXPR-LIST
int expr_c, exprlist_c, index = 0;
detuple(astp, C_EXPR_LIST, &expr_c, &exprlist_c);
for (;;) { // loop until no more exprlist_c
if (AstOP(expr_c) == C_INIT_REPEATS) {
int val, lower, upper, repeat;
char num[16];
detuple(expr_c, C_INIT_REPEATS, &val, &lower, &upper, &repeat);
if (AstOP(repeat) == C_STRING_LITERAL && leftchild(repeat) == str_to_pool("*")) {
if (global_bounds_valid) {
repeat = (global_upper_bound_hack-global_lower_bound_hack)-index+1;
} else {
repeat = 1; // TO DO: need to know size of array!!!
warn("(*) - unable to determine end of array");
}
} else {
if (AstOP(repeat) != C_CONST_INT) {
fault("Initialisation repeat count must be a constant expression");
}
repeat = child(repeat,2);
}
if (repeat == 0) {
warn("\"(0)\" repeat factor in const array! Ignored. (Imp on the 68K *might* have treated this as \"(1)\" ))");
if (exprlist_c == -1) break;
} else {
sprintf(num, "%d", /*-global_lower_bound_hack*/index);
lower = ctuple(C_CONST_INT, str_to_pool(num), /*-global_lower_bound_hack*/index);
sprintf(num, "%d", index+repeat-/*-global_lower_bound_hack*/1);
upper = ctuple(C_CONST_INT, str_to_pool(num), index+repeat-/*-global_lower_bound_hack*/1);
sprintf(num, "%d", repeat);
int repeat_c = ctuple(C_CONST_INT, str_to_pool(num), repeat);
expr_c = ctuple(C_INIT_REPEATS, val, lower, upper, repeat_c); // we only construct this here to make the data easier to print.
// otherwise it's pretty much a throw-away piece of data.
index += repeat;
out(expr_c);
if (exprlist_c == -1) break;
C(",");
}
} else {
index += 1;
out(expr_c);
if (exprlist_c == -1) break;
C(",");
}
detuple(exprlist_c, C_EXPR_LIST, &expr_c, &exprlist_c);
}
return;
}
case C_INIT_REPEATS:
{
int val, lower, upper, repeats;
detuple(astp, C_INIT_REPEATS, &val, &lower, &upper, &repeats);
// caller has to keep track of index position and array size eg for %integerarray w(0:9) = 1(5), 2, 3(*)
C("["); out(lower); C(" ... "); out(upper); C("] = "); out(val); // spaces around ... are essential
return;
}
case C_TYPE_ROUTINE: // #1 name #2 spare #3 parameter list (C_TYPE_PARAMETERS) #4 body #5 alias or -1 #6 %sex
case C_TYPE_FN: // #1 name #2 result type #3 parameter list (C_TYPE_PARAMETERS) #4 body #5 alias or -1 #6 %sex
case C_TYPE_MAP: // #1 name #2 result type #3 parameter list (C_TYPE_PARAMETERS) #4 body #5 alias or -1 #6 %sex
case C_TYPE_PREDICATE: // #1 name #2 spare #3 parameter list (C_TYPE_PARAMETERS) #4 body #5 alias or -1 #6 %sex
{
// #1 name #2 spare #3 parameter list (C_TYPE_PARAMETERS) #4 body #5 alias or -1
int name, result_type, fpp, spec_or_body, alias, sex, linkage;
int storage_class, linkage_class;
detuple(astp, astop, &name, &result_type, &fpp, &spec_or_body, &alias, &sex);
assert(AstOP(name) == C_NAME);
// assert(sex == -1 || AstOP(sex) == C_COMREG);
// otherwise we need to output the <SEX> qualifier.
// external, _system, dynamic, prim, / perm, / _auto, own, constant
if (sex == -1) {
linkage = _fpp;
linkage_class = C_LINKAGE_internal;
storage_class = C_STORAGE_default;
} else {
if (AstOP(sex) == C_COMREG) { // being phased out...
linkage = child(sex,1);
if (linkage == _system) {
linkage_class = C_LINKAGE_extern_system;
storage_class = C_STORAGE_extern;
} else if (linkage == external) {
linkage_class = C_LINKAGE_extern_imp;
storage_class = C_STORAGE_extern;
} else if (linkage == dynamic) {
linkage_class = C_LINKAGE_extern_dynamic; // like extern_system but dynamically loaded.
storage_class = C_STORAGE_extern;
} else if (linkage == prim) {
linkage_class = C_LINKAGE_extern_prim;
storage_class = C_STORAGE_default;
} else if (linkage == perm) {
linkage_class = C_LINKAGE_extern_perm;
storage_class = C_STORAGE_default;
} else if (linkage == _auto) {
linkage_class = C_LINKAGE_internal;
storage_class = C_STORAGE_auto;
} else if (linkage == _fpp) {
linkage_class = C_LINKAGE_internal;
storage_class = C_STORAGE_param;
} else {
warn("Unknown old-style linkage class %d", linkage);
}
//C("/*old-style: Linkage:%s Storage:%s*/",LinkageName[linkage_class>>4],StorageName[storage_class]);
} else if (AstOP(sex) == C_STORAGE) {
int options;
detuple(sex, C_STORAGE, &options);
storage_class = options&C_STORAGE_MASK;
linkage_class = options&C_LINKAGE_MASK;
//C("/*C_STORAGE: Linkage:%s Storage:%s*/",LinkageName[linkage_class>>4],StorageName[storage_class]);
} else {
diagnose(sex);
fault("storage/linkage info is an unexpected type.");
}
}
switch (linkage_class) {
case C_LINKAGE_extern_imp: if (spec_or_body == -1) C("extern "); break; // if this declaration has a body, don't output "extern".
case C_LINKAGE_extern_system:
case C_LINKAGE_extern_dynamic:
case C_LINKAGE_extern_prim:
case C_LINKAGE_extern_perm:
C("extern "); break;
case C_LINKAGE_internal:
default:;
switch (storage_class) {
case C_STORAGE_auto:
if (spec_or_body == -1 || AstOP(spec_or_body) == C_SPEC) {
// if we are nested in a top-level procedure, output "auto"
C("auto ");
// if we are at the top level and no qualifier was given (ie 'auto' by default) then C("extern ") ?
// However should not have a plain "%routinespec" to level 0 - those should be "%externalroutinespec" ...
// so for now this is sufficient.
}
//C("/*not auto?*/"); diagnose(spec_or_body);
break;
case C_STORAGE_static:
C("static ");
break;
case C_STORAGE_const:
C("const ");
break;
case C_STORAGE_param:
default:
break;
}
break;
}
if (astop == C_TYPE_ROUTINE) {
C("void ");
} else if (astop == C_TYPE_PREDICATE) {
C("int /* boolean */ ");
} else if (astop == C_TYPE_FN || astop == C_TYPE_MAP) {
out(result_type);
if (astop == C_TYPE_MAP) C("*");
} else fault("Internal error - unknown function-like %s", CAstOPName(astop));
C("%s", name_to_cstr(name));
C("(");
if (fpp == -1) {
C("void");
} else {
out(fpp);
}
C(")");
if (spec_or_body != -1) out(spec_or_body);
return;
}
case C_TYPE_PARAMETERS:
{
int name, parameter, more_parameters;
detuple(astp, C_TYPE_PARAMETERS, &name, ¶meter, &more_parameters);
out(parameter);
out(name);
if (more_parameters != -1) {
C(", "); out(more_parameters);
}
return;
}
case C_PARAMETER_LIST: // should we be using C_FUNCTION_CALL?
{
// I think we need to know the type of the parameter as well as the parameter itself, to
// distingush between passing the address of a procedure as a parameter versus a call to the procedure.
// Or can we handle it by inserting a C_ADDRESS tuple in front of the procedure parameter.
// #1 object this hangs off #2 actual parameter #3 rest of actual parameter list (another C_PARAMETER_LIST)
out(child(astp,1)); // name
C("(");
for (;;) {
out(child(astp,2)); // EXPR
if (child(astp,3) != -1) C(",");
astp = child(astp,3); // subsequent params - HOWEVER... TODO: use temporaries to force right-to-left evaluation for C externals. (systemroutinespec)
if (astp == -1) break;
assert(AstOP(astp) == C_PARAMETER_LIST); // child(astp,1) for subsequent parameters/indexes will be -1.
}
C(")");
return;
}
case C_BRACKETED_LIST:
{
out(child(astp,1)); // name
C("("); // MIGHT BE [] - resolve later once we have types working
for (;;) {
out(child(astp,2)); // EXPR
if (child(astp,3) != -1) C(",");
astp = child(astp,3); // subsequent params - HOWEVER... TODO: use temporaries to force right-to-left evaluation for C externals. (systemroutinespec)
if (astp == -1) break;
assert(AstOP(astp) == C_PARAMETER_LIST); // child(astp,1) for subsequent parameters/indexes will be -1.
}
C(")");
return;
}
case C_INDEX_LIST:
{
out(child(astp,1)); // name
C("["); // MIGHT BE [] - resolve later once we have types working
for (;;) {
out(child(astp,2)); // EXPR
if (child(astp,3) != -1) C("][");
astp = child(astp,3); // subsequent params - HOWEVER... TODO: use temporaries to force right-to-left evaluation for C externals. (systemroutinespec)
if (astp == -1) break;
assert(AstOP(astp) == C_PARAMETER_LIST); // child(astp,1) for subsequent parameters/indexes will be -1.
}
C("]");
return;
}
case C_TYPE_INT:
{
// #1 name. May be -1.
// #2 precision/signedness
// #3 initialisation C_AST or -1
// #4 canonical folded value of %const, or -1
// #5 percent_name
int name, precision;
int unused_init, unused_folded, percent_name;
detuple(astp, C_TYPE_INT, &name, &precision, &unused_init, &unused_folded, &percent_name);
if (name == -1) {
name = ctuple(C_NAME, str_to_pool(""), line); // will be plugged by "out(C_DECLARE_SCALAR)" etc
} else if (AstOP(name) != C_NAME) {
warn("Internal problem - name was not a C_NAME (called from line %d)", line);
name = ctuple(C_NAME, str_to_pool("CORRUPT_NAME"), line);
}
assert(AstOP(name) == C_NAME);
switch (precision) {
case C_TYPE_INT_unsigned_byte:
C("unsigned char ");break;
case C_TYPE_INT_signed_byte:
C("char ");break;
case C_TYPE_INT_unsigned_short:
C("unsigned short ");break;
case C_TYPE_INT_signed_short:
C("short ");break;
case C_TYPE_INT_unsigned_word:
C("unsigned int ");break;
case C_TYPE_INT_signed_word:
C("int ");break;
case C_TYPE_INT_unsigned_long:
C("unsigned long long int ");break;
case C_TYPE_INT_signed_long:
C("long long int ");break;
case C_TYPE_INT_unsigned_long_long:
C("unsigned __int128 ");break;
case C_TYPE_INT_signed_long_long:
C("__int128 ");break;
default:
C("/*??? %d */ int %s", rightchild(precision), name_to_cstr(name));break;
}
if (percent_name != -1) C("*");
C("%s", name_to_cstr(name));
return;
}
case C_TYPE_REAL:
{
// #1 name
// #2 precision
// #3 initialisation C_AST or -1
// #4 canonical folded value of %const, or -1
// #5 percent_name
int name, precision;
int unused_init, unused_folded, percent_name;
detuple(astp, C_TYPE_REAL, &name, &precision, &unused_init, &unused_folded, &percent_name);
if (name == -1) {
name = ctuple(C_NAME, str_to_pool(""), line); // will be plugged by out(C_DECLARE_SCALAR) etc
} else if (AstOP(name) != C_NAME) {
warn("Internal problem - name was not a C_NAME (called from line %d)", line);
name = ctuple(C_NAME, str_to_pool("CORRUPT_NAME"), line);
}
assert(AstOP(name) == C_NAME);
switch (precision) {
case C_TYPE_REAL_float:
C("float ");break;
case C_TYPE_REAL_double:
C("double ");break;
case C_TYPE_REAL_long_double:
C("long double ");break; // aka __float128
default:
C("/*??? %d */ double ", rightchild(precision));break;
}
if (percent_name != -1) C("*");
C("%s", name_to_cstr(name));
return;
}
case C_TYPE_STRING:
{
// #1 <name or -1> #2 string type {Imp or C} #3 initialisation C_AST or -1 #4 canonical folded value of %const, or -1 #5 percent_name #6 max length
int name, strtype, init, folded, percent_name, maxlen;
detuple(astp, C_TYPE_STRING, &name, &strtype, &init, &folded, &percent_name, &maxlen);
switch (strtype) {
case C_TYPE_STRING_imp_bounded:
C("_imp_string " /*, maxlenval*/); break;
case C_TYPE_STRING_imp_star:
C("_imp_string "); break; // this should probably just be _imp_string - but using 255 for now to get stuff working...
case C_TYPE_STRING_c_bounded:
C("_c_string "); break; // tricky to output char fred[bounds] at this point in the tree walk!
case C_TYPE_STRING_c_star:
C("_c_string *"); break;
//C("char *"); break; // really not sure this is valid.
default:
fault("Unimplemented new string type %d?", strtype);
}
if (percent_name != -1) C("*");
return;
}
case C_DECLARE_RECORDFORMAT:
{
int format = child(astp,1);
int is_spec = child(astp,2);
// C_TYPE_RECORDFORMAT = #1 <record name or -1> #2 record format name #3 field list of C_TYPE_RECORD_FIELD
// TO DO: before outputting a struct definition, we need to scan the top-level fields of the struct
// and see if it references itself (hopefully as a %name) - if so, then output a spec before outputting the body
C("typedef struct ");
out(child(format,2));
if (is_spec == -1) {
C(" {");
out(child(format,3)); // temporarily this is recursively outputting a record *definition* rather than just a name for record subfields.
// as a side effect of fixing the broken declaration and its is_spec field.
// (the child field list is a C_SEQ list...)
C("} ");
} else C(" ");
out(child(format,2));
C(";");
return;
}
case C_TYPE_RECORDFORMAT:
{
// C_TYPE_RECORDFORMAT = #1 <record name or -1> #2 record format name #3 field list of C_TYPE_RECORD_FIELD
out(child(astp,2));
C(" ");
return;
}
case C_TYPE_GENERAL_NAME:
{
// #1 name #2 register (68K only) or -1
// out(child(astp,1));
C("_imp_name ");
return;
}
case C_TYPE_LABEL:
{
C("__label__ ");
return;
}
case C_STORAGE:
{
switch (leftchild(astp)) {
case C_STORAGE_extern: C("extern "); return;
case C_STORAGE_static: C("static "); return;
case C_STORAGE_const: C("static const "); return;
case C_STORAGE_auto: C("auto "); return;
case C_STORAGE_param: return;
case C_STORAGE_default: /* top-level external declaration or local in a block */ return;
default: return;
}
return;
}
case C_DECLARE_SCALAR:
{
// will include anything not an array, ie %record or %string or general %name (only occurs in parameter list)
// C_DECLARE_SCALAR: #1 %sex #2 pointer to(ie %name) (or -1) #3 arrayname #4 C_TYPE...
int name, storage_class, percent_name, arrayname, base_xtype, initialisation;
detuple(astp, C_DECLARE_SCALAR, &name, &storage_class, &percent_name, &arrayname, &base_xtype, &initialisation);
out(storage_class);
out(base_xtype);
if (global_pointer_hack || percent_name != -1) C("*"); global_pointer_hack = 0;
out(name);
out(initialisation);
// this is only wanted for regular declarations - not for a parameter list...:
// C(";\n"); // currently 'init' inserts '=' before outputting value
return;
}
case C_DECLARE_ARRAY:
{
// #1 name #2 %sex #3 <BOUNDS> #5 C_TYPE... #5 init
int name, storage_class, bounds, base_xtype, initialisation;
detuple(astp, C_DECLARE_ARRAY, &name, &storage_class, &bounds, &base_xtype, &initialisation);
out(storage_class);
out(base_xtype);
if (global_pointer_hack) C("*"); global_pointer_hack = 0;
out(name);
out(bounds);
out(initialisation);
//C("/*6*/");
C(";\n"); // currently 'init' inserts '=' before outputting value
return;
}
#ifdef NEVER
#define C_TYPE_INT 11097 // #1 <name or -1>
// #2 precision/signedness
// #3 initialisation C_AST or -1
// #4 canonical folded value of %const, or -1
// #5 %name or -1
#define C_TYPE_INT_unsigned_byte 1
#define C_TYPE_INT_signed_byte 2
#define C_TYPE_INT_unsigned_short 3
#define C_TYPE_INT_signed_short 4
#define C_TYPE_INT_unsigned_word 5
#define C_TYPE_INT_signed_word 6
#define C_TYPE_INT_unsigned_long 7
#define C_TYPE_INT_signed_long 8
#define C_TYPE_INT_unsigned_long_long 9
#define C_TYPE_INT_signed_long_long 10
#define C_TYPE_REAL 11098 // #1 <name or -1>
// #2 precision
// #3 initialisation C_AST or -1
// #4 canonical folded value of %const, or -1
// #5 %name or -1
#define C_TYPE_REAL_float 11
#define C_TYPE_REAL_double 12
#define C_TYPE_REAL_long_double 13
#define C_TYPE_REAL_long_long_double 14
int C_TYPE_REAL_default_real_size = C_TYPE_REAL_float; // for %realslong and %realsnormal
#define C_TYPE_STRING 11099 // #1 <name or -1>
// #2 string type {Imp or C}
// #3 initialisation C_AST or -1
// #4 canonical folded value of %const, or -1
// #5 %name or -1
// #6 max length
#define C_TYPE_STRING_imp_bounded 12
#define C_TYPE_STRING_imp_star 13
#define C_TYPE_STRING_c_bounded 14
#define C_TYPE_STRING_c_star 15
#endif
case C_TYPE_POINTER_TO: // we might be able to remove the first parameter. Don't think it does anything useful.
{
// #1 <name or -1> #2 object pointed to (<C_TYPE_...>) { %name variable or parameter }
int save, name, type;
detuple(astp, C_TYPE_POINTER_TO, &name, &type);
if (AstOP(type) == C_DECLARE_SCALAR) {
// #1 name #2 %sex #3 pointer to(ie %name) (or -1) #4 arrayname #5 C_TYPE... #6 initialisation
//if (child(type, 1) != -1) child(astp, 1) = child(type, 1); // name
//if (child(astp, 1) != -1) child(type, 1) = child(astp, 1); // name
child(type, 3) = astp;
C("/*SET!*/");
} else if (AstOP(type) == C_TYPE_INT) {
//if (child(type, 1) != -1) child(astp, 1) = child(type, 1); // name
//if (child(astp, 1) != -1) child(type, 1) = child(astp, 1); // name
child(type,5) = astp; // %name
} else if (AstOP(type) == C_TYPE_REAL) {
//if (child(type, 1) != -1) child(astp, 1) = child(type, 1); // name
//if (child(astp, 1) != -1) child(type, 1) = child(astp, 1); // name
child(type,5) = astp;
} else if (AstOP(type) == C_TYPE_STRING) {
//if (child(type, 1) != -1) child(astp, 1) = child(type, 1); // name
//if (child(astp, 1) != -1) child(type, 1) = child(astp, 1); // name
child(type,5) = astp;
} else if (AstOP(type) == C_TYPE_RECORDFORMAT) { // not sure this is what should be here.
out(type);
C("*");
return;
} else {
// still %name to do.
showtype(type);
out(type);
C("*"); // may not be correct
return;
}
//save = global_pointer_hack;
//global_pointer_hack = 1;
out(type);
//global_pointer_hack = save;
return;
}
case C_TYPE_ARRAY_OF:
{
int name, xtype, dims, dv, hamish, bounds, init;
detuple(astp, C_TYPE_ARRAY_OF, &name, &xtype, &dims, &dv, &hamish, &bounds, &init);
out(xtype);
C(" ");
if (global_pointer_hack) C("*"); global_pointer_hack = 0;
out(name);
out(bounds);
return;
}
case C_BOUNDSPAIR:
{
int lower, upper, clower, cupper, more;
detuple(astp, C_BOUNDSPAIR, &lower, &upper, &clower, &cupper, &more); // params given twice because folding must occur in compile(), not out().
global_bounds_valid = FALSE;
if (clower != -1 && cupper != -1) {
global_bounds_valid = TRUE;
global_lower_bound_hack = rightchild(clower);
global_upper_bound_hack = rightchild(cupper);
C("[%d /*%d:%d*/]",global_upper_bound_hack-global_lower_bound_hack+1,global_lower_bound_hack,global_upper_bound_hack);
} else if ((clower != -1) && (AstOP(clower) == C_CONST_INT) && rightchild(clower) == 1) {
C("[");
out(upper); // -1 and +1 cancel out.
C("]");
} else if ((clower != -1) && AstOP(clower) == C_CONST_INT && rightchild(clower) == 0) {
C("[");
if (AstOP(upper) == C_NAME) { // actually an 'atomic()' test would be useful here.
out(upper);
} else {
C("("); out(upper); C(")");
}
C(" + 1]");
} else {
C("[");
if (cupper != -1) {
out(cupper);
} else if (AstOP(upper) == C_NAME) {
out(upper);
} else {
C("("); out(upper); C(")");
}
C(" - ");
if (clower != -1) {
out(clower);
} else if (AstOP(lower) == C_NAME) {
out(lower);
} else {
C("("); out(lower); C(")");
}
C(" + 1]");
}
out(more);
return;
}
case C_BOUNDS:
{
int dims, boundslist;
detuple(astp, C_BOUNDS, &dims, &boundslist);
// dims not needed until we make a dopevector...
// (or decide to reverse the order of indexes in case C is row-major and Imp column-major or vice-versa)
out(boundslist);
return;
}
case C_END_OF_LIST: // suppress or enable listing. Maybe not relevant in translator.
OUTFILE = NULLFILE;
return;
case C_START_OF_LIST:
OUTFILE = stdout;
return;
case C_IF: // #1 'then' statement to be executed #2 cond #3 'else' statement to be executed
{
// strange order of fields is forced by needing compatibility with unless/while/until/for etc
int then = child(astp,1);
int cond = child(astp,2);
while (AstOP(cond) == C_BRACKET) cond = leftchild(cond);
// a very unlikely combination that turned up in one of the imp80 test programs: :-)
if (AstOP(cond) == C_LOGNOT &&
AstOP(leftchild(cond)) == C_BRACKET &&
AstOP(leftchild(leftchild(cond))) == C_LOGNOT) cond = leftchild(leftchild(leftchild(cond)));
int else_c = child(astp,3);
int const_cond = child(astp,4);
int then_else = ctuple(C_THEN_ELSE, then, else_c); // ***** I don't think the then_else is actually used now!
if (const_cond == -1) { // (constant conditions are for conditional compilation with #if and don't need all this logic)
// Unfortunately the test below doesn't work because the 'then' part contains C_NULL_STATEMENT
// and the else part contains C_ADD_SEMI - and both are probably wrapped in a C_SEQ ... so the
// test for an empty branch is going to be much more complex that just != -1.
#ifdef NEVER
// If this added back in, make sure to fix the if/then/else issue below...
if (then == -1 && else_c != -1) {
// swap the legs so 'then' is always valid and 'else' is optional part.
then = else_c; else_c = -1;
cond = ctuple(C_LOGNOT, cond);
leftchild(then_else) = then;
rightchild(then_else) = else_c;
}
#endif
C("if ("); out(cond); C(") ");
if (then == -1) {
C(";");
} else {
// If this statement is a IF_THEN_ELSE and the 'then' part is only an IF_THEN, then we need
// to put a '{}' bracket group around our 'if/then' part so that the nested statement
// doesn't suffer from a dangling else.
// Unfortunately there is an obscure and stupid case of "if (cond) ; else ...;" which
// the C_IF logic converts into "if (cond) ...;" that would not be caught by this test :-(
// Imp code that might generate this case could be "%if cond %start; %finishelse ..."
// We'll ignore this problem since the swap code is disabled above.
if ( else_c != -1 && AstOP(then) == C_IF && child(then,3) == -1 ) {
// ^ inner statement is a if/then with no 'else'
C("{");
out(then);
C("}");
} else {
out(then);
}
}
if (else_c != -1) {
C(" else ");
// An 'else' part that consists of only a if/then/else statement will end up being
// formatted as an 'else if' statement without an extra level of indentation.
out(else_c);
}
} else {
// #1 string rep #2 int val (32 bits) #3 unfolded expr
//int str, val, expr;
//detuple(const_cond, C_CONST_INT, &str, &val/*, &expr*/);
C("\n#if "); out(const_cond);
C("/* ");
// global_const_hack = 1;
out(cond);
// global_const_hack = 0;
C(" */");
C("\n");
if (then != -1) {
if (AstOP(then) == C_STATEMENT_BLOCK) then = leftchild(then);
out(then);
}
if (else_c != -1) { // We *might* be able to look at the else part and convert to #elif if it is a #if ..?
for (;;) {
if (AstOP(else_c) != C_IF) {
C("\n#else\n");
if (AstOP(else_c) == C_STATEMENT_BLOCK) else_c = leftchild(else_c);
out(else_c);
C("\n#endif\n");
break;
}
detuple(else_c, C_IF, &then, &cond, &else_c, &const_cond);
then_else = ctuple(C_THEN_ELSE, then, else_c);
C("\n#elif "); out(const_cond); C("/* "); out(cond); C(" */"); C("\n");
if (then != -1) {
if (AstOP(then) == C_STATEMENT_BLOCK) then = leftchild(then);
out(then);
}
if (else_c == -1) break;
}
} else {
C("\n#endif\n");
}
}
return;
}
case C_FOREVER: // #1 statement to be executed #2 cond #3 spare for possible use by 'else'? (TBD)
{
C("for (;;)"); // check block is C_STATEMENT_BLOCK
out(STATEMENT_BLOCK(child(astp,1)));
return;
}
case C_WHILE: // #1 statement to be executed #2 cond #3 spare for possible use by 'else'? (TBD)
{
int cond = child(astp,2);
if (AstOP(cond) == C_BRACKET) cond = leftchild(cond);
C("while ("); out(cond); C(") ");
out(STATEMENT_BLOCK(child(astp,1))); // check block is C_STATEMENT_BLOCK
return;
}
case C_UNTIL: // #1 statement to be executed #2 cond #3 spare for possible use by 'else'? (TBD)
{
int cond = child(astp,2);
if (AstOP(cond) == C_BRACKET) cond = leftchild(cond);
C("do ");
out(STATEMENT_BLOCK(child(astp,1))); // check block is C_STATEMENT_BLOCK
C(" while ("); out(ctuple(C_LOGNOT, cond)); C(");\n");
return;
}
case C_IMP_FOR:
{
// Another problem still to fix: %for I = 1,1,I %cycle ... we should save the value of the final limit at the start of the loop and use that in comparisons
// although the current case is the optimised case as long as the expression for the final value does not change anywhere in the loop.
// actually, same goes for the step as well (which is easy if it is constant)
// And one more... %CYCLE KK=KK,-1,1
// make that into: for (;kk >= 1; kk--) or maybe even something like while (kk--) ...
int body, name, assop, initial, step, final, constinit, conststep, constfinal;
detuple(astp, C_IMP_FOR, &body, &name, &assop, &initial, &step, &final, &constinit, &conststep, &constfinal);
if (constinit != -1 && conststep != -1 && constfinal != -1) {
int initval = rightchild(constinit);
int stepval = rightchild(conststep);
int finalval = rightchild(constfinal);
if (stepval > 0 && initval < finalval && (finalval-initval)%stepval == 0) {
C("for (");
leftchild(assop) = name;
rightchild(assop) = initial;
out(assop);
C("; ");
out(leftchild(assop));
C(" <= ");
out(final);
C("; ");
out(leftchild(assop));
if (stepval == 1) {
C("++)");
} else {
C(" += ");
out(step);
C(") ");
}
out(STATEMENT_BLOCK(body)); // check block is C_STATEMENT_BLOCK
return;
}
if (stepval < 0 && initval > finalval && (initval-finalval)%(-stepval) == 0) {
C("for (");
leftchild(assop) = name;
rightchild(assop) = initial;
out(assop);
C("; ");
out(leftchild(assop));
C(" >= ");
out(final);
C("; ");
out(leftchild(assop));
if (stepval == -1) {
C("--)");
} else {
C(" -= %d)", -stepval);
}
out(STATEMENT_BLOCK(body)); // check block is C_STATEMENT_BLOCK
return;
}
}
C("for (");
leftchild(assop) = name;
rightchild(assop) = initial;
// NOTE: a secondary issue here is that the loop incr/end should be
// be evaluated once at the entry to the loop, not each time round,
// in case they are changed in the loop. Also the for loop control
// variable itself should not be changed other than by us.
// Would it be wise to shadow and monitor it (if compiled with all checks)?
out(assop);
C("; ");
out(leftchild(assop));
if (conststep != -1) {
int stepval = rightchild(conststep);
if (stepval < 0) { // downwards cycle
C(" >= ");
} else { // upwards cycle
C(" <= ");
}
out(final);
} else { // don't know the step so don't know if it is up or down loop (unless we know start and final?)
if (constinit != -1 && constfinal != -1) {
int initval = rightchild(constinit);
int finalval = rightchild(constfinal);
// we have to assume the unknown step is in the right direction...
if (initval <= finalval) {
C(" <= %d", finalval);
} else {
C(" >= %d", finalval);
}
} else {
C(" != "); // for now. If start/inc/end and constants and loop terminates, Use <= or >= depending on sign of increment if known
out(ctuple(C_BINPLUS, final, step)); // problem was "J + -3" which was not yet handled by expression evaluation.
}
}
C("; ");
out(leftchild(assop));
if (conststep != -1) {
int stepval = rightchild(conststep);
if (stepval < 0) {
if (stepval == -1) {
C("--)");
} else {
C(" -= %d)", -stepval);
}
} else {
if (stepval == 1) {
C("++)");
} else {
C(" += %d)", stepval);
}
}
} else {
C(" += ");
out(step);
C(") ");
}
out(STATEMENT_BLOCK(body)); // check block is C_STATEMENT_BLOCK
return;
}
case C_STATEMENT_BLOCK:
{
int first, more;
detuple(astp, C_STATEMENT_BLOCK, &more); // should only hold a C_SEQ list.
C("{ ");
for (;;) {
detuple(more, C_SEQ, &first, &more);
out(first);
if (more == -1) break;
if (AstOP(more) != C_SEQ) {
//diagnose(more); -- this is still a problem but I'll work around it for now to see what happens...
//warn(" - AstOP(more) != C_SEQ at line %d, from line %d, possibly originating at line %d", __LINE__, line, sourceline(more));
out(more);
break;
}
}
C(" } ");
return;
}
case C_COMMENT:
{
int string = child(astp,1);
C(" // %s\n", pool_to_str(string));
return;
}
case C_MACHINE_CODE_INSTR:
{
char UCI[1024], *s;
strcpy(UCI, pool_to_str(child(astp,1)));
if (UCI[strlen(UCI)-1] == '\n') {
UCI[strlen(UCI)-1] = '\0';
}
if (UCI[strlen(UCI)-1] == ';') {
UCI[strlen(UCI)-1] = '\0';
}
s = UCI;
while (isalnum(*s) || *s == ' ' || *s == '\t') s += 1;
if (*s == '_') *s = ' ';
if (strchr(s, ';') != NULL || strchr(s, '\n') != NULL) {
warn("Possible multi-statement machine code: %s\n", UCI);
}
C("asm(\"%s\");\n", UCI);
return;
}
case C_ALPHANUMERIC_LABEL_COLON: // regular label.
{
out(child(astp,1)); C(": ");
return;
}
case C_NUMERIC_LABEL_COLON: // number. Output L__number:
{
C("L__");out(child(astp,1)); C(": ");
return;
}
case C_END_OF_PERM:
case C_END_OF_PRIM:
OUTFILE = stdout;
return;
case C_ON_EVENT_BLOCK: // event list bits, code block
{
// NOTE!!!! Cannot have %fault and %on %event in the same procedure!
int eventlist, block;
detuple(astp, C_ON_EVENT_BLOCK, &eventlist, &block);
C("if (_imp_on_event(");
while (eventlist != -1) {
int event;
detuple(eventlist, C_SEQ, &event, &eventlist);
if (AstOP(event) != C_CONST_INT) {
fprintf(stderr, "ON EVENT TYPE: %s\n", CAstOPName(AstOP(event))); diagnose(event);
assert(AstOP(event) == C_CONST_INT);
}
out(event); // May want to fold and output the constant.
if (eventlist != -1) C(",");
}
C(")) ");
out(block);
return;
}
case C_RESULT: // #1 expr #2 assop (contains result value in RHS)
{
int expr, assop, lhs, rhs;
detuple(astp, C_RESULT, &assop);
if (assop == -1) {
C("return;");
} else if (AstOP(assop) == C_ASSIGN_VALUE) {
detuple(assop, C_ASSIGN_VALUE, &lhs, &rhs);
C("return("); // redefined 'return(x)' macro inserts 'imp_leave()' for us.
out(rhs);
C(");\n");
} else if (AstOP(assop) == C_ASSIGN_ADDRESS) {
detuple(assop, C_ASSIGN_ADDRESS, &lhs, &rhs);
C("return("); // already applied to rhs via C_ADDRESS (I hope)
out(rhs); // awaiting type information support
C(");\n");
} else fault("Internal error");
return;
}
case C_STOP:
{
C("exit(0);");
return;
}
//case C_MONITORSTOP: // replaced by monitor and stop.
// {
// C("{ _imp_monitor(0); exit(1); }"); // do we need a ';' after the group?
// return;
// }
case C_MONITOR:
{
int which = child(astp,1);
C("_imp_monitor(");
out(which);
C(");"); // do we need a ';' after the group?
return;
}
case C_PRINTSTRING: // actually %printtext
{
int string;
char str[1024+10];
int value; // strp = stringpool index
string = child(astp,1);
if (AstOP(string) != C_STRING_LITERAL) {
fault("Internal error - unexpected %s at line %d", CAstOPName(AstOP(string)), __LINE__);
}
int strp = leftchild(string);
// should map this to a C_PROCEDURE_CALL once the type stuff has been sorted out.
C("printstring(");
C("%s", STRING_LITERAL_to_C_string(strp));
C(");");
return;
}
case C_ONE_FAULT:
warn("At the moment, C_ONE_FAULT should have been handled by a lower layer (in compile())");
return;
// # fault statements can only appear in the outer block of a program;
// # they cannot appear in external routines. This should be checked
// # by the compile() procedure.
// P<FAULT-S> =
// "fault" <FAULT-ACTION> <MORE-FAULTS> <S>;
// P<MORE-FAULTS> =
// ',' <FAULT-ACTION> <MORE-FAULTS>,
// ;
// P<FAULT-ACTION> =
// <FAULT-LIST> '-' '>' <LABEL>;
// I coded up the grammar as '<digit-seq>' for the fault numbers, but
// are they actual const expressions? Could a symbolic constinteger
// be used here. (digit-seq is a string literal)
// P<FAULT-LIST> =
// <DIGIT-SEQ> <MORE-NUMBERS>;
// P<MORE-NUMBERS> =
// ',' <DIGIT-SEQ> <MORE-NUMBERS>,
case C_FAULT_GROUP:
{ // C_FAULT_GROUP: fault_action, (more fault_actions)
int more_fault_actions; // C_FAULT_GROUP: fault_action, (more fault_actions)
int fault_action; // C_ONE_FAULT: label, fault-list
int fault_list; // C_SEQ: digit_seq, (more digit_seqs) // P<FAULT-LIST> = <DIGIT-SEQ> <MORE-NUMBERS>;
int fault_number; // digit seq (string literal)
int event_label; // <label target>
detuple(astp, C_FAULT_GROUP, &fault_action, &more_fault_actions);
detuple(fault_action, C_ONE_FAULT, &event_label, &fault_list);
//out(compile(rightchild(astp)));
// Either: a) Only one <FAULT-ACTION>:
// if (onevent(a,b)) goto LAB;
// Or: b) Multiple <FAULT-ACTION>s:
// if (onevent(a,b,c,d,e)) {
// if (event_event == a || event_event == b) goto LAB1;
// // or use _imp_caught_on_event() to test several at once by using a bitmask.
// if (event_event == c) goto LAB2;
// if (event_event == d || event_event == e) goto LAB3;
// }
// so... first check for simple version:
if (more_fault_actions == -1) {
// This is the default case of a single "%fault n,n,n -> label" statement...
C("if (_imp_on_event(");
for (;;) {
detuple(fault_list, C_SEQ, &fault_number, &fault_list);
out(fault_number);
if (fault_list != -1) C(","); else break;
}
C(")) goto ");
out(event_label); // C_SEQ will take care of printing each number
C(";");
return;
}
// slightly more complex case: onevent catches all events, then we dispatch to different labels...
// trap all interesting events first,
C("if (_imp_on_event(");
for (;;) {
detuple(fault_action, C_ONE_FAULT, &event_label, &fault_list);
// This is the default case of a single "%fault n,n,n -> label" statement...
for (;;) {
detuple(fault_list, C_SEQ, &fault_number, &fault_list);
out(fault_number); // list all event numbers to be caught
if (fault_list != -1) C(","); else break;
}
if (more_fault_actions == -1) break;
C(", "); // visual hint as to grouping
detuple(more_fault_actions, C_FAULT_GROUP, &fault_action, &more_fault_actions);
}
C(")) {\n");
// reset for another pass...
detuple(astp, C_FAULT_GROUP, &fault_action, &more_fault_actions);
detuple(fault_action, C_ONE_FAULT, &event_label, &fault_list);
// , then dispatch:
for (;;) {
detuple(fault_action, C_ONE_FAULT, &event_label, &fault_list);
C("if (_imp_caught_on_event(EVENT.EVENT, ");
for (;;) {
detuple(fault_list, C_SEQ, &fault_number, &fault_list);
out(fault_number);
if (fault_list != -1) C(","); else break;
}
C(")) goto ");
out(event_label);
C(";\n");
if (more_fault_actions == -1) break;
detuple(more_fault_actions, C_FAULT_GROUP, &fault_action, &more_fault_actions);
}
C("}\n");
return;
}
case C_DECLARE_SWITCH:
{
int name, boundspair, junk, index_table;
int upper, lower, cupper, clower;
detuple(astp, C_DECLARE_SWITCH, &name, &boundspair, &index_table /* list of used label indexes */);
C("static int "); out(name); C("_sw; ");
C("static void *"); out(name); out(boundspair); C(" = {\n");
detuple(boundspair, C_BOUNDSPAIR, &lower, &upper, &clower, &cupper, NULL);
int sw_low = switchmap[index_table+0];
int sw_high = switchmap[index_table+1];
int sw_default_used = switchmap[index_table+2];
int *sw_case_used = &switchmap[index_table+3-sw_low];
if (clower != -1 && cupper != -1) {
int idx, seq = 0;
for (idx = rightchild(clower); idx <= rightchild(cupper); idx++) {
if (sw_case_used[idx]) {
C("&&"); out(name);
if (idx < 0) {
C("_M%0d, ", -idx);
} else {
C("_%0d, ", idx);
}
} else {
C("&&"); out(name); C("_default, ");
}
seq++; if (seq == 10) {C("\n"); seq = 0;}
}
} else {
fault("%%switch bounds must be constant");
}
C("};\n");
return;
}
case C_GOTO:
{
int lab = child(astp,1);
C("goto "); out(lab); C(";\n");
return;
}
case C_BREAK:
{
C("break;"); // BEWARE: "break" in C also breaks out of case statements. Fortunately we don't use those.
return; // Although if at some time in the future we add a plain C (not GCC extended) version, ...?
}
case C_CONTINUE:
{
C("continue;");
return;
}
case C_CONTROL: // int
{
return;
}
case C_DIAGNOSE: // int
{
return;
}
case C_SIGNAL:
{
int eventlist = child(astp,1);
C("_imp_signal("); /* variable number of parameters. C macro handles that OK. */
for (;;) {
assert(AstOP(eventlist) == C_SEQ);
int event = child(eventlist,1);
out(event); // May want to fold and output the constant.
eventlist = child(eventlist,2);
if (eventlist != -1) /*C(",")*/; else break;
}
C(");");
return;
}
case C_OPTIONS:
{
return;
}
case C_INCLUDEFILE:
{
return;
}
case C_INCLUDEMODULE:
{
return;
}
case C_NULL_STATEMENT:
{
C(";");
return;
}
case C_END_OF_MCODE: // none
{
return;
}
case C_START_OF_MCODE: // none
{
return;
}
case C_TRUSTED_PROGRAM: // none
{
return;
}
case C_MAIN_EP: // name of procedure
{
return;
}
case C_68K_AT: // ignore for now
{
return;
}
case C_SPEC_ALIAS: // ignore for now
{
return;
}
case C_SPEC68K: // ignore for now
{
return;
}
case C_68K_ENTRY_ADDRESS: // ignore for now
{
return;
}
case C_SPEC: // ignore for now
{
return;
}
case C_SHORT_ROUTINE: // none
{
return;
}
case C_TYPE_RECORD_FIELD:
{
int name, offset, base_xtype, percent_name, next;
// #1 field name
// #2 field offset if known relative to start of current record, or -1 (for later)
// #3 type: field type could be a basic type, or a C_TYPE_RECORD_VARIANT list
// #4: %name?
// #5 next <C_TYPE_RECORD_FIELD> or -1
detuple(astp, C_TYPE_RECORD_FIELD, &name, &offset, &base_xtype, &percent_name, &next);
// out(xtype); C(" "); -- xtype is a COMREG so clearly more to be done... TO DO
out(base_xtype);
C(" ");
if (percent_name != -1) C("*");
if (AstOP(base_xtype) != C_TYPE_ARRAY_OF) out(name); // because of the ordering of elements of a declaration in C, arrays have already output the name.
C(";\n");
out(next);
return;
}
case C_DEBUG:
{
int target = child(astp,1);
C("\n// Debug: ");
debug_structures = 1;
out(target);
debug_structures = 0;
C("\n");
return;
}
case C_C:
{
C("%s", pool_to_str(child(astp,1)));
return;
}
case C_CALLBACK:
{
int tablename, entryname, index_table;
detuple(astp, C_CALLBACK, &tablename, &entryname, &index_table);
if (tablename == str_to_pool("Switches")) {
// C("/* Callback: table=%s", pool_to_str(tablename)); C(", entry=%s", pool_to_str(entryname)); C(", data=%d */", index_table);
// *IF* default has not been output and some switch labels have not been set,
// then output a 'sw_default:' label and have it output an error message, "missing switch label" or whatever.
int sw_low = switchmap[index_table+0]; // switchmap[index_table+0] = lower bound
int sw_high = switchmap[index_table+1]; // switchmap[index_table+1] = upper bound
int sw_default_used = switchmap[index_table+2]; // switchmap[index_table+2] = default used?
int *sw_case_used = &switchmap[index_table+3-sw_low]; // switchmap[index_table+3 ... ] = case label used (low:high inclusive) ?
int i;
if (!sw_default_used) { // if a default label has already been output, no point in doing the test below...
for (i = sw_low; i <= sw_high; i++) {
if (sw_case_used[i] == 0) {
char *entry = pool_to_str(entryname);
// *any* missing label means that a default still has to be output.
if (sw_low == 0) {
C("goto %s_skip; %s_default: fprintf(stderr, \"\\nSwitch label '%s(%%d):' not set in %%s\\n\", %s_sw, __PRETTY_FUNCTION__); fflush(stderr); abort(); %s_skip:;\n",
entry, entry, entry, entry, entry);
} else {
C("goto %s_skip; %s_default: fprintf(stderr, \"\\nSwitch label '%s(%%d):' not set in %%s\\n\", %s_sw + %d, __PRETTY_FUNCTION__); fflush(stderr); abort(); %s_skip:;\n",
entry, entry, entry, entry, sw_low, entry);
}
break;
}
}
}
}
return;
}
case C_DECLARE_REGISTER:
{
int name, number;
detuple(astp, C_DECLARE_REGISTER, &name, &number);
C("register int "); out(name); C("; // R"); out(number); C("\n");
break;
}
default:
fprintf(stderr, "MISSING C_* SWITCH LABEL %d in out()\n", astop);
fprintf(stderr, " case %s:\n", CAstOPName(astop));
assert(FALSE);exit(1);
return;
}
}