oberonjs/src/eberon/EberonContextExpression.ob

MODULE EberonContextExpression;
IMPORT
    Cast,
    Context, ContextExpression, ContextHierarchy, 
    EberonContextDesignator, EberonContextProcedure, 
    EberonMap, EberonOperator, EberonString, EberonTypePromotion, 
    Errors, Expression, LanguageContext,
    JS,
    Object, Record, Types;
TYPE
    ExpressionNode* = RECORD(ContextExpression.ExpressionHandler)
        condition, first, second: Expression.PType;
    END;

    RelationExpression* = RECORD(ContextExpression.ExpressionNode)
        PROCEDURE RelationExpression(parent: ContextExpression.PExpressionHandler);

        PROCEDURE handleTypePromotion(promotion: EberonTypePromotion.PCombined);

        currentTypePromotion: EberonTypePromotion.PCombined;
    END;

    SimpleExpression* = RECORD(ContextExpression.SimpleExpression)
        PROCEDURE handleLogicalOr();

        typePromotion: EberonTypePromotion.PCombined;
        currentPromotion: EberonTypePromotion.PMaybe;
        orHandled: BOOLEAN;
    END;

    Term* = RECORD(ContextExpression.Term)
        PROCEDURE handleLogicalAnd();

        typePromotion: EberonTypePromotion.PCombined;
        currentPromotion: EberonTypePromotion.PMaybe;
        andHandled: BOOLEAN;
    END;

    Factor* = RECORD(ContextExpression.Factor)
    END;

    AddOperator* = RECORD(ContextExpression.AddOperator)
    END;

    MulOperator* = RECORD(ContextExpression.MulOperator)
    END;

    RelationOps = RECORD(ContextExpression.RelationOps)
    END;

    BeginTypePromotionAndMsg = RECORD(ContextHierarchy.Message)
        result: EberonTypePromotion.PCombined;
    END;

    CurrentTypePromotionMsg = RECORD(ContextHierarchy.Message)
        result: EberonTypePromotion.PMaybe;
    END;

VAR
    relationOps: POINTER TO RelationOps;

PROCEDURE hierarchyDepth(t: Record.Type): INTEGER;
BEGIN
    result <- 0;
    base <- t.base;
    WHILE base # NIL DO
        INC(result);
        base := base.base;
    END;
    RETURN result;
END;

PROCEDURE getNthBase(t: Record.PType; n: INTEGER): Record.PType;
BEGIN
    result <- t;
    i <- n;
    WHILE i # 0 DO
        result := result.base;
        DEC(i);
    END;
    RETURN result;
END;

PROCEDURE findCommonBase(t1, t2: Record.PType): Record.PType;
VAR
    result: Record.PType;
BEGIN
    depth1 <- hierarchyDepth(t1^);
    depth2 <- hierarchyDepth(t2^);
    commonBase1 <- t1;
    commonBase2 <- t2;
    IF depth1 > depth2 THEN
        commonBase1 := getNthBase(commonBase1, depth1 - depth2);
    ELSE
        commonBase2 := getNthBase(commonBase2, depth2 - depth1);
    END;

    WHILE commonBase1 # commonBase2 DO
        commonBase1 := commonBase1.base;
        commonBase2 := commonBase2.base;
    END;

    RETURN commonBase1;
END;

PROCEDURE ExpressionNode.handleExpression(e: Expression.PType);
BEGIN
    IF SELF.condition = NIL THEN
        SELF.condition := e;
    ELSIF SELF.first = NIL THEN
        SELF.first := e;
    ELSE
        SELF.second := e;
    END;
END;

PROCEDURE ExpressionNode.endParse(): BOOLEAN;
VAR
    resultType: Types.PType;
    op: LanguageContext.PCastOp;
BEGIN
    result <- SELF.first;
    IF result = NIL THEN
        result := SELF.condition;
    ELSE
        firstType <- SELF.first.type();
        secondType <- SELF.second.type();
        IF (firstType IS Record.PType) & (secondType IS Record.PType) THEN
            resultType := findCommonBase(firstType, secondType);
        ELSIF (firstType IS Record.PPointer) & (secondType IS Record.PPointer) THEN
            resultType := findCommonBase(Record.pointerBase(firstType^), Record.pointerBase(secondType^));
        END;

        IF resultType = NIL THEN 
            IF SELF.root().language().types.implicitCast(firstType, secondType, FALSE, op) # Cast.errNo THEN
                Errors.raise("incompatible types in ternary operator: '" 
                             + firstType.description() + "' and '" + secondType.description() + "'");
            END;
            resultType := firstType;
        END;

        result := Expression.makeSimple(SELF.condition.code() + " ? " 
                                        + SELF.first.code() + " : "
                                        + SELF.second.code(),
                                        resultType);
    END;
    SELF.parent()(ContextExpression.PExpressionHandler).handleExpression(result);
    RETURN TRUE;
END;

PROCEDURE RelationExpression.RelationExpression(parent: ContextExpression.PExpressionHandler)
    | SUPER(parent, relationOps);
END;

PROCEDURE RelationExpression.handleMessage(VAR msg: ContextHierarchy.Message): Object.PType;
VAR
    result: Object.PType;
BEGIN
    IF msg IS EberonContextDesignator.TransferPromotedTypesMsg THEN
    ELSE
        result := SUPER(msg);
    END;
    RETURN result;
END;

PROCEDURE RelationExpression.handleTypePromotion(promotion: EberonTypePromotion.PCombined);
BEGIN
    SELF.currentTypePromotion := promotion;
END;

PROCEDURE RelationExpression.handleLiteral(s: STRING);
BEGIN
    IF SELF.currentTypePromotion # NIL THEN
        SELF.currentTypePromotion.clear();
    END;
    SUPER(s);
END;

PROCEDURE RelationOps.in(left, right: Types.PType; cx: ContextHierarchy.Node): ContextExpression.BinaryOperatorCx;
VAR
    result: ContextExpression.BinaryOperatorCx;
BEGIN
    IF right IS EberonMap.PType THEN
        EberonContextDesignator.checkMapKeyType(left);
        result := EberonOperator.inMap;            
    ELSE
        result := SUPER(left, right, cx);
    END;
    RETURN result;
END;

PROCEDURE RelationExpression.endParse(): BOOLEAN;
BEGIN
    IF SELF.currentTypePromotion # NIL THEN
        void <- SELF.parent().handleMessage(
            NEW EberonContextDesignator.TransferPromotedTypesMsg(SELF.currentTypePromotion)^);
    END;
    RETURN SUPER();
END;

PROCEDURE SimpleExpression.handleLogicalOr();
BEGIN
    IF SELF.typePromotion # NIL THEN
        SELF.currentPromotion := SELF.typePromotion.next();
    ELSE
        SELF.orHandled := TRUE;
    END;
END;

PROCEDURE setSimpleExpressionTypePromotion(VAR e: SimpleExpression): EberonTypePromotion.PMaybe;
BEGIN
    IF e.currentPromotion = NIL THEN
        msg <- EberonContextProcedure.BeginTypePromotionOrMsg();
        void <- e.parent().handleMessage(msg);
        e.typePromotion := msg.result;
        IF e.typePromotion # NIL THEN
            IF e.orHandled THEN
                unused <- e.typePromotion.next();
            END;
            e.currentPromotion := e.typePromotion.next();
        END;
    END;
    RETURN e.currentPromotion;
END;

PROCEDURE SimpleExpression.handleMessage(VAR msg: ContextHierarchy.Message): Object.PType;
VAR
    result: Object.PType;
BEGIN
    IF msg IS BeginTypePromotionAndMsg THEN
        p <- setSimpleExpressionTypePromotion(SELF);
        IF p # NIL THEN
            msg.result := p.makeAnd();
        END;
    ELSE
        result := SUPER(msg);
    END;
    RETURN result;
END;

PROCEDURE SimpleExpression.endParse(): BOOLEAN;
BEGIN
    IF SELF.typePromotion # NIL THEN
        SELF.parent()^(RelationExpression).handleTypePromotion(SELF.typePromotion);
    END;
    RETURN SUPER();
END;

PROCEDURE setTermTypePromotion(VAR term: Term): EberonTypePromotion.PMaybe;
BEGIN
    IF term.currentPromotion = NIL THEN
        msg <- BeginTypePromotionAndMsg();
        void <- term.parent().handleMessage(msg);
        term.typePromotion := msg.result;
        IF term.typePromotion # NIL THEN
            IF term.andHandled THEN
                unused <- term.typePromotion.next();
            END;
            term.currentPromotion := term.typePromotion.next();
        END;
    END;
    RETURN term.currentPromotion;
END;

PROCEDURE Term.handleMessage(VAR msg: ContextHierarchy.Message): Object.PType;
VAR
    result: Object.PType;
BEGIN
    IF msg IS EberonContextDesignator.PromoteTypeMsg THEN
        promoted <- msg.info;
        p <- setTermTypePromotion(SELF);
        IF p # NIL THEN
            p.promote(promoted, msg.type);
        END;
    ELSIF msg IS EberonContextProcedure.BeginTypePromotionOrMsg THEN
        p <- setTermTypePromotion(SELF);
        IF p # NIL THEN
            msg.result := p.makeOr();
        END;
    ELSIF msg IS CurrentTypePromotionMsg THEN
        msg.result := setTermTypePromotion(SELF);
    ELSE
        result := SUPER(msg);
    END;
    RETURN result;
END;

PROCEDURE Term.handleLogicalAnd();
BEGIN
    IF SELF.typePromotion # NIL THEN
        SELF.currentPromotion := SELF.typePromotion.next();
    ELSE
        SELF.andHandled := TRUE;
    END;
END;

PROCEDURE Factor.handleLogicalNot();
BEGIN
    SUPER();

    msg <- CurrentTypePromotionMsg();
    void <- SELF.handleMessage(msg);
    p <- msg.result;
    IF p # NIL THEN
        p.invert();
    END;
END;

PROCEDURE AddOperator.doMatchPlusOperator(type: Types.PType): ContextExpression.BinaryOperator;
VAR
    result: ContextExpression.BinaryOperator;
BEGIN
    IF (type = EberonString.string) OR (type IS Types.PString) THEN
        result := EberonOperator.addStr;
    ELSE
        result := SUPER(type);
    END;
    RETURN result;
END;

PROCEDURE AddOperator.doExpectPlusOperator(): STRING;
    RETURN "numeric type or SET or STRING";
END;

PROCEDURE AddOperator.endParse(): BOOLEAN;
BEGIN
    SELF.parent()^(SimpleExpression).handleLogicalOr();
    RETURN TRUE;
END;

PROCEDURE MulOperator.endParse(): BOOLEAN;
BEGIN
    SELF.parent()^(Term).handleLogicalAnd();
    RETURN TRUE;
END;

PROCEDURE RelationOps.eq(type: Types.PType): ContextExpression.BinaryOperatorCx;
VAR
    result: ContextExpression.BinaryOperatorCx;
BEGIN
    IF type = EberonString.string THEN
        result := EberonOperator.equalStr;
    ELSE
        result := SUPER(type);
    END;
    RETURN result;
END;

PROCEDURE RelationOps.notEq(type: Types.PType): ContextExpression.BinaryOperatorCx;
VAR
    result: ContextExpression.BinaryOperatorCx;
BEGIN
    IF type = EberonString.string THEN
        result := EberonOperator.notEqualStr;
    ELSE
        result := SUPER(type);
    END;
    RETURN result;
END;

PROCEDURE RelationOps.less(type: Types.PType): ContextExpression.BinaryOperatorCx;
VAR
    result: ContextExpression.BinaryOperatorCx;
BEGIN
    IF type = EberonString.string THEN
        result := EberonOperator.lessStr;
    ELSE
        result := SUPER(type);
    END;
    RETURN result;
END;

PROCEDURE RelationOps.greater(type: Types.PType): ContextExpression.BinaryOperatorCx;
VAR
    result: ContextExpression.BinaryOperatorCx;
BEGIN
    IF type = EberonString.string THEN
        result := EberonOperator.greaterStr;
    ELSE
        result := SUPER(type);
    END;
    RETURN result;
END;

PROCEDURE RelationOps.lessEq(type: Types.PType): ContextExpression.BinaryOperatorCx;
VAR
    result: ContextExpression.BinaryOperatorCx;
BEGIN
    IF type = EberonString.string THEN
        result := EberonOperator.lessEqualStr;
    ELSE
        result := SUPER(type);
    END;
    RETURN result;
END;

PROCEDURE RelationOps.greaterEq(type: Types.PType): ContextExpression.BinaryOperatorCx;
VAR
    result: ContextExpression.BinaryOperatorCx;
BEGIN
    IF type = EberonString.string THEN
        result := EberonOperator.greaterEqualStr;
    ELSE
        result := SUPER(type);
    END;
    RETURN result;
END;

PROCEDURE RelationOps.is(cx: ContextHierarchy.Node): ContextExpression.BinaryOperatorCx;
VAR
    impl: ContextExpression.BinaryOperatorCx;
    r: ContextExpression.BinaryOperatorCx;

    PROCEDURE is(left, right: Expression.PType; lcx: LanguageContext.PType): Expression.PType;
    BEGIN
        d <- left.designator();
        IF d # NIL THEN
            v <- d.info();
            IF v IS EberonTypePromotion.PVariable THEN
                msg <- EberonContextDesignator.PromoteTypeMsg(
                            v, 
                            ContextExpression.unwrapType(right.designator().info()));
                void <- cx.handleMessage(msg);
            END;
        END;
        RETURN impl(left, right, lcx);
    END;
BEGIN
    impl := SUPER(cx);
    JS.do("r = is"); (*allow closure*)
    RETURN r;
END;

PROCEDURE RelationOps.coalesceType(leftType, rightType: Types.PType): Types.PType;
VAR
    result: Types.PType;
BEGIN
    IF     (((leftType = EberonString.string) & (rightType IS Types.PString))
        OR ((rightType = EberonString.string) & (leftType IS Types.PString))) THEN
        result := EberonString.string;
    ELSE
        result := SUPER(leftType, rightType);
    END;
    RETURN result;
END;

BEGIN
    NEW(relationOps);
END EberonContextExpression.