fortran.ssl

开放源码的编译器open watcom 1.6.0版的源代码

%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%	Copyright (C) 1987, by WATCOM Systems Inc. All rights	  %
%	reserved. No part of this software may be reproduced	  %
%	in any form or by any means - graphic, electronic or	  %
%	mechanical, including photocopying, recording, taping	  %
%	or information storage and retrieval systems - except	  %
%	with the written permission of WATCOM Systems Inc.	  %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Modified     By	       Reason
% --------     --	       ------
%
%

!define FORTRAN
!include "dbgintr.ssl"

input:
    ET_GETS		'=' = 0x20
    ET_MUL_GETS 	'*='
    ET_DIV_GETS 	'/='
    ET_MOD_GETS 	'%='
    ET_PLUS_GETS	'+='
    ET_MINUS_GETS	'-='
    ET_AND_GETS 	'&='
    ET_XOR_GETS 	'^='
    ET_OR_GETS		'|='
    ET_LSHFT_GETS	'<<='
    ET_RSHFT_GETS	'>>='
    ET_L_EQV		'.EQV.'     % L_ stands for 'logical'
    ET_L_NEQV		'.NEQV.'
    ET_L_OR		'.OR.'
    ET_L_AND		'.AND.'
    ET_L_NOT		'.NOT.'
    ET_OR		'|'
    ET_XOR		'^'
    ET_AND		'&'
    ET_STRING_CONCAT	'//'
    ET_LT		'.LT.'
    ET_GT		'.GT.'
    ET_EQ		'.EQ.'
    ET_NE		'.NE.'
    ET_LE		'.LE.'
    ET_GE		'.GE.'
    ET_LSHIFT		'<<'
    ET_RSHIFT		'>>'
    ET_PLUS		'+'
    ET_MINUS		'-'
    ET_MUL		'*'
    ET_DIV		'/'
    ET_MOD		'%'
    ET_EXP		'**'
    ET_PLUS_PLUS	'++'
    ET_MINUS_MINUS	'--'
    ET_NOT		'~'
    ET_COLON		':'
    ET_COMMA		','
    ET_LEFT_PAREN	'('
    ET_RIGHT_PAREN	')'
    ET_LEFT_BRACKET	'['
    ET_RIGHT_BRACKET	']'
    ET_DOT		'.'
    ET_MODULE_SPEC	'@'
    ET_VAR_EXIST	'?'
    ET_RIGHT_ARROW	'->'
    ET_STRING_QUOTE	'\''

    ET_C_NOT		'!'
    ET_C_EQ		'=='
    ET_C_NE		'!='
    ET_C_LT		'<'
    ET_C_LE		'<='
    ET_C_GT		'>'
    ET_C_GE		'>='
    ET_C_AND		'&&'
    ET_C_OR		'||'

	% keywords
    ET_INT		'INT'
    ET_REAL		'REAL'
    ET_DBLE		'DBLE'
    ET_CMPLX		'CMPLX'
    ET_DCMPLX		'DCMPLX';
    
type info_type: INFO_ARRAY INFO_FUNC INFO_STRING INFO_OTHER;

input :
	% character strings for various structure display operators
	% first character is priority
    TSTR_PAREN		'9(x)' = 0x1000
    TSTR_POINTER_IND	'1*x'
    TSTR_FIELD_SELECT	'2x.y'
    TSTR_POINTER_FIELD	'2x->y'
    TSTR_ARRAY		'2x(y)'
    TSTR_SELF		'0x'
    TSTR_NULL		'0NULL';


rules

    expr:
	MarkArrayOrder( true )
	SwitchOff( sw_case_sensitive )
	ScanCCharNum( false )
	SetEvalSubstring( false )
	MoveScanPtr( 0 )    % rescan current token
	PurgePgmStack
	@assignment
    ;
    

    parse_qualified_name >>bool:
	[GetName
	| false:
	    >>false
	| *:
	    >>true
	]
    ;

    parse_string:
	ScanString( true )  %
	ScanRestore	    % do these so that Scan() won't skip leading spaces
	MoveScanPtr( 1 )
	{
	    [
	      | ET_STRING_QUOTE:
		MoveScanPtr( 1 )
		[
		  | ET_STRING_QUOTE:
		    AddChar
		    MoveScanPtr( 1 )
		  | *:
		    PushString
		    ScanString( false )
		    >>
		]
	      | *:
		AddChar
		MoveScanPtr( 1 )
	    ]
	}
    ;


!include "dbgrules.ssl"

    nest_expr:
	@assignment
    ;


    nest_callexpr:
	ExprDepthAdj( 1 )
	@assignment
	ExprDepthAdj( -1 )
    ;


    assignment:
	@logical_equiv
	[
	  | ET_GETS:
	    @assignment
	    SwitchOn( sw_side_effect )
	    [SkipCount
	      | 0:
		DoAssign
	      | *:
	    ]
	  | ET_MUL_GETS:
	    @check_dup
	    SwitchOn( sw_side_effect )
	    [SkipCount
	      | 0:
		DoMul
		DoAssign
	      | *:
	    ]
	  | ET_DIV_GETS:
	    @check_dup
	    SwitchOn( sw_side_effect )
	    [SkipCount
	      | 0:
		DoDiv
		DoAssign
	      | *:
	    ]
	  | ET_MOD_GETS:
	    @check_dup
	    SwitchOn( sw_side_effect )
	    [SkipCount
	      | 0:
		DoMod
		DoAssign
	      | *:
	    ]
	  | ET_PLUS_GETS:
	    @check_dup
	    SwitchOn( sw_side_effect )
	    [SkipCount
	      | 0:
		@perform_add
		DoAssign
	      | *:
	    ]
	  | ET_MINUS_GETS:
	    @check_dup
	    SwitchOn( sw_side_effect )
	    [SkipCount
	      | 0:
		@perform_minus
		DoAssign
	      | *:
	    ]
	  | ET_RSHFT_GETS:
	    @check_dup
	    SwitchOn( sw_side_effect )
	    [SkipCount
	      | 0:
		@negate
		DoShift
		DoAssign
	      | *:
	    ]
	  | ET_LSHFT_GETS:
	    @check_dup
	    SwitchOn( sw_side_effect )
	    [SkipCount
	      | 0:
		DoShift
		DoAssign
	      | *:
	    ]
	  | ET_AND_GETS:
	    @check_dup
	    SwitchOn( sw_side_effect )
	    [SkipCount
	      | 0:
		DoAnd
		DoAssign
	      | *:
	    ]
	  | ET_XOR_GETS:
	    @check_dup
	    SwitchOn( sw_side_effect )
	    [SkipCount
	      | 0:
		DoXor
		DoAssign
	      | *:
	    ]
	  | ET_OR_GETS:
	    @check_dup
	    SwitchOn( sw_side_effect )
	    [SkipCount
	      | 0:
		DoOr
		DoAssign
	      | *:
	    ]
	  | *:
	]
    ;

    check_dup:
	[SkipCount
	  | 0:
	    PushDup
	  | *:
	]
	@assignment
    ;


    logical_equiv:
	@logical_or
	{
	    [
	      | ET_L_EQV:
		@logical_or
		[SkipCount
		  | 0:
		    DoTstTrue( 1 )	% assure both args are true or false
		    StackSwap( 1 )
		    DoTstTrue( 1 )
		    DoTstEQ( 1 )	% value is (x1.EQV.x2)
		  | *:
		]
	      | ET_L_NEQV:
		@logical_or
		[SkipCount
		  | 0:
		    DoTstTrue( 1 )	% assure both args are true or false
		    StackSwap( 1 )
		    DoTstTrue( 1 )
		    DoTstEQ( 1 )	% value is (x1.EQV.x2)
		    @perform_not	% value is now (x1.NEQV.x2)
		  | *:
		]
	      | *:
		>>
	    ]
	}
    ;


    logical_or:
	@logical_and
	{
	    [
	      | ET_L_OR,ET_C_OR:
		[SkipCount
		  | 0:
		    [DoTstTrue( 1 )
		      | false:
			PopEntry
		      | *:
			@skip_ors
			>
		    ]
		  | *:
		]
		@logical_and
		[SkipCount
		  | 0:
		    DoTstTrue( 1 )	% make result either true or false
		  | *:
		]
	      | *:
		>>
	    ]
	}
    ;


    skip_ors:
	SkipCountAdd( 1 )
	{
	    @logical_and
	    [
	      | ET_L_OR,ET_C_OR:
	      | *:
		>
	    ]
	}
	SkipCountAdd( -1 )
    ;


    logical_and:
	@logical_not
	{
	    [
	      | ET_L_AND,ET_C_AND:
		[SkipCount
		  | 0:
		    [DoTstTrue( 1 )
		      | false:
			@skip_ands
			>
		      | *:
			PopEntry
		    ]
		  | *:
		]
		@logical_not
		[SkipCount
		  | 0:
		    DoTstTrue( 1 )	% make result either true or false
		  | *:
		]
	      | *:
		>>
	    ]
	}
    ;


    skip_ands:
	SkipCountAdd( 1 )
	{
	    @logical_not
	    [
	      | ET_L_AND,ET_C_AND:
	      | *:
		>
	    ]
	}
	SkipCountAdd( -1 )
    ;



    logical_not:
	[
	  | ET_L_NOT,ET_C_NOT:
	    @bit_inclusive_or
	    [SkipCount
	      | 0:
		DoTstTrue( 1 )	    % make result either true or false
		@perform_not
	      | *:
	    ]
	  | *:
	    @bit_inclusive_or
	]
    ;


    perform_not:	% do .NOT. on the top stack element
	PushInt( 1 )
	DoXor
    ;



    bit_inclusive_or:
	@bit_exclusive_or
	{
	    [
	      | ET_OR:
		@bit_exclusive_or
		[SkipCount
		  | 0:
		    DoOr
		  | *:
		]
	      | *:
		>>
	    ]
	}
    ;


    bit_exclusive_or:
	@bit_and
	{
	    [
	      | ET_XOR:
		@bit_and
		[SkipCount
		  | 0:
		    DoXor
		  | *:
		]
	      | *:
		>>
	    ]
	}
    ;


    bit_and:
	@relational_expr
	{
	    [
	      | ET_AND:
		@relational_expr
		[SkipCount
		  | 0:
		    DoAnd
		  | *:
		]
	      | *:
		>>
	    ]
	}
    ;



    relational_expr:
	@arith_shift
	{
	    [
	      | ET_EQ,ET_C_EQ:
		@arith_shift
		[SkipCount
		  | 0:
		    DoTstEQ( 1 )
		  | *:
		]
	      | ET_NE,ET_C_NE:
		@arith_shift
		[SkipCount
		  | 0:
		    DoTstEQ(1)
		    @perform_not
		  | *:
		]
	      | ET_LT,ET_C_LT:
		@arith_shift
		[SkipCount
		  | 0:
		    DoTstLT( 1 )
		  | *:
		]
	      | ET_GE,ET_C_GE:
		@arith_shift
		[SkipCount
		  | 0:
		    DoTstLT( 1 )
		    @perform_not
		  | *:
		]
	      | ET_GT,ET_C_GT:
		@arith_shift
		[SkipCount
		  | 0:
		    StackSwap( 1 )
		    DoTstLT( 1 )
		  | *:
		]
	      | ET_LE,ET_C_LE:
		@arith_shift
		[SkipCount
		  | 0:
		    StackSwap( 1 )
		    DoTstLT( 1 )
		    @perform_not
		  | *:
		]
	      | *:
		>>
	    ]
	}
    ;



    arith_shift:
	@additive
	{
	    [
	      | ET_LSHIFT:
		@additive
		[SkipCount
		  | 0:
		    DoShift
		  | *:
		]
	      | ET_RSHIFT:
		@additive
		[SkipCount
		  | 0:
		    @negate
		    DoShift
		  | *:
		]
	      | ET_STRING_CONCAT:
		@additive
		[SkipCount
		  | 0:
		    DoStringConcat
		  | *:
		]