tmenu.pas

Turbo Pascal 6.0编译器源码

unit TMenu;

{$F+,S-}

interface

uses Objects, Menus, App;

type

  PTurboMenuBar = ^TTurboMenuBar;
  TTurboMenuBar = object(TMenuBar)
    constructor Init;
    procedure ChangeParam(Command: Word; S: PString);
  end;

const

  RTurboMenuBar: TStreamRec = (
    ObjType: 10100;
    VmtLink: Ofs(TypeOf(TTurboMenuBar)^);
    Load:    @TTurboMenuBar.load;
    Store:   @TTurboMenuBar.Store
  );

var

  MenuBar: PTurboMenuBar absolute App.MenuBar;

implementation

uses Drivers, Views, TVars, Context;

constructor TTurboMenuBar.Init;
var
  R: TRect;
begin
  R.Assign(0, 0, 80, 1);
  TMenuBar.Init(R, NewMenu(
    NewSubMenu('~饉', hcAboutMenu, NewMenu(
      NewItem('~A~bout...', '', 0, cmAbout, hcAboutItem,
      NewItem('~R~efresh display', '', 0, cmRefreshDisplay, hcRefreshDisplayItem,
      NewItem('~C~lear desktop', '', 0, cmClearDesktop, hcClearDesktopItem,
      nil)))),
    NewSubMenu('~F~ile', hcFileMenu, NewMenu(
      NewItem('~O~pen...', 'F3', kbF3, cmOpen, hcOpenItem,
      NewItem('~N~ew', '', 0, cmNew, hcNewItem,
      NewItem('~S~ave', 'F2', kbF2, cmSave, hcSaveItem,
      NewItem('S~a~ve as...', '', 0, cmSaveAs, hcSaveAsItem,
      NewItem('Save a~l~l', '', 0, cmSaveAll, hcSaveAllItem,
      NewLine(
      NewItem('~C~hange dir...', '', 0, cmChangeDir, hcChangeDirItem,
      NewItem('~P~rint', '', 0, cmPrint, hcPrintItem,
      NewItem('~G~et info...', '', 0, cmGetInfo, hcGetInfoItem,
      NewItem('~D~OS shell', '', 0, cmDosShell, hcDosShellItem,
      NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, hcExitItem,
      nil)))))))))))),
    NewSubMenu('~E~dit', hcEditMenu, NewMenu(
      NewItem('~R~estore line', '', 0, cmRestoreLine, hcRestoreLineItem,
      NewLine(
      NewItem('Cu~t~', 'Shift-Del', kbShiftDel, cmCut, hcCutItem,
      NewItem('~C~opy', 'Ctrl-Ins', kbCtrlIns, cmCopy, hcCopyItem,
      NewItem('~P~aste', 'Shift-Ins', kbShiftIns, cmPaste, hcPasteItem,
      NewItem('Copy ~e~xample', '', 0, cmCopyExample, hcCopyExampleItem,
      NewItem('~S~how clipboard', '', 0, cmShowClipboard, hcShowClipboardItem,
      NewLine(
      NewItem('C~l~ear', 'Ctrl-Del', kbCtrlDel, cmClear, hcClearItem,
      nil)))))))))),
    NewSubMenu('~S~earch', hcSearchMenu, NewMenu(
      NewItem('~F~ind...', '', 0, cmFind, hcFindItem,
      NewItem('~R~eplace...', '', 0, cmReplace, hcReplaceItem,
      NewItem('~S~earch again', '', 0, cmSearchAgain, hcSearchAgainItem,
      NewItem('~G~o to line number...', '', 0, cmGotoLineNumber, hcGotoLineNumberItem,
      NewItem('Find ~P~rocedure...', '', 0, cmFindProcedure, hcFindProcedureItem,
      NewItem('Find ~e~rror...', '', 0, cmFindError, hcFindErrorItem,
      nil))))))),
    NewSubMenu('~R~un', hcRunMenu, NewMenu(
      NewItem('~R~un','Ctrl-F9', kbCtrlF9, cmRun, hcRunItem,
      NewItem('~P~rogram reset', 'Ctrl-F2', kbCtrlF2, cmProgramReset, hcProgramResetItem,
      NewItem('~G~o to cursor', 'F4', kbF4, cmGotoCursor, hcGotoCursorItem,
      NewItem('~T~race into', 'F7', kbF7, cmTraceInto, hcTraceIntoItem,
      NewItem('~S~tep over', 'F8', kbF8, cmStepOver, hcStepOverItem,
      NewItem('P~a~rameters...', '', 0, cmParameters, hcParametersItem,
      nil))))))),
    NewSubMenu('~C~ompile', hcCompileMenu, NewMenu(
      NewItem('~C~ompile', 'Alt-F9', kbAltF9, cmCompile, hcCompileItem,
      NewItem('~M~ake', 'F9', kbF9, cmMake, hcMakeItem,
      NewItem('~B~uild', '', 0, cmBuild, hcBuildItem,
      NewItem('~D~estination', 'Memory', 0, cmDestination, hcDestinationItem,
      NewItem('~P~rimary file...', '', 0, cmPrimaryFile, hcPrimaryFileItem,
      nil)))))),
    NewSubMenu('~D~ebug', hcDebugMenu, NewMenu(
      NewItem('~E~valuate/modify...', 'Ctrl-F4', kbCtrlF4, cmEvaluate, hcEvaluateItem,
      NewSubMenu('~W~atches', hcWatchesSubMenu, NewMenu(
	NewItem('~A~dd watch...', 'Ctrl-F7', kbCtrlF7, cmAddWatch, hcAddWatchItem,
	NewItem('~D~elete watch', '', 0, cmDeleteWatch, hcDeleteWatchItem,
	NewItem('~E~dit watch...', '', 0, cmEditWatch, hcEditWatchItem,
	NewItem('~R~emove all watches', '', 0, cmRemoveAllWatches, hcRemoveAllWatchesItem,
        nil))))),
      NewItem('~T~oggle breakpoint', 'Ctrl-F8', kbCtrlF8, cmToggleBreakpoint, hcToggleBreakpointItem,
      NewItem('~B~reakpoints...', '', 0, cmBreakpoints, hcBreakpointsItem,
      nil))))),
    NewSubMenu('~O~ptions', hcOptionsMenu, NewMenu(
      NewItem('~C~ompiler...', '', 0, cmCompilerOptions, hcCompilerOptionsItem,
      NewItem('~M~emory sizes...', '', 0, cmMemorySizes, hcMemorySizesItem,
      NewItem('~L~inker...', '', 0, cmLinkerOptions, hcLinkerOptionsItem,
      NewItem('De~b~ugger...', '', 0, cmDebuggerOptions, hcDebuggerOptionsItem,
      NewItem('~D~irectories...', '', 0, cmDirectories, hcDirectoriesItem,
      NewLine(
      NewSubMenu('~E~nvironment', hcEnvironmentSubMenu, NewMenu(
	NewItem('~P~references...', '', 0, cmPreferences, hcPreferencesItem,
	NewItem('~E~ditor...', '', 0, cmEditorOptions, hcEditorItem,
	NewItem('~M~ouse...', '', 0, cmMouseOptions, hcMouseItem,
	NewItem('~S~tartup...', '', 0, cmStartupOptions, hcStartupItem,
	NewItem('~C~olors...', '', 0, cmColors, hcColorsItem,
        nil)))))),
      NewLine(
      NewItem('~S~ave options ...', '', 0, cmSaveOptions, hcSaveOptionsItem,
      NewItem('~R~etrieve options...', '', 0, cmRetrieveOptions, hcRetrieveOptionsItem,
      nil))))))))))),
    NewSubMenu('~W~indow', hcWindowMenu, NewMenu(
      NewItem('~S~ize/Move', 'Ctrl-F5', kbCtrlF5, cmResize, hcResizeItem,
      NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcZoomItem,
      NewItem('~T~ile', '', 0, cmTile, hcTileItem,
      NewItem('C~a~scade', '', 0, cmCascade, hcCascadeItem,
      NewItem('~N~ext', 'F6', kbF6, cmNext, hcNextItem,
      NewItem('~P~revious', 'Shift-F6', kbShiftF6, cmPrev, hcPreviousItem,
      NewItem('~C~lose', 'Alt-F3', kbAltF3, cmClose, hcCloseItem,
      NewLine(
      NewItem('~W~atch', '', 0, cmWatchWindow, hcWatchItem,
      NewItem('~R~egister', '', 0, cmRegisterWindow, hcRegisterItem,
      NewItem('~O~utput', '', 0, cmOutputWindow, hcOutputItem,
      NewItem('Call stac~k~', 'Ctrl-F3', kbCtrlF3, cmCallStackWindow, hcCallStackItem,
      NewItem('~U~ser screen', 'Alt-F5', kbAltF5, cmUserScreen, hcUserScreenItem,
      NewLine(
      NewItem('~L~ist...', 'Alt-0', kbAlt0, cmWindowList, hcWindowListItem,
      nil)))))))))))))))),
    NewSubMenu('~H~elp', hcHelpMenu, NewMenu(
      NewItem('~C~ontents', '', 0, cmHelpContents, hcContentsItem,
      NewItem('~I~ndex', 'Shift-F1', kbShiftF1, cmHelpIndex, hcIndexItem,
      NewItem('~T~opic search', 'Ctrl-F1', kbCtrlF1, cmTopicSearch, hcTopicSearchItem,
      NewItem('~P~revious topic', 'Alt-F1', kbAltF1, cmPreviousTopic, hcPreviousTopicItem,
      NewItem('~H~elp on help', '', 0, cmHelpOnHelp, hcHelpOnHelpItem,
      nil)))))),
    nil))))))))))));
end;

procedure TTurboMenuBar.ChangeParam(Command: Word; S: PString);

procedure DoChange(PM: PMenu);
var
  P, Q: PMenuItem;
begin
  if PM = nil then
    Exit;
  P := PM^.Items;
  while P <> nil do
  begin
    if P^.Name <> nil then
    begin
      if P^.Command = Command then
      begin
        DisposeStr(P^.Param);
        P^.Param := S;
        Exit
      end else if P^.Command = 0 then
        DoChange(P^.SubMenu);
    end;
    P := P^.Next;
  end;
end;

begin
  DoChange(Menu);
end;

end.