oberonjs/src/ob/ContextType.ob

MODULE ContextType;
IMPORT
    Chars, CodeGenerator, ConstValue, Context, ContextExpression, ContextHierarchy, 
    Errors, Expression, ExpressionTree, Object, R := Record, 
    Scope, ScopeBase, String, Symbols, TypeId, Types;
TYPE
    HandleSymbolAsType* = RECORD(ContextHierarchy.Node)
        PROCEDURE handleQIdent*(q: ContextHierarchy.QIdent);
        PROCEDURE setType*(type: Types.PStorageType);
    END;
    PHandleSymbolAsType = POINTER TO HandleSymbolAsType;

    DeclarationHandle* = RECORD(HandleSymbolAsType)
        PROCEDURE typeName*(): STRING;
        PROCEDURE isAnonymousDeclaration*(): BOOLEAN;
    END;
    PDeclarationHandle* = POINTER TO DeclarationHandle;

    FormalType* = RECORD(HandleSymbolAsType)
        dimensionCount: INTEGER;
    END;

    Array* = RECORD(DeclarationHandle)
        PROCEDURE doMakeInit*(type: Types.PStorageType; dimensions: STRING; length: INTEGER): STRING;
        PROCEDURE doMakeType*(elementsType: Types.PStorageType; init: STRING; length: INTEGER): Types.PStorageType;

        dimensions: POINTER TO ArrayDimensions;
    END;

    ArrayDimensions* = RECORD(ContextExpression.ExpressionHandler) 
        PROCEDURE doAddDimension*(size: INTEGER);

        dimensions: ARRAY * OF INTEGER;
    END;

    HavingFieldsDeclaration* = RECORD(DeclarationHandle)
        PROCEDURE exportField*(name: STRING);
    END;

    DeclarationAndIdentHandle* = RECORD(HavingFieldsDeclaration)
        PROCEDURE handleIdentdef*(id: Context.PIdentdefInfo);
    END;
    PDeclarationAndIdentHandle* = POINTER TO DeclarationAndIdentHandle;

    Declaration* = RECORD(DeclarationAndIdentHandle)
        id-: Context.PIdentdefInfo;
        symbol: Symbols.PSymbol;
    END;
    PDeclaration* = POINTER TO Declaration;

    RecordTypeFactory = PROCEDURE(name, cons: STRING; scope: ScopeBase.PType): R.PType; 

    Record* = RECORD(ContextHierarchy.Node)
        PROCEDURE Record*(parent: PDeclaration; factory: RecordTypeFactory);

        PROCEDURE addField(field: Context.PIdentdefInfo; type: Types.PStorageType);
        PROCEDURE setBaseType(type: Types.PType);
        PROCEDURE generateInheritance*(): STRING;
        PROCEDURE qualifiedBaseConstructor*(): STRING;

        PROCEDURE doMakeField*(field: Context.PIdentdefInfo; type: Types.PStorageType): Types.PField;
        PROCEDURE doGenerateConstructor(): STRING;
        PROCEDURE doGenerateBaseConstructorCallCode*(): STRING;

        declaration-: PDeclaration;
        cons: STRING;
        type-: R.PType;
    END;
    PRecord = POINTER TO Record;

    RecordBase* = RECORD(ContextHierarchy.Node)
        PROCEDURE handleQIdent(q: ContextHierarchy.QIdent);
    END;

    FieldList* = RECORD(Declaration)
        idents: ARRAY * OF Context.PIdentdefInfo;
        type: Types.PStorageType;
    END;

    Pointer* = RECORD(HavingFieldsDeclaration)
    END;

    Section* = RECORD(ContextHierarchy.Node)
    END;

    ResolveClosure = RECORD(Object.Type)
        PROCEDURE ResolveClosure(root: ContextHierarchy.PRoot; id: STRING);

        root: ContextHierarchy.PRoot;
        id: STRING;
    END;
    PResolveClosure = POINTER TO ResolveClosure;

    ForwardTypeMsg* = RECORD(ContextHierarchy.Message)
        PROCEDURE ForwardTypeMsg(id: STRING);

        id-: STRING;
    END;

    ScopeInfo* = RECORD
        PROCEDURE ScopeInfo(id: STRING; depth: INTEGER);

        id: STRING;
        depth: INTEGER;
    END;
    PScopeInfo = POINTER TO ScopeInfo;

    ScopeInfoGenerator* = RECORD
        PROCEDURE ScopeInfoGenerator*(name: STRING; code: CodeGenerator.PIGenerator; parent: ContextHierarchy.PNode);

        name: STRING;
        code: CodeGenerator.PIGenerator;
        parent: ContextHierarchy.PNode;
        codeBegin: CodeGenerator.PInsertion;
        info: PScopeInfo;
    END;
    PScopeInfoGenerator* = POINTER TO ScopeInfoGenerator;

    DescribeScopeMsg* = RECORD(ContextHierarchy.Message)
        result: PScopeInfo;
    END;

PROCEDURE HandleSymbolAsType.handleQIdent(q: ContextHierarchy.QIdent);
BEGIN
    s <- ContextHierarchy.getQIdSymbolAndScope(SELF.root()^, q);
    SELF.setType(ExpressionTree.unwrapType(s.symbol().info()));
END;

PROCEDURE FormalType.setType(type: Types.PStorageType);
BEGIN
    result <- type;
    types <- SELF.root().language().types;
    FOR i <- 0 TO SELF.dimensionCount - 1 DO
        result := types.makeOpenArray(result);
    END;
    SELF.parent()(PHandleSymbolAsType).setType(result);
END;

PROCEDURE FormalType.handleLiteral(s: STRING);
BEGIN
    IF s = "ARRAY" THEN
        INC(SELF.dimensionCount);
    END;
END;

PROCEDURE Array.typeName(): STRING;
    RETURN "";
END;

PROCEDURE Array.setType(elementsType: Types.PStorageType);
VAR
    dimensions: STRING;
    arrayInit: STRING;
BEGIN
    type <- elementsType;
    FOR i <- LEN(SELF.dimensions.dimensions) - 1 TO 0 BY -1 DO
        IF LEN(dimensions) # 0 THEN
            dimensions := ", " + dimensions;
        END;
        length <- SELF.dimensions.dimensions[i];
        dimensions := String.fromInt(length) + dimensions;
        IF i = 0 THEN
            arrayInit := SELF.doMakeInit(elementsType, dimensions, length);
        END;
        type := SELF.doMakeType(type, arrayInit, length);
    END;

    SELF.parent()(PHandleSymbolAsType).setType(type);
END;

PROCEDURE Array.isAnonymousDeclaration(): BOOLEAN;
    RETURN TRUE;
END;

PROCEDURE Array.doMakeInit(type: Types.PStorageType; dimensions: STRING; length: INTEGER): STRING;
VAR
    result: STRING;
    initializer: STRING;
BEGIN
    rtl <- SELF.root().language().rtl;
    IF type = Types.basic.ch THEN
        result := rtl.makeCharArray(dimensions);
    ELSE
        IF (type IS Types.PArray) OR (type IS Types.PRecord) THEN
            initializer := "function(){return " + type.initializer(SELF) + ";}";
        ELSE
            initializer := type.initializer(SELF);
        END;
        result := rtl.makeArray(dimensions + ", " + initializer);
    END;
    RETURN result;
END;

PROCEDURE Array.doMakeType(elementsType: Types.PStorageType; init: STRING; length: INTEGER): Types.PStorageType;
    RETURN SELF.root().language().types.makeStaticArray(elementsType, init, length);
END;

PROCEDURE ArrayDimensions.handleExpression(e: Expression.PType);
BEGIN
    type <- e.type();
    IF type # Types.basic.integer THEN
        Errors.raise("'INTEGER' constant expression expected, got '" + type.description() + "'");
    END;
    value <- e.constValue();
    IF value = NIL THEN
        Errors.raise("constant expression expected as ARRAY size");
    END;
    dimension <- value(ConstValue.PInt).value;
    IF dimension <= 0 THEN
        Errors.raise("array size must be greater than 0, got " + String.fromInt(dimension));
    END;
    SELF.doAddDimension(dimension);
END;

PROCEDURE ArrayDimensions.doAddDimension(size: INTEGER);
BEGIN
    SELF.dimensions.add(size);
END;

PROCEDURE ArrayDimensions.codeGenerator(): CodeGenerator.PIGenerator;
    RETURN CodeGenerator.nullGenerator;
END;

PROCEDURE ArrayDimensions.endParse(): BOOLEAN;
BEGIN
    SELF.parent()^(Array).dimensions := SELF(POINTER);
    RETURN TRUE;
END;

PROCEDURE isTypeRecursive*(type, base: Types.PType): BOOLEAN;
BEGIN
    result <- FALSE;
    IF type = base THEN
        result := TRUE;
    ELSIF type IS R.PType THEN
        IF isTypeRecursive(type.base, base) THEN
            result := TRUE;
        ELSE
            FOR field IN type.fields DO
                IF ~result & isTypeRecursive(field.type(), base) THEN
                    result := TRUE;
                END;
            END;
        END;
    ELSIF type IS Types.PArray THEN
        result := isTypeRecursive(type.elementsType, base);
    END;
    RETURN result;
END;

PROCEDURE stripTypeId(closure: Object.PType);
BEGIN
    typeId <- closure(TypeId.PType);
    R.stripTypeId(typeId^);
END;

PROCEDURE checkIfFieldCanBeExported*(name: STRING; idents: ARRAY OF Context.PIdentdefInfo; hint: STRING);
BEGIN
    FOR id IN idents DO
        IF ~id.exported() THEN
            Errors.raise(
                "field '" + name + "' can be exported only if " + hint + " '" +
                id.id() + "' itself is exported too");
        END;
    END;
END;

PROCEDURE Declaration.handleIdentdef(id: Context.PIdentdefInfo);
BEGIN
    typeId <- NEW TypeId.Lazy();
    symbol <- NEW Symbols.Symbol(id.id(), typeId);
    scope <- SELF.root().currentScope();
    scope.addSymbol(symbol, id.exported());
    IF ~id.exported() THEN
        scope.addFinalizer(stripTypeId, typeId);
    END;
    SELF.id := id;
    SELF.symbol := symbol;
END;

PROCEDURE Declaration.setType(type: Types.PStorageType);
BEGIN
    TypeId.define(SELF.symbol.info()^(TypeId.Lazy), type);
    Scope.resolve(SELF.root().currentScope()^, SELF.symbol);
END;

PROCEDURE Declaration.isAnonymousDeclaration(): BOOLEAN;
    RETURN FALSE;
END;

PROCEDURE Declaration.exportField(name: STRING);
VAR
    idents: ARRAY 1 OF Context.PIdentdefInfo;
BEGIN
    idents[0] := SELF.id;
    checkIfFieldCanBeExported(name, idents, "record");
END;

PROCEDURE Declaration.typeName(): STRING;
    RETURN SELF.id.id();
END;

PROCEDURE Declaration.genTypeName(): STRING;
    RETURN SELF.typeName();
END;

PROCEDURE Record.Record(parent: PDeclaration; factory: RecordTypeFactory)
    | SUPER(parent),
      declaration(parent);
VAR
    name: STRING;
BEGIN
    SELF.cons := parent.genTypeName();
    IF ~parent.isAnonymousDeclaration() THEN
        name := SELF.cons;
    END;
    SELF.type := factory(name, SELF.cons, parent.root().currentScope());
    parent.setType(SELF.type);
END;

PROCEDURE Record.addField(field: Context.PIdentdefInfo; type: Types.PStorageType);
BEGIN
    IF SELF.root().language().types.isRecursive(type, SELF.type) THEN
        Errors.raise("recursive field definition: '" + field.id() + "'");
    END;
    SELF.type.addField(SELF.doMakeField(field, type));
    IF field.exported() THEN
        SELF.declaration.exportField(field.id());
    END;
END;

PROCEDURE Record.setBaseType(type: Types.PType);
BEGIN
    IF ~(type IS R.PType) THEN
        Errors.raise(
            "RECORD type is expected as a base type, got '"
            + type.description()
            + "'");
    ELSE
        IF type = SELF.type THEN
            Errors.raise("recursive inheritance: '"
                         + SELF.type.description() + "'");
        END;

        SELF.type.setBase(type);
    END;
END;

PROCEDURE Record.doMakeField(field: Context.PIdentdefInfo; type: Types.PStorageType): Types.PField;
BEGIN
    RETURN NEW R.Field(field, type);
END;

PROCEDURE generateFieldsInitializationCode(r: Record): STRING;
VAR
    result: STRING;
BEGIN
    FOR f, t IN r.type.fields DO
        result := result + "this." + R.mangleField(f) + " = " + t.type().initializer(r) + ";" + Chars.ln;
    END;
    RETURN result;
END;

PROCEDURE Record.doGenerateConstructor(): STRING;
BEGIN
    gen <- NEW CodeGenerator.Generator();
    gen.write("function " + SELF.cons + "()");
    gen.openScope();
    gen.write(SELF.doGenerateBaseConstructorCallCode() 
            + generateFieldsInitializationCode(SELF));
    gen.closeScope("");
    RETURN gen.result();
END;

PROCEDURE Record.generateInheritance(): STRING;
VAR
    result: STRING;
BEGIN
    scopeMsg <- DescribeScopeMsg();
    void <- SELF.parent().handleMessage(scopeMsg);
    scope <- scopeMsg.result.id;

    base <- SELF.type.base;
    IF base = NIL THEN
        result := SELF.cons + ".prototype.$scope = " + scope + ";" + Chars.ln;
    ELSE
        qualifiedBase <- SELF.qualifyScope(base.scope) + base.name; 
        result := SELF.root().language().rtl.extend(SELF.cons, qualifiedBase, scope) + ";" + Chars.ln;
    END;
    RETURN result;
END;

PROCEDURE Record.doGenerateBaseConstructorCallCode(): STRING;
BEGIN
    result <- SELF.qualifiedBaseConstructor();
    IF LEN(result) # 0 THEN
        result := result + ".call(this);" + Chars.ln;
    END;
    RETURN result;
END;

PROCEDURE Record.qualifiedBaseConstructor(): STRING;
VAR
    result: STRING;
BEGIN
    baseType <- SELF.type.base;
    IF baseType # NIL THEN
        result := SELF.qualifyScope(baseType.scope) + baseType.name;
    END;
    RETURN result;
END;

PROCEDURE Record.endParse(): BOOLEAN;
VAR
    scopeMsg: DescribeScopeMsg;
BEGIN
    SELF.codeGenerator().write(
          SELF.doGenerateConstructor()
        + SELF.generateInheritance()
        );
    RETURN TRUE;
END;

PROCEDURE RecordBase.handleQIdent(q: ContextHierarchy.QIdent);
BEGIN
    s <- ContextHierarchy.getQIdSymbolAndScope(SELF.root()^, q);
    base <- ExpressionTree.unwrapType(s.symbol().info());
    SELF.parent()^(Record).setBaseType(base);
END;

PROCEDURE FieldList.isAnonymousDeclaration(): BOOLEAN;
    RETURN TRUE;
END;

PROCEDURE FieldList.exportField(name: STRING);
BEGIN
    checkIfFieldCanBeExported(name, SELF.idents, "field");
END;

PROCEDURE FieldList.setType(type: Types.PStorageType);
BEGIN
    SELF.type := type;    
END;

PROCEDURE FieldList.handleIdentdef(id: Context.PIdentdefInfo);
BEGIN
    SELF.idents.add(id);
END;

PROCEDURE FieldList.typeName(): STRING;
    RETURN "";
END;

PROCEDURE FieldList.endParse(): BOOLEAN;
BEGIN
    parent <- SELF.parent()(PRecord);
    FOR id IN SELF.idents DO
        parent.addField(id, SELF.type);
    END;
    RETURN TRUE;
END;

PROCEDURE setPointerTypeId(p: Pointer; typeId: TypeId.PType);
VAR
    name: STRING;
    typeDesc: STRING;
BEGIN
    IF ~(typeId^ IS TypeId.Forward) THEN
        type <- typeId.type();
        IF ~(type IS Types.PRecord) THEN
            IF type # NIL THEN
                typeDesc := ", got '" + type.description() + "'";
            END;
            Errors.raise("RECORD is expected as a POINTER base type" + typeDesc);
        END;
    END;
    
    parent <- p.parent()(PDeclarationHandle);
    IF ~parent.isAnonymousDeclaration() THEN
        name := parent.genTypeName();
    END;

    parent.setType(NEW R.Pointer(name, typeId));
END;

PROCEDURE Pointer.handleQIdent(q: ContextHierarchy.QIdent);
VAR 
    info: Types.PId;
    s: Symbols.PFoundSymbol;
BEGIN
    id <- q.id;
    IF q.module # NIL THEN
        s := ContextHierarchy.getModuleSymbolAndScope(q.module^, id);
    ELSE
        s := SELF.root().findSymbol(id);
    END;
    IF s # NIL THEN
        info := s.symbol().info();
    ELSE
        msg <- NEW ForwardTypeMsg(id);
        info := SELF.parent().handleMessage(msg^)(Types.PId);
    END;
    setPointerTypeId(SELF, ExpressionTree.unwrapTypeId(info));
END;

PROCEDURE Pointer.setType(type: Types.PStorageType);
BEGIN
    typeId <- NEW TypeId.Type(type);
    SELF.root().currentScope().addFinalizer(stripTypeId, typeId);
    setPointerTypeId(SELF, typeId);
END;

PROCEDURE Pointer.isAnonymousDeclaration(): BOOLEAN;
    RETURN TRUE;
END;

PROCEDURE Pointer.exportField(field: STRING);
BEGIN
    Errors.raise("cannot export anonymous RECORD field: '" + field + "'");
END;

PROCEDURE ResolveClosure.ResolveClosure(root: ContextHierarchy.PRoot; id: STRING)
    | root(root),
      id(id);
END;

PROCEDURE resolve(closure: Object.PType): Types.PStorageType;
BEGIN
    r <- closure(PResolveClosure);
    info <- ContextHierarchy.getSymbol(r.root^, r.id).info();
    RETURN info(TypeId.PType).type();
END;

PROCEDURE Section.handleMessage(VAR msg: ContextHierarchy.Message): Object.PType;
VAR
    result: Object.PType;
BEGIN
    IF msg IS ForwardTypeMsg THEN
        root <- SELF.root();
        scope <- root.currentScope();
        Scope.addUnresolved(scope^, msg.id);
        result := NEW TypeId.Forward(resolve, NEW ResolveClosure(root, msg.id));
    ELSE
        result := SUPER(msg);
    END;
    RETURN result;
END;

PROCEDURE Section.endParse(): BOOLEAN;
BEGIN
    Scope.checkAllResolved(SELF.root().currentScope()^);
    RETURN TRUE;
END;

PROCEDURE ForwardTypeMsg.ForwardTypeMsg(id: STRING)
    | id(id);
END;

PROCEDURE ScopeInfo.ScopeInfo(id: STRING; depth: INTEGER)
    | id(id),
      depth(depth);
END;

PROCEDURE ScopeInfoGenerator.ScopeInfoGenerator(name: STRING; code: CodeGenerator.PIGenerator; parent: ContextHierarchy.PNode)
    | name(name),
      code(code),
      parent(parent),
      codeBegin(code.makeInsertion());
BEGIN
END;

PROCEDURE makeScopeInfo(name: STRING; code: CodeGenerator.IGenerator; parent: ContextHierarchy.PNode): PScopeInfo;
VAR
    id, description: STRING;
BEGIN
    id := "$scope";
    depth <- 0;
        
    IF parent = NIL THEN
        description := Chars.doubleQuote + name + Chars.doubleQuote;
    ELSE
        msg <- DescribeScopeMsg();
        void <- parent.handleMessage(msg);
        depth := msg.result.depth + 1;
        description := msg.result.id + " + " + Chars.doubleQuote + "." + name + Chars.doubleQuote;
        id := id + String.fromInt(depth);
    END;

    code.write("var " + id + " = " + description + ";" + Chars.ln);
    RETURN NEW ScopeInfo(id, depth);
END;

PROCEDURE handleDescribeScopeMsg*(VAR msg: ContextHierarchy.Message; VAR s: ScopeInfoGenerator): BOOLEAN;
BEGIN
    result <- FALSE;
    IF msg IS DescribeScopeMsg THEN
        IF s.info = NIL THEN
            code <- CodeGenerator.Generator();
            s.info := makeScopeInfo(s.name, code, s.parent);
            s.code.insert(s.codeBegin^, code.result());
        END;
        msg.result := s.info;
        result := TRUE;
    END;
    RETURN result;
END;

END ContextType.