home *** CD-ROM | disk | FTP | other *** search
/ Compendium Deluxe 1 / LSD Compendium Deluxe 1.iso / a / programming / c / genmo112.lha / GTB-Modula / GenModula / GenerateGlobal.mod < prev    next >
Encoding:
Modula Implementation  |  1993-09-28  |  10.0 KB  |  414 lines
  1. IMPLEMENTATION MODULE GenerateGlobal;
  2.  
  3. (*
  4.  * -------------------------------------------------------------------------
  5.  *
  6.  *    :Program.    GenModula
  7.  *    :Contents.    A Modula 2 Sourcecode generator for GadToolsBox
  8.  *
  9.  *    :Author.    Reiner B. Nix
  10.  *    :Address.    Geranienhof 2, 50769 Köln Seeberg
  11.  *    :Address.    rbnix@pool.informatik.rwth-aachen.de
  12.  *    :Copyright.    Reiner B. Nix
  13.  *    :Language.    Modula-2
  14.  *    :Translator.    M2Amiga A-L V4.2d
  15.  *    :Imports.    GadToolsBox, NoFrag  by Jaan van den Baard
  16.  *    :Imports.    InOut, NewArgSupport by Reiner Nix
  17.  *    :History.    this programm is a direct descendend from
  18.  *    :History.     OG (Oberon Generator) 37.11 by Thomas Igracki, Kai Bolay
  19.  *    :History.    GenModula 1.10 (23.Aug.93)    ;M2Amiga 4.0d
  20.  *    :History.    GenModula 1.12 (28.Sep.93)    ;M2Amiga 4.2d
  21.  *
  22.  * -------------------------------------------------------------------------
  23.  *)
  24.  
  25. FROM    SYSTEM            IMPORT    ADR;
  26. FROM    GraphicsD        IMPORT    RastPort,
  27.                     TextFontPtr;
  28. FROM    GraphicsL        IMPORT    InitRastPort,
  29.                     SetFont, TextLength,
  30.                     CloseFont;
  31. FROM    DiskFontL        IMPORT    OpenDiskFont;
  32. FROM    GadToolsD        IMPORT    genericKind,
  33.                     GtTags;
  34. FROM    FileOut            IMPORT    Write, WriteString, WriteLn,
  35.                     WriteCard, WriteInt, WriteHex;
  36. FROM    GadToolsBox        IMPORT    GadgetFlags, GadgetFlagSet,
  37.                     GuiFlags, GuiFlagSet,
  38.                     GenCFlags,
  39.                     GTConfigFlags, WindowTagFlags,
  40.                     ExtNewGadgetPtr, ProjectWindowPtr;
  41. FROM    GeneratorIO        IMPORT    dfile, mfile, args,
  42.                     Gui, MainConfig, CConfig, Projects,
  43.                     WriteFill, SeekBack;
  44.  
  45. PROCEDURE WriteGlobalDefs    (    GetFilePresent    :BOOLEAN);
  46.  
  47. BEGIN
  48. IF GetFilePresent THEN
  49.   WriteString (mfile, "\t");
  50.   WriteString (mfile, "GetImage");
  51.   WriteFill   (mfile, "", 8);
  52.   WriteString (mfile, ":ObjectPtr;");
  53.   WriteLn (mfile)
  54.   END
  55. END WriteGlobalDefs;
  56.  
  57.  
  58.  
  59. PROCEDURE WriteGlobalProcs;
  60.  
  61.  
  62.   PROCEDURE WriteComputes;
  63.  
  64.   CONST    sampleText    ="abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789";
  65.       maxSample    =62;
  66.  
  67.   VAR    xsize, ysize        :CARDINAL;
  68.       font            :TextFontPtr;
  69.       rastPort        :RastPort;
  70.  
  71.   BEGIN
  72.   IF FontAdapt IN MainConfig.configFlags0 THEN
  73.     font := OpenDiskFont (ADR (Gui.font));
  74.  
  75.     IF font = NIL THEN
  76.       xsize := Gui.font.ySize
  77.     ELSE
  78.       InitRastPort (rastPort);
  79.       SetFont (ADR (rastPort), font);
  80.  
  81.       xsize := TextLength (ADR (rastPort), ADR (sampleText), maxSample) DIV maxSample;
  82.  
  83.       CloseFont (font);
  84.       END;
  85.  
  86.     ysize := Gui.font.ySize;
  87.  
  88.  
  89.  
  90.     WriteLn (mfile);
  91.     WriteString (mfile, "PROCEDURE ComputeX");
  92.     WriteFill   (mfile, "", 10);
  93.     WriteString (mfile, "(    value");
  94.     WriteFill   (mfile, "", 9);
  95.     WriteString (mfile, ":INTEGER) :INTEGER;");
  96.     WriteLn (mfile);
  97.     WriteLn (mfile);
  98.  
  99.     WriteString (mfile, "BEGIN");
  100.     WriteLn (mfile);
  101.  
  102.     WriteString (mfile, "RETURN ((FontX * value) + ");
  103.     WriteCard   (mfile, xsize DIV 2, 1);
  104.     WriteString (mfile, ") DIV ");
  105.     WriteCard   (mfile, xsize, 1);
  106.     WriteLn (mfile);
  107.  
  108.     WriteString (mfile, "END ComputeX;");
  109.     WriteLn (mfile);
  110.     WriteLn (mfile);
  111.  
  112.  
  113.  
  114.     WriteLn (mfile);
  115.     WriteString (mfile, "PROCEDURE ComputeY");
  116.     WriteFill   (mfile, "", 10);
  117.     WriteString (mfile, "(    value");
  118.     WriteFill   (mfile, "", 9);
  119.     WriteString (mfile, ":INTEGER) :INTEGER;");
  120.     WriteLn (mfile);
  121.     WriteLn (mfile);
  122.  
  123.     WriteString (mfile, "BEGIN");
  124.     WriteLn (mfile);
  125.  
  126.     WriteString (mfile, "RETURN ((FontY * value) + ");
  127.     WriteCard   (mfile, ysize DIV 2, 1);
  128.     WriteString (mfile, ") DIV ");
  129.     WriteCard   (mfile, ysize, 1);
  130.     WriteLn (mfile);
  131.  
  132.     WriteString (mfile, "END ComputeY;");
  133.     WriteLn (mfile);
  134.     WriteLn (mfile);
  135.  
  136.  
  137.  
  138.     WriteLn (mfile);
  139.     WriteString (mfile, "PROCEDURE ComputeFont");
  140.     WriteFill   (mfile, "", 10);
  141.     WriteString (mfile, "(    width, height");
  142.     WriteFill   (mfile, "", 18);
  143.     WriteString (mfile, ":CARDINAL);");
  144.     WriteLn (mfile);
  145.     WriteLn (mfile);
  146.  
  147.  
  148.     WriteString (mfile, "BEGIN");
  149.     WriteLn (mfile);
  150.  
  151.     WriteString (mfile, "Font := ADR (Attr);");
  152.     WriteLn (mfile);
  153.     WriteLn (mfile);
  154.  
  155.  
  156.     IF gcSysFont IN CConfig THEN
  157.       WriteString (mfile, "Forbid ();");
  158.       WriteLn (mfile);
  159.  
  160.       WriteString (mfile, "Font^.name  := graphicsBase^.defaultFont^.message.node.name;");
  161.       WriteLn (mfile);
  162.  
  163.       WriteString (mfile, "Font^.ySize := graphicsBase^.defaultFont^.ySize;");
  164.       WriteLn (mfile);
  165.  
  166.       WriteString (mfile, "FontX := graphicsBase^.defaultFont^.xSize;");
  167.       WriteLn (mfile);
  168.  
  169.       WriteString (mfile, "Permit ();");
  170.       WriteLn (mfile);
  171.  
  172.       WriteString (mfile, "FontY := Font^.ySize;");
  173.       WriteLn (mfile)
  174.  
  175.     ELSE
  176.       WriteString (mfile, "Font^.name  := Screen^.rastPort.font^.message.node.name;");
  177.       WriteLn (mfile);
  178.  
  179.       WriteString (mfile, "Font^.ySize := Screen^.rastPort.font^.ySize;");
  180.       WriteLn (mfile);
  181.  
  182.       WriteString (mfile, "FontX := Screen^.rastPort.font^.xSize;");
  183.       WriteLn (mfile);
  184.  
  185.       WriteString (mfile, "FontY := Font^.ySize;");
  186.       WriteLn (mfile)
  187.       END;
  188.     WriteLn (mfile);
  189.  
  190.  
  191.     WriteString (mfile, "OffX := Screen^.wBorLeft;");
  192.     WriteLn (mfile);
  193.  
  194.     WriteString (mfile, "OffY := INTEGER (Screen^.rastPort.txHeight) + Screen^.wBorTop + 1;");
  195.     WriteLn (mfile);
  196.     WriteLn (mfile);
  197.  
  198.  
  199.     WriteString (mfile, "IF (width # 0) AND (height # 0) AND");
  200.     WriteLn (mfile);
  201.     WriteString (mfile, "   ((Screen^.width < ComputeX (width) + OffX + Screen^.wBorRight) AND");
  202.     WriteLn (mfile);
  203.     WriteString (mfile, "    (Screen^.height < ComputeY (height) + OffY + Screen^.wBorBottom)) THEN");
  204.     WriteLn (mfile);
  205.     WriteString (mfile, "  Font^.name  := ADR ('topaz.font');");
  206.     WriteLn (mfile);
  207.     WriteString (mfile, "  Font^.ySize := 8;");
  208.     WriteLn (mfile);
  209.     WriteString (mfile, "  FontX := 8;");
  210.     WriteLn (mfile);
  211.     WriteString (mfile, "  FontY := 8");
  212.     WriteLn (mfile);
  213.     WriteString (mfile, "  END");
  214.     WriteLn (mfile);
  215.  
  216.  
  217.     WriteString (mfile, "END ComputeFont;");
  218.     WriteLn (mfile);
  219.     WriteLn (mfile)
  220.     END
  221.   END WriteComputes;
  222.  
  223.  
  224.  
  225.   PROCEDURE WriteDrawRast;
  226.  
  227.   BEGIN
  228.   IF args.raster THEN
  229.     WriteLn (mfile);
  230.     WriteString (mfile, "PROCEDURE DrawRast");
  231.     WriteFill   (mfile, "", 10);
  232.     WriteString (mfile, "(    window");
  233.     WriteFill   (mfile, "", 11);
  234.     WriteString (mfile, ":WindowPtr);");
  235.     WriteLn (mfile);
  236.     WriteLn (mfile);
  237.  
  238.  
  239.     WriteString (mfile, "VAR");
  240.  
  241.     WriteString (mfile, "\t");
  242.     WriteString (mfile, "backPattern");
  243.     WriteFill   (mfile, "", 11);
  244.     WriteString (mfile, ":LONGCARD;");
  245.     WriteLn (mfile);
  246.     WriteLn (mfile);
  247.  
  248.  
  249.     WriteString (mfile, "BEGIN");
  250.     WriteLn (mfile);
  251.  
  252.     WriteString (mfile, "backPattern := 0AAAA5555H;");
  253.     WriteLn (mfile);
  254.     WriteLn (mfile);
  255.  
  256.     WriteString (mfile, "WITH window^ DO");
  257.     WriteLn (mfile);
  258.  
  259.     WriteString (mfile, "  SetAPen (rPort, 2);");
  260.     WriteLn (mfile);
  261.  
  262.     WriteString (mfile, "  SetAfPen (rPort, ADR (backPattern), 1);");
  263.     WriteLn (mfile);
  264.  
  265.     WriteString (mfile, "  RectFill (rPort,");
  266.     WriteLn (mfile);
  267.  
  268.     WriteString (mfile, "            borderLeft, borderTop,");
  269.     WriteLn (mfile);
  270.  
  271.     WriteString (mfile, "            width-borderRight-1, height-borderBottom-1);");
  272.     WriteLn (mfile);
  273.  
  274.     WriteString (mfile, "  SetAfPen (rPort, NIL, 0)");
  275.     WriteLn (mfile);
  276.  
  277.     WriteString (mfile, "  END");
  278.     WriteLn (mfile);
  279.  
  280.  
  281.     WriteString (mfile, "END DrawRast;");
  282.     WriteLn (mfile);
  283.     WriteLn (mfile)
  284.     END
  285.   END WriteDrawRast;
  286.  
  287.  
  288.  
  289.   PROCEDURE WriteFilledBBox;
  290.  
  291.   BEGIN
  292.   IF args.raster THEN
  293.     WriteLn (mfile);
  294.     WriteString (mfile, "PROCEDURE FilledBBox");
  295.     WriteFill   (mfile, "", 12);
  296.     WriteString (mfile, "(    vi");
  297.     WriteFill   (mfile, "", 2);
  298.     WriteString (mfile, ":ADDRESS;");
  299.     WriteLn (mfile);
  300.  
  301.     WriteFill   (mfile, "", -8);
  302.     WriteString (mfile, "     rp");
  303.     WriteFill   (mfile, "", 2);
  304.     WriteString (mfile, ":RastPortPtr;");
  305.     WriteLn (mfile);
  306.  
  307.     WriteFill   (mfile, "", -8);
  308.     WriteString (mfile, "     l, t, w, h");
  309.     WriteFill   (mfile, "", 10);
  310.     WriteString (mfile, ":INTEGER;");
  311.     WriteLn (mfile);
  312.  
  313.     WriteFill   (mfile, "", -8);
  314.     WriteString (mfile, "     recessed");
  315.     WriteFill   (mfile, "", 8);
  316.     WriteString (mfile, ":BOOLEAN);");
  317.     WriteLn (mfile);
  318.     WriteLn (mfile);
  319.  
  320.  
  321.     WriteString (mfile, "VAR");
  322.  
  323.     WriteString (mfile, "\t");
  324.     WriteString (mfile, "bevelTagPtr");
  325.     WriteFill   (mfile, "", 11);
  326.     WriteString (mfile, ":TagItemPtr;");
  327.     WriteLn (mfile);
  328.  
  329.     WriteString (mfile, "\t");
  330.     WriteString (mfile, "bevelTags");
  331.     WriteFill   (mfile, "", 9);
  332.     WriteString (mfile, ":ARRAY [0..2] OF TagItem;");
  333.     WriteLn (mfile);
  334.     WriteLn (mfile);
  335.  
  336.  
  337.     WriteString (mfile, "BEGIN");
  338.     WriteLn (mfile);
  339.  
  340.     WriteString (mfile, "IF recessed THEN");
  341.     WriteLn (mfile);
  342.  
  343.     WriteString (mfile, "  bevelTagPtr := TAG (bevelTags,");
  344.     WriteLn (mfile);
  345.  
  346.     WriteString (mfile, "\t\t");
  347.     WriteString (mfile, "gtVisualInfo,");
  348.     WriteFill   (mfile, "", 13);
  349.     WriteString (mfile, "vi,");
  350.     WriteLn (mfile);
  351.  
  352.     WriteString (mfile, "\t\t");
  353.     WriteString (mfile, "gtbbRecessed,");
  354.     WriteFill   (mfile, "", 13);
  355.     WriteString (mfile, "TRUE,");
  356.     WriteLn (mfile);
  357.  
  358.     WriteString (mfile, "\t\t");
  359.     WriteString (mfile, "tagEnd);");
  360.     WriteLn (mfile);
  361.  
  362.     WriteString (mfile, "ELSE");
  363.     WriteLn (mfile);
  364.  
  365.     WriteString (mfile, "  bevelTagPtr := TAG (bevelTags,");
  366.     WriteLn (mfile);
  367.  
  368.     WriteString (mfile, "\t\t");
  369.     WriteString (mfile, "gtVisualInfo,");
  370.     WriteFill   (mfile, "", 11);
  371.     WriteString (mfile, "vi,");
  372.     WriteLn (mfile);
  373.  
  374.     WriteString (mfile, "\t\t");
  375.     WriteString (mfile, "tagEnd);");
  376.     WriteLn (mfile);
  377.  
  378.     WriteString (mfile, "  END;");
  379.     WriteLn (mfile);
  380.  
  381.  
  382.     WriteString (mfile, "DrawBevelBoxA (rp, l,t, w,h, bevelTagPtr); ");
  383.     WriteLn (mfile);
  384.  
  385.     WriteString (mfile, "SetAPen (rp, 0);");
  386.     WriteLn (mfile);
  387.  
  388.     WriteString (mfile, "RectFill (rp, l+2,t+1, l+w-3,t+h-2);");
  389.     WriteLn (mfile);
  390.  
  391.     WriteString (mfile, "SetAPen (rp, 1);");
  392.     WriteLn (mfile);
  393.  
  394.  
  395.     WriteString (mfile, "END FilledBBox;");
  396.     WriteLn (mfile);
  397.     WriteLn (mfile)
  398.     END
  399.   END WriteFilledBBox;
  400.  
  401.  
  402. (* WriteGlobalProcs *)
  403. BEGIN
  404. WriteLn (mfile);
  405. WriteComputes;
  406. WriteDrawRast;
  407. WriteFilledBBox
  408. END WriteGlobalProcs;
  409.  
  410.  
  411.  
  412. END GenerateGlobal.
  413.  
  414.