(* M2Swig.mod generates a swig interface file for the main module. Copyright (C) 2008-2023 Free Software Foundation, Inc. Contributed by Gaius Mulley . This file is part of GNU Modula-2. GNU Modula-2 is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3, or (at your option) any later version. GNU Modula-2 is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Modula-2; see the file COPYING3. If not see . *) IMPLEMENTATION MODULE M2Swig ; FROM Storage IMPORT ALLOCATE ; FROM M2Options IMPORT GenerateSwig ; FROM SFIO IMPORT OpenToWrite ; FROM FIO IMPORT File, Close ; FROM NameKey IMPORT Name, KeyToCharStar ; FROM M2Error IMPORT InternalError ; FROM M2Printf IMPORT fprintf0, fprintf1, fprintf2, fprintf3, fprintf4 ; FROM M2AsmUtil IMPORT GetFullScopeAsmName ; FROM SYSTEM IMPORT WORD ; FROM DynamicStrings IMPORT String, InitString, InitStringCharStar, ConCat, Mark, KillString ; FROM Lists IMPORT List, InitList, KillList, IsItemInList, IncludeItemIntoList, RemoveItemFromList, ForeachItemInListDo, NoOfItemsInList, GetItemFromList ; FROM M2Quads IMPORT IsProcedureScope ; FROM M2System IMPORT IsSystemType, Address, Byte, Loc, Word ; FROM M2Bitset IMPORT Bitset ; FROM Indexing IMPORT Index, InitIndex, KillIndex, HighIndice, PutIndice, GetIndice ; FROM M2Scope IMPORT ScopeBlock, InitScopeBlock, KillScopeBlock ; FROM M2Base IMPORT IsBaseType, Char, Cardinal, Integer, Real, LongReal, ShortReal, LongCard, ShortCard, LongInt, ShortInt, Boolean ; FROM SymbolTable IMPORT GetSymName, IsType, IsProcedure, IsConst, IsVar, GetType, GetNthParam, IsUnbounded, GetMode, ModeOfAddr, NoOfParam, IsConstString, IsConstLit, IsPointer, IsExported, ForeachExportedDo, IsUnboundedParam, IsParameter, IsParameterUnbounded, IsParameterVar, GetParameterShadowVar, GetReadQuads, GetWriteQuads, NulSym ; FROM M2BasicBlock IMPORT BasicBlock, InitBasicBlocks, KillBasicBlocks, ForeachBasicBlockDo ; TYPE UnboundedSig = POINTER TO RECORD type: CARDINAL ; name: Name ; END ; VAR includedArray: BOOLEAN ; uKey : Index ; mainModule : CARDINAL ; Done, ToDo : List ; f : File ; name : String ; (* DoExported - includes, sym, into the, ToDo, list. *) PROCEDURE DoExported (sym: CARDINAL) ; BEGIN IncludeItemIntoList(ToDo, sym) END DoExported ; (* MoveToDone - moves a sym to the, Done, list, providing that it is not already on it. It returns TRUE if the lists were modified. *) PROCEDURE MoveToDone (sym: CARDINAL) : BOOLEAN ; BEGIN IF IsItemInList(Done, sym) THEN RETURN( FALSE ) ELSIF IsItemInList(ToDo, sym) THEN RemoveItemFromList(ToDo, sym) ; IncludeItemIntoList(Done, sym) ; RETURN( TRUE ) END ; IncludeItemIntoList(Done, sym) ; RETURN( TRUE ) END MoveToDone ; (* MoveToToDo - moves a sym to the, ToDo, list, providing that it is not already on it. It returns TRUE if the lists were modified. *) PROCEDURE MoveToToDo (sym: CARDINAL) : BOOLEAN ; BEGIN IF IsItemInList(Done, sym) THEN InternalError ('not expecting to get here') ELSIF IsItemInList(ToDo, sym) THEN RETURN( FALSE ) ELSE IncludeItemIntoList(ToDo, sym) ; RETURN( TRUE ) END END MoveToToDo ; (* Trybase - returns TRUE *) PROCEDURE TryBase (sym: CARDINAL) : BOOLEAN ; BEGIN IF (sym=Cardinal) OR (sym=Integer) OR (sym=LongInt) OR (sym=LongCard) OR (sym=Char) OR (sym=ShortCard) OR (sym=ShortInt) OR (sym=Real) OR (sym=LongReal) OR (sym=ShortReal) OR (sym=Boolean) THEN RETURN( MoveToDone(sym) ) ELSE RETURN( FALSE ) END END TryBase ; (* TrySystem - returns TRUE if sym can be moved to the done list. *) PROCEDURE TrySystem (sym: CARDINAL) : BOOLEAN ; BEGIN IF (sym=Bitset) OR (sym=Address) OR (sym=Byte) OR (sym=Loc) OR (sym=Word) THEN RETURN( MoveToDone(sym) ) ELSE RETURN( FALSE ) END END TrySystem ; (* TryMove - tries to move sym to the done queue as long as type is known. *) PROCEDURE TryMove (sym, type: CARDINAL) : BOOLEAN ; BEGIN IF IsItemInList(Done, type) THEN IF MoveToDone(sym) THEN RETURN( TRUE ) END ELSE IF MoveToToDo(sym) THEN RETURN( TRUE ) END END ; RETURN( FALSE ) END TryMove ; (* TryType - *) PROCEDURE TryType (sym: CARDINAL) : BOOLEAN ; VAR type : CARDINAL ; result: BOOLEAN ; BEGIN type := GetType(sym) ; result := TryDependents(type) ; IF TryMove(sym, type) THEN RETURN( TRUE ) ELSE RETURN( result ) END END TryType ; (* TryVar - *) PROCEDURE TryVar (sym: CARDINAL) : BOOLEAN ; VAR type : CARDINAL ; result: BOOLEAN ; BEGIN type := GetType(sym) ; result := TryDependents(type) ; IF TryMove(sym, type) THEN RETURN( TRUE ) ELSE RETURN( result ) END END TryVar ; (* TryProcedure - *) PROCEDURE TryProcedure (sym: CARDINAL) : BOOLEAN ; VAR son, p, i, type : CARDINAL ; solved, result: BOOLEAN ; BEGIN type := GetType(sym) ; result := FALSE ; solved := TRUE ; IF type#NulSym THEN IF TryDependents(type) THEN result := TRUE END ; IF NOT IsItemInList(Done, type) THEN solved := FALSE END END ; p := NoOfParam(sym) ; i := 1 ; WHILE i<=p DO son := GetNthParam(sym, i) ; IF TryDependents(son) THEN result := TRUE END ; IF NOT IsItemInList(Done, son) THEN solved := FALSE END ; INC(i) END ; IF solved THEN IF MoveToDone(sym) THEN RETURN( TRUE ) END ELSE IF MoveToToDo(sym) THEN RETURN( TRUE ) END END ; RETURN( result ) END TryProcedure ; (* TryUnbounded - *) PROCEDURE TryUnbounded (sym: CARDINAL) : BOOLEAN ; VAR type : CARDINAL ; result: BOOLEAN ; BEGIN type := GetType(sym) ; result := TryDependents(type) ; IF TryMove(sym, type) THEN RETURN( TRUE ) ELSE RETURN( result ) END END TryUnbounded ; (* TryParameter - *) PROCEDURE TryParameter (sym: CARDINAL) : BOOLEAN ; VAR type : CARDINAL ; result: BOOLEAN ; BEGIN type := GetType(sym) ; result := TryDependents(type) ; IF TryMove(sym, type) THEN RETURN( TRUE ) ELSE RETURN( result ) END END TryParameter ; (* TryDependents - returns TRUE if any alteration occurred to any of the lists. *) PROCEDURE TryDependents (sym: CARDINAL) : BOOLEAN ; BEGIN IF IsBaseType(sym) THEN RETURN( TryBase(sym) ) ELSIF IsSystemType(sym) THEN RETURN( TrySystem(sym) ) ELSIF IsType(sym) THEN RETURN( TryType(sym) ) ELSIF IsParameter(sym) THEN RETURN( TryParameter(sym) ) ELSIF IsProcedure(sym) THEN RETURN( TryProcedure(sym) ) ELSIF IsConstString(sym) THEN RETURN( MoveToDone(sym) ) ELSIF IsConstLit(sym) THEN RETURN( MoveToDone(sym) ) ELSIF IsVar(sym) AND (GetMode(sym)=ImmediateValue) THEN RETURN( MoveToDone(sym) ) ELSIF IsVar(sym) THEN RETURN( TryVar(sym) ) ELSIF IsUnbounded(sym) THEN RETURN( TryUnbounded(sym) ) ELSE RETURN( FALSE ) END END TryDependents ; (* DoResolveOrder - resolves the declaration order for swig (C). *) PROCEDURE DoResolveOrder ; VAR sym, i, n : CARDINAL ; movement: BOOLEAN ; BEGIN REPEAT n := NoOfItemsInList(ToDo) ; movement := FALSE ; i := 1 ; WHILE (i<=n) AND (NOT movement) DO sym := GetItemFromList(ToDo, i) ; movement := TryDependents(sym) ; INC(i) END UNTIL NOT movement END DoResolveOrder ; (* DoName - *) PROCEDURE DoName (sym: CARDINAL) ; VAR n: Name ; BEGIN n := GetFullScopeAsmName(sym) ; fprintf1(f, "%a", n) END DoName ; (* DoParamName - *) PROCEDURE DoParamName (sym: CARDINAL) ; VAR n: Name ; BEGIN n := GetSymName(sym) ; fprintf1(f, "%a", n) END DoParamName ; (* DoVar - *) PROCEDURE DoVar (sym: CARDINAL) ; BEGIN fprintf0(f, 'extern "C" ') ; DoType(GetType(sym)) ; fprintf0(f, ' ') ; DoName(sym) ; fprintf0(f, ';\n') END DoVar ; (* DoType - *) PROCEDURE DoType (sym: CARDINAL) ; BEGIN IF IsPointer(sym) THEN DoType(GetType(sym)) ; fprintf0(f, ' *') ELSIF sym=Cardinal THEN fprintf0(f, "unsigned int") ELSIF sym=Integer THEN fprintf0(f, "int") ELSIF sym=Boolean THEN fprintf0(f, "unsigned int") ELSIF sym=LongInt THEN fprintf0(f, "long long int") ELSIF sym=LongCard THEN fprintf0(f, "long long unsigned int") ELSIF sym=Char THEN fprintf0(f, "char") ELSIF sym=ShortCard THEN fprintf0(f, "short unsigned int") ELSIF sym=ShortInt THEN fprintf0(f, "short int") ELSIF sym=Real THEN fprintf0(f, "double") ELSIF sym=LongReal THEN fprintf0(f, "long double") ELSIF sym=ShortReal THEN fprintf0(f, "float") ELSIF sym=Bitset THEN fprintf0(f, "unsigned int") ELSIF sym=Address THEN fprintf0(f, "void *") ELSIF sym=Byte THEN fprintf0(f, "unsigned char") ELSIF sym=Loc THEN fprintf0(f, "unsigned char") ELSIF sym=Word THEN fprintf0(f, "unsigned int") END END DoType ; (* DoUnbounded - *) PROCEDURE DoUnbounded (sym: CARDINAL) ; VAR n : Name ; type: CARDINAL ; BEGIN type := GetType(sym) ; DoType(GetType(type)) ; n := GetSymName(sym) ; fprintf2(f, ' *_m2_address_%a, int _m2_high_%a', n, n) END DoUnbounded ; VAR FirstBasicBlock, Input, Output, InOut, CanGuess, IsKnown : BOOLEAN ; rs, ws : CARDINAL ; (* DoBasicBlock - *) PROCEDURE DoBasicBlock (start, end: CARDINAL) ; BEGIN IF IsProcedureScope(start) THEN (* skip this basic block, as this will not modify the parameter *) RETURN ELSIF IsKnown OR CanGuess THEN (* already resolved *) RETURN ELSE IF (ws=0) AND (rs=0) THEN FirstBasicBlock := FALSE ELSIF rs=0 THEN (* only written *) IF ws<=end THEN Output := TRUE ; IF FirstBasicBlock THEN IsKnown := TRUE ELSE CanGuess := TRUE END ; FirstBasicBlock := FALSE END ELSIF ws=0 THEN (* only read *) Input := TRUE ; IF (rs<=end) AND FirstBasicBlock THEN IsKnown := TRUE ELSE CanGuess := TRUE END ; FirstBasicBlock := FALSE ELSIF rs<=ws THEN (* read before write *) InOut := TRUE ; IF (rs<=end) AND (ws<=end) AND FirstBasicBlock THEN IsKnown := TRUE ELSE CanGuess := TRUE END ; FirstBasicBlock := FALSE ELSE (* must be written before read *) Output := TRUE ; IF (rs<=end) AND (ws<=end) AND FirstBasicBlock THEN IsKnown := TRUE ELSE CanGuess := TRUE END ; FirstBasicBlock := FALSE END END END DoBasicBlock ; (* DetermineParameter - *) PROCEDURE DetermineParameter (procedure, param: CARDINAL) ; VAR sb: ScopeBlock ; bb: BasicBlock ; we, re: CARDINAL ; BEGIN sb := InitScopeBlock(procedure) ; bb := InitBasicBlocks(sb) ; Input := FALSE ; Output := FALSE ; InOut := FALSE ; CanGuess := FALSE ; IsKnown := FALSE ; FirstBasicBlock := TRUE ; GetReadQuads(param, RightValue, rs, re) ; GetWriteQuads(param, RightValue, ws, we) ; ForeachBasicBlockDo(bb, DoBasicBlock) ; KillBasicBlocks(bb) ; KillScopeBlock(sb) END DetermineParameter ; (* PrintDirection - *) PROCEDURE PrintDirection ; BEGIN IF Input THEN fprintf0(f, 'INPUT') ELSIF Output THEN fprintf0(f, 'OUTPUT') ELSE fprintf0(f, 'INOUT') END END PrintDirection ; (* CalculateVarDirective - *) PROCEDURE CalculateVarDirective (procedure, param: CARDINAL; annotate: BOOLEAN) ; VAR sym: CARDINAL ; BEGIN sym := GetParameterShadowVar(param) ; IF sym=NulSym THEN InternalError ('why did we get here') ELSE DetermineParameter(procedure, sym) ; IF annotate THEN DoParamName(sym) ; IF IsKnown THEN fprintf0(f, ' is known to be an ') ; PrintDirection ELSIF CanGuess THEN fprintf0(f, ' is guessed to be an ') ; PrintDirection ELSE fprintf0(f, ' is unknown') END ELSE fprintf0(f, '*') ; IF IsKnown OR CanGuess THEN PrintDirection ELSE DoParamName(sym) END END END END CalculateVarDirective ; (* AnnotateProcedure - *) PROCEDURE AnnotateProcedure (sym: CARDINAL) ; VAR son, p, i: CARDINAL ; needComma: BOOLEAN ; BEGIN fprintf0(f, '/* parameter: ') ; p := NoOfParam(sym) ; i := 1 ; needComma := FALSE ; WHILE i<=p DO son := GetNthParam(sym, i) ; IF IsParameterVar(son) THEN IF needComma THEN fprintf0(f, ', ') END ; CalculateVarDirective(sym, son, TRUE) ; needComma := TRUE END ; INC(i) END ; fprintf0(f, ' */\n\n') END AnnotateProcedure ; (* DoProcedure - *) PROCEDURE DoProcedure (sym: CARDINAL) : BOOLEAN ; VAR son, p, i : CARDINAL ; found: BOOLEAN ; BEGIN found := FALSE ; fprintf0(f, 'extern "C" ') ; IF GetType(sym)=NulSym THEN fprintf0(f, 'void') ; ELSE DoType(GetType(sym)) END ; fprintf0(f, ' ') ; DoName(sym) ; fprintf0(f, ' (') ; p := NoOfParam(sym) ; IF p=0 THEN fprintf0(f, 'void') ; ELSE i := 1 ; WHILE i<=p DO son := GetNthParam(sym, i) ; IF IsUnboundedParam(sym, i) THEN DoUnbounded(son) ELSE DoType(GetType(son)) ; fprintf0(f, ' ') ; IF IsParameterVar(son) THEN found := TRUE ; CalculateVarDirective(sym, son, FALSE) ELSE DoParamName(son) END END ; IF i