├── LICENSE.txt ├── README.md ├── Tool.Interface ├── ACE.pas ├── Build ├── Common.pas ├── ControlMgr.pas ├── DeskMgr.pas ├── DeskTopBus.pas ├── DialogMgr.pas ├── EventMgr.pas ├── Finder.pas ├── FontMgr.pas ├── GSOS.pas ├── HyperStudio.pas ├── HyperXCMD.pas ├── IntegerMath.pas ├── LineEdit.pas ├── ListMgr.pas ├── MIDI.pas ├── MIDISynth.pas ├── MemoryMgr.pas ├── MenuMgr.pas ├── MscToolSet.pas ├── MultiMedia.pas ├── ORCAShell.pas ├── ObjIntf.pas ├── PrintMgr.pas ├── ProDOS.pas ├── QuickDrawII.pas ├── ResourceMgr.pas ├── SFToolSet.pas ├── Scheduler.pas ├── ScrapMgr.pas ├── Sequencer.pas ├── SoundMgr.pas ├── Synthesizer.pas ├── TextEdit.pas ├── TextToolSet.pas ├── ToolLocator.pas └── WindowMgr.pas ├── backup ├── call.pas ├── cgc.asm ├── cgc.macros ├── cgc.pas ├── cgi.asm ├── cgi.comments ├── cgi.pas ├── count ├── dag.asm ├── dag.macros ├── dag.pas ├── gen.pas ├── linkit ├── make ├── native.asm ├── native.macros ├── native.pas ├── objout.asm ├── objout.macros ├── objout.pas ├── parser.pas ├── pascal.notes ├── pascal.pas ├── pascal.rez ├── pcommon.asm ├── pcommon.macros ├── pcommon.pas ├── scanner.asm ├── scanner.macros ├── scanner.pas ├── smac ├── symbols.asm ├── symbols.macros └── symbols.pas /LICENSE.txt: -------------------------------------------------------------------------------- 1 | ORCA/Pascal is released by the copyright holder under the terms of the original copyright. 2 | 3 | The Byte Works, Inc. grants you the right to use this source code privately, fork it, and change it. 4 | 5 | You may not redistribute the code in any form other than submission to this repository without the written permission of the copyright holder. 6 | 7 | The copyright holder decided to do things this way for two reasons: 8 | 9 | 1. Reserve commercial distribution rights. 10 | 11 | 2. Ensure that any contributions and updates are available from a centralized source (this GitHib repository, for now). 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ORCA-Pascal 2 | Apple IIGS ORCA/Pascal Compiler, an ISO Pascal compiler for the 65816 with libraries for the Apple IIGS 3 | 4 | __See the release page for any releases past the base release [releases page][releases]. The full compiler and development envirnment are available as part of the [Opus \]\[](https://juiced.gs/store/opus-ii-software/) collection sold by Juiced.GS.__ 5 | 6 | [releases]: https://github.com/byteworksinc/ORCA-Pascal/releases 7 | 8 | If you would like to make changes to this compiler and distribute them to others, feel free to submit them here. If the changes apply to compilation on and for an Apple IIGS, they will generally be approved for distribution on the master branch unless the changes deviate significantly from the ISO Pascal standard. For changes that deviate from ISO Pascal or changes that retarget the compiler to run on a different platform or generate code for a different platform, the project will either be forked or a new repository will be created, as appropriate. 9 | 10 | The general conditions that must be met before a change is released on master are: 11 | 12 | 1. The modified compiler must compile under the currently released version of ORCA/M and ORCA/Pascal. 13 | 14 | 2. All samples from the original ORCA/Pascal distribution must compile and execute under the modified compiler, or the sample must be updated, too. 15 | 16 | 3. The compiler must pass the ORCA/Pascal test suite, or the test suite must be suitably modified, too. The test suite is based on a commercial product, so it cannot be uploaded here. Contributors should contact the Byte Works to inquire about acces to the test suite. 17 | 18 | 4. The compiler must work with the current ORCA/Pascal libraries, or the libraries must be modified, too. 19 | 20 | Contact support@byteworks.us if you need contributor access. 21 | 22 | A complete distribution of the ORCA languages, including installers and documentation, is available from the Juiced GS store at https://juiced.gs/store/category/software/. It is distributed as part of the Opus ][ package. 23 | 24 | ## Line Endings and File Types 25 | 26 | The text and source files in this repository originally used CR line endings, as usual for Apple II text files, but they have been converted to use LF line endings because that is the format expected by Git. If you wish to move them to a real or emulated Apple II and build them there, you will need to convert them back to CR line endings. 27 | 28 | If you wish, you can configure Git to perform line ending conversions as files are checked in and out of the Git repository. With this configuration, the files in your local working copy will contain CR line endings suitable for use on an Apple II. To set this up, perform the following steps in your local copy of the Git repository (these should be done when your working copy has no uncommitted changes): 29 | 30 | 1. Add the following lines at the end of the `.git/config` file: 31 | ``` 32 | [filter "crtext"] 33 | clean = LC_CTYPE=C tr \\\\r \\\\n 34 | smudge = LC_CTYPE=C tr \\\\n \\\\r 35 | ``` 36 | 37 | 2. Add the following line to the `.git/info/attributes` file, creating it if necessary: 38 | ``` 39 | * filter=crtext 40 | ``` 41 | 42 | 3. Run the following commands to convert the existing files in your working copy: 43 | ``` 44 | rm .git/index 45 | git checkout HEAD -- . 46 | ``` 47 | 48 | Alternatively, you can keep the LF line endings in your working copy of the Git repository, but convert them when you copy the files to an Apple II. There are various tools to do this. One option is `udl`, which is [available][udl] both as a IIGS shell utility and as C code that can be built and used on modern systems. 49 | 50 | [udl]: http://ftp.gno.org/pub/apple2/gs.specific/gno/file.convert/udl.114.shk 51 | 52 | In addition to converting the line endings, you will also have to set the files to the appropriate file types before building ORCA/C on a IIGS. The included `settypes` script (for use under the ORCA shell) does this for the sources to the ORCA/C compiler itself, although it does not currently cover the test cases and headers. 53 | -------------------------------------------------------------------------------- /Tool.Interface/ACE.pas: -------------------------------------------------------------------------------- 1 | {$keep 'ACE'} 2 | unit ACE; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * ACE Tool Set Interface File (Apple IIGS Audio 8 | * Compression and Expansion) 9 | * 10 | * Other USES Files Needed: Common 11 | * 12 | * Other Tool Sets Needed: Tool Locator 13 | * 14 | * Copyright 1987-1992 15 | * By the Byte Works, Inc. 16 | * All Rights Reserved 17 | * 18 | *********************************************************} 19 | 20 | uses 21 | Common; 22 | 23 | 24 | procedure ACEBootInit; tool ($1D, $01); (* WARNING: an application should 25 | NEVER make this call *) 26 | 27 | procedure ACEStartup (zeroPageLoc: integer); tool ($1D, $02); 28 | 29 | procedure ACEShutdown; tool ($1D, $03); 30 | 31 | function ACEVersion: integer; tool ($1D, $04); 32 | 33 | procedure ACEReset; tool ($1D, $05); (* WARNING: an application should 34 | NEVER make this call *) 35 | 36 | function ACEStatus: boolean; tool ($1D, $06); 37 | 38 | function ACEInfo (infoItemCode: integer): longint; tool ($1D, $07); 39 | 40 | procedure ACECompBegin; tool ($1D, $0B); 41 | 42 | procedure ACECompress (src: handle; srcOffset: longint; dest: handle; 43 | destOffset: longint; nBlks, method: integer); 44 | tool ($1D, $09); 45 | 46 | procedure ACEExpand (src: handle; srcOffset: longint; dest: handle; 47 | destOffset: longint; nBlks, method: integer); 48 | tool ($1D, $0A); 49 | 50 | procedure ACEExpBegin; tool ($1D, $0C); 51 | 52 | function GetACEExpState: ptr; tool ($1D, $0D); 53 | 54 | procedure SetACEExpState (buffer: ptr); tool ($1D, $0E); 55 | 56 | implementation 57 | end. 58 | -------------------------------------------------------------------------------- /Tool.Interface/Build: -------------------------------------------------------------------------------- 1 | set list Common ACE ControlMgr DeskMgr DeskTopBus DialogMgr EventMgr 2 | set list {list} Finder QuickDrawII FontMgr GSOS HyperStudio HyperXCMD 3 | set list {list} IntegerMath LineEdit ListMgr MemoryMgr MenuMgr MIDI MIDISynth 4 | set list {list} MscToolSet MultiMedia ObjIntf ORCAShell PrintMgr ProDOS 5 | set list {list} ResourceMgr Scheduler ScrapMgr Sequencer SFToolSet SoundMgr 6 | set list {list} Synthesizer TextEdit TextToolSet ToolLocator WindowMgr 7 | 8 | for i in {list} 9 | echo Processing {i} 10 | compile +t +e {i}.pas 11 | copy -c {i}.int 2/orcapascaldefs/ 12 | delete {i}.int {i}.a 13 | end 14 | -------------------------------------------------------------------------------- /Tool.Interface/DeskMgr.pas: -------------------------------------------------------------------------------- 1 | {$keep 'DeskMgr'} 2 | unit DeskMgr; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * Desk Manager Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other Tool Sets Needed: Tool Locator, Memory Manager, 12 | * Miscellaneous Tool Set, Quick Draw II, 13 | * Event Manager, Window Manager, Menu Manager, 14 | * Control Manager, LineEdit Tool Set, 15 | * Dialog Manager, Scrap Manager 16 | * 17 | * Copyright 1987-1992 18 | * By the Byte Works, Inc. 19 | * All Rights Reserved 20 | * 21 | *********************************************************} 22 | 23 | uses 24 | Common; 25 | 26 | const 27 | (* NDA action codes *) 28 | eventAction = $0001; (* code for event to be handled by NDA *) 29 | runAction = $0002; (* code passed when time period elapsed *) 30 | cursorAction = $0003; (* code if NDA is frontmost window *) 31 | undoAction = $0005; (* code when user selects Undo *) 32 | cutAction = $0006; (* code when user selects Cut *) 33 | copyAction = $0007; (* code when user selects Copy *) 34 | pasteAction = $0008; (* code when user selects Paste *) 35 | clearAction = $0009; (* code when user selects Clear *) 36 | 37 | (* edit types *) 38 | undoEdit = $0001; (* Undo edit type *) 39 | cutEdit = $0002; (* Cut edit type *) 40 | copyEdit = $0003; (* Copy edit type *) 41 | pasteEdit = $0004; (* Paste edit type *) 42 | clearEdit = $0005; (* Clear edit type *) 43 | 44 | 45 | type 46 | CDA_ID = record 47 | DAName: pString; 48 | DAstart: procPtr; 49 | DAShutDown: procPtr; 50 | end; 51 | CDA_IDPtr = ^CDA_ID; 52 | CDA_IDHandle = ^CDA_IDPtr; 53 | 54 | NDA_ID = record 55 | openRtn: procPtr; 56 | closeRtn: procPtr; 57 | actionRtn: procPtr; 58 | initRtn: procPtr; 59 | period: integer; 60 | eventMask: integer; 61 | menuText: cString; 62 | end; 63 | NDA_IDPtr = ^NDA_ID; 64 | NDA_IDHandle = ^NDA_IDPtr; 65 | 66 | stringTable = record 67 | titleStr: cStringPtr; 68 | controlStr: cStringPtr; 69 | quitStr: cStringPtr; 70 | selectStr: cStringPtr; 71 | end; 72 | stringTblPtr = ^stringTable; 73 | 74 | runItem = record 75 | reserved: longint; 76 | period: integer; 77 | signature: integer; 78 | reserved2: longint; 79 | end; 80 | runItemPtr = ^runItem; 81 | 82 | 83 | procedure DeskBootInit; tool ($05, $01); (* WARNING: an application should 84 | NEVER make this call *) 85 | 86 | procedure DeskStartUp; tool ($05, $02); 87 | 88 | procedure DeskShutDown; tool ($05, $03); 89 | 90 | function DeskVersion: integer; tool ($05, $04); 91 | 92 | procedure DeskReset; tool ($05, $05); (* WARNING: an application should NEVER 93 | make this call *) 94 | 95 | function DeskStatus: boolean; tool ($05, $06); 96 | 97 | procedure AddToRunQ (header: runItemPtr); tool ($05, $1F); 98 | 99 | procedure CallDeskAcc (flags: integer; daReference: univ longint; 100 | action: integer; bufferPtr: longint); tool ($05, $24); 101 | 102 | procedure ChooseCDA; tool ($05, $11); (* WARNING: an application should NEVER 103 | make this call *) 104 | 105 | procedure CloseAllNDAs; tool ($05, $1D); 106 | 107 | procedure CloseNDA (refNum: integer); tool ($05, $16); 108 | 109 | procedure CloseNDAbyWinPtr (theWindow: grafPortPtr); tool ($05, $1C); 110 | 111 | procedure FixAppleMenu (menuID: integer); tool ($05, $1E); 112 | 113 | procedure GetDeskAccInfo (flags: integer; daReference: univ longint; 114 | buffSize: integer; bufferPtr: ptr); tool ($05, $23); 115 | 116 | function GetDeskGlobal (selector: integer): longint; tool ($05, $25); 117 | 118 | function GetDAStrPtr: stringTblPtr; tool ($05, $14); 119 | 120 | function GetNumNDAs: integer; tool ($05, $1B); 121 | 122 | procedure InstallCDA (IDHandle: handle); tool ($05, $0F); 123 | 124 | procedure InstallNDA (IDHandle: NDA_IDHandle); tool ($05, $0E); 125 | 126 | function OpenNDA (DAIDNumber: integer): integer; tool ($05, $15); 127 | 128 | procedure RemoveFromRunQ (header: runItemPtr); tool ($05, $20); 129 | 130 | procedure RemoveCDA (IDHandle: CDA_IDHandle); tool ($05, $21); 131 | 132 | procedure RemoveNDA (IDHandle: NDA_IDHandle); tool ($05, $22); 133 | 134 | procedure RestAll; tool ($05, $0C); (* WARNING: an application should NEVER 135 | make this call *) 136 | 137 | procedure RestScrn; tool ($05, $0A); (* WARNING: an application should NEVER 138 | make this call *) 139 | 140 | procedure SaveAll; tool ($05, $0B); (* WARNING: an application should 141 | NEVER make this call *) 142 | 143 | procedure SaveScrn; tool ($05, $09); (* WARNING: an application should 144 | NEVER make this call *) 145 | 146 | procedure SetDAStrPtr (altDispHandle: handle; newStrings: stringTblPtr); 147 | tool ($05, $13); 148 | 149 | procedure SystemClick (var theEvent: eventRecord; theWindow: grafPortPtr; 150 | findWindowResult: integer); tool ($05, $17); 151 | 152 | function SystemEdit (editType: integer): boolean; tool ($05, $18); 153 | 154 | function SystemEvent (eventWhat: integer; eventMessage, eventWhen, eventWhere: 155 | longint; eventMods: integer): boolean; tool ($05, $1A); 156 | 157 | procedure SystemTask; tool ($05, $19); 158 | 159 | implementation 160 | end. 161 | -------------------------------------------------------------------------------- /Tool.Interface/DeskTopBus.pas: -------------------------------------------------------------------------------- 1 | {$keep 'DeskTopBus'} 2 | unit DeskTopBus; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * Desktop Bus Tool Set Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other Tool Sets Needed: Tool Locator, Memory Manager 12 | * 13 | * Copyright 1987-1990 14 | * By the Byte Works, Inc. 15 | * All Rights Reserved 16 | * 17 | *********************************************************} 18 | 19 | uses 20 | Common; 21 | 22 | const 23 | readModes = $000A; (* read modes of ADB command *) 24 | readConfig = $000B; (* read configuration of ADB command *) 25 | readADBError = $000C; (* read ADB error byte of ADB command *) 26 | readVersionNum = $000D; (* read version number of ADB command *) 27 | readAvailCharSet = $000E; (* read available character sets *) 28 | readAvailLayout = $000F; (* read available keyboard layouts *) 29 | 30 | readMicroMem = $0009; (* read data byte from kybd controller *) 31 | 32 | abort = $0001; (* abort; no operation *) 33 | resetKbd = $0002; (* reset keyboard microcontroller *) 34 | flushKbd = $0003; (* flush keyboard *) 35 | setModes = $0004; (* set modes *) 36 | clearModes = $0005; (* clear modes *) 37 | setConfig = $0006; (* set configuration *) 38 | synch = $0007; (* synch *) 39 | writeMicroMem = $0008; (* write microcontroller memory *) 40 | resetSys = $0010; (* reset system *) 41 | keyCode = $0011; (* send ADB key code *) 42 | resetADB = $0040; (* reset ADB *) 43 | transmitADBBytes = $0047; (* transmit ADB bytes *) 44 | enableSRQ = $0050; (* enable SRQ *) 45 | flushADBDevBuf = $0060; (* flush buffer on ADB device *) 46 | disableSRQ = $0070; (* disable SRQ *) 47 | transmit2ADBBytes = $0080; (* transmit 2 ADB bytes *) 48 | listen = $0080; (* ADB listen command *) 49 | talk = $00C0; (* ADB talk command *) 50 | 51 | type 52 | readConfigRec = record 53 | rcADBAddr: byte; 54 | rcLayoutOrLang: byte; 55 | rcRepeatDelay: byte; 56 | end; 57 | 58 | setConfigRec = record 59 | scADBAddr: byte; 60 | scLayoutOrLang: byte; 61 | scRepeatDelay: byte; 62 | end; 63 | 64 | synchRec = record 65 | synchMode: byte; 66 | synchKybdMouseAddr: byte; 67 | synchLayoutOrLang: byte; 68 | synchRepeatDelay: byte; 69 | end; 70 | 71 | scaleRec = record 72 | xDivide: integer; 73 | yDivide: integer; 74 | xOffset: integer; 75 | yOffset: integer; 76 | xMultiply: integer; 77 | yMultiply: integer; 78 | end; 79 | 80 | 81 | procedure ADBBootInit; tool ($09, $01); (* WARNING: an application should 82 | NEVER make this call *) 83 | 84 | procedure ADBStartUp; tool ($09, $02); 85 | 86 | procedure ADBShutDown; tool ($09, $03); 87 | 88 | function ADBVersion: integer; tool ($09, $04); 89 | 90 | procedure ADBReset; tool ($09, $05); (* WARNING: an application should NEVER 91 | NEVER make this call *) 92 | 93 | function ADBStatus: boolean; tool ($09, $06); 94 | 95 | procedure AbsON; tool ($09, $0F); 96 | 97 | procedure AbsOFF; tool ($09, $10); 98 | 99 | procedure AsyncADBReceive (compPtr: procPtr; adbCommand: integer); 100 | tool ($09, $0D); 101 | 102 | procedure ClearSRQTable; tool ($09, $16); 103 | 104 | procedure GetAbsScale (var dataInPtr: scaleRec); tool ($09, $13); 105 | 106 | function ReadAbs: boolean; tool ($09, $11); 107 | 108 | procedure ReadKeyMicroData (dataLength: integer; dataPtr: ptr; 109 | adbCommand: integer); tool ($09, $0A); 110 | 111 | procedure ReadKeyMicroMemory (dataOutPtr, dataInPtr: ptr; 112 | adbCommand: integer); tool ($09, $0B); 113 | 114 | procedure SendInfo (dataLength: integer; dataPtr: ptr; adbCommand: integer); 115 | tool ($09, $09); 116 | 117 | procedure SetAbsScale (var dataOutPtr: scaleRec); tool ($09, $12); 118 | 119 | procedure SRQPoll (compPtr: procPtr; adbRegAddr: integer); tool ($09, $14); 120 | 121 | procedure SRQRemove (adbRegAddr: integer); tool ($09, $15); 122 | 123 | procedure SyncADBReceive (inputWord: integer; compPtr: procPtr; 124 | adbCommand: integer); tool ($09, $0E); 125 | 126 | implementation 127 | 128 | end. 129 | -------------------------------------------------------------------------------- /Tool.Interface/EventMgr.pas: -------------------------------------------------------------------------------- 1 | {$keep 'EventMgr'} 2 | unit EventMgr; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * Event Manager Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other Tool Sets Needed: Tool Locator, Memory Manager, 12 | * Miscellaneous Tool Set, Quick Draw II, 13 | * Desk Manager, ADB Tool Set 14 | * 15 | * Copyright 1987-1990 16 | * By the Byte Works, Inc. 17 | * All Rights Reserved 18 | * 19 | *********************************************************} 20 | 21 | uses 22 | Common; 23 | 24 | const 25 | (* Event codes are in the Common.Intf interface file *) 26 | 27 | (* event masks *) 28 | mDownMask = $0002; (* call applies to mouse-down events *) 29 | mUpMask = $0004; (* call applies to mouse-up events *) 30 | keyDownMask = $0008; (* call applies to key-down events *) 31 | autoKeyMask = $0020; (* call applies to auto-key events *) 32 | updateMask = $0040; (* call applies to update events *) 33 | activeMask = $0100; (* call applies to activate events *) 34 | switchMask = $0200; (* call applies to switch events *) 35 | deskAccMask = $0400; (* call applies to desk accessory events *) 36 | driverMask = $0800; (* call applies to device driver events *) 37 | app1Mask = $1000; (* call applies to application-1 events *) 38 | app2Mask = $2000; (* call applies to application-2 events *) 39 | app3Mask = $4000; (* call applies to application-3 events *) 40 | app4Mask = $8000; (* call applies to application-4 events *) 41 | everyEvent = $FFFF; (* call applies to all events *) 42 | 43 | (* journal codes *) 44 | jcTickCount = $00; (* TickCount call *) 45 | jcGetMouse = $01; (* GetMouse call *) 46 | jcButton = $02; (* Button call *) 47 | jcEvent = $04; (* GetNextEvent and EventAvail calls *) 48 | 49 | (* Modifier flags *) 50 | activeFlag = $0001; (* set if window was activated *) 51 | changeFlag = $0002; (* set if active window changed state *) 52 | btn1State = $0040; (* set if button 1 was up *) 53 | btn0State = $0080; (* set if button 0 was up *) 54 | appleKey = $0100; (* set if Apple key was down *) 55 | shiftKey = $0200; (* set if Shift key was down *) 56 | capsLock = $0400; (* set if Caps Lock key was down *) 57 | optionKey = $0800; (* set if Option key was down *) 58 | controlKey = $1000; (* set if Control key was down *) 59 | keyPad = $2000; (* set if keypress was from key pad *) 60 | 61 | 62 | 63 | procedure EMBootInit; tool ($06, $01); (* WARNING: an application should 64 | NEVER make this call *) 65 | 66 | procedure EMStartUp (dPageAddr, queueSize, xMinClamp, xMaxClamp, yMinClamp, 67 | yMaxClamp, userID: integer); tool ($06, $02); 68 | 69 | procedure EMShutDown; tool ($06, $03); 70 | 71 | function EMVersion: integer; tool ($06, $04); 72 | 73 | procedure EMReset; tool ($06, $05); (* WARNING: an application should 74 | NEVER make this call *) 75 | 76 | function EMStatus: boolean; tool ($06, $06); 77 | 78 | function Button (buttonNumber: integer): boolean; tool ($06, $0D); 79 | 80 | function DoWindows: integer; tool ($06, $09); (* WARNING: an application should 81 | NEVER make this call *) 82 | 83 | function EventAvail (eventMask: integer; var theEvent: eventRecord): boolean; 84 | tool ($06, $0B); 85 | 86 | (* FakeMouse's modLatch_padding are 2 separate parameters, each 1 byte in *) 87 | (* length. Use (modLatch << 8 | padding) to create the parameter. *) 88 | 89 | procedure FakeMouse (changedFlag: integer; modLatch_padding: integer; 90 | xPosition, yPosition, buttonStatus: integer); 91 | tool ($06, $19); 92 | 93 | function FlushEvents (eventMask, stopMask: integer): integer; tool ($06, $15); 94 | 95 | function GetCaretTime: longint; tool ($06, $12); 96 | 97 | function GetDblTime: longint; tool ($06, $11); 98 | 99 | function GetKeyTranslation: integer; tool ($06, $1B); 100 | 101 | procedure GetMouse (var mouseLocPtr: point); tool ($06, $0C); 102 | 103 | function GetNextEvent (eventMask: integer; var theEvent: eventRecord): boolean; 104 | tool ($06, $0A); 105 | 106 | function GetOSEvent (eventMask: integer; var theEvent: eventRecord): boolean; 107 | tool ($06, $16); 108 | 109 | function OSEventAvail (eventMask: integer; var theEvent: eventRecord): boolean; 110 | tool ($06, $17); 111 | 112 | function PostEvent (eventCode: integer; eventMsg: longint): integer; 113 | tool ($06, $14); 114 | 115 | procedure SetAutoKeyLimit (newLimit: integer); tool ($06, $1A); 116 | 117 | procedure SetEventMask (systemEventMask: integer); tool ($06, $18); 118 | 119 | procedure SetKeyTranslation (kTransID: integer); tool ($06, $1C); 120 | 121 | procedure SetSwitch; tool ($06, $13); (* WARNING: only switcher-type 122 | applications should make this call *) 123 | 124 | function StillDown (buttonNumber: integer): boolean; tool ($06, $0E); 125 | 126 | function TickCount: longint; tool ($06, $10); 127 | 128 | function WaitMouseUp (buttonNumber: integer): boolean; tool ($06, $0F); 129 | 130 | implementation 131 | end. 132 | -------------------------------------------------------------------------------- /Tool.Interface/FontMgr.pas: -------------------------------------------------------------------------------- 1 | {$keep 'FontMgr'} 2 | unit FontMgr; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * Font Manager Interface File 8 | * 9 | * Other USES Files Needed: Common, QuickDrawII 10 | * 11 | * Other Tool Sets Needed: Tool Locator, Memory Manager, 12 | * Quick Draw II, Integer Math Tool Set 13 | * 14 | * Copyright 1987-1990 15 | * By the Byte Works, Inc. 16 | * All Rights Reserved 17 | * 18 | *********************************************************} 19 | 20 | uses 21 | Common, QuickDrawII; 22 | 23 | const 24 | (* font stat bits *) 25 | memBit = $0001; (* font is in memory *) 26 | unrealBit = $0002; (* font is scaled from another font *) 27 | apFamBit = $0004; (* font family supplied by application *) 28 | apVarBit = $0008; (* font added by AddFontVar call or *) 29 | (* scaled from such a font *) 30 | purgeBit = $0010; (* font is purgeable *) 31 | notDiskBit = $0020; (* font not in ROM or in FONTS folder *) 32 | notFoundBit = $8000; (* specified font not found *) 33 | 34 | (* font spec bits *) 35 | memOnlyBit = $0001; (* allow only ROM fonts and fonts *) 36 | (* currently in memory *) 37 | realOnlyBit = $0002; (* allow only unscaled fonts *) 38 | anyFamBit = $0004; (* ignore family number in call *) 39 | anyStyleBit = $0008; (* allow any partially matching style *) 40 | anySizeBit = $0010; (* ignore point size in call *) 41 | 42 | (* family stat bits *) 43 | notBaseBit = $0020; (* family is not a base family *) 44 | 45 | (* family spec bits *) 46 | baseOnlyBit = $0020; (* allow only base families *) 47 | 48 | (* Scale word *) 49 | dontScaleBit = $0001; (* disable font scaling *) 50 | 51 | (* Family Numbers *) 52 | newYork = $0002; 53 | geneva = $0003; 54 | monaco = $0004; 55 | venice = $0005; 56 | london = $0006; 57 | athens = $0007; 58 | sanFran = $0008; 59 | toronto = $0009; 60 | cairo = $000B; 61 | losAngeles = $000C; 62 | times = $0014; 63 | helvetica = $0015; 64 | courier = $0016; 65 | symbol = $0017; 66 | taliesin = $0018; 67 | shaston = $FFFE; 68 | 69 | (* Font records are defined in Common and QuickDrawII interface files. *) 70 | 71 | 72 | procedure FMBootInit; tool ($1B, $01); (* WARNING: an application should 73 | NEVER make this call *) 74 | 75 | procedure FMStartUp (userID, dPageAddr: integer); tool ($1B, $02); 76 | 77 | procedure FMShutDown; tool ($1B, $03); 78 | 79 | function FMVersion: integer; tool ($1B, $04); 80 | 81 | procedure FMReset; tool ($1B, $05); (* WARNING: an application should 82 | NEVER make this call *) 83 | 84 | function FMStatus: boolean; tool ($1B, $06); 85 | 86 | procedure AddFamily (famNum: integer; namePtr: univ pStringPtr); tool ($1B, $0D); 87 | 88 | procedure AddFontVar (theFontHandle: fontHndl; newSpecs: integer); 89 | tool ($1B, $14); 90 | 91 | function ChooseFont (currentID: fontID; famSpecs: integer): longint; 92 | tool ($1B, $16); 93 | 94 | function CountFamilies (famSpecs: integer): integer; tool ($1B, $09); 95 | 96 | function CountFonts (desiredID: fontID; specs: integer): integer; 97 | tool ($1B, $10); 98 | 99 | function FamNum2ItemID (familyNum: integer): integer; tool ($1B, $1B); 100 | 101 | function FindFamily (famSpecs, positionNum: integer; name: univ pStringPtr): 102 | integer; tool ($1B, $0A); 103 | 104 | procedure FindFontStats (desiredID: fontID; specs, positionNum: integer; 105 | var resultPtr: fontStatRec); tool ($1B, $11); 106 | 107 | procedure FixFontMenu (menuID, startingID, famSpecs: integer); tool ($1B, $15); 108 | 109 | function FMGetCurFID: longint; tool ($1B, $1A); 110 | 111 | function FMGetSysFID: longint; tool ($1B, $19); 112 | 113 | procedure FMSetSysFont (theFontID: fontID); tool ($1B, $18); 114 | 115 | function GetFamInfo (famNum: integer; name: univ pStringPtr): integer; 116 | tool ($1B, $0B); 117 | 118 | function GetFamNum (name: univ pStringPtr): integer; tool ($1B, $0C); 119 | 120 | procedure InstallFont (desiredID: fontID; scaleWord: integer); tool ($1B, $0E); 121 | 122 | function InstallWithStats (desiredID: fontID; scaleWord: integer): 123 | fontStatRecPtr; tool ($1B, $1C); 124 | 125 | function ItemID2FamNum (itemID: integer): integer; tool ($1B, $17); 126 | 127 | procedure LoadFont (desiredID: fontID; specs, positionNum: integer; 128 | var resultPtr: fontStatRec); tool ($1B, $12); 129 | 130 | procedure LoadSysFont; tool ($1B, $13); 131 | 132 | procedure SetPurgeStat (theFontID: fontID; purgeStat: integer); tool ($1B, $0F); 133 | 134 | implementation 135 | end. 136 | -------------------------------------------------------------------------------- /Tool.Interface/HyperStudio.pas: -------------------------------------------------------------------------------- 1 | (**************************************************************** 2 | * 3 | * Interface for HyperStudio 4 | * 5 | * Other USES Files Needed: - None - 6 | * 7 | * February 1993 8 | * Mike Westerfield 9 | * 10 | * Thanks to Ken Kashmarek, who supplied the original files from 11 | * wich I shamelessly swiped the names used here. (Of course, 12 | * that made it easier for him to convert his software!) 13 | * 14 | * Copyright 1993 15 | * Byte Works, Inc. 16 | * 17 | ****************************************************************) 18 | 19 | {$keep 'HyperStudio'} 20 | 21 | unit HyperStudio; 22 | 23 | interface 24 | 25 | uses Common; 26 | 27 | const 28 | {Callback numbers} 29 | cMoveToFirst = 1; 30 | cMoveToLast = 2; 31 | cMovePrev = 3; 32 | cMoveNext = 4; 33 | cMoveToID = 5; 34 | cRedrawCard = 6; 35 | cGetStackName = 7; 36 | cFindText = 8; 37 | cPokeyFlag = 9; 38 | cDoMenu = 10; 39 | cGetHSMode = 11; 40 | cGetHSVersion = 12; 41 | cGetStackPathName = 13; 42 | cGetNumCards = 14; 43 | cGetNumButtons = 15; 44 | cGetNumFields = 16; 45 | cGetNumGraphics = 17; 46 | cPoint2StackHead = 18; 47 | cPoint2FirstCard = 19; 48 | cPoint2CurrCard = 20; 49 | cPoint2NextCard = 21; 50 | cPoint2CardItems = 22; 51 | cPoint2NextCdItem = 23; 52 | cPoint2StackItem = 24; 53 | cGetCallerAddr = 25; 54 | cHideStackItem = 26; 55 | cShowStackItem = 27; 56 | cLockItem = 28; 57 | cUnLockItem = 29; 58 | cDeleteStackItem = 30; 59 | cGetItemRect = 31; 60 | cSetItemRect = 32; 61 | cGetButtonIcon = 33; 62 | cSetButtonIcon = 34; 63 | cGetItemStats = 35; 64 | cLaunchApplication = 36; 65 | cGetItemLoc = 37; 66 | cRedrawItem = 38; 67 | cMouseClick = 39; 68 | cGetHSCursorAdr = 40; 69 | cPassText = 41; 70 | cGetClickLoc = 42; 71 | cExecuteButton = 43; 72 | cScrollField = 44; 73 | cSetHSFont = 45; 74 | cSetBrushNum = 46; 75 | cSetLineWidth = 47; 76 | cGetOffScreen = 48; 77 | cGetCurrentScore = 49; 78 | cSetNextTransition = 50; 79 | cIsMenuThere = 51; 80 | cGetUndoBuffer = 52; 81 | cGetCardPalette = 53; 82 | cPlayDiskSound = 54; 83 | cPlayResSound = 55; 84 | cGetSelectedInfo = 56; 85 | cGetPatterns = 57; 86 | cGetFieldText = 58; 87 | cSetFieldText = 59; 88 | cGetHSFont = 60; 89 | cLoadPaintFile = 61; 90 | cSwapCardPos = 62; 91 | cSortCards = 63; 92 | cSetDirtyFlag = 64; 93 | cAddScript2Button = 65; 94 | cCreatePaletteWindow = 66; 95 | cCallNBA = 67; 96 | cCallHS_XCMD = 68; 97 | cGetResRefNums = 69; 98 | cSetBkgdDirty = 70; 99 | cPlaySound = 71; 100 | cGetAdvancedUser = 72; 101 | cVideoOn = 73; 102 | cVideoOff = 74; 103 | cMakeTransMask = 75; 104 | cInitTrans = 76; 105 | cIncTrans = 77; 106 | cHorizStrip = 78; 107 | cVertStrip = 79; 108 | cBrushDialog = 80; 109 | cLineDialog = 81; 110 | cPatternDialog = 82; 111 | cColorDialog = 83; 112 | cStartDrawing = 84; 113 | cDrawToScreen = 85; 114 | cDrawToOffScreen = 86; 115 | cEndDrawing = 87; 116 | cSetDrawColor = 88; 117 | cGetNewBtnName = 89; 118 | cGetSndStatus = 90; 119 | cSetMarkedCard = 91; 120 | cGetNewExtrasMenu = 92; 121 | cGetOtherCursors = 93; 122 | cDoButtonAnimation = 94; 123 | cPlayAnimation = 95; 124 | cFlush2Undo = 96; 125 | cLoadStackField = 97; 126 | cSaveStackField = 98; 127 | cPrintStackField = 99; 128 | cLoadText = 100; 129 | cSaveText = 101; 130 | cPrintText = 102; 131 | cGetPaintVars = 103; 132 | cGetItemHandle = 104; 133 | cBeginXSound = 105; 134 | cEndXSound = 106; 135 | cGetColorCtlDefProc = 107; 136 | 137 | mAboutHyperStudio = 0; 138 | mPreferences = 1; 139 | mNewStack = 2; 140 | mOpenStack = 3; 141 | mSaveStack = 4; 142 | mSaveStackAs = 5; 143 | mLoadBackground = 6; 144 | mSaveBackground = 7; 145 | mAddClipArt = 8; 146 | mPageSetup = 9; 147 | mPrint = 10; 148 | mQuit = 11; 149 | mUndo = 12; 150 | mCut = 13; 151 | mCopy = 14; 152 | mPaste = 15; 153 | mClear = 16; 154 | mNewCard = 17; 155 | mDeleteCard = 18; 156 | mCutCard = 19; 157 | mCopyCard = 20; 158 | mFlipHorizontal = 21; 159 | mFlipVertical = 22; 160 | mEraseBackground = 23; 161 | mBack = 24; 162 | mHome = 25; 163 | mFirstCard = 26; 164 | mPreviousCard = 27; 165 | mNextCard = 28; 166 | mLastCard = 29; 167 | mMoveToCard = 30; 168 | mFindText = 31; 169 | mSetCurrentTool = 32; 170 | mItemInfo = 33; 171 | mCardInfo = 34; 172 | mBackgroundInfo = 35; 173 | mStackInfo = 36; 174 | mBringCloser = 37; 175 | mSendFarther = 38; 176 | mAddButton = 39; 177 | mAddGraphic = 40; 178 | mAddField = 41; 179 | mAddVideo = 42; 180 | mSetCurrentColor = 43; 181 | mLineSizedialog = 44; 182 | mBrushShapedialog = 45; 183 | mToggleDrawFilled = 46; 184 | mToggleDrawMultiple = 47; 185 | mToggleDrawCentered = 48; 186 | mTextStyledialog = 49; 187 | mTextColordialog = 50; 188 | mBackgroundColordialog = 51; 189 | mReplaceColorsdialog = 52; 190 | mEditPattern = 53; 191 | mStandardPaletteRestore = 54; 192 | mHideItems = 55; 193 | mToggleMenubarVisibility = 56; 194 | 195 | type 196 | wString = record {word string} 197 | length: integer; 198 | str: packed array[1..256] of char; 199 | end; 200 | wStringPtr = ^wString; 201 | 202 | HSParams = record {HyperStudio Parameters} 203 | ButtonID: integer; 204 | CardID: integer; 205 | ScriptHand: handle; 206 | ScriptLength: longint; 207 | TextPassedPtr: wStringPtr; 208 | CallBack: ptr; 209 | Version: integer; 210 | MemoryID: integer; 211 | Command: integer; 212 | SubCommand: integer; 213 | CP1: longint; 214 | CP2: longint; 215 | CP3: longint; 216 | CP4: longint; 217 | CP5: longint; 218 | end; 219 | HSParamPtr = ^HSParams; 220 | 221 | procedure __NBACallBack (call: integer; parm: HSParamPtr); extern; 222 | 223 | implementation 224 | 225 | end. 226 | -------------------------------------------------------------------------------- /Tool.Interface/HyperXCMD.pas: -------------------------------------------------------------------------------- 1 | (********************************************************* 2 | * 3 | * Definition file for HyperCard XCMDs and XFCNs in Pascal 4 | * For use with HyperCard IIGS Version 1.1 5 | * 6 | * Other USES Files Needed: Common 7 | * 8 | * Copyright Apple Computer, Inc. 1990-91 9 | * All Rights Reserved 10 | * 11 | * Copyright 1993, Byte Works, Inc. 12 | * 13 | *********************************************************) 14 | 15 | {$keep 'HyperXCMD'} 16 | 17 | unit HyperXCMD; 18 | 19 | interface 20 | 21 | uses Common; 22 | 23 | const 24 | _CallBackVector = $E10220; {HyperCard call entry point} 25 | 26 | {XCMDBlock constants for event.what...} 27 | xOpenEvt = 1000; {the first event after you are created} 28 | xCloseEvt = 1001; {your window is being forced close} 29 | xHidePalettesEvt = 1004; {someone called HideHCPalettes} 30 | xShowPalettesEvt = 1005; {someone called ShowHCPalettes} 31 | xCursorWithin = 1300; {cursor is within the window} 32 | 33 | {XWindow styles} 34 | xWindoidStyle = 0; 35 | xRectStyle = 1; 36 | xShadowStyle = 2; 37 | xDialogStyle = 3; 38 | 39 | type 40 | str19 = string[19]; 41 | string19Ptr = ^str19; 42 | string19Handle = ^string19Ptr; 43 | str31 = string[31]; 44 | string31Ptr = ^str31; 45 | string31Handle = ^string31Ptr; 46 | 47 | XWEventInfo = record 48 | eventWindow: grafPortPtr; 49 | event: eventRecord; 50 | eventParams: array[1..9] of longint; 51 | eventResult: handle; 52 | end; 53 | XWEventInfoPtr = ^XWEventInfo; 54 | 55 | XCMDBlock = record 56 | paramCount: integer; 57 | params: array[1..16] of handle; 58 | returnValue: handle; 59 | passFlag: boolean; 60 | userID: integer; 61 | returnStat: integer; {0 if normal, 1 if error} 62 | end; 63 | XCMDPtr = ^XCMDBlock; 64 | 65 | gsosInStringHandle = ^gsosInStringPtr; 66 | 67 | (**** HyperTalk Utilities ****) 68 | function EvalExpr (expr: pString): handle; vector(_CallBackVector, $0002); 69 | 70 | procedure SendCardMessage (msg: pString); vector(_CallBackVector, $0001); 71 | 72 | procedure SendHCMessage (msg: pString); vector(_CallBackVector, $0005); 73 | 74 | 75 | (**** Memory Utilities ****) 76 | function GetGlobal (globName: pString): handle; vector(_CallBackVector, $0012); 77 | 78 | procedure SetGlobal (globName: pString; globValue: handle); 79 | vector(_CallBackVector, $0013); 80 | 81 | procedure ZeroBytes (dstPtr: ptr; longCount: Longint); 82 | vector(_CallBackVector, $0006); 83 | 84 | 85 | (**** String Utilities ****) 86 | function GSStringEqual (src1: gsosInStringHandle; src2: gsosInStringHandle): boolean; 87 | vector(_CallBackVector, $0022); 88 | 89 | procedure ScanToReturn (var scanPtr: ptr); vector(_CallBackVector, $001C); 90 | 91 | procedure ScanToZero (var scanPtr: ptr); vector(_CallBackVector, $001D); 92 | 93 | function StringEqual (str1: pString; str2: pString): boolean; 94 | vector(_CallBackVector, $001A); 95 | 96 | function StringLength (strPtr: ptr): longint; vector(_CallBackVector, $0003); 97 | 98 | function StringMatch (stringPattern: pString; target: ptr): ptr; 99 | vector(_CallBackVector, $0004); 100 | 101 | 102 | (**** String Conversions ****) 103 | { Standard Pascal does not allow returning strings. 104 | function BoolToStr (bool: boolean): str31; vector(_CallBackVector, $0010); 105 | } 106 | 107 | function CopyGSString (src: gsosInStringHandle): gsosInStringHandle; 108 | vector(_CallBackVector, $0020); 109 | 110 | function GSConcat (src1: gsosInStringHandle; src2: gsosInStringHandle): 111 | gsosInStringHandle; 112 | vector(_CallBackVector, $0021); 113 | 114 | { Standard Pascal does not allow returning strings. 115 | function ExtToStr (extendedNumber: Extended): str31; 116 | vector(_CallBackVector, $0011); 117 | } 118 | 119 | { Standard Pascal does not allow returning strings. 120 | function GSToPString (src: gsosInStringHandle): pString; 121 | vector(_CallBackVector, $001E); 122 | } 123 | 124 | function GSToZero (src: gsosInStringHandle): handle; 125 | vector(_CallBackVector, $0023); 126 | 127 | { Standard Pascal does not allow returning strings. 128 | function LongToStr (posNum: longint): str31; vector(_CallBackVector, $000D); 129 | } 130 | 131 | { Standard Pascal does not allow returning strings. 132 | function NumToHex (longNumber: longint; nDigits: integer): Str19; 133 | vector(_CallBackVector, $000F); 134 | } 135 | 136 | { Standard Pascal does not allow returning strings. 137 | function NumToStr (longNumber: longint): str31; vector(_CallBackVector, $000E); 138 | } 139 | 140 | function PasToZero (str: pString): handle; vector(_CallBackVector, $0007); 141 | 142 | procedure PointToStr (pt: Point; var str: pString); 143 | vector(_CallBackVector, $002D); 144 | 145 | function PToGSString (src: pString): gsosInStringHandle; 146 | vector(_CallBackVector, $001F); 147 | 148 | procedure RectToStr (rct: Rect; var str: pString); 149 | vector(_CallBackVector, $002E); 150 | 151 | procedure ReturnToPas (zeroStr: ptr; var pasStr: pString); 152 | vector(_CallBackVector, $001B); 153 | 154 | function StrToBool (str: str31): boolean; vector(_CallBackVector, $000B); 155 | 156 | function StrToExt (str: str31): Extended; vector(_CallBackVector, $000C); 157 | 158 | function StrToLong (str: str31): longint; vector(_CallBackVector, $0009); 159 | 160 | function StrToNum (str: str31): longint; vector(_CallBackVector, $000A); 161 | 162 | procedure StrToPoint (str: pString; var pt: Point); 163 | vector(_CallBackVector, $002F); 164 | 165 | procedure StrToRect (str: pString; var rct: Rect); 166 | vector(_CallBackVector, $0030); 167 | 168 | function ZeroToGS (src: handle): gsosInStringHandle; 169 | vector(_CallBackVector, $0024); 170 | 171 | procedure ZeroToPas (zeroStr: ptr; var pasStr: pString); 172 | vector(_CallBackVector, $0008); 173 | 174 | 175 | (**** Field Utilities ****) 176 | function GetFieldByID (cardFieldFlag: boolean; fieldID: integer): handle; 177 | vector(_CallBackVector, $0016); 178 | 179 | function GetFieldByName (cardFieldFlag: boolean; fieldName: pString): handle; 180 | vector(_CallBackVector, $0014); 181 | 182 | function GetFieldByNum (cardFieldFlag: boolean; fieldNum: integer): handle; 183 | vector(_CallBackVector, $0015); 184 | 185 | procedure SetFieldByID (cardFieldFlag: boolean; fieldID: integer; 186 | fieldVal: handle); 187 | vector(_CallBackVector, $0019); 188 | 189 | procedure SetFieldByName (cardFieldFlag: boolean; fieldNName: pString; 190 | fieldVal: handle); 191 | vector(_CallBackVector, $0017); 192 | 193 | procedure SetFieldByNum (cardFieldFlag: boolean; fieldNum: integer; 194 | fieldVal: handle); 195 | vector(_CallBackVector, $0018); 196 | 197 | (**** Graphic Utilities ****) 198 | procedure ChangedMaskAndData (whatChanged: integer); 199 | vector(_CallBackVector, $002C); 200 | 201 | procedure GetMaskAndData (var mask: LocInfo; var data: LocInfo); 202 | vector(_CallBackVector, $002B); 203 | 204 | 205 | (**** Miscellaneous Utilities ****) 206 | procedure BeginXSound; vector(_CallBackVector, $0029); 207 | 208 | procedure EndXSound; vector(_CallBackVector, $002A); 209 | 210 | 211 | (**** Resource Names Utilities ****) 212 | function FindNamedResource (resourceType: integer; resourceName: pString; 213 | var theFile: integer; var resourceID: longint): 214 | boolean; 215 | vector(_CallBackVector, $0026); 216 | 217 | { Standard Pascal does not allow returning strings. 218 | function GetResourceName (resourceType: integer; resourceID: longint): pString; 219 | vector(_CallBackVector, $0028); 220 | } 221 | 222 | function LoadNamedResource (resourceType: integer; resourceName: pString): 223 | handle; 224 | vector(_CallBackVector, $0025); 225 | 226 | procedure SetResourceName (resourceType: integer; resourceID: longint; 227 | resourceName: pString); 228 | vector(_CallBackVector, $0027); 229 | 230 | 231 | (**** Creating and Disposing XWindoids ****) 232 | function NewXWindow (boundsRect: Rect; title: str31; visible: boolean; 233 | windowStyle: integer): grafPortPtr; 234 | vector(_CallBackVector, $0031); 235 | 236 | procedure CloseXWindow (window: grafPortPtr); vector(_CallBackVector, $0033); 237 | 238 | 239 | (**** XWindoid Utilities ****) 240 | function GetXWindowValue (window: grafPortPtr): longint; 241 | vector(_CallBackVector, $0037); 242 | 243 | procedure HideHCPalettes; vector(_CallBackVector, $0034); 244 | 245 | procedure ShowHCPalettes; vector(_CallBackVector, $0035); 246 | 247 | procedure SetXWIdleTime (window: grafPortPtr; interval: longint); 248 | vector(_CallBackVector, $0032); 249 | 250 | procedure SetXWindowValue (window: grafPortPtr; customValue: longint); 251 | vector(_CallBackVector, $0036); 252 | 253 | procedure XWAllowReEntrancy (window: grafPortPtr; allowSysEvts: boolean; 254 | allowHCEvts: boolean); 255 | vector(_CallBackVector, $0038); 256 | 257 | implementation 258 | 259 | end. 260 | -------------------------------------------------------------------------------- /Tool.Interface/IntegerMath.pas: -------------------------------------------------------------------------------- 1 | {$keep 'IntegerMath'} 2 | unit IntegerMath; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * Integer Math Tool Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other Tool Sets Needed: Tool Locator, Memory Manager 12 | * 13 | * Copyright 1987-1990 14 | * By the Byte Works, Inc. 15 | * All Rights Reserved 16 | * 17 | *********************************************************} 18 | 19 | uses 20 | Common; 21 | 22 | const 23 | (* Limits *) 24 | minLongint = $80000000; (* min negative signed longint *) 25 | minFrac = $80000000; (* pinned value for neg Frac overflow *) 26 | minFixed = $80000000; (* pinned value for neg Fixed overflow *) 27 | minInt = $8000; (* min negative signed integer *) 28 | maxUInt = $FFFF; (* max positive unsigned integer *) 29 | maxLongint = $7FFFFFFF; (* max positive signed longint *) 30 | maxFrac = $7FFFFFFF; (* pinned value for positive Frac overflow *) 31 | maxFixed = $7FFFFFFF; (* pinned value, positive Fixed overflow *) 32 | maxULong = $FFFFFFFF; (* max unsigned longint *) 33 | 34 | (* Signed Flag *) 35 | unsignedFlag = $0000; (* value is not signed *) 36 | signedFlag = $0001; (* value is signed *) 37 | 38 | type 39 | extendedValue = array [0..9] of byte; 40 | extendedValuePtr = ^extendedValue; 41 | 42 | 43 | procedure IMBootInit; tool ($0B, $01); (* WARNING: an application should 44 | NEVER make this call *) 45 | 46 | procedure IMStartUp; tool ($0B, $02); 47 | 48 | procedure IMShutDown; tool ($0B, $03); 49 | 50 | function IMVersion: integer; tool ($0B, $04); 51 | 52 | procedure IMReset; tool ($0B, $05); (* WARNING: an application should 53 | NEVER make this call *) 54 | 55 | function IMStatus: boolean; tool ($0B, $06); 56 | 57 | function Dec2Int (inputStr: univ cStringPtr; strLength, signedFlag: integer): 58 | integer; tool ($0B, $28); 59 | 60 | function Dec2Long (inputStr: univ cStringPtr; strLength, signedFlag: integer): 61 | longint; tool ($0B, $29); 62 | 63 | function Fix2Frac (fixedValue: longint): longint; tool ($0B, $1C); 64 | 65 | function Fix2Long (fixedValue: longint): longint; tool ($0B, $1B); 66 | 67 | procedure Fix2X (fixedValue: longint; var extendedVal: extendedValue); 68 | tool ($0B, $1E); 69 | 70 | function FixATan2 (input1, input2: longint): longint; tool ($0B, $17); 71 | 72 | function FixDiv (dividend, divisor: longint): longint; tool ($0B, $11); 73 | 74 | function FixMul (multiplicand, multiplier: longint): longint; tool ($0B, $0F); 75 | 76 | function FixRatio (numerator, denominator: integer): longint; tool ($0B, $0E); 77 | 78 | function FixRound (fixedValue: longint): integer; tool ($0B, $13); 79 | 80 | function Frac2Fix (fracValue: longint): longint; tool ($0B, $1D); 81 | 82 | procedure Frac2X (fracValue: longint; var extendedVal: extendedValue); 83 | tool ($0B, $1F); 84 | 85 | function FracCos (angle: longint): longint; tool ($0B, $15); 86 | 87 | function FracDiv (dividend, divisor: longint): longint; tool ($0B, $12); 88 | 89 | function FracMul (multiplicand, multiplier: longint): longint; tool ($0B, $10); 90 | 91 | function FracSin (angle: longint): longint; tool ($0B, $16); 92 | 93 | function FracSqrt (fracValue: longint): longint; tool ($0B, $14); 94 | 95 | function Hex2Int (inputStr: univ cStringPtr; strLength: integer): integer; 96 | tool ($0B, $24); 97 | 98 | function Hex2Long (inputStr: univ cStringPtr; strLength: integer): longint; 99 | tool ($0B, $25); 100 | 101 | function HexIt (value: integer): longint; tool ($0B, $2A); 102 | 103 | function HiWord (longValue: longint): integer; tool ($0B, $18); 104 | 105 | procedure Int2Dec (value: integer; outputStr: univ cStringPtr; 106 | strLength: integer; signedFlag: boolean); tool ($0B, $26); 107 | 108 | procedure Int2Hex (value: integer; outputStr: univ cStringPtr; 109 | strLength: integer); tool ($0B, $22); 110 | 111 | procedure Long2Dec (value: longint; outputStr: univ cStringPtr; 112 | strLength: integer; signedFlag: boolean); tool ($0B, $27); 113 | 114 | function Long2Fix (longValue: longint): longint; tool ($0B, $1A); 115 | 116 | procedure Long2Hex (value: longint; outputStr: univ cStringPtr; 117 | strLength: integer); tool ($0B, $23); 118 | 119 | (* ACTUALLY RETURNS 2 LONG WORDS: REMAINDER AND QUOTIENT 120 | function LongDivide (dividend, divisor: longint): 2 longints; tool ($0B, $0D); 121 | *) 122 | 123 | (* ACTUALLY RETURNS 2 LONG WORDS: MSB AND LSB 124 | function LongMul (multiplicand, multiplier: longint): 2 longints; 125 | tool ($0B, $0C); 126 | *) 127 | 128 | function LoWord (longValue: longint): integer; tool ($0B, $19); 129 | 130 | function Multiply (multiplicand, multiplier: integer): longint; tool ($0B, $09); 131 | 132 | (* SDivide returns 2 words: the lo word = quotient; hi word = remainder *) 133 | function SDivide (dividend, divisor: integer): longint; tool ($0B, $0A); 134 | 135 | (* UDivide returns 2 words: the lo word = quotient; hi word = remainder *) 136 | function UDivide (dividend, divisor: integer): longint; tool ($0B, $0B); 137 | 138 | function X2Fix (var extendedVal: extendedValue): longint; tool ($0B, $20); 139 | 140 | function X2Frac (var extendedVal: extendedValue): longint; tool ($0B, $21); 141 | 142 | implementation 143 | end. 144 | -------------------------------------------------------------------------------- /Tool.Interface/LineEdit.pas: -------------------------------------------------------------------------------- 1 | {$keep 'LineEdit'} 2 | unit LineEdit; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * Line Edit Tool Set Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other Tool Sets Needed: Tool Locator, Memory Manager, 12 | * Quick Draw II, Event Manager 13 | * 14 | * Copyright 1987-1990, 1993 15 | * By the Byte Works, Inc. 16 | * All Rights Reserved 17 | * 18 | *********************************************************} 19 | 20 | uses 21 | Common; 22 | 23 | const 24 | (* Justification *) 25 | leJustLeft = $0000; (* left justify *) 26 | leJustCenter = $0001; (* center *) 27 | leJustRight = $FFFF; (* right justify *) 28 | leJustFill = $0002; (* fill justification *) 29 | 30 | (* LEClassifyKey result values *) 31 | leKeyIsSpecial = $8000; 32 | leKeyIsNumber = $4000; 33 | leKeyIsHex = $2000; 34 | leKeyIsAlpha = $1000; 35 | leKeyIsNonControl = $0800; 36 | 37 | type 38 | leRec = record 39 | leLineHandle: ^cStringPtr; 40 | leLength: integer; 41 | leMaxLength: integer; 42 | leDestRect: rect; 43 | leViewRect: rect; 44 | lePort: grafPortPtr; 45 | leLineHite: integer; 46 | leBaseHite: integer; 47 | leSelStart: integer; 48 | leSelEnd: integer; 49 | leActFlag: integer; 50 | leCarAct: integer; 51 | leCarOn: integer; 52 | leCarTime: longint; 53 | leHiliteHook: procPtr; 54 | leCaretHook: procPtr; 55 | leJust: integer; 56 | lePWChar: integer; 57 | end; 58 | leRecPtr = ^leRec; 59 | leRecHndl = ^leRecPtr; 60 | 61 | 62 | procedure LEBootInit; tool ($14, $01); (* WARNING: an application should 63 | NEVER make this call *) 64 | 65 | procedure LEStartUp (userID, dPageAddr: integer); tool ($14, $02); 66 | 67 | procedure LEShutDown; tool ($14, $03); 68 | 69 | function LEVersion: integer; tool ($14, $04); 70 | 71 | procedure LEReset; tool ($14, $05); (* WARNING: an application should 72 | NEVER make this call *) 73 | 74 | function LEStatus: boolean; tool ($14, $06); 75 | 76 | function GetLeDefProc: procPtr; tool ($14, $24); 77 | 78 | procedure LEActivate (LEHandle: leRecHndl); tool ($14, $0F); 79 | 80 | procedure LEClick (var theEvent: eventRecord; LEHandle: leRecHndl); 81 | tool ($14, $0D); 82 | 83 | procedure LECopy (LEHandle: leRecHndl); tool ($14, $13); 84 | 85 | procedure LECut (LEHandle: leRecHndl); tool ($14, $12); 86 | 87 | procedure LEDeactivate (LEHandle: leRecHndl); tool ($14, $10); 88 | 89 | procedure LEDelete (LEHandle: leRecHndl); tool ($14, $15); 90 | 91 | procedure LEDispose (LEHandle: leRecHndl); tool ($14, $0A); 92 | 93 | procedure LEFromScrap; tool ($14, $19); 94 | 95 | function LEGetScrapLen: integer; tool ($14, $1C); 96 | 97 | function LEGetTextHand (LEHandle: leRecHndl): handle; tool ($14, $22); 98 | 99 | function LEGetTextLen (LEHandle: leRecHndl): integer; tool ($14, $23); 100 | 101 | procedure LEIdle (LEHandle: leRecHndl); tool ($14, $0C); 102 | 103 | procedure LEInsert (theText: univ cStringPtr; textLength: integer; 104 | LEHandle: leRecHndl); tool ($14, $16); 105 | 106 | procedure LEKey (key, modifiers: integer; LEHandle: leRecHndl); 107 | tool ($14, $11); 108 | 109 | function LENew (var destRect, viewRect: rect; maxTextLen: integer): leRecHndl; 110 | tool ($14, $09); 111 | 112 | procedure LEPaste (LEHandle: leRecHndl); tool ($14, $14); 113 | 114 | function LEScrapHandle: handle; tool ($14, $1B); 115 | 116 | procedure LESetCaret (caretProc: procPtr; LEHandle: leRecHndl); 117 | tool ($14, $1F); 118 | 119 | procedure LESetHilite (hiliteProc: procPtr; LEHandle: leRecHndl); 120 | tool ($14, $1E); 121 | 122 | procedure LESetJust (just: integer; LEHandle: leRecHndl); tool ($14, $21); 123 | 124 | procedure LESetScrapLen (newLength: integer); tool ($14, $1D); 125 | 126 | procedure LESetSelect (selStart, selEnd: integer; LEHandle: leRecHndl); 127 | tool ($14, $0E); 128 | 129 | procedure LESetText (theText: univ cStringPtr; textLength: integer; 130 | LEHandle: leRecHndl); tool ($14, $0B); 131 | 132 | procedure LETextBox (theText: univ cStringPtr; textLength: integer; 133 | var box: rect; just: integer); tool ($14, $18); 134 | 135 | procedure LETextBox2 (theText: univ cStringPtr; textLength: integer; 136 | var box: rect; just: integer); tool ($14, $20); 137 | 138 | procedure LEToScrap; tool ($14, $1A); 139 | 140 | procedure LEUpdate (LEHandle: leRecHndl); tool ($14, $17); 141 | 142 | {new in 6.0.1} 143 | 144 | function LEClassifyKey (eventPtr: eventRecord): integer; tool ($14, $25); 145 | 146 | implementation 147 | end. 148 | -------------------------------------------------------------------------------- /Tool.Interface/ListMgr.pas: -------------------------------------------------------------------------------- 1 | {$keep 'ListMgr'} 2 | unit ListMgr; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * List Manager Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other Tool Sets Needed: Tool Locator, Memory Manager, 12 | * Miscellaneous Tool Set, QuickDraw II, 13 | * Event Manager, Window Manager, Control Manager 14 | * 15 | * Copyright 1987-1992 16 | * By the Byte Works, Inc. 17 | * All Rights Reserved 18 | * 19 | *********************************************************} 20 | 21 | uses 22 | Common; 23 | 24 | const 25 | (* Bit mask for listType *) 26 | cStringFlag = $0001; (* null-terminated string type *) 27 | selectOnlyOne = $0002; (* only 1 selection allowed *) 28 | 29 | (* memFlag *) 30 | memDisabled = $40; (* sets member flag to disabled *) 31 | memSelected = $80; (* sets member flag to selected *) 32 | 33 | type 34 | (* Member record is defined in the Common.intf inteface file. *) 35 | 36 | memberList = array [1..100] of memRec; (* user may modify size *) 37 | 38 | listRec = record 39 | listRect: rect; 40 | listSize: integer; 41 | listView: integer; 42 | listType: integer; 43 | listStart: integer; 44 | listCtl: ctlRecHndl; 45 | listDraw: procPtr; 46 | listMemHeight: integer; 47 | listMemSize: integer; 48 | listPointer: memRecPtr; 49 | listRefCon: longint; 50 | listScrollClr: barColorsPtr; 51 | end; 52 | listRecPtr = ^listRec; 53 | 54 | (* List control record: included as part of Control Record. *) 55 | (* See the Common interface file for this record. *) 56 | 57 | (* List color table *) 58 | lColorTable = record 59 | listFrameClr: integer; 60 | listNorTextClr: integer; 61 | listSelTextClr: integer; 62 | listNorBackClr: integer; 63 | listSelBackClr: integer; 64 | end; 65 | 66 | 67 | procedure ListBootInit; tool ($1C, $01); (* WARNING: an application should 68 | NEVER make this call *) 69 | 70 | procedure ListStartUp; tool ($1C, $02); 71 | 72 | procedure ListShutDown; tool ($1C, $03); 73 | 74 | function ListVersion: integer; tool ($1C, $04); 75 | 76 | procedure ListReset; tool ($1C, $05); (* WARNING: an application should 77 | NEVER make this call *) 78 | 79 | function ListStatus: boolean; tool ($1C, $06); 80 | 81 | function CompareStrings (flags: integer; string1, string2: pString): integer; 82 | tool ($1C, $18); 83 | 84 | function CreateList (theWindow: grafPortPtr; var theList: listRec): ctlRecHndl; 85 | tool ($1C, $09); 86 | 87 | procedure DrawMember (theMember: memRecPtr; var theList: listRec); 88 | tool ($1C, $0C); 89 | 90 | procedure DrawMember2 (itemnum: integer; theListCtl: ctlRecHndl); 91 | tool ($1C, $11); 92 | 93 | function GetListDefProc: procPtr; tool ($1C, $0E); 94 | 95 | procedure ListKey (flags: integer; event: eventRecord; listCtl: ctlRecHndl); 96 | tool ($1C, $17); 97 | 98 | procedure NewList (theMember: memRecPtr; var theList: listRec); 99 | tool ($1C, $10); 100 | 101 | procedure NewList2 (drawRtn: procPtr; listStart: integer; listRef: longint; 102 | listRefDesc, listSize: integer; theListCtl: ctlRecHndl); 103 | tool ($1C, $16); 104 | 105 | function NextMember (firstMember: memRecPtr; var theList: listRec): 106 | memRecPtr; tool ($1C, $0B); 107 | 108 | function NextMember2 (itemNum: integer; theListCtl: ctlRecHndl): integer; 109 | tool ($1C, $12); 110 | 111 | function ResetMember (var theList: listRec): memRecPtr; tool ($1C, $0F); 112 | 113 | function ResetMember2 (theListCtl: ctlRecHndl): integer; tool ($1C, $13); 114 | 115 | procedure SelectMember (theMember: memRecPtr; var theList: listRec); 116 | tool ($1C, $0D); 117 | 118 | procedure SelectMember2 (itemNum: integer; theListCtl: ctlRecHndl); 119 | tool ($1C, $14); 120 | 121 | procedure SortList (compareRtn: procPtr; var theList: listRec); tool ($1C, $0A); 122 | 123 | procedure SortList2 (compareRtn: procPtr; theListCtl: ctlRecHndl); 124 | tool ($1C, $15); 125 | 126 | implementation 127 | end. 128 | -------------------------------------------------------------------------------- /Tool.Interface/MIDI.pas: -------------------------------------------------------------------------------- 1 | {$keep 'MIDI'} 2 | unit MIDI; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * MIDI Tool Set Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other Tool Sets Needed: Tool Locator, Memory Manager; 12 | * Sound Manager, Note Synthesizer, 13 | * Note Sequencer (if using Synthesizer 14 | * or Sequencer) 15 | * 16 | * Copyright 1987-1990 17 | * By the Byte Works, Inc. 18 | * All Rights Reserved 19 | * 20 | *********************************************************} 21 | 22 | uses 23 | Common; 24 | 25 | procedure MidiBootInit; tool ($20, $01); (* WARNING: an application should 26 | NEVER make this call *) 27 | 28 | procedure MidiStartup (theUserID, directPageAddr: integer); tool ($20, $02); 29 | 30 | procedure MidiShutdown; tool ($20, $03); 31 | 32 | function MidiVersion: integer; tool ($20, $04); 33 | 34 | procedure MidiReset; tool ($20, $05); (* WARNING: an application should 35 | NEVER make this call *) 36 | 37 | function MidiStatus: boolean; tool ($20, $06); 38 | 39 | procedure MidiClock (funcNum: integer; arg: longint); tool ($20, $0B); 40 | 41 | procedure MidiControl (funcNum: integer; arg: longint); tool ($20, $09); 42 | 43 | procedure MidiDevice (funcNum: integer; driverInfo: ptr); tool ($20, $0A); 44 | 45 | function MidiInfo (funcNum: integer): longint; tool ($20, $0C); 46 | 47 | function MidiReadPacket (bufPtr: ptr; bufSize: integer): integer; 48 | tool ($20, $0D); 49 | 50 | function MidiWritePacket (bufPtr: ptr): integer; tool ($20, $0E); 51 | 52 | implementation 53 | end. 54 | -------------------------------------------------------------------------------- /Tool.Interface/MIDISynth.pas: -------------------------------------------------------------------------------- 1 | {$keep 'MIDISynth'} 2 | unit MIDISynth; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * MIDISynth Tool Set Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Copyright 1993 12 | * By the Byte Works, Inc. 13 | * All Rights Reserved 14 | * 15 | *********************************************************} 16 | 17 | uses 18 | Common; 19 | 20 | const 21 | {Error Codes} 22 | msAlreadyStarted = $2301; {MidiSynth already started.} 23 | msNotStarted = $2302; {MidiSynth never started.} 24 | msNoDPMem = $2303; {Can't get direct page memory.} 25 | msNoMemBlock = $2304; {Can't get memory block.} 26 | msNoMiscTool = $2305; {Misc Tools not started.} 27 | msNoSoundTool = $2306; {Sound Tools not started.} 28 | msGenInUse = $2307; {Ensoniq generator in use.} 29 | msBadPortNum = $2308; {Illegal port number.} 30 | msPortBusy = $2309; {Port is busy.} 31 | msParamRangeErr = $230a; {Parameter range error.} 32 | msMsgQueueFull = $230b; {Message queue full.} 33 | msRecBufFull = $230c; {Rec buffer is full.} 34 | msOutputDisabled = $230d; {MIDI output disabled.} 35 | msMessageError = $230e; {Message error.} 36 | msOutputBufFull = $230f; {MIDI output buffer is full.} 37 | msDriverNotStarted = $2310; {Driver not started.} 38 | msDriverAlreadySet = $2311; {Driver already set.} 39 | msDevNotAvail = $2380; {the requested device is not available} 40 | msDevSlotBusy = $2381; {requested slot is already in use} 41 | msDevBusy = $2382; {the requested device is already in use} 42 | msDevOverrun = $2383; {device overrun by incoming MIDI data} 43 | msDevNoConnect = $2384; {no connection to MIDI} 44 | msDevReadErr = $2385; {framing error in received MIDI data} 45 | msDevVersion = $2386; {ROM version is incompatible with device driver} 46 | msDevIntHndlr = $2387; {conflicting interrupt handler is installed} 47 | 48 | type 49 | msDirectPageHndl = ^msDirectPagePtr; 50 | msDirectPagePtr = ^msDirectPage; 51 | msDirectPage = record 52 | reserved1: array [0..11] of byte; 53 | mpacketStat: integer; 54 | mpacketData1: integer; 55 | mpacketData2: integer; 56 | seqClockFrac: byte; 57 | seqClockInt: longint; 58 | reserved2: array [$17..$30] of byte; 59 | seqItemStat: byte; 60 | seqItemData1: byte; 61 | seqItemData2: byte; 62 | reserved3: array [$34..$3E] of byte; 63 | metroVol: byte; 64 | reserved4: array [$40..$E3] of byte; 65 | metroFreq: byte; 66 | reserved5: array [$E6..$E9] of byte; 67 | seqItemTrack: byte; 68 | reserved6: byte; 69 | packetBytes: byte; 70 | reserved7: array [$ED..$100] of byte; 71 | end; 72 | 73 | getMSDataOutputRecHndl = ^getMSDataOutputRecPtr; 74 | getMSDataOutputRecPtr = ^getMSDataOutputRec; 75 | getMSDataOutputRec = record 76 | directPage: msDirectPagePtr; 77 | reserved: longint; 78 | end; 79 | 80 | measureRecHndl = ^measureRecPtr; 81 | measureRecPtr = ^measureRec; 82 | measureRec = record 83 | measureNumber: integer; 84 | beatNumber: integer; 85 | msRemainder: integer; 86 | end; 87 | 88 | callBackRecHndl = ^callBackRecPtr; 89 | callBackRecPtr = ^callBackRec; 90 | callBackRec = record 91 | endSeq: procPtr; 92 | userMeter: procPtr; 93 | mstart: procPtr; 94 | mstop: procPtr; 95 | packetIn: procPtr; 96 | seqEvent: procPtr; 97 | sysEx: procPtr; 98 | packetOut: procPtr; 99 | pgmChange: procPtr; 100 | mContinue: procPtr; 101 | sMarker: procPtr; 102 | recBufFull: procPtr; 103 | reserved1: procPtr; 104 | reserved2: procPtr; 105 | end; 106 | 107 | seqPlayRecHndl = ^seqPlayRecPtr; 108 | seqPlayRecPtr = ^seqPlayRec; 109 | seqPlayRec = record 110 | pBufStart: ptr; 111 | reserved: longint; 112 | rBufStart: ptr; 113 | rBufEnd: ptr; 114 | seqFlags: integer; 115 | theClock: longint; 116 | end; 117 | 118 | envelopeRecHndl = ^envelopeRecPtr; 119 | envelopeRecPtr = ^envelopeRec; 120 | envelopeRec = record 121 | attackLevel: byte; 122 | attackRate: byte; 123 | decay1Level: byte; 124 | decay1Rate: byte; 125 | decay2Level: byte; 126 | decay2Rate: byte; 127 | sustainLevel: byte; 128 | decay3Rate: byte; 129 | release1Level: byte; 130 | release1Rate: byte; 131 | release2Level: byte; 132 | release2Rate: byte; 133 | release3Rate: byte; 134 | decayGain: byte; 135 | velocityGain: byte; 136 | pitchBendRange: byte; 137 | end; 138 | 139 | wavelistRecHndl = ^wavelistRecPtr; 140 | wavelistRecPtr = ^wavelistRec; 141 | wavelistRec = record 142 | topKey: byte; 143 | oscConfig: byte; 144 | stereo: byte; 145 | detune: byte; 146 | waveAddrA: byte; 147 | waveSizeA: byte; 148 | volumeA: byte; 149 | octaveA: byte; 150 | semitoneA: byte; 151 | findTuneA: byte; 152 | wavAddrB: byte; 153 | waveSizeB: byte; 154 | volumeB: byte; 155 | octaveB: byte; 156 | semitoneB: byte; 157 | fineTuneB: byte; 158 | end; 159 | 160 | instrumentRecHndl = ^instrumentRecPtr; 161 | instrumentRecPtr = ^instrumentRec; 162 | instrumentRec = record 163 | gen1EnvRec: envelopeRec; 164 | gen1WaveRecs: array[1..8] of wavelistRec; 165 | gen2EnvRec: envelopeRec; 166 | gen2WaveRecs: array [1..8] of wavelistRec; 167 | end; 168 | 169 | seqItemRecHndl = ^seqItemRecPtr; 170 | seqItemRecPtr = ^seqItemRec; 171 | seqItemRec = record 172 | trackNum: byte; 173 | timeStampHigh: byte; 174 | timeStampLow: byte; 175 | timeStampMid: byte; 176 | dataByteCount: byte; 177 | MIDIStat: byte; 178 | dataByte1: byte; 179 | dataByte2: byte; 180 | end; 181 | 182 | procedure MSBootInit; tool ($23, $01); 183 | procedure MSStartUp; tool ($23, $02); 184 | procedure MSShutDown; tool ($23, $03); 185 | function MSVersion: integer; tool ($23, $04); 186 | procedure MSReset; tool ($23, $05); 187 | function MSStatus: Boolean; tool ($23, $06); 188 | 189 | { This call cannot be made from ORCA/Pascal 190 | function ConvertToMeasure (ticksPerBeat, beats: integer; seqClockTics: longint): 191 | MeasureRec; tool ($23, $21); 192 | } 193 | 194 | function ConvertToTime (ticksPerBeat, beats, beatNum, measure: integer): longint; 195 | tool ($23, $20); 196 | procedure DeleteTrack (trackNum: integer; sequence: ptr); tool ($23, $1D); 197 | 198 | { This call cannot be made from ORCA/Pascal 199 | function GetMSData: getMSDataOutputRec; tool ($23, $1F); 200 | } 201 | 202 | procedure GetTuningTable (table: ptr); tool ($23, $25); 203 | procedure InitMIDIDriver (slot, internal, userID: integer; driver: procPtr); 204 | tool ($23, $27); 205 | procedure KillAllNotes; tool ($23, $0D); 206 | function Locate (timeStamp: longint; seqBuffer: ptr): seqItemRecPtr; 207 | tool ($23, $11); 208 | function LocateEnd (seqBuffer: ptr): ptr; tool ($23, $1B); 209 | procedure Merge (buffer1, buffer2: ptr); tool ($23, $1C); 210 | procedure MIDIMessage (destination, numBytes, message, dataByte1, 211 | dataByte2: integer); tool ($23, $1A); 212 | procedure MSResume; tool ($23, $23); 213 | procedure MSSuspend; tool ($23, $22); 214 | procedure PlayNote (channel, noteNum, volume: integer); tool ($23, $0B); 215 | procedure RemoveMIDIDriver; tool ($23, $28); 216 | procedure SeqPlayer (var sequence: seqPlayRec); tool ($23, $15); 217 | procedure SetBasicChannel (channel: integer); tool ($23, $09); 218 | procedure SetBeat (duration: integer); tool ($23, $19); 219 | procedure SetCallBack (var buffer: callBackRec); tool ($23, $17); 220 | procedure SetInstrument (inst: instrumentRecPtr; number: integer); 221 | tool ($23, $14); 222 | procedure SetMetro (volume, frequency: integer; wave: ptr); tool ($23, $1E); 223 | procedure SetMIDIMode (mode: integer); tool ($23, $0A); 224 | procedure SetMIDIPort (inputDisable, outputDisable: integer); tool ($23, $13); 225 | procedure SetPlayTrack (trackNum, playState: integer); tool ($23, $0F); 226 | procedure SetRecTrack (trackNum: integer); tool ($23, $0E); 227 | procedure SetTempo (tempo: integer); tool ($23, $16); 228 | procedure SetTrackOut (trackNum, path: integer); tool ($23, $26); 229 | procedure SetTuningTable (table: ptr); tool ($23, $24); 230 | procedure SetVelComp (velocity: integer); tool ($23, $24); 231 | procedure StopNote (channel, noteNum: integer); tool ($23, $0C); 232 | procedure SysExOut (message: ptr; delay: integer; monitor: procPtr); 233 | tool ($23, $18); 234 | procedure TrackToChannel (trackNum, channel: integer); tool ($23, $10); 235 | 236 | implementation 237 | 238 | end. 239 | -------------------------------------------------------------------------------- /Tool.Interface/MemoryMgr.pas: -------------------------------------------------------------------------------- 1 | {$keep 'MemoryMgr'} 2 | unit MemoryMgr; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * Memory Manager Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other Tool Sets Needed: Tool Locator 12 | * 13 | * Copyright 1987-1992 14 | * By the Byte Works, Inc. 15 | * All Rights Reserved 16 | * 17 | *********************************************************} 18 | 19 | uses 20 | Common; 21 | 22 | const 23 | attrNoPurge = $0000; (* not purgeable *) 24 | attrBank = $0001; (* fixed bank *) 25 | attrAddr = $0002; (* fixed address *) 26 | attrPage = $0004; (* page aligned *) 27 | attrNoSpec = $0008; (* may not use special memory *) 28 | attrNoCross = $0010; (* may not cross bank boundary *) 29 | attrPurge1 = $0100; (* purge level 1 *) 30 | attrPurge2 = $0200; (* purge level 2 *) 31 | attrPurge3 = $0300; (* purge level 3 *) 32 | attrPurge = $0300; (* test or set both purge bits *) 33 | attrHandle = $1000; (* block of handles - reserved for MM *) 34 | attrSystem = $2000; (* system handle - reserved for MM *) 35 | attrFixed = $4000; (* fixed block *) 36 | attrLocked = $8000; (* locked block *) 37 | 38 | type 39 | OOMHeader = record 40 | reserved: longint; 41 | version: integer; (* must be zero *) 42 | signature: integer; (* set to $A55A *) 43 | end; 44 | 45 | 46 | procedure MMBootInit; tool ($02, $01); (* WARNING: an application should 47 | NEVER make this call *) 48 | 49 | function MMStartUp: integer; tool ($02, $02); 50 | 51 | procedure MMShutDown (userID: integer); tool ($02, $03); 52 | 53 | function MMVersion: integer; tool ($02, $04); 54 | 55 | procedure MMReset; tool ($02, $05); (* WARNING: an application should 56 | NEVER make this call *) 57 | 58 | function MMStatus: boolean; tool ($02, $06); 59 | 60 | procedure AddToOOMQueue (var headerPtr: OOMHeader); tool ($02, $0C); 61 | 62 | procedure BlockMove (sourcPtr, destPtr: ptr; count: longint); tool ($02, $2B); 63 | 64 | procedure CheckHandle (theHandle: handle); tool ($02, $1E); 65 | 66 | procedure CompactMem; tool ($02, $1F); 67 | 68 | procedure DisposeAll (userID: integer); tool ($02, $11); 69 | 70 | procedure DisposeHandle (theHandle: handle); tool ($02, $10); 71 | 72 | function FindHandle (memLocation: ptr): handle; tool ($02, $1A); 73 | 74 | function FreeMem: longint; tool ($02, $1B); 75 | 76 | function GetHandleSize (theHandle: handle): longint; tool ($02, $18); 77 | 78 | procedure HandToHand (sourceHandle, destHandle: handle; count: longint); 79 | tool ($02, $2A); 80 | 81 | procedure HandToPtr (sourceHandle: handle; destPtr: ptr; count: longint); 82 | tool ($02, $29); 83 | 84 | procedure HLock (theHandle: handle); tool ($02, $20); 85 | 86 | procedure HLockAll (userID: integer); tool ($02, $21); 87 | 88 | procedure HUnLock (theHandle: handle); tool ($02, $22); 89 | 90 | procedure HUnLockAll (userID: integer); tool ($02, $23); 91 | 92 | function MaxBlock: longint; tool ($02, $1C); 93 | 94 | function NewHandle (blockSize: longint; userID, memAttributes: integer; 95 | memLocation: univ ptr): handle; tool ($02, $09); 96 | 97 | procedure PtrToHand (srcPtr: ptr; theHandle: handle; count: longint); 98 | tool ($02, $28); 99 | 100 | procedure PurgeAll (userID: integer); tool ($02, $13); 101 | 102 | procedure PurgeHandle (theHandle: handle); tool ($02, $12); 103 | 104 | function RealFreeMem: longint; tool ($02, $2F); 105 | 106 | procedure ReAllocHandle (blockSize: longint; userID, memAttributes: integer; 107 | memLocation: ptr; theHandle: handle); tool ($02, $0A); 108 | 109 | procedure RemoveFromOOMQueue (var headerPtr: OOMHeader); tool ($02, $0D); 110 | 111 | procedure RestoreHandle (theHandle: handle); tool ($02, $0B); 112 | 113 | function SetHandleID (newID: integer; theHandle: handle): integer; 114 | tool ($02, $30); 115 | 116 | procedure SetHandleSize (newSize: longint; theHandle: handle); tool ($02, $19); 117 | 118 | procedure SetPurge (purgeLevel: integer; theHandle: handle); tool ($02, $24); 119 | 120 | procedure SetPurgeAll (purgeLevel, userID: integer); tool ($02, $25); 121 | 122 | function TotalMem: longint; tool ($02, $1D); 123 | 124 | implementation 125 | end. 126 | -------------------------------------------------------------------------------- /Tool.Interface/MscToolSet.pas: -------------------------------------------------------------------------------- 1 | {$keep 'MscToolSet'} 2 | unit MscToolSet; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * Miscellaneous Tool Set Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other Tool Sets Needed: Tool Locator, Memory Manager 12 | * 13 | * Copyright 1987-1992, 1993 14 | * By the Byte Works, Inc. 15 | * All Rights Reserved 16 | * 17 | *********************************************************} 18 | 19 | uses 20 | Common; 21 | 22 | type 23 | queueHeader = record 24 | reserved1: longint; 25 | reserved2: integer; 26 | signature: integer; (* set to $A55A *) 27 | end; 28 | queueHeaderPtr = ^queueHeader; 29 | 30 | intStateRecord = record 31 | irq_A: integer; 32 | irq_X: integer; 33 | irq_Y: integer; 34 | irq_S: integer; 35 | irq_D: integer; 36 | irq_P: byte; 37 | irq_DB: byte; 38 | irq_e: byte; 39 | irq_K: byte; 40 | irq_PC: integer; 41 | irq_state: byte; 42 | irq_shadow: integer; 43 | irq_mslot: byte; 44 | end; 45 | 46 | 47 | procedure MTBootInit; tool ($03, $01); (* WARNING: an application should 48 | NEVER make this call *) 49 | 50 | procedure MTStartUp; tool ($03, $02); 51 | 52 | procedure MTShutDown; tool ($03, $03); 53 | 54 | function MTVersion: integer; tool ($03, $04); 55 | 56 | procedure MTReset; tool ($03, $05); (* WARNING: an application should 57 | NEVER make this call *) 58 | 59 | function MTStatus: boolean; tool ($03, $06); 60 | 61 | procedure AddToQueue (newEntry, headerPtr: queueHeaderPtr); tool ($03, $2E); 62 | 63 | function ConvSeconds (convVerb: integer; seconds: longint; datePtr: ptr) 64 | : longint; tool ($03, $37); 65 | 66 | procedure DeleteFromQueue (newEntry, headerPtr: queueHeaderPtr); tool ($03, $2F); 67 | 68 | procedure SetInterruptState (var interruptState: intStateRecord; 69 | bytesDesired: integer); tool ($03, $30); 70 | 71 | procedure GetInterruptState (var interruptState: intStateRecord; 72 | bytesDesired: integer); tool ($03, $31); 73 | 74 | function GetIntStateRecSize: integer; tool ($03, $32); 75 | 76 | function GetCodeResConverter: procPtr; tool ($03, $34); 77 | 78 | procedure WriteBRam (bufferAddress: ptr); tool ($03, $09); 79 | 80 | procedure ReadBRam (bufferAddress: ptr); tool ($03, $0A); 81 | 82 | procedure WriteBParam (theData, paramRefNum: integer); tool ($03, $0B); 83 | 84 | function ReadBParam (paramRefNum: integer): integer; tool ($03, $0C); 85 | 86 | (* ReadTimeHex returns 8 bytes - no direct interface is possible *) 87 | 88 | (* To set up parameters for WriteTimeHex, you could shift the first value *) 89 | (* and then OR it with the second value: month_day := month << 8 | day *) 90 | 91 | procedure WriteTimeHex (month_day, year_hour, minute_second: integer); 92 | tool ($03, $0E); 93 | 94 | procedure ReadASCIITime (bufferAddress: ptr); tool ($03, $0F); 95 | 96 | (* FWEntry returns 4 integers - no direct interface is possible *) 97 | 98 | function GetAddr (refNum: integer): ptr; tool ($03, $16); 99 | 100 | function GetTick: longint; tool ($03, $25); 101 | 102 | function GetIRQEnable: integer; tool ($03, $29); 103 | 104 | procedure IntSource (srcRefNum: integer); tool ($03, $23); 105 | 106 | procedure ClampMouse (xMinClamp, xMaxClamp, yMinClamp, yMaxClamp: integer); 107 | tool ($03, $1C); 108 | 109 | procedure ClearMouse; tool ($03, $1B); 110 | 111 | (* GetMouseClamp returns 4 integers - no direct interface is possible *) 112 | 113 | procedure HomeMouse; tool ($03, $1A); 114 | 115 | procedure InitMouse (mouseSlot: integer); tool ($03, $18); 116 | 117 | procedure PosMouse (xPos, yPos: integer); tool ($03, $1E); 118 | 119 | (* ReadMouse returns 2 integers and 2 bytes - no direct interface is possible *) 120 | (* ReadMouse2 returns 3 integers - no direct interface is possible *) 121 | 122 | function ServeMouse: integer; tool ($03, $1F); 123 | 124 | procedure SetMouse (mouseMode: integer); tool ($03, $19); 125 | 126 | procedure SetAbsClamp (xMinClamp, xMaxClamp, yMinClamp, yMaxClamp: integer); 127 | tool ($03, $2A); 128 | 129 | (* GetAbsClamp returns 4 integers - no direct interface is possible *) 130 | 131 | function PackBytes (startHandle: handle; var size: integer; bufferPtr: ptr; 132 | bufferSize: integer): integer; tool ($03, $26); 133 | 134 | function UnPackBytes (packBufferPtr: ptr; bufferSize: integer; 135 | startHandle: handle; var size: integer): integer; 136 | tool ($03, $27); 137 | 138 | function Munger (destPtr: handle; var destLen: integer; targPtr: ptr; 139 | targLen: integer; replPtr: ptr; replLen: integer; 140 | padPtr: ptr): integer; tool ($03, $28); 141 | 142 | procedure SetHeartBeat (taskPtr: ptr); tool ($03, $12); 143 | 144 | procedure DelHeartBeat (taskPtr: ptr); tool ($03, $13); 145 | 146 | procedure ClrHeartBeat; tool ($03, $14); 147 | 148 | procedure SysBeep; tool ($03, $2C); 149 | 150 | procedure SysBeep2 (beepType: integer); tool ($03, $38); 151 | 152 | procedure SysFailMgr (errorCode: integer; failString: univ pStringPtr); 153 | tool ($03, $15); 154 | 155 | function GetNewID (IDTag: integer): integer; tool ($03, $20); 156 | 157 | procedure DeleteID (IDTag: integer); tool ($03, $21); 158 | 159 | procedure StatusID (IDTag: integer); tool ($03, $22); 160 | 161 | procedure SetVector (vectorRefNum: integer; vectorPtr: ptr); tool ($03, $10); 162 | 163 | function GetVector (vectorRefNum: integer): ptr; tool ($03, $11); 164 | 165 | procedure VersionString (flags: integer; theVersion: longint; 166 | str: univ cStringPtr); tool ($03, $39); 167 | 168 | function WaitUntil (delayFrom, delayAmount: integer): integer; tool ($03, $3A); 169 | 170 | function ScanDevices: integer; tool ($03, $3D); 171 | 172 | procedure ShowBootInfo (str: cStringPtr; icon: ptr); tool ($03, $3C); 173 | 174 | function StringToText (flags: integer; textPtr: cStringPtr; textLen: integer; 175 | result: gsosOutStringPtr): longint; tool ($03, $3B); 176 | 177 | {new in 6.0.1} 178 | 179 | function AlertMessage (msgTable: ptr; msgNum: integer; subs: ptr): integer; 180 | tool($03, $3E); 181 | 182 | function DoSysPrefs (bitsToClear, bitsToSet: integer): integer; tool ($03, $3F); 183 | 184 | implementation 185 | end. 186 | -------------------------------------------------------------------------------- /Tool.Interface/MultiMedia.pas: -------------------------------------------------------------------------------- 1 | {$keep 'MultiMedia'} 2 | unit MultiMedia; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * MultiMedia Sequence Editor, Scheduler 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other Tool Sets Needed: Tool Locator 12 | * 13 | * Copyright 1992, 1993 14 | * By the Byte Works, Inc. 15 | * All Rights Reserved 16 | * 17 | *********************************************************} 18 | 19 | uses 20 | Common; 21 | 22 | const 23 | inChapters = 1; 24 | inFrames = 2; 25 | inTimes = 3; 26 | 27 | mcCInit = 1; {control values for MCControl} 28 | mcCEject = 2; 29 | mcCVideoOn = 3; 30 | mcCVideoOff = 4; 31 | mcCDisplayOn = 5; 32 | mcCDisplayOff = 6; 33 | mcCBlankVideo = 7; 34 | mcCDefaultCom = 8; 35 | mcCLockDev = 9; 36 | mcCUnLockDev = 10; 37 | 38 | mcC8Data1Stop = 40; 39 | mcC7Data1Stop = 41; 40 | mcC6Data1Stop = 42; 41 | mcC5Data1Stop = 43; 42 | mcC8Data2Stop = 44; 43 | mcC7Data2Stop = 45; 44 | mcC6Data2Stop = 46; 45 | mcC5Data2Stop = 47; 46 | 47 | mcCBaudDflt = 50; 48 | 49 | mcCBaud50 = 51; 50 | mcCBaud75 = 52; 51 | mcCBaud110 = 53; 52 | mcCBaud134 = 54; 53 | mcCBaud150 = 55; 54 | mcCBaud300 = 56; 55 | mcCBaud600 = 57; 56 | mcCBaud1200 = 58; 57 | mcCBaud1800 = 59; 58 | mcCBaud2400 = 60; 59 | mcCBaud3600 = 61; 60 | mcCBaud4800 = 62; 61 | mcCBaud7200 = 63; 62 | mcCBaud9600 = 64; 63 | mcCBaud19200 = 65; 64 | 65 | mcCModem = 100; 66 | mcCPrinter = 101; 67 | 68 | mcCIgnoreDS = 200; 69 | mcCReportDS = 201; 70 | 71 | mcFTypes = 0; {status values for MCGetFeatures} 72 | mcFStep = 1; 73 | mcFRecord = 2; 74 | mcFVideo = 3; 75 | mcFEject = 4; 76 | mcFLock = 5; 77 | mcFVDisplay = 6; 78 | mcFVOverlay = 7; 79 | mcFVOChars = 8; 80 | mcFVolume = 9; 81 | 82 | mcSUnknown = 0; {status values for MCGetStatus} 83 | mcSDeviceType = $0000; 84 | mcSLaserDisc = 1; 85 | mcSCDAudio = 2; 86 | mcSCDLaserCD = 3; 87 | mcSVCR = 4; 88 | mcSCamCorder = 5; 89 | mcSPlayStatus = $0001; 90 | mcSPlaying = 1; 91 | mcSStill = 2; 92 | mcSParked = 3; 93 | mcSDoorStatus = $0002; 94 | mcSDoorOpen = 1; 95 | mcSDoorClosed = 2; 96 | mcSDiscType = $0003; 97 | mcS_CLV = 1; 98 | mcS_CAV = 2; 99 | mcS_CDV = 3; 100 | mcS_CD = 4; 101 | mcSDiscSize = $0004; 102 | mcSDisc3inch = 3; 103 | mcSDisk5inch = 5; 104 | mcSDisk8inch = 8; 105 | mcSDisk12inch = 12; 106 | mcSDiskSide = $0005; 107 | mcSSideOne = 1; 108 | mcSSideTwo = 2; 109 | mcSVolumeL = $0006; 110 | mcSVolumeR = $0007; 111 | 112 | mcElapsedTrack = 0; {MCGetTimes selector values} 113 | mcRemainTrack = 1; 114 | mcElapsedDisc = 2; 115 | mcRemainDisc = 3; 116 | mcTotalDisc = 4; 117 | 118 | mcTotalFrames = 5; 119 | mcTracks = 6; 120 | mcDiscID = 7; 121 | 122 | AudioOff = 0; {Audio values} 123 | AudioRight = 1; 124 | AudioLinR = 2; 125 | AudioMinR = 3; 126 | AudioRinL = 4; 127 | AudioRinLR = 5; 128 | AudioReverse = 6; 129 | AudioRinLMR = 7; 130 | AudioLeft = 8; 131 | AudioSterio = 9; 132 | AudioLinLR = 10; 133 | AudioLinLMR = 11; 134 | AudioMinL = 12; 135 | AudioMinLRinR = 13; 136 | AudioMonLLinR = 14; 137 | AudioMonaural = 15; 138 | 139 | procedure MCBootInit; tool ($26, $01); 140 | 141 | procedure MCStartUp (userID: integer); tool ($26, $02); 142 | 143 | procedure MCShutDown; tool ($26, $03); 144 | 145 | function MCVersion: integer; tool ($26, $04); 146 | 147 | procedure MCReset; tool ($26, $05); 148 | 149 | function MCStatus: boolean; tool ($26, $06); 150 | 151 | procedure MCLoadDriver (mcChannelNo: integer); tool ($26, $0A); 152 | 153 | procedure MCUnLoadDriver (mcChannelNo: integer); tool ($26, $0B); 154 | 155 | procedure MCDStartUp (mcChannelNo: integer; portnameptr: pString; 156 | drvrUserID: integer); tool ($26, $14); 157 | 158 | procedure MCDShutDown (mcChannelNo: integer); tool ($26, $15); 159 | 160 | function MCBinToTime (mcBinVal: longint): longint; tool ($26, $0D); 161 | 162 | procedure MCControl (mcChannelNo, ctlcommand: integer); tool ($26, $1B); 163 | 164 | function MCGetDiscID (mcChannelNo: integer): longint; tool ($26, $28); 165 | 166 | procedure MCGetDicTitle (mcDiscID: longint; var PStrPtr: pString); 167 | tool ($26, $12); 168 | 169 | function MCGetDiscTOC (mcChannelNo, mcTrackNo: integer): longint; 170 | tool ($26, $27); 171 | 172 | procedure MCGetErrorMsg (mcErrorNo: integer; var PStrPtr: pString); 173 | tool ($26, $09); 174 | 175 | function MCGetFeatures (mcChannelNo, mcFeatSel: integer): longint; 176 | tool ($26, $16); 177 | 178 | procedure MCGetName (mcChannelNo: integer; var PStrPtr: pString); 179 | tool ($26, $2D); 180 | 181 | function MCGetNoTracks (mcChannelNo: integer): integer; tool ($26, $29); 182 | 183 | function MCGetPosition (mcChannelNo, mcUnitType: integer): longint; 184 | tool ($26, $24); 185 | 186 | procedure MCGetProgram (mcDiscID: longint; var PStrPtr: pString); 187 | tool ($26, $10); 188 | 189 | procedure MCGetSpeeds (mcChannelNo: integer; var PStrPtr: pString); 190 | tool ($26, $1D); 191 | 192 | function MCGetStatus (mcChannelNo, mcStatusSel: integer): integer; 193 | tool ($26, $1A); 194 | 195 | function MCGetTimes (mcChannelNo, mcTimeSel: integer): longint; tool ($26, $26); 196 | 197 | procedure MCGetTrackTitle (mcDiscID: longint; mcTrackNo: integer; 198 | var PStrPtr: pString); tool ($26, $0E); 199 | 200 | procedure MCJog (mcChannelNo, mcUnitType: integer; mcNJog: longint; 201 | mcJogRepeat: integer); tool ($26, $20); 202 | 203 | procedure MCPause (mcChannelNo: integer); tool ($26, $18); 204 | 205 | procedure MCPlay (mcChannelNo: integer); tool ($26, $17); 206 | 207 | procedure MCRecord (mcChannelNo: integer); tool ($26, $2A); 208 | 209 | procedure MCSetAudio (mcChannelNo, mcAudioCtl: integer); tool ($26, $25); 210 | 211 | procedure MCSetVolume (mcChannelNo, mcLeftVol, mcRightVol: integer); 212 | tool ($26, $2E); 213 | 214 | procedure MCScan (mcChannelNo, mcDirection: integer); tool ($26, $1C); 215 | 216 | function MCSearchDone (mcChannelNo: integer): boolean; tool ($26, $22); 217 | 218 | procedure MCSearchTo (mcChannelNo, mcUnitType: integer; searchLoc: longint); 219 | tool ($26, $21); 220 | 221 | procedure MCSearchWait (mcChannelNo: integer); tool ($26, $23); 222 | 223 | procedure MCSendRawData (mcChannelNo: integer; mcNativePtr: gsosInString); 224 | tool ($26, $19); 225 | 226 | procedure MCSetDiscTitle (mcDiscID: longint; titlePtr: pString); 227 | tool ($26, $13); 228 | 229 | procedure MCSetProgram (mcDiscID: longint; titlePtr: gsosInString); 230 | tool ($26, $11); 231 | 232 | procedure MCSetTrackTitle (mcDiscID: longint; trackNum: integer; 233 | titlePtr: pString); tool ($26, $0F); 234 | 235 | procedure MCSpeed (mcChannelNo, mcFPS: integer); tool ($26, $1E); 236 | 237 | procedure MCStop (mcChannelNo: integer); tool ($26, $2B); 238 | 239 | procedure MCStopAt (mcChannelNo, mcUnitType: integer; mcStopLoc: longint); 240 | tool ($26, $1F); 241 | 242 | function MCTimeToBin (mcTimeValue: longint): longint; tool ($26, $0C); 243 | 244 | procedure MCWaitRawData (mcChannelNo: integer; var result: gsosOutString; 245 | tickwait, term_mask: integer); tool ($26, $2C); 246 | 247 | implementation 248 | end. 249 | -------------------------------------------------------------------------------- /Tool.Interface/ObjIntf.pas: -------------------------------------------------------------------------------- 1 | {******************************************************** 2 | * 3 | * Object Interface 4 | * 5 | * Other USES Files Needed: - None - 6 | * 7 | * Copyright 1993 8 | * By the Byte Works, Inc. 9 | * All Rights Reserved 10 | * 11 | *********************************************************} 12 | 13 | {$keep 'ObjIntf'} 14 | 15 | unit ObjIntf; 16 | 17 | interface 18 | 19 | type 20 | tObject = object 21 | function ShallowClone: tObject; 22 | function Clone: tObject; 23 | procedure ShallowFree; 24 | procedure Free; 25 | end; 26 | 27 | implementation 28 | 29 | end. 30 | -------------------------------------------------------------------------------- /Tool.Interface/PrintMgr.pas: -------------------------------------------------------------------------------- 1 | {$keep 'PrintMgr'} 2 | unit PrintMgr; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * Print Manager Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other Tool Sets Needed: Tool Locator, Memory Manager, Miscellaneous 12 | * Tool Set, QuickDraw II, Desk Manager, 13 | * Window Manager, Menu Manager, Control Manager, 14 | * QuickDraw II Auxilliary, LineEdit Tool Set, 15 | * Dialog Manager, Font Manager, List Manager 16 | * 17 | * Copyright 1987-1990 18 | * By the Byte Works, Inc. 19 | * All Rights Reserved 20 | * 21 | *********************************************************} 22 | 23 | uses 24 | Common; 25 | 26 | const 27 | (* Printer error codes *) 28 | prAbort = $80; 29 | 30 | type 31 | (* Printer information subrecord *) 32 | prInfoRec = record 33 | iDev: integer; 34 | iVRes: integer; 35 | iHRes: integer; 36 | rPage: rect; 37 | end; 38 | 39 | (* Printer style subrecord *) 40 | prStyleRec = record 41 | wDev: integer; 42 | internA: array [0..2] of integer; 43 | feed: integer; 44 | paperType: integer; 45 | case boolean of 46 | true: (crWidth: integer;); 47 | false: (vSizing: integer; 48 | reduction: integer; 49 | internB: integer;); 50 | end; 51 | 52 | (* Job information subrecord *) 53 | prJobRec = record 54 | iFstPage: integer; 55 | iLstPage: integer; 56 | iCopies: integer; 57 | bJDocLoop: byte; 58 | fFromUser: byte; 59 | pIdleProc: procPtr; 60 | pFileName: pathPtr; 61 | iFileVol: integer; 62 | bFileVers: byte; 63 | bJobX: byte; 64 | end; 65 | 66 | (* Print record *) 67 | PrRec = record 68 | prVersion: integer; 69 | prInfo: prInfoRec; 70 | rPaper: rect; 71 | prStl: prStyleRec; 72 | prInfoPT: array [0..13] of byte; 73 | prXInfo: array [0..23] of byte; 74 | prJob: PrJobRec; 75 | printX: array [0..37] of byte; 76 | iReserved: integer; 77 | end; 78 | PrRecPtr = ^PrRec; 79 | PrHandle = ^PrRecPtr; 80 | 81 | (* Printer status subrecord *) 82 | PrStatusRec = record 83 | iTotPages: integer; 84 | iCurPage: integer; 85 | iTotCopies: integer; 86 | iCurCopy: integer; 87 | iTotBands: integer; 88 | iCurBand: integer; 89 | fPgDirty: boolean; 90 | fImaging: integer; 91 | hPrint: prHandle; 92 | pPrPort: grafPortPtr; 93 | hPic: longint; 94 | end; 95 | PrStatusPtr = ^PrStatusRec; 96 | 97 | 98 | procedure PMBootInit; tool ($13, $01); (* WARNING: an application should 99 | NEVER make this call *) 100 | 101 | procedure PMStartup (userID, dPageAddr: integer); tool ($13, $02); 102 | 103 | procedure PMShutDown; tool ($13, $03); 104 | 105 | function PMVersion: integer; tool ($13, $04); 106 | 107 | procedure PMReset; tool ($13, $05); (* WARNING: an application should 108 | NEVER make this call *) 109 | 110 | function PMStatus: boolean; tool ($13, $06); 111 | 112 | procedure PMLoadDriver (driver: integer); tool ($13, $35); 113 | 114 | procedure PMUnloadDriver (driver: integer); tool ($13, $34); 115 | 116 | function PrChoosePrinter: boolean; tool ($13, $16); 117 | 118 | procedure PrCloseDoc (printerPort: grafPortPtr); tool ($13, $0F); 119 | 120 | procedure PrClosePage (printerPort: grafPortPtr); tool ($13, $11); 121 | 122 | procedure PrDefault (thePrintRecord: prHandle); tool ($13, $09); 123 | 124 | function PrDriverVer: integer; tool ($13, $23); 125 | 126 | function PrError: integer; tool ($13, $14); 127 | 128 | function PrGetDocName: pStringPtr; tool ($13, $36); 129 | 130 | function PrGetNetworkName: pStringPtr; tool ($13, $2B); 131 | 132 | function PrGetPgOrientation (prRecordHdl: prHandle): integer; tool ($13, $38); 133 | 134 | function PrGetPortDvrName: pStringPtr; tool ($13, $29); 135 | 136 | function PrGetPrinterDvrName: pStringPtr; tool ($13, $28); 137 | 138 | (* PrGetPrinterSpecs returns 2 words: low word = type of printer *) 139 | (* high word = printer characteristics *) 140 | function PrGetPrinterSpecs: longint; tool ($13, $18); 141 | 142 | function PrGetUserName: pStringPtr; tool ($13, $2A); 143 | 144 | function PrGetZoneName: pStringPtr; tool ($13, $25); 145 | 146 | function PrJobDialog (thePrintRecord: prHandle): boolean; tool ($13, $0C); 147 | 148 | function PrOpenDoc (thePrintRecord: prHandle; printerPort: grafPortPtr): 149 | grafPortPtr; tool ($13, $0E); 150 | 151 | procedure PrOpenPage (printerPort: grafPortPtr; pageFrame: rectPtr); 152 | tool ($13, $10); 153 | 154 | procedure PrPicFile (thePrintRecord: prHandle; printerPort: grafPortPtr; 155 | statusRecPtr: PrStatusPtr); tool ($13, $12); 156 | 157 | procedure PrPixelMap (srcLoc: locInfoPtr; var srcRect: rect; colorFlag: boolean); 158 | tool($13, $0D); 159 | 160 | function PrPortVer: integer; tool ($13, $24); 161 | 162 | procedure PrSetDocName (docName: pStringPtr); tool ($13, $37); 163 | 164 | procedure PrSetError (errorNumber: integer); tool ($13, $15); 165 | 166 | function PrStlDialog (thePrintRecord: prHandle): boolean; tool ($13, $0B); 167 | 168 | function PrValidate (thePrintRecord: prHandle): boolean; tool ($13, $0A); 169 | 170 | implementation 171 | end. 172 | -------------------------------------------------------------------------------- /Tool.Interface/ProDOS.pas: -------------------------------------------------------------------------------- 1 | {$keep 'ProDOS'} 2 | unit ProDOS; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * ProDOS 16 Interface File 8 | * 9 | * Other Uses Files Needed: Common 10 | * 11 | * Notes: Each call refers to a data control block (DCB), 12 | * defined as a record. Calls which return values 13 | * store the output into the DCB. 14 | * All calls return an error number. 15 | * 16 | * Copyright 1987-1990 17 | * By the Byte Works, Inc. 18 | * All Rights Reserved 19 | * 20 | *********************************************************} 21 | 22 | uses 23 | Common; 24 | 25 | type 26 | createDCB = record 27 | pathName: pathPtr; 28 | access: integer; 29 | fileType: integer; 30 | auxType: longint; 31 | storageType: integer; 32 | createDate: integer; 33 | createTime: integer; 34 | end; 35 | 36 | destroyDCB = record 37 | pathName: pathPtr; 38 | end; 39 | 40 | changePathDCB = record 41 | pathName: pathPtr; 42 | newPathName: pathPtr; 43 | end; 44 | 45 | setFileInfoDCB = record 46 | pathName: pathPtr; 47 | access: integer; 48 | fileType: integer; 49 | auxType: longint; 50 | nullField: integer; 51 | createDate: integer; 52 | createTime: integer; 53 | modDate: integer; 54 | modTime: integer; 55 | end; 56 | 57 | getFileInfoDCB = record 58 | pathName: pathPtr; 59 | access: integer; 60 | fileType: integer; 61 | auxTypeOrTotalBlocks: longint; 62 | storageType: integer; 63 | createDate: integer; 64 | createTime: integer; 65 | modDate: integer; 66 | modTime: integer; 67 | blocksUsed: longint; 68 | end; 69 | 70 | volumeDCB = record 71 | devName: pathPtr; 72 | volName: pathPtr; 73 | totalBlocks: longint; 74 | freeBlocks: longint; 75 | fileSysID: integer; 76 | end; 77 | 78 | prefixDCB = record 79 | prefixNum: integer; 80 | prefix: pathPtr; 81 | end; 82 | 83 | clrBkupBitDCB = record 84 | pathName: pathPtr; 85 | end; 86 | 87 | openDCB = record 88 | refNum: integer; 89 | pathName: pathPtr; 90 | reserved: longint; (* set this value to $00000000 *) 91 | end; 92 | 93 | newlineDCB = record 94 | refNum: integer; 95 | enableMask: integer; 96 | newlineChar: integer; 97 | end; 98 | 99 | readWriteDCB = record 100 | refNum: integer; 101 | dataBuffer: ptr; 102 | requestCount: longint; 103 | transferCount: longint; 104 | end; 105 | 106 | closeDCB = record 107 | refNum: integer; 108 | end; 109 | 110 | flushDCB = record 111 | refNum: integer; 112 | end; 113 | 114 | markDCB = record 115 | refNum: integer; 116 | position: longint; 117 | end; 118 | 119 | eofDCB = record 120 | refNum: integer; 121 | fileSize: longint; 122 | end; 123 | 124 | levelDCB = record 125 | level: integer; 126 | end; 127 | 128 | dirEntryDCB = record 129 | refNum: integer; 130 | flags: integer; 131 | base: integer; 132 | displacement: integer; 133 | name: ptr; 134 | entryNum: integer; 135 | fileType: integer; 136 | eofValue: longint; 137 | blockCount: longint; 138 | createDate: longint; 139 | createTime: longint; 140 | modDate: longint; 141 | modTime: longint; 142 | access: integer; 143 | auxType: longint; 144 | fileSystemID: integer; 145 | end; 146 | 147 | getDevNumDCB = record 148 | devName: pathPtr; 149 | devNum: integer; 150 | end; 151 | 152 | deviceDCB = record 153 | devNum: integer; 154 | end; 155 | 156 | blockDCB = record 157 | devNum: integer; 158 | dataBuffer: ptr; 159 | blockNum: longint; 160 | end; 161 | 162 | formatDCB = record 163 | devName: pathPtr; 164 | volName: pathPtr; 165 | fileSysID: integer; 166 | end; 167 | 168 | getNameDCB = record 169 | theName: pathPtr; 170 | end; 171 | 172 | quitDCB = record 173 | pathName: pathPtr; 174 | flags: integer; 175 | end; 176 | 177 | P16versionDCB = record 178 | version: integer; 179 | end; 180 | 181 | dInfoDCB = record 182 | devNum: integer; 183 | devName: pathPtr; 184 | end; 185 | 186 | allocInterruptDCB = record 187 | intNum: integer; 188 | intCode: ptr; 189 | end; 190 | 191 | deallocInterruptDCB = record 192 | intNum: integer; 193 | end; 194 | 195 | 196 | procedure P16Create (var parms: createDCB); prodos ($01); 197 | 198 | procedure P16Destroy (var parms: destroyDCB); prodos ($02); 199 | 200 | procedure P16Change_Path (var parms: changePathDCB); prodos ($04); 201 | 202 | procedure P16Set_File_Info (var parms: setFileInfoDCB); prodos ($05); 203 | 204 | procedure P16Get_File_Info (var parms: getFileInfoDCB); prodos ($06); 205 | 206 | procedure P16Volume (var parms: volumeDCB); prodos ($08); 207 | 208 | procedure P16Set_Prefix (var parms: prefixDCB); prodos ($09); 209 | 210 | procedure P16Get_Prefix (var parms: prefixDCB); prodos ($0A); 211 | 212 | procedure P16Clear_Backup (var parms: clrBkupBitDCB); prodos ($0B); 213 | 214 | procedure P16Open (var parms: openDCB); prodos ($10); 215 | 216 | procedure P16Newline (var parms: newlineDCB); prodos ($11); 217 | 218 | procedure P16Read (var parms: readWriteDCB); prodos ($12); 219 | 220 | procedure P16Write (var parms: readWriteDCB); prodos ($13); 221 | 222 | procedure P16Close (var parms: closeDCB); prodos ($14); 223 | 224 | procedure P16Flush (var parms: flushDCB); prodos ($15); 225 | 226 | procedure P16Set_Mark (var parms: markDCB); prodos ($16); 227 | 228 | procedure P16Get_Mark (var parms: markDCB); prodos ($17); 229 | 230 | procedure P16Set_EOF (var parms: eofDCB); prodos ($18); 231 | 232 | procedure P16Get_EOF (var parms: eofDCB); prodos ($19); 233 | 234 | procedure P16Set_Level (var parms: levelDCB); prodos ($1A); 235 | 236 | procedure P16Get_Level (var parms: levelDCB); prodos ($1B); 237 | 238 | procedure P16Get_Dir_Entry (var parms: dirEntryDCB); prodos ($1C); 239 | 240 | procedure P16Get_Dev_Number (var parms: getDevNumDCB); prodos ($20); 241 | 242 | procedure P16Get_Last_Dev (var parms: deviceDCB); prodos ($21); 243 | 244 | procedure P16Read_Block (var parms: blockDCB); prodos ($22); 245 | 246 | procedure P16Write_Block (var parms: blockDCB); prodos ($23); 247 | 248 | procedure P16Format (var parms: formatDCB); prodos ($24); 249 | 250 | procedure P16Erase_Disk (var parms: formatDCB); prodos ($25); 251 | 252 | procedure P16Get_Name (var parms: getNameDCB); prodos ($27); 253 | 254 | procedure P16Get_Boot_Vol (var parms: getNameDCB); prodos ($28); 255 | 256 | procedure P16Quit (var parms: quitDCB); prodos ($29); 257 | 258 | procedure P16Get_Version (var parms: P16versionDCB); prodos ($2A); 259 | 260 | procedure P16D_Info (var parms: dInfoDCB); prodos ($2C); 261 | 262 | procedure P16Alloc_Interrupt (var parms: allocInterruptDCB); prodos ($31); 263 | 264 | procedure P16Dealloc_Interrupt (var parms: deallocInterruptDCB); prodos ($32); 265 | 266 | implementation 267 | end. 268 | -------------------------------------------------------------------------------- /Tool.Interface/ResourceMgr.pas: -------------------------------------------------------------------------------- 1 | {$keep 'ResourceMgr'} 2 | unit ResourceMgr; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * Resource Manager Interface File 8 | * 9 | * Other USES files needed: Common 10 | * 11 | * Other Tool Sets Needed: - None - 12 | * 13 | * Copyright 1987-1992, 1993 14 | * By the Byte Works, Inc. 15 | * All Rights Reserved 16 | * 17 | *********************************************************} 18 | 19 | uses 20 | Common; 21 | 22 | const 23 | (* Resource Manager Error Codes *) 24 | resForkUsed = $1E01; (* resource fork not empty *) 25 | resBadFormat = $1E02; (* format of resource fork is unknown *) 26 | resNoConverter = $1E03; (* no converter logged in for resource *) 27 | resNoCurFile = $1E04; (* there are no current open resource files *) 28 | resDupID = $1E05; (* ID is already used *) 29 | resNotFound = $1E06; (* resource was not found *) 30 | resFileNotFound = $1E07; (* resource file not found *) 31 | resBadAppID = $1E08; (* user ID not found, call ResourceStartup *) 32 | resNoUniqueID = $1E09; (* a unique ID was not found *) 33 | resIndexRange = $1E0A; (* index is out of range *) 34 | resSysIsOpen = $1E0B; (* system file is already open *) 35 | resHasChanged = $1E0C; (* resource changed - operation can't be done *) 36 | resDifConverter = $1E0D; (* different converter logged for resrc type *) 37 | 38 | (* Resource flag values *) 39 | resChanged = $0020; (* true if resource has changed *) 40 | resPreLoad = $0040; (* true if should load with OpenResourceFile *) 41 | resProtected = $0080; (* true if should never write to disk *) 42 | resAbsLoad = $0400; (* true if should load at absolute address *) 43 | resConverter = $0800; (* true if requires converter for loads/writes *) 44 | resMemAttr = $C31C; (* mask for NewHandle for resource memory *) 45 | 46 | (* System file ID *) 47 | sysFileID = $0001; (* file ID of system resource file *) 48 | 49 | (* Map flag values *) 50 | systemMap = $0001; 51 | mapChanged = $0002; (* true if map has changed *) 52 | romMap = $0004; (* true if resource file is in ROM *) 53 | 54 | type 55 | resID = longint; 56 | resType = integer; 57 | resAttr = integer; 58 | 59 | resHeaderRec = record 60 | rFileVersion: longint; 61 | rFileToMap: longint; 62 | rFileMapSize: longint; 63 | rFileMemo: packed array [1..128] of byte; 64 | end; 65 | 66 | freeBlockRec = record 67 | blkOffset: longint; 68 | blkSize: longint; 69 | end; 70 | 71 | resRefRec = record 72 | rResType: resType; 73 | rResID: resID; 74 | rResOffset: longint; 75 | rResAttr: resAttr; 76 | rResSize: longint; 77 | rResHandle: handle; 78 | end; 79 | 80 | resMapHandle = ^resMapPtr; 81 | resMapPtr = ^resMapRec; 82 | resMapRec = record 83 | mapNext: resMapHandle; 84 | mapFlag: integer; 85 | mapOffset: longint; 86 | mapSize: longint; 87 | mapToIndex: integer; 88 | mapFileNum: integer; 89 | mapID: integer; 90 | mapIndexSize: longint; 91 | mapIndexUsed: longint; 92 | mapFreeListSize: integer; 93 | mapFreeListUsed: integer; 94 | (* Set the array size for your application. *) 95 | mapFreeList: array [1..1] of freeBlockRec; 96 | end; 97 | 98 | resourceSpec = record 99 | resourceType: resType; 100 | resourceID: resID; 101 | end; 102 | 103 | resNameEntryPtr = ^resNameEntry; 104 | resNameEntry = record 105 | namedResID: resID; 106 | resName: pString 107 | end; 108 | 109 | resNameRecordHandle = ^ResNameRecordPtr; 110 | resNameRecordPtr = ^ResNameRecord; 111 | resNameRecord = record 112 | version: integer; 113 | nameCount: longint; 114 | resNameEntries: array [1..1] of resNameEntry; 115 | end; 116 | 117 | 118 | procedure ResourceBootInit; tool ($1E, $01); (* WARNING: an application should 119 | NEVER make this call *) 120 | 121 | procedure ResourceStartup (myID: integer); tool ($1E, $02); 122 | 123 | procedure ResourceShutdown; tool ($1E, $03); 124 | 125 | function ResourceVersion: integer; tool ($1E, $04); 126 | 127 | procedure ResourceReset; tool ($1E, $05); (* WARNING: an application should 128 | NEVER make this call *) 129 | 130 | function ResourceStatus: boolean; tool ($1E, $06); 131 | 132 | procedure AddResource (resourceHandle: handle; resourceAttr: integer; 133 | resourceType: integer; resourceID: longint); 134 | tool ($1E, $0C); 135 | 136 | procedure CloseResourceFile (fileID: integer); tool ($1E, $0B); 137 | 138 | function CountResources (resourceType: integer): longint; tool ($1E, $22); 139 | 140 | function CountTypes: integer; tool ($1E, $20); 141 | 142 | procedure CreateResourceFile (auxType: longint; fileType: integer; 143 | fileAccess: integer; var fileName: gsosInString); 144 | tool ($1E, $09); 145 | 146 | procedure DetachResource (resourceType: integer; resourceID: longint); 147 | tool ($1E, $18); 148 | 149 | function GetCurResourceApp: integer; tool ($1E, $14); 150 | 151 | function GetCurResourceFile: integer; tool ($1E, $12); 152 | 153 | function GetIndResource (resourceType: resType; resourceIndex: longint): resID; 154 | tool ($1E, $23); 155 | 156 | function GetIndType (typeIndex: integer): resType; tool ($1E, $21); 157 | 158 | function GetMapHandle (fileID: integer): resMapHandle; tool ($1E, $26); 159 | 160 | function GetOpenFileRefNum (fileID: integer): integer; tool ($1E, $1F); 161 | 162 | function GetResourceAttr (resourceType: resType; resourceID: resID): resAttr; 163 | tool ($1E, $1B); 164 | 165 | function GetResourceSize (resourceType: resType; resourceID: resID): longint; 166 | tool ($1E, $1D); 167 | 168 | function HomeResourceFile (resourceType: resType; resourceID: resID): integer; 169 | tool ($1E, $15); 170 | 171 | function LoadAbsResource (loadAddress: longint; maxSize: longint; 172 | resourceType: resType; resourceID: resID): longint; 173 | tool ($1E, $27); 174 | 175 | function LoadResource (resourceType: resType; resourceID: resID): handle; 176 | tool ($1E, $0E); 177 | 178 | function LoadResource2 (flags: integer; buffer: ptr; resourceType: resType; 179 | resourceID: resID): handle; tool ($1E, $29); 180 | 181 | procedure MarkResourceChange (changeFlag: boolean; resourceType: resType; 182 | resourceID: resID); tool ($1E, $10); 183 | 184 | procedure MatchResourceHandle (var foundRec: resourceSpec; 185 | resourceHandle: handle); tool ($1E, $1E); 186 | 187 | function OpenResourceFile (openAccess: integer; mapAddress: resMapPtr; 188 | var fileName: gsosInString): integer; tool ($1E, $0A); 189 | 190 | procedure ReleaseResource (purgeLevel: integer; resourceType: resType; 191 | resourceID: resID); tool ($1E, $17); 192 | 193 | procedure RemoveResource (resourceType: resType; resourceID: resID); 194 | tool ($1E, $0F); 195 | 196 | procedure ResourceConverter (converterProc: procPtr; resourceType: resType; 197 | logFlags: integer); tool ($1E, $28); 198 | 199 | function RMFindNamedResource (resourceType: resType; name: pString; 200 | var fileNum: integer): longint; tool ($1E, $2A); 201 | 202 | procedure RMGetResourceName (resourceType: resType; rID: longint; 203 | var name: pString); tool ($1E, $2B); 204 | 205 | procedure RMSetResourceName (resourceType: resType; rID: longint; 206 | name: pString); tool ($1E, $2D); 207 | 208 | function RMLoadNamedResource (resourceType: resType; name: pString): 209 | handle; tool ($1E, $2C); 210 | 211 | procedure SetCurResourceApp (myID: integer); tool ($1E, $13); 212 | 213 | procedure SetCurResourceFile (fileID: integer); tool ($1E, $11); 214 | 215 | procedure SetResourceAttr (resourceAttr: resAttr; resourceType: resType; 216 | resourceID: resID); tool ($1E, $1C); 217 | 218 | function SetResourceFileDepth (searchDepth: integer): integer; tool ($1E, $25); 219 | 220 | procedure SetResourceID (newID: resID; resourceType: resType; 221 | currentID: resID); tool ($1E, $1A); 222 | 223 | function SetResourceLoad (readFlag: integer): integer; tool ($1E, $24); 224 | 225 | function UniqueResourceID (IDrange: integer; resourceType: resType): resID; 226 | tool ($1E, $19); 227 | 228 | procedure UpdateResourceFile (fileID: integer); tool ($1E, $0D); 229 | 230 | procedure WriteResource (resourceType: resType; resourceID: resID); 231 | tool ($1E, $16); 232 | 233 | {new in 6.0.1} 234 | 235 | function OpenResourceFileByID (openAccess, userID: integer): integer; 236 | tool ($1E, $2E); 237 | 238 | procedure CompactResourceFile (flags, fileID: integer); tool ($1E, $2F); 239 | 240 | implementation 241 | end. 242 | -------------------------------------------------------------------------------- /Tool.Interface/SFToolSet.pas: -------------------------------------------------------------------------------- 1 | {$keep 'SFToolSet'} 2 | unit SFToolSet; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * Standard File Operations Tool Set Interface File 8 | * 9 | * Other USES Files Needed: Common, Dialog Manager 10 | * 11 | * Other Tool Sets Needed: Tool Locator, Memory Manager, 12 | * Miscellaneous Tool Set, QuickDraw II, 13 | * Event Manager, Window Manager, Control Manager, 14 | * Menu Manager, LineEdit Tool Set, Dialog Manager 15 | * 16 | * Copyright 1987-1990 17 | * By the Byte Works, Inc. 18 | * All Rights Reserved 19 | * 20 | *********************************************************} 21 | 22 | uses 23 | Common, DialogMgr; 24 | 25 | const 26 | (* Filter procedure results. *) 27 | noDisplay = $0000; (* don't display file *) 28 | noSelect = $0001; (* display file, but don't allow selection *) 29 | displaySelect = $0002; (* display file and allow selection *) 30 | 31 | type 32 | typeList = record 33 | numEntries: byte; 34 | fileType: array [1..10] of byte; (* Array can be expanded *) 35 | end; 36 | typeListPtr = ^typeList; 37 | 38 | replyRecord = record 39 | good: boolean; 40 | fileType: integer; 41 | auxFileType: integer; 42 | fileName: packed array [0..15] of char; 43 | fullPathName: pathName; 44 | end; 45 | 46 | replyRecord5_0 = record 47 | good: integer; 48 | fileType: integer; 49 | auxFileType: longint; 50 | nameVerb: integer; 51 | nameRef: longint; 52 | pathVerb: integer; 53 | pathRef: longint; 54 | end; 55 | 56 | typeRec = record 57 | flags: integer; 58 | fileType: integer; 59 | auxType: longint; 60 | end; 61 | 62 | typeList5_0 = record 63 | numEntries: integer; 64 | fileAndAuxTypes: array [1..10] of typeRec; (* change array size *) 65 | end; (* as needed *) 66 | typeList5_0Ptr = ^typeList5_0; 67 | 68 | multiReplyRecord = record 69 | good: integer; 70 | namesHandle: handle; 71 | end; 72 | 73 | 74 | procedure SFBootInit; tool ($17, $01); (* WARNING: an application should 75 | NEVER make this call *) 76 | 77 | procedure SFStartup (userID, dPageAddr: integer); tool ($17, $02); 78 | 79 | procedure SFShutDown; tool ($17, $03); 80 | 81 | function SFVersion: integer; tool ($17, $04); 82 | 83 | procedure SFReset; tool ($17, $05); (* WARNING: an application should 84 | NEVER make this call *) 85 | 86 | function SFStatus: boolean; tool ($17, $06); 87 | 88 | procedure SFAllCaps (allCapsFlag: boolean); tool ($17, $0D); 89 | 90 | procedure SFGetFile (whereX, whereY: integer; prompt: univ pStringPtr; 91 | filterProc: procPtr; theTypeList: typeListPtr; 92 | var theReply: replyRecord); tool ($17, $09); 93 | 94 | procedure SFGetFile2 (whereX, whereY, promptVerb: integer; 95 | promptRef: univ longint; filterProcPtr: procPtr; 96 | var theTypeList: typeList5_0; 97 | var theReply: replyRecord5_0); tool ($17, $0E); 98 | 99 | procedure SFMultiGet2 (whereX, whereY, promptVerb: integer; 100 | promptRef: univ longint; filterProcPtr: procPtr; 101 | var theTypeList: typeList5_0; 102 | var theReply: multiReplyRecord); tool ($17, $14); 103 | 104 | procedure SFPGetFile (whereX, whereY: integer; prompt: univ pStringPtr; 105 | filterProc: procPtr; theTypeList: typeListPtr; 106 | theDialogTemplate: dialogTempPtr; dialogHookPtr: procPtr; 107 | var theReply: replyRecord); tool ($17, $0B); 108 | 109 | procedure SFPGetFile2 (whereX, whereY: integer; itemDrawPtr: procPtr; 110 | promptVerb: integer; promptRef: univ longint; 111 | filterProcPtr: procPtr; var theTypeList: typeList5_0; 112 | var dlgTemp: dialogTemplate; dialogHookPtr: procPtr; 113 | var theReply: replyRecord5_0); tool ($17, $10); 114 | 115 | procedure SFPMultiGet2 (whereX, whereY: integer; itemDrawPtr: procPtr; 116 | promptVerb: integer; promptRef: univ longint; 117 | filterProcPtr: procPtr; 118 | var theTypeList: typeList5_0; 119 | var dlgTemp: dialogTemplate; dialogHookPtr: procPtr; 120 | var theReply: multiReplyRecord); tool ($17, $15); 121 | 122 | procedure SFPPutFile (whereX, whereY: integer; prompt, origName: univ pStringPtr; 123 | maxLen: integer; theDialogTemplate: dialogTempPtr; 124 | dialogHookPtr: procPtr; var theReply: replyRecord); 125 | tool ($17, $0C); 126 | 127 | procedure SFPPutFile2 (whereX, whereY: integer; itemDrawPtr: procPtr; 128 | promptVerb: integer; promptRef: univ longint; 129 | origNameVerb: integer; origNameRef: univ longint; 130 | var dlgTemp: dialogTemplate; dialogHookPtr: procPtr; 131 | var theReply: replyRecord5_0); tool ($17, $11); 132 | 133 | procedure SFPutFile (whereX, whereY: integer; prompt, origName: univ pStringPtr; 134 | maxLen: integer; var theReply: replyRecord); 135 | tool ($17, $0A); 136 | 137 | procedure SFPutFile2 (whereX, whereY, promptVerb: integer; 138 | promptRef: univ longint; origNameVerb: integer; 139 | origNameRef: univ longint; 140 | var theReply: replyRecord5_0); tool ($17, $0F); 141 | 142 | procedure SFReScan (filterProcPtr: procPtr; var theTypeList: typeList); 143 | tool ($17, $13); 144 | 145 | function SFShowInvisible (invisibleState: boolean): boolean; tool ($17, $12); 146 | 147 | implementation 148 | end. 149 | -------------------------------------------------------------------------------- /Tool.Interface/Scheduler.pas: -------------------------------------------------------------------------------- 1 | {$keep 'Scheduler'} 2 | unit Scheduler; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * Scheduler Tool Set Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other Tool Sets Needed: Tool Locator 12 | * 13 | * Copyright 1987-1990 14 | * By the Byte Works, Inc. 15 | * All Rights Reserved 16 | * 17 | *********************************************************} 18 | 19 | uses 20 | Common; 21 | 22 | 23 | procedure SchBootInit; tool ($07, $01); (* WARNING: an application should 24 | NEVER make this call *) 25 | 26 | procedure SchStartup; tool ($07, $02); 27 | 28 | procedure SchShutDown; tool ($07, $03); 29 | 30 | function SchVersion: integer; tool ($07, $04); 31 | 32 | procedure SchReset; tool ($07, $05); (* WARNING: an application should 33 | NEVER make this call *) 34 | 35 | function SchStatus: boolean; tool ($07, $06); 36 | 37 | function SchAddTask (theTask: procPtr): integer; tool ($07, $09); 38 | 39 | procedure SchFlush; tool ($07, $0A); (* WARNING: an application should 40 | NEVER make this call *) 41 | 42 | 43 | implementation 44 | 45 | end. 46 | -------------------------------------------------------------------------------- /Tool.Interface/ScrapMgr.pas: -------------------------------------------------------------------------------- 1 | {$keep 'ScrapMgr'} 2 | unit ScrapMgr; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * Scrap Manager Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other Tool Sets Needed: Tool Locator, Memory Manager 12 | * 13 | * Copyright 1987-1992, 1993 14 | * By the Byte Works, Inc. 15 | * All Rights Reserved 16 | * 17 | *********************************************************} 18 | 19 | uses 20 | Common; 21 | 22 | const 23 | (* Scrap types *) 24 | textScrap = 0; 25 | picScrap = 1; 26 | 27 | (* ShowClipboard flag values *) 28 | cpOpenWindow = $8000; 29 | cpCloseWindow = $4000; 30 | 31 | type 32 | scrapBuffer = record 33 | scrapType: integer; 34 | scrapSize: longint; 35 | scrapHandle: handle; 36 | end; 37 | 38 | procedure ScrapBootInit; tool ($16, $01); (* WARNING: an application should 39 | NEVER make this call *) 40 | 41 | procedure ScrapStartup; tool ($16, $02); 42 | 43 | procedure ScrapShutDown; tool ($16, $03); 44 | 45 | function ScrapVersion: integer; tool ($16, $04); 46 | 47 | procedure ScrapReset; tool ($16, $05); (* WARNING: an application should 48 | NEVER make this call *) 49 | 50 | function ScrapStatus: boolean; tool ($16, $06); 51 | 52 | procedure GetIndScrap (index: integer; buffer: scrapBuffer); tool ($16, $14); 53 | 54 | procedure GetScrap (destHandle: handle; scrapType: integer); tool ($16, $0D); 55 | 56 | function GetScrapCount: integer; tool ($16, $12); 57 | 58 | function GetScrapHandle (scrapType: integer): handle; tool ($16, $0E); 59 | 60 | function GetScrapPath: pathPtr; tool ($16, $10); 61 | 62 | function GetScrapSize (scrapType: integer): longint; tool ($16, $0F); 63 | 64 | function GetScrapState: integer; tool ($16, $13); 65 | 66 | procedure LoadScrap; tool ($16, $0A); 67 | 68 | procedure PutScrap (numBytes: longint; scrapType: integer; srcPtr: ptr); 69 | tool ($16, $0C); 70 | 71 | procedure SetScrapPath (var thePath: pathName); tool ($16, $11); 72 | 73 | procedure UnloadScrap; tool ($16, $09); 74 | 75 | procedure ZeroScrap; tool ($16, $0B); 76 | 77 | {new in 6.0.1} 78 | 79 | function ShowClipboard (flags: integer; zoomRect: rectPtr): grafPortPtr; 80 | tool ($16, $15); 81 | 82 | implementation 83 | end. 84 | -------------------------------------------------------------------------------- /Tool.Interface/Sequencer.pas: -------------------------------------------------------------------------------- 1 | {$keep 'Sequencer'} 2 | unit Sequencer; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * Note Sequencer Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other Tool Sets Needed: Tool Locator, Memory Manager 12 | * 13 | * Copyright 1987-1992 14 | * By the Byte Works, Inc. 15 | * All Rights Reserved 16 | * 17 | *********************************************************} 18 | 19 | uses 20 | Common; 21 | 22 | procedure SeqBootInit; tool ($1A, $01); (* WARNING: an application should 23 | NEVER make this call *) 24 | 25 | procedure SeqStartup (dPageAddr, mode, updateRate, increment: integer); 26 | tool ($1A, $02); 27 | 28 | procedure SeqShutdown; tool ($1A, $03); 29 | 30 | function SeqVersion: integer; tool ($1A, $04); 31 | 32 | procedure SeqReset; tool ($1A, $05); (* WARNING: an application should 33 | NEVER make this call *) 34 | 35 | function SeqStatus: boolean; tool ($1A, $06); 36 | 37 | function ClearIncr: integer; tool ($1A, $0A); 38 | 39 | (* The function GetLoc returns 3 words: *) 40 | (* curPhraseItem, curPattItem, and curLevel *) 41 | (* function GetLoc: 3 words; tool ($1A, $0C); *) 42 | 43 | function GetTimer: integer; tool ($1A, $0B); 44 | 45 | procedure SeqAllNotesOff; tool ($1A, $0D); 46 | 47 | procedure SetIncr (increment: integer); tool ($1A, $09); 48 | 49 | procedure SetInstTable (instTable: handle); tool ($1A, $12); 50 | 51 | procedure SetTrkInfo (priority, instIndex, trackNum: integer); tool ($1A, $0E); 52 | 53 | procedure StartInts; tool ($1A, $13); 54 | 55 | procedure StartSeq (errHndlrRoutine, compRoutine: procPtr; sequence: univ handle); 56 | tool ($1A, $0F); 57 | 58 | procedure StartSeqRel (errHndlrRtn, compRtn: procPtr; sequence: univ handle); 59 | tool ($1A, $15); 60 | 61 | procedure StepSeq; tool ($1A, $10); 62 | 63 | procedure StopInts; tool ($1A, $14); 64 | 65 | procedure StopSeq (next: boolean); tool ($1A, $11); 66 | 67 | implementation 68 | end. 69 | -------------------------------------------------------------------------------- /Tool.Interface/SoundMgr.pas: -------------------------------------------------------------------------------- 1 | {$keep 'SoundMgr'} 2 | unit SoundMgr; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * Sound Manager Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other Tool Sets Needed: Tool Locator, Memory Manager 12 | * 13 | * Copyright 1987-1990 14 | * By the Byte Works, Inc. 15 | * All Rights Reserved 16 | * 17 | *********************************************************} 18 | 19 | uses 20 | Common; 21 | 22 | const 23 | (* Channel-generator-type word *) 24 | ffSynthMode = $0001; (* free-form synthesizer mode *) 25 | noteSynthMode = $0002; (* note synthesizer mode *) 26 | 27 | (* Stop-sound mask *) 28 | gen0off = $0001; 29 | gen1off = $0002; 30 | gen2off = $0004; 31 | gen3off = $0008; 32 | gen4off = $0010; 33 | gen5off = $0020; 34 | gen6off = $0040; 35 | gen7off = $0080; 36 | gen8off = $0100; 37 | gen9off = $0200; 38 | gen10off = $0400; 39 | gen11off = $0800; 40 | gen12off = $1000; 41 | gen13off = $2000; 42 | gen14off = $4000; 43 | 44 | (* Generator status word *) 45 | genAvail = $0000; 46 | ffSynth = $0100; 47 | noteSynth = $0200; 48 | lastBlock = $8000; 49 | 50 | 51 | type 52 | soundPBPtr = ^soundParamBlock; 53 | soundParamBlock = record 54 | waveStart: ptr; (* starting address of wave *) 55 | waveSize: integer; (* waveform size in pages *) 56 | freqOffset: integer; (* waveform playback frequency *) 57 | DOCBuffer: integer; (* DOC buffer starting address *) 58 | DOCBufferSize: integer; (* DOC buffer size code *) 59 | nextWAddr: soundPBPtr; (* ptr to next waveform block *) 60 | volSetting: integer; (* DOC volume setting *) 61 | end; 62 | 63 | DOCRegParamBlk = record 64 | oscGenType: integer; 65 | freqLow1: byte; (* 1st oscillator's parameters *) 66 | freqHigh1: byte; 67 | vol1: byte; 68 | tablePtr1: byte; 69 | control1: byte; 70 | tableSize1: byte; 71 | freqLow2: byte; (* 2nd oscillator's parameters *) 72 | freqHigh2: byte; 73 | vol2: byte; 74 | tablePtr2: byte; 75 | control2: byte; 76 | tableSize2: byte; 77 | end; 78 | 79 | 80 | procedure SoundBootInit; tool ($08, $01); (* WARNING: an application should 81 | NEVER make this call *) 82 | 83 | procedure SoundStartUp (WAP: integer); tool ($08, $02); 84 | 85 | procedure SoundShutDown; tool ($08, $03); 86 | 87 | function SoundVersion: integer; tool ($08, $04); 88 | 89 | procedure SoundReset; tool ($08, $05); (* WARNING: an application should 90 | NEVER make this call *) 91 | 92 | function SoundToolStatus: boolean; tool ($08, $06); 93 | 94 | procedure FFSetUpSound (channelGen: integer; 95 | var paramBlockPtr: soundParamBlock); tool ($08, $15); 96 | 97 | function FFGeneratorStatus (genNumber: integer): integer; 98 | tool ($08, $11); 99 | 100 | function FFSoundDoneStatus (genNumber: integer): boolean; tool ($08, $14); 101 | 102 | function FFSoundStatus: integer; tool ($08, $10); 103 | 104 | procedure FFStartPlaying (genWord: integer); tool ($08, $16); 105 | 106 | procedure FFStartSound (genNumFFSynth: integer; var PBlockPtr: soundParamBlock); 107 | tool ($08, $0E); 108 | 109 | procedure FFStopSound (genMask: integer); tool ($08, $0F); 110 | 111 | function GetSoundVolume (genNumber: integer): integer; tool ($08, $0C); 112 | 113 | function GetTableAddress: longint; tool ($08, $0B); 114 | 115 | procedure ReadDOCReg (var DOCregParamBlkPtr: DOCregParamBlk); tool ($08, $18); 116 | 117 | procedure ReadRamBlock (destPtr: ptr; DOCStart, byteCount: integer); 118 | tool ($08, $0A); 119 | 120 | procedure SetDOCReg (var DOCRegParamBlock: DOCRegParamBlk); tool ($08, $17); 121 | 122 | procedure SetSoundMIRQV (sMasterIRQ: longint); tool ($08, $12); 123 | 124 | procedure SetSoundVolume (volume, genNumber: integer); tool ($08, $0D); 125 | 126 | function SetUserSoundIRQV (userIRQVector: longint): longint; tool ($08, $13); 127 | 128 | procedure WriteRamBlock (srcPtr: ptr; DOCStart, byteCount: integer); 129 | tool ($08, $09); 130 | 131 | implementation 132 | end. 133 | -------------------------------------------------------------------------------- /Tool.Interface/Synthesizer.pas: -------------------------------------------------------------------------------- 1 | {$keep 'Synthesizer'} 2 | unit Synthesizer; 3 | interface 4 | 5 | (******************************************************** 6 | * 7 | * Note Synthesizer Tool Set Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other tool sets needed: Sound Tool Set 12 | * 13 | * Copyright 1987-1990 14 | * By the Byte Works, Inc. 15 | * All Rights Reserved 16 | * 17 | *********************************************************) 18 | 19 | uses 20 | Common; 21 | 22 | type 23 | waveForm = record 24 | topKey: byte; 25 | waveAddress: byte; 26 | waveSize: byte; 27 | DOCMode: byte; 28 | relPitch: integer; 29 | end; 30 | 31 | instrument = record 32 | envelope: array [1..24] of byte; 33 | releaseSegment: byte; 34 | priorityIncrement: byte; 35 | pitchBendRange: byte; 36 | vibratoDepth: byte; 37 | vibratoSpeed: byte; 38 | spare: byte; 39 | aWaveCount: byte; 40 | bWaveCount: byte; 41 | aWaveList: array [1..1] of waveForm; (* aWaveCount * 6 bytes *) 42 | bWaveList: array [1..1] of waveForm; (* bWaveCount * 6 bytes *) 43 | end; 44 | 45 | generatorControlBlock = record 46 | synthID: byte; 47 | genNum: byte; 48 | semitone: byte; 49 | volume: byte; 50 | pitchBend: byte; 51 | vibratoDepth: byte; 52 | reserved: array [1..10] of byte; 53 | end; 54 | 55 | procedure NSBootInit; tool ($19, $01); (* WARNING: an application should 56 | NEVER make this call *) 57 | 58 | procedure NSStartUp (updateRate: integer; updateRtn: procPtr) ; tool ($19, $02); 59 | 60 | procedure NSShutDown; tool ($19, $03); 61 | 62 | function NSVersion: integer; tool ($19, $04); 63 | 64 | procedure NSReset; tool ($19, $05); (* WARNING: an application should 65 | NEVER make this call *) 66 | 67 | function NSStatus: boolean; tool ($19, $06); 68 | 69 | procedure AllNotesOff; tool ($19, $0D); 70 | 71 | function AllocGen (requestPriority: integer): integer; tool ($19, $09); 72 | 73 | procedure DeallocGen (genNum: integer); tool ($19, $0A); 74 | 75 | procedure NoteOff (genNum, semitone: integer); tool ($19, $0C); 76 | 77 | procedure NoteOn (genNum, semitone, volume: integer; 78 | var theInstrument: instrument); tool ($19, $0B); 79 | 80 | function NSSetUpdateRate (newRate: integer): integer; tool ($19, $0E); 81 | 82 | function NSSetUserUpdateRtn (newUpdateRtn: procPtr): procPtr; tool ($19, $0F); 83 | 84 | implementation 85 | end. 86 | -------------------------------------------------------------------------------- /Tool.Interface/TextEdit.pas: -------------------------------------------------------------------------------- 1 | {$keep 'TextEdit'} 2 | unit TextEdit; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * Text Edit Tool Set Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other Tool Sets Needed: Tool Locator, Miscellaneous Tool Set, 12 | * QuickDraw II, Event Manager, 13 | * Window Manager, Control Manager, 14 | * Menu Manager, QuickDraw Auxiliary, 15 | * Scrap Manager, Font Manager, Resource Manager 16 | * 17 | * Copyright 1987-1990 18 | * By the Byte Works, Inc. 19 | * All Rights Reserved 20 | * 21 | *********************************************************} 22 | 23 | uses 24 | Common, ControlMgr; 25 | 26 | const 27 | (* Text Edit error codes *) 28 | teAlreadyStarted = $2201; 29 | teNotStarted = $2202; 30 | teInvalidHandle = $2203; 31 | teInvalidVerb = $2204; 32 | teInvalidFlag = $2205; 33 | teInvalidPCount = $2206; 34 | teInvalidRect = $2207; 35 | teBufferOverflow = $2208; 36 | teInvalidLine = $2209; 37 | teInvalidCall = $220A; 38 | teInvalidParameter = $220B; 39 | teInvalidTextBox2 = $220C; 40 | 41 | (* Text descriptors: Bits 0-2 of descriptor word *) 42 | dataIsPString = $000; 43 | dataIsCString = $001; 44 | dataIsC1Input = $002; 45 | dataIsC1Output = $003; 46 | dataIsTextBox2 = $004; 47 | dataIsTextBlock = $005; 48 | 49 | (* Text Edit reference descriptors *) 50 | teRefIsPtr = $0000; 51 | teRefIsHandle = $0001; 52 | teRefIsResource = $0002; 53 | teRefIsNewHandle = $0003; 54 | 55 | type 56 | teColorTablePtr = ^TEColorTable; 57 | teColorTable = record 58 | contentColor: integer; 59 | outlineColor: integer; 60 | hiliteForeColor: integer; 61 | hiliteBackColor: integer; 62 | vertColorDescriptor: integer; 63 | vertColorRef: longint; 64 | horzColorDescriptor: integer; 65 | horzColorRef: longint; 66 | growColorDescriptor: integer; 67 | growColorRef: longint; 68 | end; 69 | 70 | teTextBlock = record 71 | nextHandle: longint; 72 | prevHandle: longint; 73 | textLength: longint; 74 | flags: integer; 75 | reserved: integer; 76 | (* Change size of array to suit your needs. *) 77 | theText: packed array [1..512] of text; 78 | end; 79 | 80 | superItem = record 81 | theLength: longint; 82 | theData: longint; 83 | end; 84 | 85 | superBlock = record 86 | nextHandle: longint; 87 | prevHandle: longint; 88 | textLength: longint; 89 | reserved: longint; 90 | (* Change the array size to suit your needs. *) 91 | theItems: array [1..10] of superItem; 92 | end; 93 | 94 | (* Definitions of textList, superHandle, teStyle, and keyRecord can be *) 95 | (* found in the Common.Intf interface file. *) 96 | 97 | teHandle = ctlRecHndl; 98 | teRecPtr = ctlPtr; 99 | teTabItem = record 100 | tabKind: integer; 101 | tabData: integer; 102 | end; 103 | 104 | teRuler = record 105 | leftMargin: integer; 106 | leftIndent: integer; 107 | rightMargin: integer; 108 | just: integer; 109 | extraLS: integer; 110 | flags: integer; 111 | userData: longint; 112 | tabType: integer; 113 | (* Change size of array for application. *) 114 | tabs: array [1..1] of teTabItem; 115 | tabTerminator: integer; 116 | end; 117 | 118 | teStyleGroupHndl = ^teStyleGroupPtr; 119 | teStyleGroupPtr = ^teStyleGroup; 120 | teStyleGroup = record 121 | count: integer; 122 | (* Change array size for application. *) 123 | styles: array [1..1] of teStyle; 124 | end; 125 | 126 | teStyleItem = record 127 | length: longint; 128 | offset: longint; 129 | end; 130 | 131 | teFormatHndl = ^teFormatPtr; 132 | teFormatPtr = ^teFormat; 133 | teFormat = record 134 | version: integer; 135 | rulerListLength: longint; 136 | (* Change array size for application. *) 137 | theRulerList: array [1..1] of teRuler; 138 | styleListLength: longint; 139 | (* Change array size for application. *) 140 | theStyleList: array [1..1] of teStyle; 141 | numberOfStyles: longint; 142 | (* Change array size for application. *) 143 | theStyles: array [1..1] of teStyleItem; 144 | end; 145 | 146 | teTextRef = longint; 147 | teStyleRef = longint; 148 | 149 | (* The TEParamBlock record appears in the Resource Manager interface file *) 150 | (* as editTextControl. *) 151 | 152 | teInfoRec = record 153 | charCount: longint; 154 | lineCount: longint; 155 | formatMemory: longint; 156 | totalMemory: longint; 157 | styleCount: longint; 158 | rulerCount: longint; 159 | end; 160 | 161 | teHooks = record 162 | charFilter: procPtr; 163 | wordWrap: procPtr; 164 | wordBreak: procPtr; 165 | drawText: procPtr; 166 | eraseText: procPtr; 167 | end; 168 | 169 | 170 | procedure TEBootInit; tool ($22, $01); 171 | 172 | procedure TEStartup (myId: integer; directPage: integer); tool ($22, $02); 173 | 174 | procedure TEShutDown; tool ($22, $03); 175 | 176 | function TEVersion: integer; tool ($22, $04); 177 | 178 | procedure TEReset; tool ($22, $05); 179 | 180 | function TEStatus: boolean; tool ($22, $06); 181 | 182 | procedure TEActivate (theTERecord: teHandle); tool ($22, $0F); 183 | 184 | procedure TEClear (theTERecord: teHandle); tool ($22, $19); 185 | 186 | procedure TEClick (var theEvent: eventRecord; theTERecord: teHandle); 187 | tool ($22, $11); 188 | 189 | procedure TECopy (theTERecord: teHandle); tool ($22, $17); 190 | 191 | procedure TECut (theTERecord: teHandle); tool ($22, $16); 192 | 193 | procedure TEDeactivate (theTERecord: teHandle); tool ($22, $10); 194 | 195 | function TEGetDefProc: procPtr; tool ($22, $22); 196 | 197 | procedure TEGetRuler (rulerDescriptor: integer; rulerRef: univ longint; 198 | theTERecord: teHandle); tool ($22, $23); 199 | 200 | procedure TEGetSelection (selectionStart, selectionEnd: univ ptr; 201 | theTERecord: teHandle); tool ($22, $1C); 202 | 203 | function TEGetSelectionStyle (var commonStyle: teStyle; 204 | styleHandle: TEStyleGroupHndl; 205 | theTERecord: teHandle): integer; tool ($22, $1E); 206 | 207 | function TEGetText (bufferDescriptor: integer; bufferRef: univ longint; 208 | bufferLength: longint; styleDescriptor: integer; 209 | styleRef: univ longint; theTERecord: teHandle): longint; 210 | tool ($22, $0C); 211 | 212 | procedure TEGetTextInfo (var infoRec: teInfoRec; parameterCount: integer; 213 | theTERecord: teHandle); tool ($22, $0D); 214 | 215 | procedure TEIdle (theTERecord: teHandle); tool ($22, $0E); 216 | 217 | procedure TEInsert (textDescriptor: integer; textRef: teTextRef; 218 | textLength: longint; styleDescriptor: integer; 219 | styleRef: teStyleRef; theTERecord: teHandle); 220 | tool ($22, $1A); 221 | 222 | procedure TEInsertPageBreak; tool ($22, $23); 223 | 224 | procedure TEKey (var theEventRecord: eventRecord; theTERecord: teHandle); 225 | tool ($22, $14); 226 | 227 | procedure TEKill (theTERecord: teHandle); tool ($22, $0A); 228 | 229 | function TENew (var parameterBlock: editTextControl): teHandle; tool ($22, $09); 230 | 231 | procedure TEOffsetToPoint (textOffset: longint; vertPosPtr, horzPosPtr: ptr; 232 | theTERecord: teHandle); tool ($22, $20); 233 | 234 | function TEPaintText (thePort: grafPortPtr; startingLine: longint; 235 | var destRect: rect; flags: integer; 236 | theTERecord: teHandle): longint; tool ($22, $13); 237 | 238 | procedure TEPaste (theTERecord: teHandle); tool ($22, $18); 239 | 240 | function TEPointToOffset (vertPos, horzPos: longint; theTERecord: teHandle): 241 | longint; tool ($22, $21); 242 | 243 | procedure TEReplace (textDescriptor: integer; textRef: teTextRef; 244 | textLength: longint; styleDescriptor: integer; 245 | styleRef: teStyleRef; theTERecord: teHandle); 246 | tool ($22, $1B); 247 | 248 | procedure TEScroll (scrollDescriptor: integer; vertAmount, horzAmount: longint; 249 | theTERecord: teHandle); tool ($22, $25); 250 | 251 | procedure TESetRuler (rulerDescriptor: integer; rulerRef: univ longint; 252 | theTERecord: teHandle); tool ($22, $24); 253 | 254 | procedure TESetSelection (selectionStart, selectionEnd: longint; 255 | theTEREcord: teHandle); tool ($22, $1D); 256 | 257 | procedure TESetText (textDescriptor: integer; textRef: teTextRef; 258 | textLength: longint; styleDescriptor: integer; 259 | styleRef: teStyleRef; theTERecord: teHandle); 260 | tool ($22, $0B); 261 | 262 | procedure TEStyleChange (flags: integer; var newStyle: teStyle; 263 | theTERecord: teHandle); tool ($22, $1F); 264 | 265 | procedure TEUpdate (theTERecord: TEHandle); tool ($22, $12); 266 | 267 | implementation 268 | end. 269 | -------------------------------------------------------------------------------- /Tool.Interface/TextToolSet.pas: -------------------------------------------------------------------------------- 1 | {$keep 'TextToolSet'} 2 | unit TextToolSet; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * Text Tool Set Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other Tool Sets Needed: Tool Locator, Memory Manager 12 | * 13 | * Copyright 1987-1989 14 | * By the Byte Works, Inc. 15 | * All Rights Reserved 16 | * 17 | *********************************************************} 18 | 19 | uses 20 | Common; 21 | 22 | const 23 | (* Echo flag values *) 24 | noEcho = $0000; (* don't echo chars to output device *) 25 | echo = $0001; (* echo chars to output device *) 26 | 27 | (* Device numbers *) 28 | inputDev = $0000; 29 | outputDev = $0001; 30 | errorOutputDev = $0002; 31 | 32 | (* Device types *) 33 | basicType = $0000; 34 | pascalType = $0001; 35 | ramBased = $0002; 36 | 37 | 38 | procedure TextBootInit; tool ($0C, $01); (* WARNING: an application should 39 | NEVER make this call *) 40 | 41 | procedure TextStartup; tool ($0C, $02); 42 | 43 | procedure TextShutDown; tool ($0C, $03); 44 | 45 | function TextVersion: integer; tool ($0C, $04); 46 | 47 | procedure TextReset; tool ($0C, $05); (* WARNING: an application should 48 | NEVER make this call *) 49 | 50 | function TextStatus: boolean; tool ($0C, $06); 51 | 52 | procedure CtlTextDev (deviceNumber, controlCode: integer); tool ($0C, $16); 53 | 54 | procedure ErrWriteBlock (theText: textBlock; offset, count: integer); 55 | tool ($0C, $1F); 56 | 57 | procedure ErrWriteChar (theChar: char); tool ($0C, $19); 58 | 59 | procedure ErrWriteCString (theCString: univ cStringPtr); tool ($0C, $21); 60 | 61 | procedure ErrWriteLine (theString: univ pStringPtr); tool ($0C, $1B); 62 | 63 | procedure ErrWriteString (theString: univ pStringPtr); tool ($0C, $1D); 64 | 65 | (* GetErrGlobals returns 2 words: loWord = OR mask, hiWord = AND mask *) 66 | function GetErrGlobals: longint; tool ($0C, $0E); 67 | 68 | (* GetErrorDevice returns 1 integer and 1 longint. *) 69 | (* function GetErrorDevice: (deviceType: integer; ptrOrSlot: longint); *) 70 | (* tool ($0C, $14); *) 71 | 72 | (* GetInGlobals returns 2 words: loWord = OR mask, hiWord = AND mask *) 73 | function GetInGlobals: longint; tool ($0C, $0C); 74 | 75 | (* GetInputDevice returns 1 integer and 1 longint. *) 76 | (* function GetInputDevice: (deviceType: integer; ptrOrSlot: longint); *) 77 | (* tool ($0C, $12); *) 78 | 79 | (* GetOutGlobals returns 2 words: loWord = OR mask, hiWord = AND mask *) 80 | function GetOutGlobals: longint; tool ($0C, $0D); 81 | 82 | (* GetOutputDevice returns 1 integer and 1 longint. *) 83 | (* function GetOutputDevice: (deviceType: integer; ptrOrSlot: longint); *) 84 | (* tool ($0C, $13); *) 85 | 86 | procedure InitTextDev (deviceNum: integer); tool ($0C, $15); 87 | 88 | function ReadChar (echoFlag: boolean): char; tool ($0C, $22); 89 | 90 | function ReadLine (bufferPtr: ptr; maxCount: integer; endOfLine: char; 91 | echoFlag: boolean): integer; tool ($0C, $24); 92 | 93 | procedure SetErrGlobals (ANDMask, ORMask: integer); tool ($0C, $0B); 94 | 95 | procedure SetErrorDevice (deviceType: integer; slotOrPointer: longint); 96 | tool ($0C, $11); 97 | 98 | procedure SetInGlobals (ANDMask, ORMask: integer); tool ($0C, $09); 99 | 100 | procedure SetInputDevice (deviceType: integer; slotOrPointer: longint); 101 | tool ($0C, $0F); 102 | 103 | procedure SetOutGlobals (ANDMask, ORMask: integer); tool ($0C, $0A); 104 | 105 | procedure SetOutputDevice (deviceType: integer; slotOrPointer: longint); 106 | tool ($0C, $10); 107 | 108 | procedure StatusTextDev (deviceNum, requestCode: integer); tool ($0C, $17); 109 | 110 | procedure TextReadBlock (bufferPtr: ptr; offset, blockSize: integer; 111 | echoFlag: boolean); tool ($0C, $23); 112 | 113 | procedure TextWriteBlock (theText: univ textPtr; offset, count: integer); 114 | tool ($0C, $1E); 115 | 116 | procedure WriteChar (theChar: char); tool ($0C, $18); 117 | 118 | procedure WriteCString (theCString: univ cStringPtr); tool ($0C, $20); 119 | 120 | procedure WriteLine (theString: univ pStringPtr); tool ($0C, $1A); 121 | 122 | procedure WriteString (theString: univ pStringPtr); tool ($0C, $1C); 123 | 124 | implementation 125 | end. 126 | -------------------------------------------------------------------------------- /Tool.Interface/ToolLocator.pas: -------------------------------------------------------------------------------- 1 | {$keep 'ToolLocator'} 2 | unit ToolLocator; 3 | interface 4 | 5 | {******************************************************** 6 | * 7 | * Tool Locator Interface File 8 | * 9 | * Other USES Files Needed: Common 10 | * 11 | * Other Tool Sets Needed: - None - 12 | * 13 | * Copyright 1987-1992 14 | * By the Byte Works, Inc. 15 | * All Rights Reserved 16 | * 17 | *********************************************************} 18 | 19 | uses 20 | Common; 21 | 22 | const 23 | (* MessageCenter action codes *) 24 | addMessage = 1; (* add message to msg center data *) 25 | getMessage = 2; (* return message from msg center *) 26 | deleteMessage = 3; (* delete message from msg center *) 27 | 28 | 29 | type 30 | (* Table of tools to load from the TOOLS directory in the SYSTEM folder *) 31 | toolSpec = record 32 | toolNumber: integer; 33 | minVersion: integer; 34 | end; 35 | 36 | (* Change array size for your application. *) 37 | ttArray = array [1..20] of toolSpec; 38 | 39 | toolTable = record 40 | numToolsRequired: integer; 41 | tool: ttArray; 42 | end; 43 | 44 | startStopRecord = record 45 | flags: integer; 46 | videoMode: integer; 47 | resFileID: integer; 48 | DPageHandle: handle; 49 | numTools: integer; 50 | toolArray: ttArray; 51 | end; 52 | startStopRecordPtr = ^startStopRecord; 53 | 54 | (* Function pointer table *) 55 | FPT = record 56 | count: longint; (* number of functions plus 1 *) 57 | addr1: ptr; (* ptr to BootInit routine minus 1 *) 58 | addr2: ptr; (* ptr to StartUp routine minus 1 *) 59 | addr3: ptr; (* ptr to ShutDown routine minus 1 *) 60 | addr4: ptr; (* ptr to Version routine minus 1 *) 61 | addr5: ptr; (* ptr to Reset routine minus 1 *) 62 | addr6: ptr; (* ptr to Status routine minus 1 *) 63 | addr7: ptr; (* ptr to reserved routine minus 1 *) 64 | addr8: ptr; (* ptr to reserved routine minus 1 *) 65 | addr9: ptr; (* ptr to 1st nonrequired routine minus 1 *) 66 | (* Other pointers to additional nonrequired routines, each minus 1 *) 67 | addr: array [1..50] of ptr; 68 | end; 69 | 70 | messageRecord = record 71 | blockLength: integer; 72 | IDstring: pString; (* may be a max of 64 chars long *) 73 | (* Change length of array to suit application. *) 74 | dataBlock: packed array [1..1] of byte; 75 | end; 76 | 77 | 78 | procedure TLBootInit; tool ($01, $01); (* WARNING: an application should 79 | NEVER make this call *) 80 | 81 | procedure TLStartup; tool ($01, $02); 82 | 83 | procedure TLShutDown; tool ($01, $03); 84 | 85 | function TLVersion: integer; tool ($01, $04); 86 | 87 | procedure TLReset; tool ($01, $05); (* WARNING: an application should 88 | NEVER make this call *) 89 | 90 | function TLStatus: boolean; tool ($01, $06); 91 | 92 | procedure AcceptRequests (nameString: pString; userID: integer; 93 | requestProc: ptr); tool ($01, $1B); 94 | 95 | function GetFuncPtr (userOrSystem: integer; funcNum_TSNum: integer): longint; 96 | tool ($01, $0B); 97 | 98 | function GetMsgHandle (flags: integer; messageRef: univ longint): longint; 99 | tool ($01, $1A); 100 | 101 | function GetTSPtr (userOrSystem, tsNum: integer): longint; tool ($01, $09); 102 | 103 | function GetWAP (userOrSystem, tsNum: integer): longint; tool ($01, $0C); 104 | 105 | procedure LoadOneTool (toolNumber, minVersion: integer); tool ($01, $0F); 106 | 107 | procedure LoadTools (var theToolTable: toolTable); tool ($01, $0E); 108 | 109 | (* MessageByName returns two words: lo word = message number *) 110 | (* hi word = boolean flag *) 111 | function MessageByName (createItFlag: boolean; var inputRecord: messageRecord): 112 | longint; tool ($01, $17); 113 | 114 | procedure MessageCenter (action, msgID: integer; messageHandle: handle); 115 | tool ($01, $15); 116 | 117 | procedure RestoreTextState (stateHandle: handle); tool ($01, $14); 118 | 119 | function SaveTextState: handle; tool ($01, $13); 120 | 121 | procedure SendRequest (reqCode, sendHow: integer; target, dataIn: univ longint; 122 | dataOut: ptr); tool ($01, $1C); 123 | 124 | procedure SetDefaultTPT; tool ($01, $16); (* WARNING: an application should 125 | NEVER make this call *) 126 | 127 | procedure SetTSPtr (userOrSystem, tsNum: integer; theFPT: FPT); 128 | tool ($01, $0A); 129 | 130 | procedure SetWAP (userOrSystem, tsNum: integer; waptPtr: ptr); 131 | tool ($01, $0D); 132 | 133 | procedure ShutDownTools (startStopVerb: integer; 134 | startStopRecRef: univ longint); tool ($01, $19); 135 | 136 | function StartupTools (myID, startStopVerb: integer; 137 | startStopRecRef: univ longint): longint; 138 | tool ($01, $18); 139 | 140 | function TLMountVolume (whereX, whereY: integer; line1Ptr, line2Ptr, 141 | but1Ptr, but2Ptr: pStringPtr): integer; tool ($01, $11); 142 | 143 | function TLTextMountVolume (line1Ptr, line2Ptr, button1Ptr, button2Ptr: 144 | pStringPtr): integer; tool ($01, $12); 145 | 146 | procedure UnloadOneTool (toolNumber: integer); tool ($01, $10); 147 | 148 | implementation 149 | end. 150 | -------------------------------------------------------------------------------- /backup: -------------------------------------------------------------------------------- 1 | if "{#}" != "1" 2 | echo Form: backup [day] 3 | exit 65535 4 | end 5 | 6 | set dest /library/mike/{1}/pascal 7 | 8 | set list make linkit count backup smac pascal.notes 9 | set list {list} pascal.pas pascal.rez 10 | set list {list} parser.pas 11 | set list {list} call.pas 12 | set list {list} symbols.pas symbols.asm symbols.macros 13 | set list {list} pcommon.pas pcommon.asm pcommon.macros 14 | set list {list} scanner.pas scanner.asm scanner.macros 15 | set list {list} cgi.pas cgi.comments cgi.asm 16 | set list {list} native.pas native.asm native.macros 17 | set list {list} objout.pas objout.asm objout.macros 18 | set list {list} dag.pas dag.asm dag.macros 19 | set list {list} cgc.pas cgc.asm cgc.macros 20 | set list {list} gen.pas 21 | 22 | unset exit 23 | create {dest} >.null >&.null 24 | for i in {list} 25 | newer {dest}/{i} {i} 26 | if {Status} != 0 27 | copy -c {i} {dest}/{i} 28 | end 29 | end 30 | -------------------------------------------------------------------------------- /cgc.asm: -------------------------------------------------------------------------------- 1 | mcopy cgc.macros 2 | **************************************************************** 3 | * 4 | * CnvSX - Convert floating point to SANE extended 5 | * 6 | * Inputs: 7 | * rec - pointer to a record 8 | * 9 | **************************************************************** 10 | * 11 | CnvSX start 12 | rec equ 4 record containing values 13 | rec_real equ 0 disp to real value 14 | rec_ext equ 8 disp to extended (SANE) value 15 | 16 | tsc set up DP 17 | phd 18 | tcd 19 | ph4 rec push addr of real number 20 | clc push addr of SANE number 21 | lda rec 22 | adc #rec_ext 23 | tax 24 | lda rec+2 25 | adc #0 26 | pha 27 | phx 28 | fd2x convert TOS to extended 29 | move4 0,4 return 30 | pld 31 | pla 32 | pla 33 | rtl 34 | end 35 | -------------------------------------------------------------------------------- /cgc.macros: -------------------------------------------------------------------------------- 1 | macro 2 | &l move4 &m1,&m2 3 | lclb &yistwo 4 | &l ~setm 5 | ~lda &m1 6 | ~sta &m2 7 | ~lda.h &m1 8 | ~sta.h &m2 9 | ~restm 10 | mend 11 | macro 12 | &l ph4 &n1 13 | aif "&n1"="*",.f 14 | lclc &c 15 | &l anop 16 | &c amid &n1,1,1 17 | aif "&c"="#",.d 18 | aif s:longa=1,.a 19 | rep #%00100000 20 | .a 21 | aif "&c"<>"{",.b 22 | &c amid &n1,l:&n1,1 23 | aif "&c"<>"}",.g 24 | &n1 amid &n1,2,l:&n1-2 25 | ldy #2 26 | lda (&n1),y 27 | pha 28 | lda (&n1) 29 | pha 30 | ago .e 31 | .b 32 | aif "&c"<>"[",.c 33 | ldy #2 34 | lda &n1,y 35 | pha 36 | lda &n1 37 | pha 38 | ago .e 39 | .c 40 | aif "&c"<>"<",.c1 41 | &n1 amid &n1,2,l:&n1-1 42 | pei &n1+2 43 | pei &n1 44 | ago .e 45 | .c1 46 | lda &n1+2 47 | pha 48 | lda &n1 49 | pha 50 | ago .e 51 | .d 52 | &n1 amid &n1,2,l:&n1-1 53 | pea +(&n1)|-16 54 | pea &n1 55 | ago .f 56 | .e 57 | aif s:longa=1,.f 58 | sep #%00100000 59 | .f 60 | mexit 61 | .g 62 | mnote "Missing closing '}'",16 63 | mend 64 | macro 65 | &l ~lda &op 66 | lclc &c 67 | &c amid "&op",1,1 68 | aif "&c"<>"{",.b 69 | &c amid "&op",l:&op,1 70 | aif "&c"="}",.a 71 | mnote "Missing closing '}'",2 72 | &op setc &op} 73 | .a 74 | &op amid "&op",2,l:&op-2 75 | &op setc (&op) 76 | .b 77 | &l lda &op 78 | mend 79 | macro 80 | &l ~lda.h &op 81 | &l anop 82 | lclc &c 83 | &c amid "&op",1,1 84 | aif "&c"="[",.b 85 | aif "&c"<>"{",.d 86 | &c amid "&op",l:&op,1 87 | aif "&c"="}",.a 88 | mnote "Missing closing '}'",2 89 | &op setc &op} 90 | .a 91 | &op amid "&op",2,l:&op-2 92 | &op setc (&op) 93 | .b 94 | aif &yistwo,.c 95 | &yistwo setb 1 96 | ldy #2 97 | .c 98 | &op setc "&op,y" 99 | lda &op 100 | mexit 101 | .d 102 | aif "&c"<>"#",.e 103 | &op amid "&op",2,l:&op-1 104 | &op setc "#^&op" 105 | lda &op 106 | mexit 107 | .e 108 | lda 2+&op 109 | mend 110 | macro 111 | &l ~restm 112 | &l anop 113 | aif (&~la+&~li)=2,.i 114 | sep #32*(.not.&~la)+16*(.not.&~li) 115 | aif &~la,.h 116 | longa off 117 | .h 118 | aif &~li,.i 119 | longi off 120 | .i 121 | mend 122 | macro 123 | &l ~setm 124 | &l anop 125 | aif c:&~la,.b 126 | gblb &~la 127 | gblb &~li 128 | .b 129 | &~la setb s:longa 130 | &~li setb s:longi 131 | aif s:longa.and.s:longi,.a 132 | rep #32*(.not.&~la)+16*(.not.&~li) 133 | longa on 134 | longi on 135 | .a 136 | mend 137 | macro 138 | &l ~sta &op 139 | lclc &c 140 | &c amid "&op",1,1 141 | aif "&c"<>"{",.b 142 | &c amid "&op",l:&op,1 143 | aif "&c"="}",.a 144 | mnote "Missing closing '}'",2 145 | &op setc &op} 146 | .a 147 | &op amid "&op",2,l:&op-2 148 | &op setc (&op) 149 | .b 150 | &l sta &op 151 | mend 152 | macro 153 | &l ~sta.h &op 154 | &l anop 155 | lclc &c 156 | &c amid "&op",1,1 157 | aif "&c"="[",.b 158 | aif "&c"<>"{",.d 159 | &c amid "&op",l:&op,1 160 | aif "&c"="}",.a 161 | mnote "Missing closing '}'",2 162 | &op setc &op} 163 | .a 164 | &op amid "&op",2,l:&op-2 165 | &op setc (&op) 166 | .b 167 | aif &yistwo,.c 168 | &yistwo setb 1 169 | ldy #2 170 | .c 171 | &op setc "&op,y" 172 | sta &op 173 | mexit 174 | .d 175 | sta 2+&op 176 | mend 177 | MACRO 178 | &LAB FD2X 179 | &LAB PEA $010E 180 | LDX #$090A 181 | JSL $E10000 182 | MEND 183 | MACRO 184 | &LAB FX2C 185 | &LAB PEA $0510 186 | LDX #$090A 187 | JSL $E10000 188 | MEND 189 | -------------------------------------------------------------------------------- /cgi.asm: -------------------------------------------------------------------------------- 1 | **************************************************************** 2 | * 3 | * InitLabels - initialize the labels array 4 | * 5 | * Outputs: 6 | * labelTab - initialized 7 | * intLabel - initialized 8 | * 9 | **************************************************************** 10 | * 11 | InitLabels start 12 | maxLabel equ 2400 13 | 14 | ! with labelTab[0] do begin 15 | lda #-1 val := -1; 16 | sta labelTab+6 17 | sta labelTab+8 18 | stz labelTab defined := false; 19 | stz labelTab+2 chain := nil; 20 | stz labelTab+4 21 | ! end; {with} 22 | ldx #labelTab for i := 1 to maxLabel do 23 | ldy #labelTab+10 labelTab[i] := labelTab[0]; 24 | lda #maxLabel*10-1 25 | mvn labelTab,labelTab 26 | stz intLabel intLabel := 0; 27 | rtl 28 | end 29 | -------------------------------------------------------------------------------- /count: -------------------------------------------------------------------------------- 1 | echo Pascal: 2 | 3 | set list cg.pas stage3.pas stage3.save stage3.gentree 4 | set list {list} cg.writecode native.pas 5 | set list {list} pascal.pas pascal.exp pascal.body 6 | set list {list} symbols.pas cgi.pas call.pas 7 | 8 | wc -l {list} 9 | 10 | echo Assembly: 11 | 12 | set list sc.asm sc.insymbol sc.options ob.asm symbols.asm 13 | 14 | wc -l {list} 15 | 16 | echo Special Macros: 17 | 18 | set list sc.smac sym.smac 19 | 20 | wc -l {list} 21 | 22 | echo Link and Make files: 23 | 24 | set list lk backup make msym mcg count msc mcall mpascal 25 | 26 | wc -l {list} 27 | 28 | echo Macros: 29 | 30 | set list sc.macros ob.macros sym.macros 31 | 32 | wc -l {list} 33 | -------------------------------------------------------------------------------- /dag.asm: -------------------------------------------------------------------------------- 1 | mcopy dag.macros 2 | **************************************************************** 3 | * 4 | * function udiv(x,y: longint): longint; 5 | * 6 | * Inputs: 7 | * num1 - numerator 8 | * num2 - denominator 9 | * 10 | * Outputs: 11 | * ans - result 12 | * 13 | **************************************************************** 14 | * 15 | udiv start 16 | ans equ 0 answer 17 | rem equ 4 remainder 18 | 19 | subroutine (4:num1,4:num2),8 20 | ; 21 | ; Initialize 22 | ; 23 | stz rem rem = 0 24 | stz rem+2 25 | move4 num1,ans ans = num1 26 | lda num2 check for division by zero 27 | ora num2+2 28 | beq dv9 29 | 30 | lda num2+2 do 16 bit divides separately 31 | ora ans+2 32 | beq dv5 33 | ; 34 | ; 32 bit divide 35 | ; 36 | ldy #32 32 bits to go 37 | dv3 asl ans roll up the next number 38 | rol ans+2 39 | rol ans+4 40 | rol ans+6 41 | sec subtract for this digit 42 | lda ans+4 43 | sbc num2 44 | tax 45 | lda ans+6 46 | sbc num2+2 47 | bcc dv4 branch if minus 48 | stx ans+4 turn the bit on 49 | sta ans+6 50 | inc ans 51 | dv4 dey next bit 52 | bne dv3 53 | bra dv9 go do the sign 54 | ; 55 | ; 16 bit divide 56 | ; 57 | dv5 lda #0 initialize the remainder 58 | ldy #16 16 bits to go 59 | dv6 asl ans roll up the next number 60 | rol a 61 | sec subtract the digit 62 | sbc num2 63 | bcs dv7 64 | adc num2 digit is 0 65 | dey 66 | bne dv6 67 | bra dv8 68 | dv7 inc ans digit is 1 69 | dey 70 | bne dv6 71 | 72 | dv8 sta ans+4 save the remainder 73 | ; 74 | ; Return the result 75 | ; 76 | dv9 return 4:ans move answer 77 | end 78 | 79 | **************************************************************** 80 | * 81 | * function umod(x,y: longint): longint; 82 | * 83 | * Inputs: 84 | * num1 - numerator 85 | * num2 - denominator 86 | * 87 | * Outputs: 88 | * ans+4 - result 89 | * 90 | **************************************************************** 91 | * 92 | umod start 93 | ans equ 0 answer 94 | rem equ 4 remainder 95 | 96 | subroutine (4:num1,4:num2),8 97 | ; 98 | ; Initialize 99 | ; 100 | stz rem rem = 0 101 | stz rem+2 102 | move4 num1,ans ans = num1 103 | lda num2 check for division by zero 104 | ora num2+2 105 | beq dv9 106 | 107 | lda num2+2 do 16 bit divides separately 108 | ora ans+2 109 | beq dv5 110 | ; 111 | ; 32 bit divide 112 | ; 113 | ldy #32 32 bits to go 114 | dv3 asl ans roll up the next number 115 | rol ans+2 116 | rol ans+4 117 | rol ans+6 118 | sec subtract for this digit 119 | lda ans+4 120 | sbc num2 121 | tax 122 | lda ans+6 123 | sbc num2+2 124 | bcc dv4 branch if minus 125 | stx ans+4 turn the bit on 126 | sta ans+6 127 | inc ans 128 | dv4 dey next bit 129 | bne dv3 130 | bra dv9 go do the sign 131 | ; 132 | ; 16 bit divide 133 | ; 134 | dv5 lda #0 initialize the remainder 135 | ldy #16 16 bits to go 136 | dv6 asl ans roll up the next number 137 | rol a 138 | sec subtract the digit 139 | sbc num2 140 | bcs dv7 141 | adc num2 digit is 0 142 | dey 143 | bne dv6 144 | bra dv8 145 | dv7 inc ans digit is 1 146 | dey 147 | bne dv6 148 | 149 | dv8 sta ans+4 save the remainder 150 | ; 151 | ; Return the result 152 | ; 153 | dv9 return 4:ans+4 move answer 154 | end 155 | 156 | **************************************************************** 157 | * 158 | * function umul(x,y: longint): longint; 159 | * 160 | * Inputs: 161 | * num2,num1 - operands 162 | * 163 | * Outputs: 164 | * ans - result 165 | * 166 | **************************************************************** 167 | * 168 | umul start 169 | ans equ 0 answer 170 | 171 | subroutine (4:num1,4:num2),8 172 | ; 173 | ; Initialize the sign and split on precision. 174 | ; 175 | stz ans+4 set up the multiplier 176 | stz ans+6 177 | lda num1 178 | sta ans 179 | lda num1+2 180 | sta ans+2 181 | beq ml3 branch if the multiplier is 16 bit 182 | ; 183 | ; Do a 32 bit by 32 bit multiply. 184 | ; 185 | ldy #32 32 bit multiply 186 | jsr ml1 187 | brl ml7 188 | 189 | ml1 lda ans SYSS1*SYSS1+2+SYSS1+2 -> SYSS1,SYSS1+2 190 | lsr a 191 | bcc ml2 192 | clc add multiplicand to the partial product 193 | lda ans+4 194 | adc num2 195 | sta ans+4 196 | lda ans+6 197 | adc num2+2 198 | sta ans+6 199 | ml2 ror ans+6 shift the interem result 200 | ror ans+4 201 | ror ans+2 202 | ror ans 203 | dey loop til done 204 | bne ml1 205 | rts 206 | ; 207 | ; Do and 16 bit by 32 bit multiply. 208 | ; 209 | ml3 lda num2+2 branch if 16x16 is possible 210 | beq ml4 211 | 212 | ldy #16 set up for 16 bits 213 | jsr ml1 do the multiply 214 | lda ans+2 move the answer 215 | sta ans 216 | lda ans+4 217 | sta ans+2 218 | bra ml7 219 | ; 220 | ; Do a 16 bit by 16 bit multiply. 221 | ; 222 | ml4 ldy #16 set the 16 bit counter 223 | ldx ans move the low word 224 | stx ans+2 225 | ml5 lsr ans+2 test the bit 226 | bcc ml6 branch if the bit is off 227 | clc 228 | adc num2 229 | ml6 ror a shift the answer 230 | ror ans 231 | dey loop 232 | bne ml5 233 | sta ans+2 save the high word 234 | ; 235 | ; Return the result. 236 | ; 237 | ml7 return 4:ans fix the stack 238 | end 239 | -------------------------------------------------------------------------------- /dag.macros: -------------------------------------------------------------------------------- 1 | MACRO 2 | &lab subroutine &parms,&work 3 | &lab anop 4 | aif c:&work,.a 5 | lclc &work 6 | &work setc 0 7 | .a 8 | gbla &totallen 9 | gbla &worklen 10 | &worklen seta &work 11 | &totallen seta 0 12 | aif c:&parms=0,.e 13 | lclc &len 14 | lclc &p 15 | lcla &i 16 | &i seta c:&parms 17 | .b 18 | &p setc &parms(&i) 19 | &len amid &p,2,1 20 | aif "&len"=":",.c 21 | &len amid &p,1,2 22 | &p amid &p,4,l:&p-3 23 | ago .d 24 | .c 25 | &len amid &p,1,1 26 | &p amid &p,3,l:&p-2 27 | .d 28 | &p equ &totallen+3+&work 29 | &totallen seta &totallen+&len 30 | &i seta &i-1 31 | aif &i,^b 32 | .e 33 | tsc 34 | sec 35 | sbc #&work 36 | tcs 37 | inc a 38 | phd 39 | tcd 40 | mend 41 | MACRO 42 | &lab return &r 43 | &lab anop 44 | lclc &len 45 | aif c:&r,.a 46 | lclc &r 47 | &r setc 0 48 | &len setc 0 49 | ago .h 50 | .a 51 | &len amid &r,2,1 52 | aif "&len"=":",.b 53 | &len amid &r,1,2 54 | &r amid &r,4,l:&r-3 55 | ago .c 56 | .b 57 | &len amid &r,1,1 58 | &r amid &r,3,l:&r-2 59 | .c 60 | aif &len<>2,.d 61 | ldy &r 62 | ago .h 63 | .d 64 | aif &len<>4,.e 65 | ldx &r+2 66 | ldy &r 67 | ago .h 68 | .e 69 | aif &len<>10,.g 70 | aif &totallen=0,.f 71 | lda &worklen+1 72 | sta &worklen+&totallen+1 73 | lda &worklen 74 | sta &worklen+&totallen 75 | .f 76 | pld 77 | tsc 78 | clc 79 | adc #&worklen+&totallen 80 | tcs 81 | phb 82 | plx 83 | ply 84 | lda &r+8 85 | pha 86 | lda &r+6 87 | pha 88 | lda &r+4 89 | pha 90 | lda &r+2 91 | pha 92 | lda &r 93 | pha 94 | phy 95 | phx 96 | plb 97 | rtl 98 | mexit 99 | .g 100 | mnote 'Not a valid return length',16 101 | mexit 102 | .h 103 | aif &totallen=0,.i 104 | lda &worklen+1 105 | sta &worklen+&totallen+1 106 | lda &worklen 107 | sta &worklen+&totallen 108 | .i 109 | pld 110 | tsc 111 | clc 112 | adc #&worklen+&totallen 113 | tcs 114 | aif &len=0,.j 115 | tya 116 | .j 117 | rtl 118 | mend 119 | MACRO 120 | &LAB MOVE4 &F,&T 121 | &LAB ~SETM 122 | LDA 2+&F 123 | STA 2+&T 124 | LDA &F 125 | STA &T 126 | ~RESTM 127 | MEND 128 | MACRO 129 | &LAB ~SETM 130 | &LAB ANOP 131 | AIF C:&~LA,.B 132 | GBLB &~LA 133 | GBLB &~LI 134 | .B 135 | &~LA SETB S:LONGA 136 | &~LI SETB S:LONGI 137 | AIF S:LONGA.AND.S:LONGI,.A 138 | REP #32*(.NOT.&~LA)+16*(.NOT.&~LI) 139 | LONGA ON 140 | LONGI ON 141 | .A 142 | MEND 143 | MACRO 144 | &LAB ~RESTM 145 | &LAB ANOP 146 | AIF (&~LA+&~LI)=2,.I 147 | SEP #32*(.NOT.&~LA)+16*(.NOT.&~LI) 148 | AIF &~LA,.H 149 | LONGA OFF 150 | .H 151 | AIF &~LI,.I 152 | LONGI OFF 153 | .I 154 | MEND 155 | -------------------------------------------------------------------------------- /linkit: -------------------------------------------------------------------------------- 1 | set list obj/pascal obj/call obj/parser obj/native obj/cgi obj/symbols 2 | set list {list} obj/scanner obj/dag obj/cgc obj/gen obj/objout obj/pcommon 3 | 4 | echo link {parameters} {list} keep=obj/pascal 5 | link {parameters} {list} keep=obj/pascal 6 | echo filetype obj/pascal exe $DB01 7 | filetype obj/pascal exe $DB01 8 | -------------------------------------------------------------------------------- /make: -------------------------------------------------------------------------------- 1 | unset exit 2 | set flags +t +e 3 | 4 | Newer obj/pascal pascal.rez 5 | if {status} != 0 6 | set exit on 7 | echo compile -e pascal.rez keep=obj/Pascal 8 | compile -e pascal.rez keep=obj/Pascal 9 | unset exit 10 | end 11 | 12 | if {#} == 0 then 13 | 14 | Newer obj/gen.a gen.pas 15 | if {Status} != 0 16 | set gen gen 17 | set dag dag 18 | end 19 | 20 | Newer obj/cgc.a cgc.pas cgc.asm cgc.macros 21 | if {Status} != 0 22 | set cgc cgc 23 | set dag dag 24 | set gen gen 25 | set objout objout 26 | set native native 27 | set symbols symbols 28 | end 29 | 30 | Newer obj/dag.a dag.pas dag.asm dag.macros 31 | if {Status} != 0 32 | set dag dag 33 | end 34 | 35 | Newer obj/pascal.a pascal.pas 36 | if {Status} != 0 37 | set pascal pascal 38 | end 39 | 40 | Newer obj/parser.a parser.pas 41 | if {Status} != 0 42 | set parser parser 43 | set pascal pascal 44 | end 45 | 46 | Newer obj/call.a call.pas 47 | if {Status} != 0 48 | set call call 49 | set parser parser 50 | end 51 | 52 | Newer obj/objout.a objout.pas objout.asm objout.macros 53 | if {Status} != 0 54 | set objout objout 55 | set symbols symbols 56 | set native native 57 | set gen gen 58 | end 59 | 60 | Newer obj/native.a native.pas native.asm native.pas 61 | if {Status} != 0 62 | set native native 63 | set symbols symbols 64 | set gen gen 65 | end 66 | 67 | Newer obj/cgi.a cgi.pas cgi.asm 68 | if {Status} != 0 69 | set cgi cgi 70 | set call call 71 | set native native 72 | set scanner scanner 73 | set symbols symbols 74 | set parser parser 75 | set pascal pascal 76 | set dag dag 77 | set cgc cgc 78 | set gen gen 79 | set objout objout 80 | end 81 | 82 | Newer obj/scanner.a scanner.pas scanner.asm scanner.macros 83 | if {Status} != 0 84 | set scanner scanner 85 | set symbols symbols 86 | set call call 87 | set parser parser 88 | set pascal pascal 89 | end 90 | 91 | Newer obj/symbols.a symbols.pas symbols.asm symbols.macros 92 | if {Status} != 0 93 | set symbols symbols 94 | set call call 95 | set parser parser 96 | set pascal pascal 97 | end 98 | 99 | Newer obj/pcommon.a pcommon.pas pcommon.asm pcommon.macros 100 | if {Status} != 0 101 | set pcommon pcommon 102 | set call call 103 | set symbols symbols 104 | set cgi cgi 105 | set native native 106 | set objout objout 107 | set parser parser 108 | set dag dag 109 | set cgc cgc 110 | set gen gen 111 | end 112 | 113 | set exit on 114 | set list {pcommon} {cgi} {cgc} {objout} {native} {gen} {dag} {scanner} {symbols} {call} {parser} {pascal} 115 | for i in {list} 116 | echo compile {flags} {i}.pas keep=obj/{i} 117 | compile {flags} {i}.pas keep=obj/{i} 118 | end 119 | 120 | else 121 | 122 | set exit on 123 | for i in {parameters} 124 | echo compile {flags} {i}.pas keep=obj/{i} 125 | compile {flags} {i}.pas keep=obj/{i} 126 | end 127 | end 128 | 129 | * echo purge 130 | * purge >.null 131 | echo linkit 132 | linkit 133 | echo copy -c obj/pascal 16/Pascal 134 | copy -c obj/pascal 16/Pascal 135 | -------------------------------------------------------------------------------- /native.asm: -------------------------------------------------------------------------------- 1 | mcopy native.macros 2 | **************************************************************** 3 | * 4 | * Remove - remove an instruction from the peephole array 5 | * 6 | * Inputs: 7 | * ns - index of element to remove 8 | * 9 | **************************************************************** 10 | * 11 | Remove start 12 | elSize equ 12 size of an element 13 | nPeepSize equ 128 size of array 14 | ns equ 4 array element 15 | 16 | lda ns,S compute the source address 17 | cmp #nPeepSize (quit if nothing to move) 18 | bge rtl 19 | asl a 20 | adc ns,S 21 | asl a 22 | asl a 23 | adc #NPEEP 24 | tax 25 | sec compute the source address 26 | sbc #elSize 27 | tay 28 | sec compute the move length 29 | sbc #(nPeepSize-1)*elSize+NPEEP 30 | eor #$FFFF 31 | mvn NPEEP,NPEEP move the array elements 32 | rtl dec nNextSpot nnextspot := nnextspot-1; 33 | lda #1 didone := true; 34 | sta didOne 35 | lda 2,S fix stack and return 36 | sta 4,S 37 | pla 38 | sta 1,S 39 | rtl 40 | end 41 | 42 | **************************************************************** 43 | * 44 | * Short - See if label lab is within short range of instruction n 45 | * 46 | * Inputs: 47 | * n - instruction number 48 | * lab - label number 49 | * 50 | **************************************************************** 51 | * 52 | Short start 53 | elSize equ 12 size of npeep array element 54 | peep_opcode equ 0 disp in nativeType of opcode 55 | peep_mode equ 2 disp in nativeType of mode 56 | peep_operand equ 4 disp in nativeType of operand 57 | peep_name equ 6 disp in nativeType of name 58 | peep_flags equ 10 disp in nativeType of flags 59 | 60 | d_lab equ 256 label op code # 61 | 62 | len equ 0 63 | i equ 2 64 | 65 | subroutine (2:n,2:lab),4 66 | 67 | stz len len := 0; 68 | lda n i := n-1; 69 | dec a while i > 0 do begin 70 | dec a 71 | ldx #elSize 72 | jsl ~mul2 73 | tax 74 | bmi lb3 75 | lb1 lda nPeep+peep_opcode,X if npeep[i].opcode = d_lab then 76 | cmp #d_lab 77 | bne lb2 78 | lda nPeep+peep_operand,X if npeep[i].operand = lab then begin 79 | cmp lab 80 | bne lb2 81 | stz fn Short := len <= 126; 82 | lda len 83 | cmp #127 84 | bge lab1 85 | inc fn 86 | bra lab1 goto 1; 87 | lb2 anop end; 88 | lda nPeep+peep_opcode,X len := len+size[npeep[i].mode]; 89 | tay 90 | lda size,Y 91 | and #$00FF 92 | clc 93 | adc len 94 | sta len 95 | txa i := i-1; 96 | sec 97 | sbc #elSize 98 | tax 99 | bpl lb1 end; {while} 100 | lb3 stz len len := 0; 101 | lda n i := n+1; 102 | ldx #elSize 103 | jsl ~mul2 104 | tax 105 | lda n 106 | inc a 107 | sta i 108 | lb4 lda i while i < nnextspot do begin 109 | cmp nNextSpot 110 | bge lb6 111 | lda nPeep+peep_opcode,X if npeep[i].opcode = d_lab then 112 | cmp #d_lab 113 | bne lb5 114 | lda nPeep+peep_operand,X if npeep[i].operand = lab then begin 115 | cmp lab 116 | bne lb5 117 | stz fn Short := len < 128; 118 | lda len 119 | cmp #128 120 | bge lab1 121 | inc fn 122 | bra lab1 goto 1; 123 | lb5 anop end; 124 | lda nPeep+peep_opcode,X len := len+size[npeep[i].mode]; 125 | tay 126 | lda size,Y 127 | and #$00FF 128 | clc 129 | adc len 130 | sta len 131 | inc i i := i+1; 132 | txa 133 | clc 134 | adc #elSize 135 | tax 136 | bra lb4 end; {while} 137 | lb6 stz fn Short := false; 138 | lab1 anop 1:end; {Short} 139 | return 2:fn 140 | 141 | fn ds 2 function return value 142 | 143 | size dc i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4' 144 | dc i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4' 145 | dc i1'3,2,4,2,2,2,2,2,1,3,1,1,3,3,3,4' 146 | dc i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4' 147 | dc i1'1,2,2,2,3,2,2,2,1,3,1,1,3,3,3,4' 148 | dc i1'2,2,2,2,3,2,2,2,1,3,1,1,4,3,3,4' 149 | dc i1'1,2,3,2,2,2,2,2,1,3,1,1,3,3,3,4' 150 | dc i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4' 151 | 152 | dc i1'2,2,3,2,2,2,2,2,1,3,1,1,3,3,3,4' 153 | dc i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4' 154 | dc i1'3,2,3,2,2,2,2,2,1,3,1,1,3,3,3,4' 155 | dc i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4' 156 | dc i1'3,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4' 157 | dc i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4' 158 | dc i1'3,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4' 159 | dc i1'2,2,2,2,3,2,2,2,1,3,1,1,3,3,3,4' 160 | 161 | dc i1'0,0,1,2,0,2,0,255' 162 | end 163 | -------------------------------------------------------------------------------- /native.macros: -------------------------------------------------------------------------------- 1 | MACRO 2 | &lab subroutine &parms,&work 3 | &lab anop 4 | aif c:&work,.a 5 | lclc &work 6 | &work setc 0 7 | .a 8 | gbla &totallen 9 | gbla &worklen 10 | &worklen seta &work 11 | &totallen seta 0 12 | aif c:&parms=0,.e 13 | lclc &len 14 | lclc &p 15 | lcla &i 16 | &i seta c:&parms 17 | .b 18 | &p setc &parms(&i) 19 | &len amid &p,2,1 20 | aif "&len"=":",.c 21 | &len amid &p,1,2 22 | &p amid &p,4,l:&p-3 23 | ago .d 24 | .c 25 | &len amid &p,1,1 26 | &p amid &p,3,l:&p-2 27 | .d 28 | &p equ &totallen+3+&work 29 | &totallen seta &totallen+&len 30 | &i seta &i-1 31 | aif &i,^b 32 | .e 33 | tsc 34 | sec 35 | sbc #&work 36 | tcs 37 | inc a 38 | phd 39 | tcd 40 | mend 41 | MACRO 42 | &lab return &r 43 | &lab anop 44 | lclc &len 45 | aif c:&r,.a 46 | lclc &r 47 | &r setc 0 48 | &len setc 0 49 | ago .h 50 | .a 51 | &len amid &r,2,1 52 | aif "&len"=":",.b 53 | &len amid &r,1,2 54 | &r amid &r,4,l:&r-3 55 | ago .c 56 | .b 57 | &len amid &r,1,1 58 | &r amid &r,3,l:&r-2 59 | .c 60 | aif &len<>2,.d 61 | ldy &r 62 | ago .h 63 | .d 64 | aif &len<>4,.e 65 | ldx &r+2 66 | ldy &r 67 | ago .h 68 | .e 69 | aif &len<>10,.g 70 | aif &totallen=0,.f 71 | lda &worklen+1 72 | sta &worklen+&totallen+1 73 | lda &worklen 74 | sta &worklen+&totallen 75 | .f 76 | pld 77 | tsc 78 | clc 79 | adc #&worklen+&totallen 80 | tcs 81 | phb 82 | plx 83 | ply 84 | lda &r+8 85 | pha 86 | lda &r+6 87 | pha 88 | lda &r+4 89 | pha 90 | lda &r+2 91 | pha 92 | lda &r 93 | pha 94 | phy 95 | phx 96 | plb 97 | rtl 98 | mexit 99 | .g 100 | mnote 'Not a valid return length',16 101 | mexit 102 | .h 103 | aif &totallen=0,.i 104 | lda &worklen+1 105 | sta &worklen+&totallen+1 106 | lda &worklen 107 | sta &worklen+&totallen 108 | .i 109 | pld 110 | tsc 111 | clc 112 | adc #&worklen+&totallen 113 | tcs 114 | aif &len=0,.j 115 | tya 116 | .j 117 | rtl 118 | mend 119 | -------------------------------------------------------------------------------- /objout.macros: -------------------------------------------------------------------------------- 1 | MACRO 2 | &LAB LONG &A,&B 3 | LCLB &I 4 | LCLB &M 5 | &A AMID &A,1,1 6 | &M SETB ("&A"="M").OR.("&A"="m") 7 | &I SETB ("&A"="I").OR.("&A"="i") 8 | AIF C:&B=0,.A 9 | &B AMID &B,1,1 10 | &M SETB ("&B"="M").OR.("&B"="m").OR.&M 11 | &I SETB ("&B"="I").OR.("&B"="i").OR.&I 12 | .A 13 | &LAB REP #&M*32+&I*16 14 | AIF .NOT.&M,.B 15 | LONGA ON 16 | .B 17 | AIF .NOT.&I,.C 18 | LONGI ON 19 | .C 20 | MEND 21 | MACRO 22 | &LAB PH4 &N1 23 | LCLC &C 24 | &LAB ANOP 25 | &C AMID &N1,1,1 26 | AIF "&C"="#",.D 27 | AIF S:LONGA=1,.A 28 | REP #%00100000 29 | .A 30 | AIF "&C"<>"{",.B 31 | &C AMID &N1,L:&N1,1 32 | AIF "&C"<>"}",.G 33 | &N1 AMID &N1,2,L:&N1-2 34 | LDY #2 35 | LDA (&N1),Y 36 | PHA 37 | LDA (&N1) 38 | PHA 39 | AGO .E 40 | .B 41 | AIF "&C"<>"[",.C 42 | LDY #2 43 | LDA &N1,Y 44 | PHA 45 | LDA &N1 46 | PHA 47 | AGO .E 48 | .C 49 | LDA &N1+2 50 | PHA 51 | LDA &N1 52 | PHA 53 | AGO .E 54 | .D 55 | &N1 AMID &N1,2,L:&N1-1 56 | PEA +(&N1)|-16 57 | PEA &N1 58 | AGO .F 59 | .E 60 | AIF S:LONGA=1,.F 61 | SEP #%00100000 62 | .F 63 | MEXIT 64 | .G 65 | MNOTE "Missing closing '}'",16 66 | MEND 67 | MACRO 68 | &LAB SHORT &A,&B 69 | LCLB &I 70 | LCLB &M 71 | &A AMID &A,1,1 72 | &M SETB ("&A"="M").OR.("&A"="m") 73 | &I SETB ("&A"="I").OR.("&A"="i") 74 | AIF C:&B=0,.A 75 | &B AMID &B,1,1 76 | &M SETB ("&B"="M").OR.("&B"="m").OR.&M 77 | &I SETB ("&B"="I").OR.("&B"="i").OR.&I 78 | .A 79 | &LAB SEP #&M*32+&I*16 80 | AIF .NOT.&M,.B 81 | LONGA OFF 82 | .B 83 | AIF .NOT.&I,.C 84 | LONGI OFF 85 | .C 86 | MEND 87 | MACRO 88 | &LAB INC4 &A 89 | &LAB ~SETM 90 | INC &A 91 | BNE ~&SYSCNT 92 | INC 2+&A 93 | ~&SYSCNT ~RESTM 94 | MEND 95 | MACRO 96 | &LAB ~SETM 97 | &LAB ANOP 98 | AIF C:&~LA,.B 99 | GBLB &~LA 100 | GBLB &~LI 101 | .B 102 | &~LA SETB S:LONGA 103 | &~LI SETB S:LONGI 104 | AIF S:LONGA.AND.S:LONGI,.A 105 | REP #32*(.NOT.&~LA)+16*(.NOT.&~LI) 106 | LONGA ON 107 | LONGI ON 108 | .A 109 | MEND 110 | MACRO 111 | &LAB ~RESTM 112 | &LAB ANOP 113 | AIF (&~LA+&~LI)=2,.I 114 | SEP #32*(.NOT.&~LA)+16*(.NOT.&~LI) 115 | AIF &~LA,.H 116 | LONGA OFF 117 | .H 118 | AIF &~LI,.I 119 | LONGI OFF 120 | .I 121 | MEND 122 | MACRO 123 | &LAB PH2 &N1 124 | LCLC &C 125 | &LAB ANOP 126 | &C AMID &N1,1,1 127 | AIF "&C"="#",.D 128 | AIF S:LONGA=1,.A 129 | REP #%00100000 130 | .A 131 | AIF "&C"<>"{",.B 132 | &C AMID &N1,L:&N1,1 133 | AIF "&C"<>"}",.G 134 | &N1 AMID &N1,2,L:&N1-2 135 | LDA (&N1) 136 | PHA 137 | AGO .E 138 | .B 139 | LDA &N1 140 | PHA 141 | AGO .E 142 | .D 143 | &N1 AMID &N1,2,L:&N1-1 144 | PEA &N1 145 | AGO .F 146 | .E 147 | AIF S:LONGA=1,.F 148 | SEP #%00100000 149 | .F 150 | MEXIT 151 | .G 152 | MNOTE "Missing closing '}'",16 153 | MEND 154 | macro 155 | &l sub &parms,&work 156 | &l anop 157 | aif c:&work,.a 158 | lclc &work 159 | &work setc 0 160 | .a 161 | gbla &totallen 162 | gbla &worklen 163 | &worklen seta &work 164 | &totallen seta 0 165 | aif c:&parms=0,.e 166 | lclc &len 167 | lclc &p 168 | lcla &i 169 | &i seta c:&parms 170 | .b 171 | &p setc &parms(&i) 172 | &len amid &p,2,1 173 | aif "&len"=":",.c 174 | &len amid &p,1,2 175 | &p amid &p,4,l:&p-3 176 | ago .d 177 | .c 178 | &len amid &p,1,1 179 | &p amid &p,3,l:&p-2 180 | .d 181 | &p equ &totallen+4+&work 182 | &totallen seta &totallen+&len 183 | &i seta &i-1 184 | aif &i,^b 185 | .e 186 | tsc 187 | aif &work=0,.f 188 | sec 189 | sbc #&work 190 | tcs 191 | .f 192 | phd 193 | tcd 194 | mend 195 | MACRO 196 | &LAB MOVE4 &A,&B 197 | &LAB LDA &A 198 | STA &B 199 | LDA 2+&A 200 | STA 2+&B 201 | MEND 202 | MACRO 203 | &LAB JEQ &BP 204 | &LAB BNE *+5 205 | BRL &BP 206 | MEND 207 | macro 208 | &l ret &r 209 | &l anop 210 | lclc &len 211 | aif c:&r,.a 212 | lclc &r 213 | &r setc 0 214 | &len setc 0 215 | ago .h 216 | .a 217 | &len amid &r,2,1 218 | aif "&len"=":",.b 219 | &len amid &r,1,2 220 | &r amid &r,4,l:&r-3 221 | ago .c 222 | .b 223 | &len amid &r,1,1 224 | &r amid &r,3,l:&r-2 225 | .c 226 | aif &len<>2,.d 227 | ldy &r 228 | ago .h 229 | .d 230 | aif &len<>4,.e 231 | ldx &r+2 232 | ldy &r 233 | ago .h 234 | .e 235 | aif &len<>10,.g 236 | ldy #&r 237 | ldx #^&r 238 | ago .h 239 | .g 240 | mnote 'Not a valid return length',16 241 | mexit 242 | .h 243 | aif &totallen=0,.i 244 | lda &worklen+2 245 | sta &worklen+&totallen+2 246 | lda &worklen+1 247 | sta &worklen+&totallen+1 248 | .i 249 | pld 250 | tsc 251 | clc 252 | adc #&worklen+&totallen 253 | tcs 254 | aif &len=0,.j 255 | tya 256 | .j 257 | rtl 258 | mend 259 | MACRO 260 | &LAB ADD4 &M1,&M2,&M3 261 | LCLB &YISTWO 262 | LCLC &C 263 | &LAB ~SETM 264 | AIF C:&M3,.A 265 | &C AMID "&M2",1,1 266 | AIF "&C"<>"#",.A 267 | &C AMID "&M1",1,1 268 | AIF "&C"="{",.A 269 | AIF "&C"="[",.A 270 | &C AMID "&M2",2,L:&M2-1 271 | AIF &C>=65536,.A 272 | CLC 273 | ~LDA &M1 274 | ~OP ADC,&M2 275 | ~STA &M1 276 | BCC ~&SYSCNT 277 | ~OP.H INC,&M1 278 | ~&SYSCNT ANOP 279 | AGO .C 280 | .A 281 | AIF C:&M3,.B 282 | LCLC &M3 283 | &M3 SETC &M1 284 | .B 285 | CLC 286 | ~LDA &M1 287 | ~OP ADC,&M2 288 | ~STA &M3 289 | ~LDA.H &M1 290 | ~OP.H ADC,&M2 291 | ~STA.H &M3 292 | .C 293 | ~RESTM 294 | MEND 295 | MACRO 296 | &LAB ~OP.H &OPC,&OP 297 | &LAB ANOP 298 | LCLC &C 299 | &C AMID "&OP",1,1 300 | AIF "&C"="[",.B 301 | AIF "&C"<>"{",.D 302 | &C AMID "&OP",L:&OP,1 303 | AIF "&C"="}",.A 304 | MNOTE "Missing closing '}'",2 305 | &OP SETC &OP} 306 | .A 307 | &OP AMID "&OP",2,L:&OP-2 308 | &OP SETC (&OP) 309 | .B 310 | AIF &YISTWO,.C 311 | &YISTWO SETB 1 312 | LDY #2 313 | &OP SETC "&OP,Y" 314 | .C 315 | &OPC &OP 316 | MEXIT 317 | .D 318 | AIF "&C"<>"#",.E 319 | &OP AMID "&OP",2,L:&OP-1 320 | &OP SETC "#^&OP" 321 | &OPC &OP 322 | MEXIT 323 | .E 324 | &OPC 2+&OP 325 | MEND 326 | MACRO 327 | &LAB ~LDA.H &OP 328 | &LAB ANOP 329 | LCLC &C 330 | &C AMID "&OP",1,1 331 | AIF "&C"="[",.B 332 | AIF "&C"<>"{",.D 333 | &C AMID "&OP",L:&OP,1 334 | AIF "&C"="}",.A 335 | MNOTE "Missing closing '}'",2 336 | &OP SETC &OP} 337 | .A 338 | &OP AMID "&OP",2,L:&OP-2 339 | &OP SETC (&OP) 340 | .B 341 | AIF &YISTWO,.C 342 | &YISTWO SETB 1 343 | LDY #2 344 | &OP SETC "&OP,Y" 345 | .C 346 | LDA &OP 347 | MEXIT 348 | .D 349 | AIF "&C"<>"#",.E 350 | &OP AMID "&OP",2,L:&OP-1 351 | &OP SETC "#^&OP" 352 | LDA &OP 353 | MEXIT 354 | .E 355 | LDA 2+&OP 356 | MEND 357 | MACRO 358 | &LAB ~STA.H &OP 359 | &LAB ANOP 360 | LCLC &C 361 | &C AMID "&OP",1,1 362 | AIF "&C"="[",.B 363 | AIF "&C"<>"{",.D 364 | &C AMID "&OP",L:&OP,1 365 | AIF "&C"="}",.A 366 | MNOTE "Missing closing '}'",2 367 | &OP SETC &OP} 368 | .A 369 | &OP AMID "&OP",2,L:&OP-2 370 | &OP SETC (&OP) 371 | .B 372 | AIF &YISTWO,.C 373 | &YISTWO SETB 1 374 | LDY #2 375 | &OP SETC "&OP,Y" 376 | .C 377 | STA &OP 378 | MEXIT 379 | .D 380 | STA 2+&OP 381 | MEND 382 | MACRO 383 | &LAB ~LDA &OP 384 | LCLC &C 385 | &C AMID "&OP",1,1 386 | AIF "&C"<>"{",.B 387 | &C AMID "&OP",L:&OP,1 388 | AIF "&C"="}",.A 389 | MNOTE "Missing closing '}'",2 390 | &OP SETC &OP} 391 | .A 392 | &OP AMID "&OP",2,L:&OP-2 393 | &OP SETC (&OP) 394 | .B 395 | &LAB LDA &OP 396 | MEND 397 | MACRO 398 | &LAB ~STA &OP 399 | LCLC &C 400 | &C AMID "&OP",1,1 401 | AIF "&C"<>"{",.B 402 | &C AMID "&OP",L:&OP,1 403 | AIF "&C"="}",.A 404 | MNOTE "Missing closing '}'",2 405 | &OP SETC &OP} 406 | .A 407 | &OP AMID "&OP",2,L:&OP-2 408 | &OP SETC (&OP) 409 | .B 410 | &LAB STA &OP 411 | MEND 412 | MACRO 413 | &LAB ~OP &OPC,&OP 414 | LCLC &C 415 | &C AMID "&OP",1,1 416 | AIF "&C"<>"{",.B 417 | &C AMID "&OP",L:&OP,1 418 | AIF "&C"="}",.A 419 | MNOTE "Missing closing '}'",2 420 | &OP SETC &OP} 421 | .A 422 | &OP AMID "&OP",2,L:&OP-2 423 | &OP SETC (&OP) 424 | .B 425 | &LAB &OPC &OP 426 | MEND 427 | MACRO 428 | &LAB _NEWHANDLE 429 | &LAB LDX #$0902 430 | JSL $E10000 431 | MEND 432 | MACRO 433 | &LAB PL4 &N1 434 | LCLC &C 435 | &LAB ANOP 436 | AIF S:LONGA=1,.A 437 | REP #%00100000 438 | .A 439 | &C AMID &N1,1,1 440 | AIF "&C"<>"{",.B 441 | &C AMID &N1,L:&N1,1 442 | AIF "&C"<>"}",.F 443 | &N1 AMID &N1,2,L:&N1-2 444 | PLA 445 | STA (&N1) 446 | LDY #2 447 | PLA 448 | STA (&N1),Y 449 | AGO .D 450 | .B 451 | AIF "&C"<>"[",.C 452 | PLA 453 | STA &N1 454 | LDY #2 455 | PLA 456 | STA &N1,Y 457 | AGO .D 458 | .C 459 | PLA 460 | STA &N1 461 | PLA 462 | STA &N1+2 463 | .D 464 | AIF S:LONGA=1,.E 465 | SEP #%00100000 466 | .E 467 | MEXIT 468 | .F 469 | MNOTE "Missing closing '}'",16 470 | MEND 471 | MACRO 472 | &LAB _DISPOSEHANDLE 473 | &LAB LDX #$1002 474 | JSL $E10000 475 | MEND 476 | MACRO 477 | &LAB _HLOCK 478 | &LAB LDX #$2002 479 | JSL $E10000 480 | MEND 481 | MACRO 482 | &LAB _HUNLOCK 483 | &LAB LDX #$2202 484 | JSL $E10000 485 | MEND 486 | MACRO 487 | &LAB _GETHANDLESIZE 488 | &LAB LDX #$1802 489 | JSL $E10000 490 | MEND 491 | MACRO 492 | &LAB PL2 &N1 493 | LCLC &C 494 | &LAB ANOP 495 | AIF S:LONGA=1,.A 496 | REP #%00100000 497 | .A 498 | &C AMID &N1,1,1 499 | AIF "&C"<>"{",.B 500 | &C AMID &N1,L:&N1,1 501 | AIF "&C"<>"}",.F 502 | &N1 AMID &N1,2,L:&N1-2 503 | PLA 504 | STA (&N1) 505 | AGO .D 506 | .B 507 | PLA 508 | STA &N1 509 | .D 510 | AIF S:LONGA=1,.E 511 | SEP #%00100000 512 | .E 513 | MEXIT 514 | .F 515 | MNOTE "Missing closing '}'",16 516 | MEND 517 | -------------------------------------------------------------------------------- /pascal.notes: -------------------------------------------------------------------------------- 1 | ORCA/Pascal 2.2 2 | Copyright 1996, Byte Works Inc. 3 | 4 | -- Change List -------------------------------------------------------------- 5 | 6 | 2.2 1. Bugs fixed; see notes, below. 7 | 8 | 2. Pascal supports the extended character set. See "Extended 9 | Characters." 10 | 11 | 2.1 1. Bugs fixed; see notes, below. 12 | 13 | 2. New optimization added for method calls. See "New 14 | Optimization." 15 | 16 | 2.0.1 1. Bugs fixed; see notes, below. 17 | 18 | -- Manual Errata ------------------------------------------------------------ 19 | 20 | p. 340 21 | 22 | trunc4 returns a longint, so the definition line should read: 23 | 24 | function trunc4 (x: real): longint; 25 | 26 | p. 361 27 | 28 | The ISO and ANSI compliance statements say that ORCA/Pascal 1.2 complies with the standards. So do the other versions, including the current one. 29 | 30 | p. 364 31 | 32 | Add the following: 33 | 34 | ORCA/Pascal supports Apple's extended ASCII character set, allowing use of non-ASCII characters in identifiers and supporting some special characters as substitutes for traditional mathematical operations. See "Extended Characters" for implementation details. 35 | 36 | p. 378 37 | 38 | Under "Implementation Restrictions," delete these: 39 | 40 | "2. Arrays cannot be larger than 64K bytes long." 41 | 42 | "3. Records cannot be larger than 64K bytes long." 43 | 44 | ORCA/Pascal supports both using the large memory model. If you try to use a structure larger than 64K with the small memory model, you get a more specific error message telling you to switch memory models. 45 | 46 | -- New Features ------------------------------------------------------------- 47 | 48 | New Optimization 49 | ---------------- 50 | 51 | There is a new optimization bit for the Optimize directive. When bit 5 (value of 32, or $0020) is set, the compiler is allowed to perform optimizations that will generate code that is not ROMable. Currently, the only optimization it performs is to use self-modifying code for method calls, resulting in code for the call that is about 1/3 faster and shorter than without this optimization. 52 | 53 | WARNING: Object Pascal code compiled with Pascal 2.1 and later is not compatible with Object Pascal code compiled with Pascal 2.0. You must recompile the entire program and all libraries if the program or libraries involve objects. 54 | 55 | Extended Characters 56 | ------------------- 57 | 58 | Bear with me. This is an ASCII file, and it describes non-ASCII material. 59 | 60 | Beginning with version 2.1, the PRIZM desktop editor supports the full Apple extended character set. A file called FontTest on the samples disk shows the complete character set, and also contains a table that shows how to type each character from a U.S. English keyboard. 61 | 62 | Pascal supports the use of extended characters in strings, comments, identifiers, and for a few mathematical operations. 63 | 64 | Any character you can type from PRIZM (or for that matter, any character with an ordinal value in [1..12, 14..255]) can appear in a string or comment. The ordinal value of the character matches the values shown in FontTest, as well as several official Apple publications. Keep in mind that many output devices, including Apple's text console driver, do not support all of these characters. ORCA/Pascal will properly send extended characters to whatever output device you choose, but what happens when the output device tries to handle the character varies from device to device. 65 | 66 | Many of the characters in the extended character set are used in languages oter than English, and are now allowed in identifiers. There are two ways to think about which characters will work in an identifier. 67 | 68 | The simple way is to remember that all characters that look like a graphically modified ASCII alphabetic character or a Greek alphabetic character are allowed in identifiers. For example, an a with two dots above it is now legal in an identifier. 69 | 70 | The more exact, and naturally more complicated way to think about which characters are allowed in an identifier is to list all of them. Since this is an ASCII file, I'll list the ordinal values--you can cross reference the values in FontTest. The ordinal values of the extended characters that are allowed in identifiers are [$80..$9F, $A7, $AE, $AF, $B4..$B9, $BB..$BF, $C4, $C6, $CB..$CF, $D8, $DE, $DF]. 71 | 72 | In addition, ORCA/Pascal supports several extended characters as shortcuts for multi-character mathematical operations. These are: 73 | 74 | ordinal value description substitutes for 75 | ------------- ----------- --------------- 76 | $C7 two < << 77 | $C8 two > >> 78 | $AD not equal <> 79 | $B2 less than or equal <= 80 | $B3 greater than or equal >= 81 | $D6 division (- with dots) div 82 | 83 | Finally, the non-breaking space, sometimes called the sticky space (ordinal value $CA), is treated exactly like a standard space character. 84 | 85 | -- Bugs from Pascal 2.1 that are fixed in Pascal 2.2 ------------------------ 86 | 87 | 1. Incorrect code was generated for compares of objects. For example, if obj1 and obj2 are object variables, 88 | 89 | if obj1 = nil then ... 90 | 91 | and 92 | 93 | if obj1 <> obj2 then ... 94 | 95 | both generated incorrect code. 96 | 97 | 2. A bug in error reporting has been corrected. For some rare errors, the compiler incremented the error count but did not print the error message. 98 | 99 | 3. Eof and eoln have not worked for the standard input file since the switch to the .CONSOLE driver. They do, now. 100 | 101 | (Jason) 102 | 103 | 4. When a Read of a real value encounters a character sequence that starts with a character that can't be a part of a real number, as in 104 | 105 | var 106 | r: real; 107 | 108 | begin 109 | read(r); 110 | 111 | with input of 112 | 113 | a 114 | 115 | should generate a run-time error. In ORCA/Pascal 2.1, this error was not detected. 116 | 117 | (Rick Prest) 118 | 119 | 5. Reading a value into an array element or a pointer, as in 120 | 121 | read(readValue[4]) 122 | 123 | did not always work correctly. 124 | 125 | (Rick Prest) 126 | 127 | 6. Ord4 did not report an error when used on a nonscalar value, as in ord4(3.4). 128 | 129 | 7. When the +t +e flags were used and too many END statements caused the compiler to flag a "'.' expected" error, the error was not reported properly. The file name and error message were garbage when the editor was called, resulting in a blank file with an error message containing random characters. 130 | 131 | 8. Code generation has been improved for optimized code when a value is stored through a global pointer. 132 | 133 | 9. Loads of double values were not performed correctly by the FPE version of the SysFloat library, resulting in a large loss of precision. 134 | 135 | (Soenke Behrens, Dirk Froehling, Frank Gizinski) 136 | 137 | 10. With output redirected to a file and input comming from the keyboard, pressing the return key echoed the return that should have shown up on the screen to the output file. 138 | 139 | (Soenke Behrens, David Empson) 140 | 141 | -- Bugs Fixed from Pascal 2.0.1 --------------------------------------------- 142 | 143 | 1. The compiler flagged a compile error when debug code was generated for a variable that was declared as a type where the type was a pointer to a record, as in 144 | 145 | type 146 | r = record 147 | i: integer; 148 | end; 149 | rp = ^r; 150 | 151 | var 152 | p: rp; 153 | 154 | 2. Objects could not be packed; now they can. 155 | 156 | 3. It is now possible to compare an object to nil using the equality and inequality comparisons (= and <>). 157 | 158 | 4. Stores to boolean and character fields within an object intermitantly saved only one byte, when they should have saved two bytes. 159 | 160 | 5. String constants in the interface part of a unit did not resolve properly when used from another unit or the main program. 161 | 162 | (Ken Kazinski) 163 | 164 | -- Bugs Fixed from Pascal 2.0.0 --------------------------------------------- 165 | 166 | 1. With optimizations on, assigning the same constant to both a byte and word 167 | could generate code that did not correctly set the most significant byte of 168 | the word. 169 | 170 | (GNOTim2) 171 | 172 | 2. In some cases, successive stores of the same long constant to two different 173 | locations with common subexpression elimination turned on would damage the 174 | stack. 175 | 176 | (GNOTim2) 177 | 178 | 3. In some conditional branches involcing comples integer expressions, the 179 | condition code was not properly evaluated. 180 | 181 | (GNOTim2) 182 | 183 | 4. Optimization of arithmetic shifts by a constant in the range 9..15 has been 184 | improved. 185 | 186 | (GNOTim2) 187 | 188 | 5. Text programs didn't work when launched from the Finder. 189 | 190 | (JamesG7858) 191 | 192 | 6. On page 250, the manual shows parameter lists for overridden methods, 193 | like this: 194 | 195 | cube = object (box) 196 | front, back: integer; 197 | function Volume: integer; 198 | procedure Fill (ptop, pleft, pbottom, pright, 199 | pfront, pback: integer); override; 200 | procedure Grow (size: integer); override; 201 | end; 202 | 203 | This is incorrect. When you override a method, the parameter lists must 204 | match. As with forward procedures in Standard Pascal, ORCA/Pascal flags an 205 | error when you redefine the method list. The correct way to declare this class 206 | is: 207 | 208 | cube = object (box) 209 | front, back: integer; 210 | function Volume: integer; 211 | procedure Fill; override; 212 | procedure Grow; override; 213 | end; 214 | 215 | (Daniel B. Johnson) 216 | 217 | 7. The {$rtl} pragma was not exiting with an RTL. 218 | -------------------------------------------------------------------------------- /pascal.pas: -------------------------------------------------------------------------------- 1 | {$optimize -1} 2 | {$stacksize $4000} 3 | {------------------------------------------------------------} 4 | { } 5 | { ORCA/Pascal 2.2 } 6 | { } 7 | { A native code compiler for the Apple IIGS. } 8 | { } 9 | { By Mike Westerfield } 10 | { } 11 | { Copyright March 1988 } 12 | { By the Byte Works, Inc. } 13 | { } 14 | {------------------------------------------------------------} 15 | { } 16 | { Version 2.2 prepared in March, 1996 } 17 | { Version 2.1 prepared in July, 1994 } 18 | { Version 2.0.1 prepared in June, 1993 } 19 | { Version 2.0.0 prepared in March, 1993 } 20 | { Version 1.4.2 prepared in October, 1992 } 21 | { Version 1.4.1 prepared in October, 1991 } 22 | { Version 1.4 prepared in September, 1991 } 23 | { Version 1.3 prepared in September, 1990 } 24 | { } 25 | {------------------------------------------------------------} 26 | 27 | program pascal (output); 28 | 29 | {$segment 'pascal'} 30 | 31 | {$LibPrefix '0/obj/'} 32 | 33 | uses PCommon, CGI, Scanner, Symbols, Parser; 34 | 35 | begin 36 | {initialization:} 37 | MMInit; {memory manager} 38 | InitPCommon; {common module} 39 | InitScalars; {global variables} 40 | InitSets; 41 | CodeGenScalarInit; 42 | scanner_init; 43 | enterstdtypes; 44 | stdnames; 45 | entstdnames; 46 | EnterUndecl; 47 | if progress or list then begin 48 | writeln('ORCA/Pascal 2.2.0'); {write banner} 49 | writeln('Copyright 1987,1988,1991,1993,1994,1996, Byte Works, Inc.'); 50 | writeln; 51 | end; {if} 52 | level := 1; {set the top symbol level} 53 | top := 1; 54 | 55 | {compile:} 56 | InSymbol; {get the first symbol} 57 | programme(blockbegsys+statbegsys-[casesy]); {compile the program} 58 | 59 | {termination:} 60 | if codeGeneration then CodeGenFini; {shut down code generator} 61 | scanner_fini; {shut down scanner} 62 | StopSpin; 63 | end. 64 | -------------------------------------------------------------------------------- /pascal.rez: -------------------------------------------------------------------------------- 1 | #include "types.rez" 2 | 3 | resource rVersion(1) { 4 | { 5 | 2, /* Major revision */ 6 | 2, /* Minor revision */ 7 | 0, /* Bug version */ 8 | release, /* Release stage */ 9 | 0, /* Non-final release # */ 10 | }, 11 | verUS, /* Region code */ 12 | "ORCA/Pascal", /* Short version number */ 13 | "Copyright 1996, Byte Works, Inc." /* Long version number */ 14 | }; 15 | -------------------------------------------------------------------------------- /smac: -------------------------------------------------------------------------------- 1 | MACRO 2 | &LAB ENUM &LIST,&START 3 | &LAB ANOP 4 | AIF C:&~ENUM,.A 5 | GBLA &~ENUM 6 | .A 7 | AIF C:&START=0,.B 8 | &~ENUM SETA &START 9 | .B 10 | LCLA &CNT 11 | &CNT SETA 1 12 | .C 13 | &LIST(&CNT) EQU &~ENUM 14 | &~ENUM SETA &~ENUM+1 15 | &CNT SETA &CNT+1 16 | AIF &CNT<=C:&LIST,^C 17 | MEND 18 | 19 | 20 | MACRO 21 | &LAB SUBR &PARMS 22 | &LAB PHD 23 | LDA MY_DP 24 | TCD 25 | AIF C:&PARMS=0,.F 26 | LCLC &PARM 27 | LCLA &P 28 | LCLA &LEN 29 | LCLA &TOTALLEN 30 | LCLC &C 31 | &P SETA 1 32 | .A 33 | &PARM SETC &PARMS(&P) 34 | &C AMID &PARM,1,1 35 | &PARM AMID &PARM,3,L:&PARM-2 36 | &LEN SETA &C 37 | &PARM EQU &TOTALLEN 38 | &TOTALLEN SETA &TOTALLEN+&C 39 | &P SETA &P+1 40 | AIF &P<=C:&PARMS,^A 41 | AIF &TOTALLEN<>2,.B 42 | LDA 6,S 43 | STA 0 44 | LDA 4,S 45 | STA 6,S 46 | LDA 2,S 47 | STA 4,S 48 | PLA 49 | STA 1,S 50 | MEXIT 51 | .B 52 | AIF &TOTALLEN<>4,.C 53 | LDA 6,S 54 | STA 0 55 | LDA 8,S 56 | STA 2 57 | LDA 4,S 58 | STA 8,S 59 | LDA 2,S 60 | STA 6,S 61 | PLA 62 | STA 3,S 63 | PLA 64 | MEXIT 65 | .C 66 | PHB 67 | PLA 68 | STA R0 69 | PLA 70 | STA R2 71 | PLA 72 | STA R4 73 | AIF (&TOTALLEN/2*2)<>&TOTALLEN,.D 74 | LDX #0 75 | ~&SYSCNT PLA 76 | STA 0,X 77 | INX 78 | INX 79 | CPX #&TOTALLEN 80 | BNE ~&SYSCNT 81 | AGO .E 82 | .D 83 | SEP #$20 84 | LDX #0 85 | ~&SYSCNT PLA 86 | STA 0,X 87 | INX 88 | CPX #&TOTALLEN 89 | BNE ~&SYSCNT 90 | REP #$20 91 | .E 92 | LDA R4 93 | PHA 94 | LDA R2 95 | PHA 96 | LDA R0 97 | PHA 98 | PLB 99 | .F 100 | MEND 101 | 102 | 103 | MACRO 104 | &LAB RETURN &VAL 105 | AIF C:&VAL<>0,.A 106 | &LAB PLD 107 | RTL 108 | MEXIT 109 | .A 110 | AIF "&VAL"<>"2",.B 111 | &LAB PLD 112 | TAX 113 | RTL 114 | MEXIT 115 | .B 116 | MNOTE 'Return values not implemented yet.',16 117 | MEND 118 | 119 | 120 | MACRO 121 | &LAB PASCAL 122 | &LAB TSC 123 | PLD 124 | PLB 125 | TCS 126 | MEND 127 | 128 | 129 | MACRO 130 | &LAB ASSEMBLY 131 | &LAB PHK 132 | PLB 133 | LDA MY_DP 134 | TCD 135 | MEND 136 | 137 | 138 | MACRO 139 | &LAB MOVE4 &A,&B 140 | &LAB LDA &A 141 | STA &B 142 | LDA 2+&A 143 | STA 2+&B 144 | MEND 145 | 146 | 147 | MACRO 148 | &LAB TERR &ERR 149 | &LAB LDA &ERR 150 | PHA 151 | JSL TERMERROR 152 | MEND 153 | 154 | 155 | MACRO 156 | &LAB LISTERROR &ERR 157 | &LAB LDA 0 158 | PHA 159 | PH2 &ERR 160 | JSL ERROR 161 | PLA 162 | STA 0 163 | MEND 164 | 165 | 166 | macro 167 | &lab FastFile &DCB 168 | &lab ~setm 169 | jsl $E100A8 170 | dc i2'$010E' 171 | dc i4'&DCB' 172 | ~restm 173 | mend 174 | 175 | 176 | macro 177 | &lab sub &p,&w 178 | &lab anop 179 | lcla &pc 180 | lclc &n 181 | lclc &s 182 | lclc &pr 183 | gbla &disp 184 | gbla &ws 185 | &ws seta &w 186 | &pc seta 1 187 | &disp seta 3+&w 188 | .a 189 | &pr setc &p(&pc) 190 | &s amid &pr,1,1 191 | &n amid &pr,3,l:&pr-2 192 | &n equ &disp 193 | &disp seta &disp+&s 194 | &pc seta &pc+1 195 | aif &pc<=c:&p,^a 196 | tdc 197 | tax 198 | tsc 199 | sec 200 | sbc #&w-1 201 | tcd 202 | dec a 203 | tcs 204 | phx 205 | mend 206 | 207 | 208 | macro 209 | &lab return 210 | &lab lda &ws 211 | sta &disp-3 212 | lda &ws+1 213 | sta &disp-2 214 | clc 215 | tdc 216 | adc #&disp-4 217 | plx 218 | tcs 219 | txa 220 | tcd 221 | rtl 222 | mend 223 | 224 | 225 | macro 226 | &lab enum &list,&start 227 | &lab anop 228 | aif c:&~enum,.a 229 | gbla &~enum 230 | .a 231 | aif c:&start=0,.b 232 | &~enum seta &start 233 | .b 234 | lcla &cnt 235 | &cnt seta 1 236 | .c 237 | &list(&cnt) equ &~enum 238 | &~enum seta &~enum+1 239 | &cnt seta &cnt+1 240 | aif &cnt<=c:&list,^c 241 | mend 242 | 243 | 244 | macro 245 | &lab terr &err 246 | &lab lda &err 247 | brl termerror 248 | mend 249 | 250 | 251 | macro 252 | &lab move4 &a,&b 253 | &lab lda &a 254 | sta &b 255 | lda 2+&a 256 | sta 2+&b 257 | mend 258 | -------------------------------------------------------------------------------- /symbols.asm: -------------------------------------------------------------------------------- 1 | mcopy symbols.macros 2 | **************************************************************** 3 | * 4 | * EnterId - Enter an identifier in the symbol table 5 | * 6 | * Inputs: 7 | * fcp - pointer to the identifier record 8 | * 9 | **************************************************************** 10 | * 11 | EnterId start 12 | using GetCom 13 | lcp equ 1 local identifier pointer 14 | lcpl equ 5 last lcp 15 | lleft equ 9 left link? 16 | p1 equ 13 work pointers 17 | p2 equ 17 18 | 19 | sub (4:fcp),20 20 | 21 | ldx #displaySize lcp := display[top].fname; 22 | lda TOP 23 | jsl ~mul2 24 | clc 25 | adc #display_fname 26 | tax 27 | lda DISPLAY,X 28 | sta lcp 29 | lda DISPLAY+2,X 30 | sta lcp+2 31 | ora lcp if lcp = nil then 32 | bne lb1 33 | lda fcp display[top].fname := fcp 34 | sta DISPLAY,X 35 | lda fcp+2 36 | sta DISPLAY+2,X 37 | brl lb10 else begin 38 | lb1 anop repeat 39 | move4 lcp,lcpl lcpl := lcp; 40 | ldy #2 comp := 41 | lda [lcp],Y compnames(lcp^.name^,fcp^.name^); 42 | pha 43 | lda [lcp] 44 | pha 45 | lda [fcp],Y 46 | pha 47 | lda [fcp] 48 | pha 49 | jsl CompNames 50 | tax if comp = 0 then begin 51 | bne lb4 {name conflict, follow right link} 52 | listerror #30 error(30); 53 | ! lcp := lcp^.rlink; 54 | ! lleft := false; 55 | bra lb5 end 56 | lb4 bpl lb6 else if comp < 0 then begin 57 | lb5 ldy #identifier_rlink lcp := lcp^.rlink; 58 | lda [lcp],Y 59 | tax 60 | iny 61 | iny 62 | lda [lcp],Y 63 | sta lcp+2 64 | stx lcp 65 | stz lleft lleft := false; 66 | bra lb7 end 67 | lb6 anop else begin 68 | ldy #identifier_llink lcp := lcp^.llink; 69 | lda [lcp],Y 70 | tax 71 | iny 72 | iny 73 | lda [lcp],Y 74 | sta lcp+2 75 | stx lcp 76 | lda #true lleft := true; 77 | sta lleft 78 | ! end 79 | lb7 lda lcp until lcp = nil; 80 | ora lcp+2 81 | bne lb1 82 | lda lleft if lleft then 83 | beq lb8 84 | ldy #identifier_llink lcpl^.llink := fcp 85 | bra lb9 else 86 | lb8 ldy #identifier_rlink lcpl^.rlink := fcp 87 | lb9 lda fcp 88 | sta [lcpl],Y 89 | iny 90 | iny 91 | lda fcp+2 92 | sta [lcpl],Y 93 | lb10 anop end; 94 | ldy #identifier_llink fcp^.llink := nil; 95 | lda #0 fcp^.rlink := nil; 96 | sta [fcp],Y 97 | iny 98 | iny 99 | sta [fcp],Y 100 | iny 101 | iny 102 | sta [fcp],Y 103 | iny 104 | iny 105 | sta [fcp],Y 106 | 107 | ret 108 | end 109 | 110 | **************************************************************** 111 | * 112 | * MarkAsUsed - Insert a name into the list of names used from other levels 113 | * 114 | * Inputs: 115 | * name - pointer to name used 116 | * top - index to display for the proper used list 117 | * 118 | **************************************************************** 119 | * 120 | MarkAsUsed private 121 | using GetCom 122 | p1 equ 1 work pointer 123 | p2 equ 5 124 | p3 equ 9 125 | 126 | sub (4:name),12 127 | 128 | lda TOP p1 := @display[top].labsused; 129 | ldx #DisplaySize 130 | jsl ~mul2 131 | clc 132 | adc #display_labsused 133 | adc #display 134 | sta p1 135 | lda #^display 136 | sta p1+2 137 | ldy #2 p2 := p1^; 138 | lda [p1] 139 | sta p2 140 | lda [p1],Y 141 | sta p2+2 142 | lb1 lda p2 while p2 <> nil do begin 143 | ora p2+2 144 | beq lb3 145 | ldy #ltype_name if p2^.name = name then 146 | lda [p2],Y 147 | cmp name 148 | bne lb2 149 | iny 150 | iny 151 | lda [p2],Y 152 | cmp name+2 153 | beq lb4 goto 1; 154 | 155 | lb2 ldy #ltype_next p2 := p2^.next; 156 | lda [p2],Y 157 | tax 158 | iny 159 | iny 160 | lda [p2],Y 161 | sta p2+2 162 | stx p2 163 | bra lb1 end; 164 | lb3 ph2 #ltypeSize new(p3); 165 | jsl Malloc 166 | sta p3 167 | stx p3+2 168 | ldy #ltype_name p3^.name := name; 169 | lda name 170 | sta [p3],Y 171 | iny 172 | iny 173 | lda name+2 174 | sta [p3],Y 175 | ldy #ltype_next p3^.next := p1^; 176 | lda [p1] 177 | sta [p3],Y 178 | ldy #2 179 | lda [p1],Y 180 | ldy #ltype_next+2 181 | sta [p3],Y 182 | ldy #ltype_disx p3^.disx := disx; 183 | lda DISX 184 | sta [p3],Y 185 | lda p3 p1^ := p3; 186 | sta [p1] 187 | ldy #2 188 | lda p3+2 189 | sta [p1],Y 190 | lb4 anop 1: 191 | 192 | ret 193 | end 194 | 195 | **************************************************************** 196 | * 197 | * SearchId - find an identifier 198 | * 199 | * Inputs: 200 | * fidcls - set of allowable identifiers 201 | * fcp - address to place pointer to identifier found 202 | * 203 | **************************************************************** 204 | * 205 | SearchId start 206 | using GetCom 207 | lcp equ 1 pointer to current symbol 208 | ldisx equ 5 address of display record being searched 209 | len equ 9 length of the string 210 | p1 equ 11 211 | 212 | !DISX pointer display level where the symbol is found 213 | typesSet equ 1 set masks for elements of idclass 214 | konstSet equ 2 215 | varsmSet equ 4 216 | fieldSet equ 8 217 | procSet equ 16 218 | 219 | ; sub (1:fidcls,4:fcp),14 Pascal 1.x 220 | sub (2:fidcls,4:fcp),14 Pascal 2.x 221 | 222 | lda id len := length(ID)+1; 223 | and #$00FF 224 | inc a 225 | sta len 226 | lda TOP for ldisx := top downto 0 do begin 227 | sta DISX disx := ldisx; 228 | ldx #displaySize 229 | jsl ~mul2 230 | clc 231 | adc #DISPLAY 232 | sta ldisx 233 | lda #^DISPLAY 234 | adc #0 235 | sta ldisx+2 236 | lb1 ldy #display_fname lcp := display[disx].fname; 237 | lda [ldisx],Y 238 | sta lcp 239 | iny 240 | iny 241 | lda [ldisx],Y 242 | sta lcp+2 243 | lb2 lda lcp while lcp <> nil do begin 244 | ora lcp+2 245 | beq lb12 246 | ldy #2 comp := compnames(lcp^.name^,id); 247 | lda [lcp],Y 248 | pha 249 | lda [lcp] 250 | pha 251 | ph4 #id 252 | jsl CompNames 253 | tax 254 | bne lb8 if comp = 0 then 255 | ldy #identifier_klass if lcp^.klass in fidcls then begin 256 | lda [lcp],Y 257 | tax 258 | lda #0 259 | sec 260 | lb5 rol A 261 | dbpl X,lb5 262 | and fidcls 263 | beq lb6 264 | lda [ldisx] gispacked := 265 | sta GISPACKED display[disx].ispacked; 266 | lda TOP if top <> disx then 267 | cmp DISX 268 | beq lb5a 269 | ph4 p1 MarkAsUsed(lcp^.name); 270 | jsl MarkAsUsed 271 | lb5a brl lab1 goto 1; 272 | ! end 273 | lb6 anop else begin 274 | lda PRTERR if prterr then 275 | beq lb7 276 | listerror #32 error(32); 277 | lb7 bra lb9 lcp := lcp^.rlink 278 | ! end 279 | lb8 bpl lb10 else if comp < 0 then 280 | lb9 ldy #identifier_rlink lcp := lcp^.rlink 281 | bra lb11 else 282 | lb10 ldy #identifier_llink lcp := lcp^.llink 283 | lb11 lda [lcp],Y 284 | tax 285 | iny 286 | iny 287 | lda [lcp],Y 288 | sta lcp+2 289 | stx lcp 290 | bra lb2 end; {while} 291 | lb12 sub4 ldisx,#displaySize end; {for} 292 | dec DISX 293 | jpl lb1 294 | lda PRTERR if prterr then begin 295 | beq lab1 296 | listerror #33 error(33); 297 | lda fidcls {to avoid returning nil, reference 298 | bit #typesSet an entry for an undeclared id of 299 | beq la1 appropriate class 300 | ldx UTYPPTR+2 --> procedure enterundecl} 301 | ! {types,konst,varsm,field,proc,func, 302 | lda UTYPPTR directive,prog} 303 | bra la6 if types in fidcls then 304 | la1 bit #varsmSet lcp := utypptr 305 | beq la2 else if varsm in fidcls then 306 | ldx UVARPTR+2 lcp := uvarptr 307 | lda UVARPTR 308 | bra la6 else if field in fidcls then 309 | la2 bit #fieldSet lcp := ufldptr 310 | beq la3 311 | ldx UFLDPTR+2 312 | lda UFLDPTR 313 | bra la6 314 | la3 bit #konstSet else if konst in fidcls then 315 | beq la4 lcp := ucstptr 316 | ldx UCSTPTR+2 317 | lda UCSTPTR 318 | bra la6 319 | la4 bit #procSet else if proc in fidcls then 320 | beq la5 lcp := uprcptr 321 | ldx UPRCPTR+2 322 | lda UPRCPTR 323 | bra la6 324 | la5 ldx UFCTPTR+2 else 325 | lda UFCTPTR lcp := ufctptr; 326 | la6 sta lcp end; 327 | stx nil do begin 359 | ora fcp+2 360 | beq lb6 361 | ldy #2 comp := compnames(fcp^.name^,id); 362 | lda [fcp],Y 363 | pha 364 | lda [fcp] 365 | pha 366 | ph4 #id 367 | jsl CompNames 368 | tax 369 | beq lb6 if comp = 0 then 370 | ! goto 1 371 | bpl lb4 else if comp < 0 then 372 | ldy #identifier_rlink fcp := fcp^.rlink 373 | bra lb5 else 374 | lb4 ldy #identifier_llink fcp := fcp^.llink; 375 | lb5 lda [fcp],Y 376 | tax 377 | iny 378 | iny 379 | lda [fcp],Y 380 | sta fcp+2 381 | stx fcp 382 | bra lb1 end; 383 | lb6 anop 1: 384 | ldy #2 fcpl := fcp 385 | lda fcp 386 | sta [fcpl] 387 | lda fcp+2 388 | sta [fcpl],Y 389 | 390 | ret 391 | end 392 | 393 | -------------------------------------------------------------------------------- /symbols.macros: -------------------------------------------------------------------------------- 1 | MACRO 2 | &LAB PH4 &N1 3 | LCLC &C 4 | &LAB ANOP 5 | &C AMID &N1,1,1 6 | AIF "&C"="#",.D 7 | AIF S:LONGA=1,.A 8 | REP #%00100000 9 | .A 10 | AIF "&C"<>"{",.B 11 | &C AMID &N1,L:&N1,1 12 | AIF "&C"<>"}",.G 13 | &N1 AMID &N1,2,L:&N1-2 14 | LDY #2 15 | LDA (&N1),Y 16 | PHA 17 | LDA (&N1) 18 | PHA 19 | AGO .E 20 | .B 21 | AIF "&C"<>"[",.C 22 | LDY #2 23 | LDA &N1,Y 24 | PHA 25 | LDA &N1 26 | PHA 27 | AGO .E 28 | .C 29 | LDA &N1+2 30 | PHA 31 | LDA &N1 32 | PHA 33 | AGO .E 34 | .D 35 | &N1 AMID &N1,2,L:&N1-1 36 | PEA +(&N1)|-16 37 | PEA &N1 38 | AGO .F 39 | .E 40 | AIF S:LONGA=1,.F 41 | SEP #%00100000 42 | .F 43 | MEXIT 44 | .G 45 | MNOTE "Missing closing '}'",16 46 | MEND 47 | MACRO 48 | &lab move4 &a,&b 49 | &lab lda &a 50 | sta &b 51 | lda 2+&a 52 | sta 2+&b 53 | mend 54 | MACRO 55 | &LAB LISTERROR &ERR 56 | &LAB LDA 0 57 | PHA 58 | PH2 &ERR 59 | JSL ERROR 60 | PLA 61 | STA 0 62 | MEND 63 | MACRO 64 | &LAB SUB4 &M1,&M2,&M3 65 | LCLB &YISTWO 66 | LCLC &C 67 | &LAB ~SETM 68 | AIF C:&M3,.A 69 | &C AMID "&M2",1,1 70 | AIF "&C"<>"#",.A 71 | &C AMID "&M1",1,1 72 | AIF "&C"="{",.A 73 | AIF "&C"="[",.A 74 | &C AMID "&M2",2,L:&M2-1 75 | AIF &C>=65536,.A 76 | SEC 77 | ~LDA &M1 78 | ~OP SBC,&M2 79 | ~STA &M1 80 | BCS ~&SYSCNT 81 | ~OP.H DEC,&M1 82 | ~&SYSCNT ANOP 83 | AGO .C 84 | .A 85 | AIF C:&M3,.B 86 | LCLC &M3 87 | &M3 SETC &M1 88 | .B 89 | SEC 90 | ~LDA &M1 91 | ~OP SBC,&M2 92 | ~STA &M3 93 | ~LDA.H &M1 94 | ~OP.H SBC,&M2 95 | ~STA.H &M3 96 | .C 97 | ~RESTM 98 | MEND 99 | MACRO 100 | &LAB DBPL &R,&BP 101 | AIF "&R"="X",.L1 102 | AIF "&R"="Y",.L1 103 | &LAB DEC &R 104 | BPL &BP 105 | MEXIT 106 | .L1 107 | &LAB DE&R 108 | BPL &BP 109 | MEND 110 | MACRO 111 | &LAB LONG &A,&B 112 | LCLB &I 113 | LCLB &M 114 | &A AMID &A,1,1 115 | &M SETB "&A"="M" 116 | &I SETB "&A"="I" 117 | AIF C:&B=0,.A 118 | &B AMID &B,1,1 119 | &M SETB ("&B"="M").OR.&M 120 | &I SETB ("&B"="I").OR.&I 121 | .A 122 | &LAB REP #&M*32+&I*16 123 | AIF .NOT.&M,.B 124 | LONGA ON 125 | .B 126 | AIF .NOT.&I,.C 127 | LONGI ON 128 | .C 129 | MEND 130 | MACRO 131 | &LAB SHORT &A,&B 132 | LCLB &I 133 | LCLB &M 134 | &A AMID &A,1,1 135 | &M SETB "&A"="M" 136 | &I SETB "&A"="I" 137 | AIF C:&B=0,.A 138 | &B AMID &B,1,1 139 | &M SETB ("&B"="M").OR.&M 140 | &I SETB ("&B"="I").OR.&I 141 | .A 142 | &LAB SEP #&M*32+&I*16 143 | AIF .NOT.&M,.B 144 | LONGA OFF 145 | .B 146 | AIF .NOT.&I,.C 147 | LONGI OFF 148 | .C 149 | MEND 150 | MACRO 151 | &LAB JPL &BP 152 | &LAB BMI *+5 153 | BRL &BP 154 | MEND 155 | MACRO 156 | &LAB PH2 &N1 157 | LCLC &C 158 | &LAB ANOP 159 | &C AMID &N1,1,1 160 | AIF "&C"="#",.D 161 | AIF S:LONGA=1,.A 162 | REP #%00100000 163 | .A 164 | AIF "&C"<>"{",.B 165 | &C AMID &N1,L:&N1,1 166 | AIF "&C"<>"}",.G 167 | &N1 AMID &N1,2,L:&N1-2 168 | LDA (&N1) 169 | PHA 170 | AGO .E 171 | .B 172 | LDA &N1 173 | PHA 174 | AGO .E 175 | .D 176 | &N1 AMID &N1,2,L:&N1-1 177 | PEA &N1 178 | AGO .F 179 | .E 180 | AIF S:LONGA=1,.F 181 | SEP #%00100000 182 | .F 183 | MEXIT 184 | .G 185 | MNOTE "Missing closing '}'",16 186 | MEND 187 | MACRO 188 | &LAB ~OP.H &OPC,&OP 189 | &LAB ANOP 190 | LCLC &C 191 | &C AMID "&OP",1,1 192 | AIF "&C"="[",.B 193 | AIF "&C"<>"{",.D 194 | &C AMID "&OP",L:&OP,1 195 | AIF "&C"="}",.A 196 | MNOTE "Missing closing '}'",2 197 | &OP SETC &OP} 198 | .A 199 | &OP AMID "&OP",2,L:&OP-2 200 | &OP SETC (&OP) 201 | .B 202 | AIF &YISTWO,.C 203 | &YISTWO SETB 1 204 | LDY #2 205 | &OP SETC "&OP,Y" 206 | .C 207 | &OPC &OP 208 | MEXIT 209 | .D 210 | AIF "&C"<>"#",.E 211 | &OP AMID "&OP",2,L:&OP-1 212 | &OP SETC "#^&OP" 213 | &OPC &OP 214 | MEXIT 215 | .E 216 | &OPC 2+&OP 217 | MEND 218 | MACRO 219 | &LAB ~LDA.H &OP 220 | &LAB ANOP 221 | LCLC &C 222 | &C AMID "&OP",1,1 223 | AIF "&C"="[",.B 224 | AIF "&C"<>"{",.D 225 | &C AMID "&OP",L:&OP,1 226 | AIF "&C"="}",.A 227 | MNOTE "Missing closing '}'",2 228 | &OP SETC &OP} 229 | .A 230 | &OP AMID "&OP",2,L:&OP-2 231 | &OP SETC (&OP) 232 | .B 233 | AIF &YISTWO,.C 234 | &YISTWO SETB 1 235 | LDY #2 236 | &OP SETC "&OP,Y" 237 | .C 238 | LDA &OP 239 | MEXIT 240 | .D 241 | AIF "&C"<>"#",.E 242 | &OP AMID "&OP",2,L:&OP-1 243 | &OP SETC "#^&OP" 244 | LDA &OP 245 | MEXIT 246 | .E 247 | LDA 2+&OP 248 | MEND 249 | MACRO 250 | &LAB ~STA.H &OP 251 | &LAB ANOP 252 | LCLC &C 253 | &C AMID "&OP",1,1 254 | AIF "&C"="[",.B 255 | AIF "&C"<>"{",.D 256 | &C AMID "&OP",L:&OP,1 257 | AIF "&C"="}",.A 258 | MNOTE "Missing closing '}'",2 259 | &OP SETC &OP} 260 | .A 261 | &OP AMID "&OP",2,L:&OP-2 262 | &OP SETC (&OP) 263 | .B 264 | AIF &YISTWO,.C 265 | &YISTWO SETB 1 266 | LDY #2 267 | &OP SETC "&OP,Y" 268 | .C 269 | STA &OP 270 | MEXIT 271 | .D 272 | STA 2+&OP 273 | MEND 274 | MACRO 275 | &LAB ~SETM 276 | &LAB ANOP 277 | AIF C:&~LA,.B 278 | GBLB &~LA 279 | GBLB &~LI 280 | .B 281 | &~LA SETB S:LONGA 282 | &~LI SETB S:LONGI 283 | AIF S:LONGA.AND.S:LONGI,.A 284 | REP #32*(.NOT.&~LA)+16*(.NOT.&~LI) 285 | LONGA ON 286 | LONGI ON 287 | .A 288 | MEND 289 | MACRO 290 | &LAB ~RESTM 291 | &LAB ANOP 292 | AIF (&~LA+&~LI)=2,.I 293 | SEP #32*(.NOT.&~LA)+16*(.NOT.&~LI) 294 | AIF &~LA,.H 295 | LONGA OFF 296 | .H 297 | AIF &~LI,.I 298 | LONGI OFF 299 | .I 300 | MEND 301 | MACRO 302 | &LAB ~LDA &OP 303 | LCLC &C 304 | &C AMID "&OP",1,1 305 | AIF "&C"<>"{",.B 306 | &C AMID "&OP",L:&OP,1 307 | AIF "&C"="}",.A 308 | MNOTE "Missing closing '}'",2 309 | &OP SETC &OP} 310 | .A 311 | &OP AMID "&OP",2,L:&OP-2 312 | &OP SETC (&OP) 313 | .B 314 | &LAB LDA &OP 315 | MEND 316 | MACRO 317 | &LAB ~STA &OP 318 | LCLC &C 319 | &C AMID "&OP",1,1 320 | AIF "&C"<>"{",.B 321 | &C AMID "&OP",L:&OP,1 322 | AIF "&C"="}",.A 323 | MNOTE "Missing closing '}'",2 324 | &OP SETC &OP} 325 | .A 326 | &OP AMID "&OP",2,L:&OP-2 327 | &OP SETC (&OP) 328 | .B 329 | &LAB STA &OP 330 | MEND 331 | MACRO 332 | &LAB ~OP &OPC,&OP 333 | LCLC &C 334 | &C AMID "&OP",1,1 335 | AIF "&C"<>"{",.B 336 | &C AMID "&OP",L:&OP,1 337 | AIF "&C"="}",.A 338 | MNOTE "Missing closing '}'",2 339 | &OP SETC &OP} 340 | .A 341 | &OP AMID "&OP",2,L:&OP-2 342 | &OP SETC (&OP) 343 | .B 344 | &LAB &OPC &OP 345 | MEND 346 | macro 347 | &l ret &r 348 | &l anop 349 | lclc &len 350 | aif c:&r,.a 351 | lclc &r 352 | &r setc 0 353 | &len setc 0 354 | ago .h 355 | .a 356 | &len amid &r,2,1 357 | aif "&len"=":",.b 358 | &len amid &r,1,2 359 | &r amid &r,4,l:&r-3 360 | ago .c 361 | .b 362 | &len amid &r,1,1 363 | &r amid &r,3,l:&r-2 364 | .c 365 | aif &len<>2,.d 366 | ldy &r 367 | ago .h 368 | .d 369 | aif &len<>4,.e 370 | ldx &r+2 371 | ldy &r 372 | ago .h 373 | .e 374 | aif &len<>10,.g 375 | ldy #&r 376 | ldx #^&r 377 | ago .h 378 | .g 379 | mnote 'Not a valid return length',16 380 | mexit 381 | .h 382 | aif &totallen=0,.i 383 | lda &worklen+2 384 | sta &worklen+&totallen+2 385 | lda &worklen+1 386 | sta &worklen+&totallen+1 387 | .i 388 | pld 389 | tsc 390 | clc 391 | adc #&worklen+&totallen 392 | tcs 393 | aif &len=0,.j 394 | tya 395 | .j 396 | rtl 397 | mend 398 | macro 399 | &l sub &parms,&work 400 | &l anop 401 | aif c:&work,.a 402 | lclc &work 403 | &work setc 0 404 | .a 405 | gbla &totallen 406 | gbla &worklen 407 | &worklen seta &work 408 | &totallen seta 0 409 | aif c:&parms=0,.e 410 | lclc &len 411 | lclc &p 412 | lcla &i 413 | &i seta c:&parms 414 | .b 415 | &p setc &parms(&i) 416 | &len amid &p,2,1 417 | aif "&len"=":",.c 418 | &len amid &p,1,2 419 | &p amid &p,4,l:&p-3 420 | ago .d 421 | .c 422 | &len amid &p,1,1 423 | &p amid &p,3,l:&p-2 424 | .d 425 | &p equ &totallen+4+&work 426 | &totallen seta &totallen+&len 427 | &i seta &i-1 428 | aif &i,^b 429 | .e 430 | tsc 431 | aif &work=0,.f 432 | sec 433 | sbc #&work 434 | tcs 435 | .f 436 | phd 437 | tcd 438 | mend 439 | --------------------------------------------------------------------------------