-- File LupineDeclareBindingImpl.mesa.
-- Last edited by BZM on 12-May-82 19:18:54.
-- Last edited by Andrew Birrell on February 18, 1983 11:06 am.

-- This module cooperates with LupineDeclare*Impl to export LupineDeclare.


DIRECTORY
  CWF USING [WFC],
  LupineDeclare USING [ImportExport, WriteTransferName, WriteTypeName],
  LupineDeclarePrivate USING [DispatcherName],
  LupineManagerPrivate USING [
	AllocString, Indent, ModuleName,
	Nest, Options, String, StringNIL, WFL, WFL1, WFS, WFS1, WFSL ],
  LupineSymbolTable USING [
	EnumerateTransfers, GetInterfaceInfo, GMT,
	MaxVersionStampStringLength, TransferProcedure,
	VersionStamp, VersionStampString ],
  RPCLupine USING [maxShortStringLength];


LupineDeclareBindingImpl: PROGRAM
  IMPORTS
    CWF, Declare: LupineDeclare, LupineManagerPrivate,
    Private: LupineDeclarePrivate, ST: LupineSymbolTable 
  EXPORTS LupineDeclare
  = BEGIN OPEN LupineManagerPrivate, LupineDeclare;


-- Binding interface code generator.

BindingInterface: PUBLIC PROCEDURE [options: Options] =
  BEGIN
  WFSL["

-- Public RPC types and constants.

  InterfaceName: TYPE = RpcPublic.InterfaceName;
  VersionRange: TYPE = RpcPublic.VersionRange;
  Principal: TYPE = RpcPublic.Principal;
  EncryptionKey: TYPE = RpcPublic.EncryptionKey;
  Zones: TYPE = RpcPublic.Zones;
  
  defaultInterfaceName: InterfaceName = RpcPublic.defaultInterfaceName;
  standardZones: Zones = RpcPublic.standardZones;


-- Standard remote binding routines.

  ImportInterface: "L, Safe[options], "PROCEDURE [
        interfaceName: InterfaceName _ defaultInterfaceName,
        parameterStorage: Zones _ standardZones ];

  UnimportInterface: "L, Safe[options], "PROCEDURE;

  ExportInterface: "L, Safe[options], "PROCEDURE [
        interfaceName: InterfaceName _ defaultInterfaceName,
        user: Principal,
        password: EncryptionKey,
        parameterStorage: Zones _ standardZones ];

  UnexportInterface: "L, Safe[options], "PROCEDURE;

*F
-- Dynamic instantiation and binding.

  ImportNewInterface: "L, Safe[options], "PROCEDURE [
        interfaceName: InterfaceName _ defaultInterfaceName,
        parameterStorage: Zones _ standardZones ]
    RETURNS [interfaceRecord: InterfaceRecord];*N"L];

  WFS1[ STL[options: options, mesa: "
  UnimportNewInterface: PROCEDURE [interfaceRecord: InterfaceRecord];*N"L] ];
  
  WFSL[ "
  -- NewInterfaceRecord is necessary for Cedar clients who want to
  -- manufacture a private interface instance, because
  -- RpcBindingImpl has finalization on type InterfaceRecord.
  NewInterfaceRecord: "L, Safe[options], "PROCEDURE
    RETURNS [interfaceRecord: InterfaceRecord];*N"L];

  InterfaceRecord[options];
  END;

InterfaceRecord: PROCEDURE [options: Options, nest: Nest_1] =
  BEGIN
  WFSL["*N"L, Indent[nest],
    "InterfaceRecord: TYPE = "L,
    STL[options, "REF"L, "LONG POINTER TO"L], " InterfaceRecordObject;*N*N"L];
  WFL1[nest, "InterfaceRecordObject: TYPE = RECORD ["L];
  BEGIN
  DeclareTransferField: ST.TransferProcedure =
    BEGIN
    WFS1[Indent[nest+2]];  Declare.WriteTransferName[transfer];
    WFS1[": "L]; Declare.WriteTypeName[transferType];  WFS1[",*N"L];
    END;
  [] _ ST.EnumerateTransfers [
    proc: DeclareTransferField, procs: TRUE, signals: TRUE, errors: TRUE ];
  END;
  WFL[nest+2, "lupineDetails: PRIVATE "L,
    STL[options, "REF"L, "LONG POINTER TO"L], " LupineDetailsObject_NIL];*N"L];
  WFL1[nest, "LupineDetailsObject: PRIVATE TYPE;"L];
  END;


-- Standard interface binding code generator.

BindingRoutinesStandard: PUBLIC PROC [kind: ImportExport, options: Options] =
  BEGIN
  WFS["
*F
-- Standard remote binding routines.

  bound: BOOLEAN _ FALSE;
  myInterface: RpcPrivate."L,
    (SELECT kind FROM
      import => "Import"L, export => "Export"L, ENDCASE => ERROR),
    "Handle _ NULL;
  paramZones: RpcPublic.Zones _ RpcPublic.standardZones;*N"L];

  SELECT kind FROM

  import =>
   BEGIN
   WFSL["
  ImportInterface: PUBLIC ENTRY "L, Safe[options], "PROCEDURE [
        interfaceName: RpcPublic.InterfaceName,
        parameterStorage: RpcPublic.Zones ] =
    "L, Trusted[options], "BEGIN ENABLE UNWIND => NULL;
    IsNull: PROCEDURE [string: LONG STRING] RETURNS [BOOLEAN] =
      INLINE {RETURN[ string=NIL OR string.length=0 ]};
    IF bound THEN Lupine.BindingError;*N"L];
    ImportCall[options];
    ZoneAssignment[options];
    WFSL["    bound _ TRUE;
    END;

  UnimportInterface: PUBLIC ENTRY "L, Safe[options], "PROCEDURE =
    "L, Trusted[options], "BEGIN ENABLE UNWIND => NULL;
    IF ~bound THEN Lupine.BindingError;
    myInterface _ RpcPrivate.UnimportInterface[myInterface];
    paramZones _ RpcPublic.standardZones;
    bound _ FALSE;
    END;*N"L ];
    END;  -- import.

   export =>
    BEGIN
    WFSL["
  ExportInterface: PUBLIC ENTRY "L, Safe[options], "PROCEDURE [
        interfaceName: RpcPublic.InterfaceName,
        user: RpcPublic.Principal,
        password: RpcPublic.EncryptionKey,
        parameterStorage: RpcPublic.Zones ] =
    "L, Trusted[options], "BEGIN ENABLE UNWIND => NULL;
    IsNull: PROCEDURE [string: LONG STRING] RETURNS [BOOLEAN] =
      INLINE {RETURN[ string=NIL OR string.length=0 ]};
    IF bound THEN Lupine.BindingError;*N"L];
    ExportCall[options];
    ZoneAssignment[options];
    WFSL["    bound _ TRUE;
    END;

  UnexportInterface: PUBLIC ENTRY "L, Safe[options], "PROCEDURE =
    "L, Trusted[options], "BEGIN ENABLE UNWIND => NULL;
    IF ~bound THEN Lupine.BindingError;
    myInterface _ RpcPrivate.UnexportInterface[myInterface];
    paramZones _ RpcPublic.standardZones;
    bound _ FALSE;
    END;*N"L];
    END;  -- export.

  ENDCASE => ERROR;
  END;  -- BindingRoutinesStandard.




-- Dynamic interface record binding generator.

BindingRoutinesDynamic: PUBLIC PROC [kind: ImportExport, options: Options] =
  BEGIN
  WFS1["

-- Dynamic instantiation and binding routines.*N"L];

  SELECT kind FROM

  import =>
   BEGIN
   WFSL["
  ImportNewInterface: PUBLIC "L, Safe[options], "PROCEDURE [
        interfaceName: RpcPublic.InterfaceName,
        parameterStorage: RpcPublic.Zones ]
      RETURNS [interfaceRecord: RpcControl.InterfaceRecord] =
    "L, Trusted[options], "BEGIN
    interfaceRecord _ NewInterface[];
    LupineDetails[interfaceRecord].module.ImportInterface [
        interfaceName: interfaceName,
        parameterStorage: parameterStorage
      ! UNWIND => FreeInterface[interfaceRecord] ];
    END;

  UnimportNewInterface: "L,
    STL[options: options, mesa: "PUBLIC "L], Safe[options], "PROCEDURE [
      interfaceRecord: RpcControl.InterfaceRecord ] =
    "L, Trusted[options], "BEGIN
    LupineDetails[interfaceRecord].module.UnimportInterface[];
    FreeInterface[interfaceRecord];
    END;*N"L ];
    END;  -- import.

   export =>
    BEGIN
    NULL;
    END;  -- export.

  ENDCASE => ERROR;
  END;  -- BindingRoutinesDynamic.

BindingRoutinesPrivate: PUBLIC PROC [kind: ImportExport, options: Options] =
  BEGIN
  SELECT kind FROM

  import =>
   BEGIN
  WFSL["

-- Utility routines for interface instantiation and caching.

  ConcreteLupineDetails: TYPE = "L,
    STL[options, "REF"L, "LONG POINTER TO"L], " LupineDetailsObject;

  LupineDetailsObject:  PUBLIC TYPE = RECORD [
	module: ClientModule_NIL,
	list: RpcControl.InterfaceRecord_NIL, --package reference
	next: RpcControl.InterfaceRecord_NIL --free list -- ];

  LupineDetails: PROCEDURE [abstractInterface: RpcControl.InterfaceRecord]
      RETURNS [ConcreteLupineDetails] =
    INLINE {RETURN[abstractInterface.lupineDetails]};

  ClientModule: TYPE = POINTER TO FRAME["L, ModuleName[client], "];


  clientInterfaceCache: RpcControl.InterfaceRecord _ NIL; -- free interface records
  clientInterfaceList: RpcControl.InterfaceRecord _ NIL; -- all interface records

  NewInterfaceRecord: PUBLIC ", Safe[options], "PROCEDURE
    RETURNS [interfaceRecord: RpcControl.InterfaceRecord] =
    ", Trusted[options], "BEGIN
    interfaceRecord _ "L, LupineZone[options], "NEW[RpcControl.InterfaceRecordObject];
    END;

  NewInterface: PROCEDURE RETURNS [interface: RpcControl.InterfaceRecord]=
    BEGIN
    GetCachedInterface: ENTRY PROCEDURE
        RETURNS [cachedIR: RpcControl.InterfaceRecord] =
      INLINE BEGIN ENABLE UNWIND => NULL;
      IF (cachedIR_clientInterfaceCache) # NIL
        THEN clientInterfaceCache _ LupineDetails[clientInterfaceCache].next;
      END;*N"L,
    STL[options: options, cedar:
    "    ReclaimInterfaces[];*N"L ],
    "    IF (interface _ GetCachedInterface[]) = NIL
      THEN BEGIN
        ChainNewInterface: ENTRY PROCEDURE =
          INLINE BEGIN ENABLE UNWIND => NULL;
          interface.lupineDetails _ "L, LupineZone[options], "NEW[
            LupineDetailsObject _ [module: module, list: clientInterfaceList]];
          clientInterfaceList _ interface;
          END; -- ChainNewInterface.
        module: ClientModule = NEW ClientPrototype;
        interface _ NewInterfaceRecord[];
        interface^ _ [*B"L];
    BEGIN
    AssignTransferField: ST.TransferProcedure =
      BEGIN
      IF transferIndex > 1 THEN WFS1[", "L];
      Declare.WriteTransferName[transfer];
      WFS1[": module."L];  Declare.WriteTransferName[transfer];
      END;  -- AssignTransferField.
    [] _ ST.EnumerateTransfers [
      proc: AssignTransferField, procs: TRUE, signals: TRUE, errors: TRUE ];
    END;
    WFS["];
        ChainNewInterface[];
        END;
    END;

  FreeInterface: ENTRY PROCEDURE [interface: RpcControl.InterfaceRecord]=
    INLINE BEGIN ENABLE UNWIND => NULL;
    LupineDetails[interface].next _ clientInterfaceCache;
    clientInterfaceCache _ interface;
    END;*N"L];

  WFS1[ STL[options: options,
   cedar: "

-- Finalization for dynamic interfaces.  Just cache and reuse for now.

  freedInterfaces: RTT.FinalizationQueue = RTT.NewFQ[20];

  ReclaimInterfaces: PROCEDURE =
    INLINE BEGIN
    WHILE ~RTT.FQEmpty[freedInterfaces] DO
      interface: RpcControl.InterfaceRecord =
        NARROW[RTT.FQNext[freedInterfaces]];
      IF interface.lupineDetails # NIL THEN
        UnimportNewInterface[interface];
      ENDLOOP;
    END;


-- Module initialization.

  RTT.EstablishFinalization[
    type: CODE[RpcControl.InterfaceRecordObject],
    npr: 1,  fq: freedInterfaces ];*N"L,

   mesa: "
   
-- No module initialization.*N"L ] ];

    END;  -- import.

   export =>
    BEGIN
    NULL;
    END;  -- export.

  ENDCASE => ERROR;
  END;  -- BindingRoutinesPrivate.


-- Binding utility routines.


ImportCall: PROCEDURE [options: Options] =
  BEGIN
  Interface: PROC RETURNS [String] =
    INLINE {RETURN[STL[options, ""L, "interfaceName."L]]};
  WFSL[
   STL[options: options, cedar:
"    BEGIN
    type: STRING = [RpcPrivate.maxShortStringLength];
    instance: STRING = [RpcPrivate.maxShortStringLength];
    ConvertUnsafe.AppendRope[to: type, from: interfaceName.type];
    ConvertUnsafe.AppendRope[to: instance, from: interfaceName.instance];*N"L],
"    myInterface _ RpcPrivate.ImportInterface [
      interface: [
        type: IF ~IsNull["L, Interface[], "type]
          THEN "L, Interface[], "type ELSE "L];
	    DefaultInterfaceType[options];  WFSL[",
        instance: "L, Interface[], "instance,
        version: interfaceName.version ],
      localOnly: RpcControl.InterMdsCallsOnly,
      stubProtocol: RpcControl.LupineProtocolVersion ];*N"L,
   STL[options: options, cedar: "    END;*N"L] ];
  END;

ExportCall: PROCEDURE [options: Options] =
  BEGIN
  Interface: PROC RETURNS [String] =
    INLINE {RETURN[STL[options, ""L, "interfaceName."L]]};
  WFSL[
   STL[options: options, cedar:
"    BEGIN
    type: STRING = [RpcPrivate.maxShortStringLength];
    instance: STRING = [RpcPrivate.maxShortStringLength];
    userString: STRING = [RpcPrivate.maxPrincipalLength];
    ConvertUnsafe.AppendRope[to: type, from: interfaceName.type];
    ConvertUnsafe.AppendRope[to: instance, from: interfaceName.instance];
    ConvertUnsafe.AppendRope[to: userString, from: user];*N"L],
"    myInterface _ RpcPrivate.ExportInterface [
      interface: [
        type: IF ~IsNull["L, Interface[], "type]
          THEN "L, Interface[], "type ELSE "L];
	    DefaultInterfaceType[options];  WFSL[",
        instance: "L, Interface[], "instance,
        version: interfaceName.version ],
      user: "L, STL[options, "userString"L, "user"L], ",  password: password,
      dispatcher: "L, Private.DispatcherName[type: server], ",
      localOnly: RpcControl.InterMdsCallsOnly,
      stubProtocol: RpcControl.LupineProtocolVersion ];*N"L,
   STL[options: options, cedar: "    END;*N"L] ];
  END;

LupineZone: PROC [options: Options] RETURNS [--zoneQualifier:-- String] =
  INLINE {RETURN[ STL[options, ""L, "Heap.systemZone."L] ]};

ZoneAssignment: PROCEDURE [options: Options] =
  BEGIN
  WFS[
    "    paramZones _ [*N"L,
    STL[options: options,
     cedar:
      "      gc: IF parameterStorage.gc # NIL
        THEN parameterStorage.gc ELSE SafeStorage.GetSystemZone[],
      heap: IF parameterStorage.heap # NIL
        THEN parameterStorage.heap ELSE UnsafeStorage.GetSystemUZone[],*N"L,
     mesa:
      "      heap: IF parameterStorage.heap # NIL
        THEN parameterStorage.heap ELSE Heap.systemZone,*N"L ],
    "      mds: IF parameterStorage.mds # NIL
        THEN parameterStorage.mds ELSE Heap.systemMDSZone ];*N"L ];
  END;

DefaultInterfaceType: PROCEDURE [options: Options] =
  {WFS1[""""L];  WriteInterfaceNameDateID;  WFS1["""L"L]};

WriteInterfaceNameDateID: PROCEDURE =
  -- A module's name-date-uid string is NOT an RName and must have
  -- a maximum of 64 characters.  The module name is shortened if necessary.
  -- NEW: The stamp has the form "PilotDefs~0#0#000". (Compiler equivalent)
  -- OLD: The stamp has the form "PilotDefs~1-Jan-81~00:00:00~0#0#000".
  BEGIN
  MaxIDLength: INTEGER = RPCLupine.maxShortStringLength;
  MaxTimeStringLength: INTEGER = 0--18--;  ZoneLength: INTEGER = 4;
  DefaultRegistry: String = ""L;  -- The stamp is not currently an RName.
  Separator: String = "~"L;
  module: String = ModuleName[interface];
  maxModuleLength: INTEGER = MIN[
    module.length,
    MaxIDLength - (ST.MaxVersionStampStringLength + MaxTimeStringLength
	 + DefaultRegistry.length + 2*Separator.length) ];
  timeString: AllocString = [MaxTimeStringLength+ZoneLength];
  stampString: AllocString = [ST.MaxVersionStampStringLength];
  time: ST.GMT;
  version: ST.VersionStamp;
  [moduleVersion: version, moduleCreateTime: time] _ ST.GetInterfaceInfo[];
--CWF.SWF1[timeString, "%LT"L, @time];
--timeString.length _ MaxTimeStringLength;
--FOR i: CARDINAL IN [0..timeString.length) DO
    -- Grapevine's Maintain program does not like spaces in RNames.
--  IF timeString[i] = '  THEN timeString[i] _ Separator[0]  ENDLOOP;
  FOR i: INTEGER IN [0..maxModuleLength) DO CWF.WFC[module[i]] ENDLOOP;
  WFSL[
    -- Module name (truncated if necessary) was written above,
  --Separator, timeString,
    Separator, ST.VersionStampString[version, stampString],
    DefaultRegistry ];
  END;


STL, SelectTargetLanguage: PROCEDURE [
	options: Options, cedar, mesa: String_StringNIL ]
      RETURNS [--targetString:-- String] =
    INLINE BEGIN
    RETURN[ SELECT options.targetLanguage FROM
	Cedar => cedar, Mesa => mesa, ENDCASE => ERROR ];
    END;


Safe: PROCEDURE [options: Options] RETURNS [String] =
    INLINE BEGIN
    RETURN[STL[options: options, cedar: "SAFE "L]];
    END;

Trusted: PROCEDURE [options: Options] RETURNS [String] =
    INLINE BEGIN
    RETURN[STL[options: options, cedar: "TRUSTED "L]];
    END;


END.  -- LupineDeclareBindingImpl.