IMD 1.18: 20/01/2023 23:55:10 PRQ-SFT-BND-6 3RCC PERQ SYSTEM D.5 SOURCE DISTRIBUTION FLOPPY Copyright (C) Three Rivers Computer Corporation, 1981 single density, double sided D.5 Group name Command file OS.SOURCE SRC.CMD   z};diP z;diX oL35;di @~;di f&;di(=s;diYM;di@;d i sIq;dixs;dip Q;didLm;diR`;d iH I;d iSM!;di8 Jwa  ;diX x;di,u~;di #!;di#!i  ih qii0&;diX sB;di8 I. ;d ipe;di:d;diiM;dixyu;d ih};di Iq;di Ti@yix R`;d i i ɜ9z iow M d;dRQPETh~;di x8YR)`I;dMi+it!;d`jf&x io;d iowi i   23-Jun-81 BAM Address for DiskFailure printed in unsigned { decimal { 1-Jun-81of { system that diverged after 15-Mar-81. { Virtual memory and tim BAM Do automatic re-enable of swapping if turned off { by Shell (i.e. for Scavenger) ing statistics. { Get rid of "System" conditional compile. { Change { 28-May-81 BAM Handler for Stream Reset error { 23-May-81 JPS Replace enable/disable of control-main version from C to D. { 15-Mar-81 JPS Put in stuff for exceptions. { 28-Mar-81 BAM Changed lc processing { (exported by System) with enable/disable of { KeyBoarength of UsrCmdLine to 255. { 19-Mar-81 BAM PERQ_String. { 17-Mar-81 BAM Set time when come up sd interrupts (exported by IO_Others). { 22-May-81 JPS Fix control-c processing. { 18-May-81 JPS o Login LookUp faster. { 3-Mar-81 DAS Added variables for Login. Added { InCmdFiUse StreamKeyBoardReset. { Change TwoCtlC exception to CtlCAbort. { 13-May-81 BAM le for Shell. { 25-Feb-81 DAS Added FlushAll call in command. { 24-Feb-81 JPS Add code to shrinkRemove old comments about stand alone { Add vble for default cursor function (screen {  color) that can be set by login from profile { Add comments to some exceptions { 13-May-81 JPS 1. Add exceptions and default handlers for { control-C. { 2. Add procedures to enable and disable { control-C processing. Program System; { System - POS main program. Perq Software Group. Copyright (C) Three Rivers Computer Corpo { 3. Add exception to ExitProgram. { 4. Remove vestiges of old systeration, 1980. } { 30-Jun-81 BAM Add new vbles for DefScrOff and Comp and demo. { 25-Jun-81 m: standard error { procedures. { 12-May-81 BAM Add default handlers for many e BAM Change to window 0 before error type out. { 25-Jun-81 JPS Turn tablet off in command loop. { xceptions { Use new IO { 6-Apr-81 JPS Retrofit changes for exceptions to version   . { 19-Feb-81 John Strait Incorporate system version number into the { name of the LogIn r is changed, IO, Loader, Memory, Movemem, System, and Shell should be run file. { 17-Feb-81 Don Scelza Removed the include file for SysVers. { Put the code inlie-compiled, and the System should be re-linked. } Type DoubleWord = ^Integer; Vane in System. { 16-Feb-81 John Strait Removed the Loader to a separate module. { 16-Feb-81 Don Scelza Changed Sr UsrCmdLine: String[255]; SystemVersion: Integer; SystemInitialized: Boolean; UserMode: Boolean; CmdFile: Tystem to use Perq.String and { changed MainVersion to C. { 11-Feb-81 Diana Forgy Took out ext; DDS: Integer; LastFileName, RFileName, StrVersion, ShellName: String; CmdSegment: Integer; InPmd: Boolecommand interpreter and made { most of it program Shell. { { This pan; SysDisk: Integer; SysBootChar: Integer; NextSSize: Integer; NextSComplemented: Boolean; NextSOff: Brogram is compatable with the { new Compiler and PString. { { { oolean; InCmdFile: Boolean; CurUserID, CurGroupID: 0..255; CurUserName, CurPFile: String; DefCursFunct: Inte 17-Nov-80 Don Scelza Added the code for LastFileName. { This will allow a user to supply thger; { what to set curs func to after each prog} CtrlCPending: Boolean; { true if one control-C typed } {$e { name of a file once for the Editor, Compiler, { and Linker. { ifc SysTiming then} LoadTime, OldLoadTime: DoubleWord; ExecuteTime, OldExecuteTime: DoubleWord; SwapTime, OldSwap 14-Nov-80 Don Scelza Added conditional compile for stand { alone programs { 10 Oct 8Time: DoubleWord; MoveTime, OldMoveTime: DoubleWord; IOTime, OldIOTime: DoubleWord; PrintStatistics: Boolean;  and expand the screen. { *** Caution *** The Shell must never be loaded { 0 JPS Add support for the diagnostic display (DDS). { 23 Sep 80 JPS and DAS Add PAUSE command. {  when the screen is small, because it might { allocate a buffer for a command file. This { Announce 12 or 24 MByte disk. {} {********************} Exports {********************} Const MainVe buffer will hang around after the Shell returns { to the system. { rsion = 'D'; DebugSystemInit = False; FirstDDS = 199; ShellConst = 'Shell.'; LogConst = 'LogIn.';  23-Feb-81 RFR Added SysDisk, SysBootChar definitions. { Added call to FSSetupSystem PFileConst = 'Default.Profile'; SysTiming = True; { Gather System timing statistics. If this constant    shrink screen, screen complemented? } DefScrOff: Boolean; { when have to shrink screen, screen off? } DemoInt: Intetine, the KeyBoard { type-ahead buffer is cleared. If you want to prevent this, you must { catch CtlC also. { {ger; { reserved for Demo system } {*** WARNING!! IF YOU CHANGE THE EXPORTED PROCEDURES AND EXCEPTIONS, MAKE {***  If your program uses a Text file and you want to clear the line editing { buffer for that file, you should call th SURE THE NUMBERS FOR THE FOLLOWING EXCEPTIONS ARE UPDATED {*** AND RECOMPILE SCROUNGE IF CHANGED !!!!! **e Stream routine { StreamKeyBoardReset(F) (assuming F is the name of the file). If F { is a Text file which is at***} {*** WARNING!! DO NOT CHANGE THE ORDER OF THE ^C EXCEPTIONS !!!!! *****} Procedure Command; Procedure SetDDS( Displtached to the console, this will get rid { of the character F^ points to and clear Stream's line editing buffer. { {---ay: Integer ); Procedure SysVers( n: integer; var S: string ); Const ErrCtlC = 4; {******} Exception CtlC; {----------------------------------------------------------------------------------------} Const ErrCtlShftC = 6; {******} Exception CtlShf--------------------------------------------------------------- { { Abstract: { CtlC is raised by the KeyBoard interruptC; {----------------------------------------------------------------------------- { { Abstract: { CtlShftC is raised t routine when a control-c { is typed. If you handle this exception you should clear { CtrlCPending in your handlby the KeyBoard interrupt routine when a control- { shift-c is typed. If you handle this exception you should clear { er. If you are catching control-c's to { try to prevent aborts, you should enable CtlCAbort also, since the { Stre CtrlCPending in your handler. { { When this is raised by the KeyBoard interrupt routine, the KeyBoard { typeam package will raise it when the control-c is read. { {-----------------------------------------------------------------------ahead buffer is cleared. You cannot prevent this. { { If your program uses a Text file and you want to clear the line -------} Const ErrCtlCAbort = 5; {******} Exception CtlCAbort; {-----------------------------------------------------------editing { buffer for that file, you should call the Stream routine { StreamKeyBoardReset(F) (assuming F is the nam------------------ { { Abstract: { CtlCAbort is raised by the KeyBoard interrupt routine when the second { of twe of the file). If F { is a Text file which is attached to the console, this will get rid { of the character F^ po adjacent control-c's is typed. It is also raised by the { Stream package when a control-c is read. If you handle thisoints to and clear Stream's line editing buffer. { {-------------------------------------------------------------------------- {$endc} shouldReEnableSwapping: Boolean; SavedSwapId: Integer; DefScrComp: Boolean; { when have to exception { you should clear CtrlCPending in your handler. { { When this is raised by the KeyBoard interrupt rou  -------} exports const Ether3MBaud = False; { no support for 3 MBaud EtherNet } Ether10MBaud = False--------------------------------------------------------------------------} exports const LightUsed = TRUE; { no support for 10 MBaud EtherNet } type Double = array[0..1] of Integer; private ; {whether should use the lights at all} LightY = 3; LightHeight = 14; LightWidth ---} Const ErrExitProgram = 7; {******} Exception ExitProgram; {----------------------------------------------------------------------------- { { Abstract: { ExitProgram is raised to abort (or exit) a program. The default { handler fomodule Lights; {----------------------------------------------------------------------------- { { Lights - Perq Lightr CtlCAbort and Scrounge raise this exception. { { WARNING: No one but System and Loader should Handle this exception. s. { J. P. Strait 26 May 81. { Copyright (C) Three Rivers Computer Corporation, 1981 { { Abstract: { Thi{ Anyone may raise it to exit a program. { {-------------------------------------------------------------------s module defines the screen coordinates and size of the { Perq "lights". These are portions of the screen that are { ----------} {********************} Private {********************}  inverted during tedious operations such as recalibrating the { disk and scavenging files (in FileAccess). { { Design: { The lights must *not* extend below the 128th line of the screen. { The Y + Size must be less than or equal toModule SystemDefs; {----------------------------------------------------------------------------- { { SystemDefs -  256. { It is a good idea for the lights to be totally inside of the title { line. { The current lights Common system definitions. { John P. Strait 13 May 81. { Copyright (C) Three Rivers Computer Corporation, 1981. start at the left leave lots of room for new { lights to the right of the current one. There is room for { { { Abstract: { SystemDefs exports common system Const and Type definitions. The { intent is that SystemDefs sho10 lights all together { {-----------------------------------------------------------------------------} {----------------uld not export Procedures or Vars since { these require a Seg file. It is also intended that SystemDefs be { reas------------------------------------------------------------- { Versions: { 28-may-81 Brad A. Myers V1.1 Changed size and onably short so that it doesn't take long to import. { {----------------------------------------------------------------------spacing of lights and { made them non-square { 26-May-81 John Strait V1.0 Started {-  ixed bug in IntDouble 12-Apr-81 George Robertson V2.0 Converted to use microcode support 19-Mar-81 Brad Myers V1.3Bit32) : FSBit32; function DblEql(a,b : FSBit32) : boolean; function DblNeq(a,b : FSBit32) : boolean; function DblLeq(a,b : Fixed to import FileDefs 2-Feb-81 George Robertson at Carnegie-Mellon University V1.0 Fixed FSBit32) : boolean; function DblLes(a,b : FSBit32) : boolean; function DblGeq(a,b : FSBit32) : boolean; function DblGtr(a,b  DoubleInt to handle negative integers. Fixed DoubleMul to handle : FSBit32) : boolean; private  multiplicands > 2^15 by using Knuth's algorithm on p.233 of Knuth module Profile; {---------------------------------------------------------------------- { { Abstract: { This module is  vol.2. ----------------------------------------------------------------------------} exports imports Fiused to get information from the user profile { file. { { Written by: Don Scelza { { Copyright (C) Three Rivers Computer = 18; LightSpacing = 3*LightWidth; LightRecalibrate = LightSpacing; LightScavenge = LighleDefs from FileDefs; { to get FSBitnn } type MyDouble = packed record case integer of 1: tRecalibrate + LightWidth + LightSpacing; LightSwap = LightScavenge + LightWidth + LightSpacing; private  ( Lsw : integer; Msw : integer ); 2:  ( Ptr : FSBit32 ); 3: (  Byte0 : FSBit8; Byte1 : FSBit8; Byte2 : FSBit8; Byte3 : FSBit8module Arith; {---------------------------------------------------------------------------- Implements interim Double precisi ) end; function DoubleAdd(a,b : FSBit32) : FSBit32; function DoubleSub(a,b : Fon arithmetic package Needed until Pascal compiler supports type long. Copyright (C) 1980 Carnegie-Mellon University -SBit32) : FSBit32; function DoubleNeg(a : FSBit32) : FSBit32; function DoubleMul(a,b : FSBit32) : FSBit32; function DoubleD---------------------------------------------------------------------------} {-------------------------------------------------iv(a,b : FSBit32) : FSBit32; function DoubleInt(a : integer) : FSBit32; function IntDouble(a : FSBit32) : integer; functi--------------------------- Versions: 1-Jun-81 Brad Myers V2.2 Added comments 14-Apr-81 George Robertson V2.1 Fon DoubleBetween(a,start,stop : FSBit32) : boolean; function DoubleMod(a,b : FSBit32) : FSBit32; function DoubleAbs(a : FS  .. { { The base unit of the file is a text line. The function that provides { values from the profile file will return a linmodule UserPass; {------------------------------------------------------------------------- { { Abstract: { This modulee of text each time that it { is called. All text line between the # and the next { # are ass provides facilities for dealing with the password { and accounts file for PERQ. The login and protection facilities { umed to be assoicated with the first subsystem. { Successive calles to PFileEntry will return the next line of text for the { for Perq provide a very simple user validification. This system { is NOT completly secure. { { Written by: Don Scelza { current subsystem. { {----------------------------------------------------------------------} Exception PNotFound(FileName: { Copyright (C) Three Rivers Computer Corporation, 1981. { {---------------------------------------------------------------- String); {------------------------------------------------------------------------ Abstract: Raised when profile file canno---------} { 6-Jun-81 V1.3 Brad Myers { Fixed so System.Users always in root directory: >System.Users { } { 29-Aprt be found Parameters: fileName is profile not found ------------------------------------------------------------------------81 V1.2 Son Scelza { Added code and types for profile and remove user. { } { 9-Mar-81 V1.1 Don Scelza { Changed the -} Exception PNotInited; {------------------------------------------------------------------------ Abstract: Raised when max number of users. This will allow the entire { file to fit into a single disk block. { } { 5-Mar-81 V1.0 Don Scelza a profile procedure is used but PFileInit not called first ----------------------------------------------------- { Created UserPass { } {********************} Exports {********************} type IDType = 0..255; PassType = Corperation, 1981 { {-----------------------------------------------------------------------} { 30-Apr-81 V1.0 Don S-------------------} procedure PFileInit(PFileName, SubSystem: String); function PFileEntry: string; {*****************celza { Created the module. { } {********************} Exports {********************} {------------------------------**} Private {*********************} --------------------------------------- { { This module provides facilities that will allow a program to get { information from the user profile. { { The profile file is a text file that has the form: { { # { { . { . { . { # .    { The user ID of the user. } GroupID: IDType; { The group ID of the user. } Encrynd executes that program. When the program { terminates (normally or abnormally) it returns to the loader which returns { to ptPass: PassType; { The encrypted password. } Profile: String; { Path name of the profile filits caller. { {-----------------------------------------------------------------------------} { 4 Jun 81 V2.3 John Ste. } end; function FindUser(UserName: String; var UserRec: UserRecord): Boolean; function ValidUser( UserName, Prait { Add Virgil headers and comments. { } { 23 May 81 V2.2 John Strait { Use new IOKeyDisable/IOKeyEnable in place ofassword: String; var UserRec: UserRecord): Boolean; function AddUser(UserName, Password: String; Group: IDType;  old DisCtlC/EnaCtlC. { } { 18 May 81 V2.1 Brad Myers { Import IO_Unit and IO_Others instead of IO. { Added ** to error ProPath: String): Boolean; procedure NewUserFile; procedure ListUsers; function RemoveUser(UserName: String): boolean; messages { } { 13 May 81 V2.0 John Strait { Use exceptions. { } { 13 Apr 81 V1.9 John Strait { Fix bug in multi-s const PassFile = '>System.Users'; const MaxUsers = 10; type Users = array[0..MaxUsers] of UserRecord; {******ector read code. { } { 10 Apr 81 V1.8 John Strait { Use new RunRead module. { } { 6 Apr 81 V1.7 John Strait { 1) **************} Private {********************} Fix bug in Q-code version processing. { 2) Stuff for virtual memory. { 3) Make use of new ProgramSN in RunHeader. { } { 30 Mar 81 V1.6 Brad Myers. { Use local lookup for seg file names. { } { 25 Mar 81 V1.5 John Strait. { Improved retries and messages from retry mechanism. { } { 25 Mar 81 V1.5 John Strait. { Improved retries and messages from retry mechanism. { } { 20 Mar 81 V1.4 Miles A. Barel { Added QCode Version Checks and long file names { } { 3 Mar 81 V1.3 John Stramodule Loader; {----------------------------------------------------------------------------- { { Loader - Perq systeit. { Improve retry mechanism to immediately do a recalibrate after an { address error. { } { 1 Mar 81 V1.2 John Strait. ^Integer; { a two word value } UserRecord = packed record InUse: boolean; m loader. { J. P. Strait 10 Feb 81. rewritten as a module. { Copyright (C) Three Rivers Computer Corporation, { is this entry in use. } Name: String[31]; { Name of the user } UserID: IDType; 1981. { { Abstract: { This module implements the Perq POS system loader. Given a run-file { name as input, it loads a     { 18 May 81 1.5 Brad Myers { Increment Q-Code version number. { } { 9 Apr 81 1.4 John Strait { Change RunInfo to { maximum configuration in LoadStack } type SNArray = packed array[1..SegLength] o { Speed up the loader by using multi-sector reads from the hard disk. { If errors, abort loading before loading the stack seg be a record that just contains the header information { and define a pointer to it. { Change node definitions in order to impment. { } { 23 Feb 81 V1.1 RFR. { Changed <= to = FSLookup test. { } { 10 Feb 81 V1.0 John Strait. { Start file. lement RunFiles module. { } { 8 Apr 81 1.3 John Strait { Add "ProgramSN" to RunHeader. This is the ISN of the program s{ } exports const LoaderVersion = '2.3'; procedure Load( RunFileName: String ); private egment. { } { 19 Mar 81 1.2 Miles A. Barel { Increased size of SEG and RUN file names and added QCode Version stuff { }  { 23 Feb 81 1.1 Don Scelza { Changed the name Header to RunHeader. There was a name { conflict with the C-MU file system. { } { 10 Feb 81 1.0 John Strait { Start file. { } exports const CodeVersion = '1.5'; RFileFormat = 1; QCodeVersion = 2; { Current QCode Version Number } FileLength = 100; { max chars in a filmodule Code; {----------------------------------------------------------------------------- { { Code.Pas - Common defe name } SegLength = 8; { max chars in a segment name } StackLeader = 2; { number of leader woinitions for the Linker and Loader. { J. P. Strait 10 Feb 81. Rewritten as a module. { Copyright (C) Threrds in stack before } { XSTs (must be even) } e Rivers Computer Corporation, 1981. { { Abstract: { { Code.Pas defines constants and types shared by the Linker and t { Currently contains initial TP and GP } DefStackSize = #20; { default stack segment size (in blocks) } he { Loader. These include definitions of the run file and of offsets in the { stack segment. { { Design: { When the DefHeapSize = #4; { default heap segment size (in blocks) } DefIncStack = #4; { default stack size incre format of run files is changed, the constant RFileFormat { must also be changed. This is necessary to prevent the procedures ment (in blocks) } DefIncHeap = #4; { default heap size increment (in blocks) } FudgeStack = #2000; which { read run files from crapping out. { {-----------------------------------------------------------------------------}  { fudge space between system and user GDB's } { this must hold all loader variables at }     SId : SNArray; { name of imported segment } FilN : pFNString; { file name  GDBSize : integer; SumOfLocals : integer); fof imported segment } XGP : integer; { global pointer of import } XSN : inalse:(Block: array[0..255] of integer) end; CImpInfo = record case boolean of { Importteger; { internal number of import } Seg : pSegNode; Next : pImpNode  List Info - as generated } { by the compiler } true: ( Mo end; { Run file: } RunElement = (RunHeader,SysSegment,UserSegment,Import,SegFileNaduleName: SNArray; { module identifier } FileName: FNString { file name } f Char; { segment name } pFNString = ^FNString; FNString = String[FileLength]; { file name } mes); RunInfo = record { run header } RFileFormat:integer; Version: QVerRange = 0..255; { range of QCode version numbers } pSegNode = ^SegNode;  integer; System: boolean; InitialGP: integer; CurOffset: i pImpNode = ^ImpNode; { Segment information record:} SegNode = record SegId nteger; StackSize: integer; StackIncr: integer; HeapSize: intege : SNArray; { segment name } RootNam : pFNString; { file name without .Pas or .Seg } r; HeapIncr: integer; ProgramSN: integer; SegCount: integer  GDBSize : integer; { size of this segment's GDB } XSTSize : integer; { size of this segment's end; RunFileType = file of Integer; { Segment file: } pSegBlock = ^S XST } GDBOff : integer; { StackBase offset to GDB } ISN : integer; { segegBlock; SegBlock = packed record case boolean of { .SEG file definition } { firstment number inside Linker } CodeSize : integer; { number of blocks in .Seg file } S block: } true: (ProgramSegment: boolean; SegBlkFiller : 0..127; SN : integer; UsageCnt : integer; ImpList : pImpNode; Next  QVersion : QVerRange; ModuleName : SNArray; FileN : pSegNode end; { Import information record } ImpNode = record ame : FNString; NumSeg : integer; ImportBlock : integer;    to read run files will not crap out. { {-----------------------------------------------------------------------------} {pr 81 V1.0 John Strait { Start file. { } exports const RunWriteVersion = '1.0'; imports Code from Code;  9 Apr 81 V1.0 John Strait { Start file. { } exports const RunReadVersion = '1.0'; imports Code from Code;  procedure WriteRunFile( var RunFile: RunFileType; Header: RunInfo; FirstSeg, FirstUserSeg: pSegNode ); procedure ReadRunFile( var RunFile: RunFileType; Seg: Integer; var Header: RunInfo;  private  var FirstSeg, FirstUserSeg, LastSeg: pSegNode; ImportsWanted: Boolean ); procedure ReadSegNamodule Dynamic; {----------------------------------------------------------------------------- { { Dynamic - Perq dynammes( var RunFile: RunFileType; Seg: Integer; FirstUserSeg: pSegNode ); private ic memory allocation and de-allocation. { J. P. Strait 1 Jan 80. { Copyright (C) Three Rivers Computer Corporation, 1980, 1981. { { Abstract: { Dynamic implements Pascal dynamic allocation - New and Dispose. { Memory of a given size with a given alignment may be allocated from { any data segment. If the data segment is full (doesn't contai ); false:( Ary: array [0..0] of integer) end;  SegFileType = file of SegBlock; private module RunWrite; {----------------------------------------------------------------------------- { { RunWrite - Module tmodule RunRead; {----------------------------------------------------------------------------- { { RunRead - Module to o write run files. { John P Strait 9 Apr 81. { CopyRight (C) Three Rivers Computer Corporation, 1981. { { Abstread run files. { John P Strait 9 Apr 81. { CopyRight (C) Three Rivers Computer Corporation, 1981. { { Abstracract: { RunWrite exports procedures to write run files. { { Design: { If and when the format of run files is chat: { RunRead exports procedures to read and write run files. { { Design: { If and when the format of run files inged, the constant { RFileFormat in module Code must be changed. This is necessary { so that the procedures to res changed, the constant { RFileFormat in module Code must be changed. This is necessary { so that the procedures ad run files will not crap out. { {-----------------------------------------------------------------------------} { 9 A    de is at least two words long and { is of the form { { record Next: Integer; { Length: Integer;  Delete Insert Pos { PosC AppendString { AppendChar UpperCase { ConvUpper {{ Rest: 2*Length - 2 words { end; { { Where Next*2 is the address of the next free node and {---------------------------------------------------------------------------} { Date: 20 May 81 V2.3 { Who: JE Ball  Length*2 is the { number of free words. { {---------------------------------------------------------------------------(CMU) and Brad Myers { Rewrote copy loop in Insert { Added new function: RevPosC { } { Date: 13-May-81 V2.2 { Who: John --} { 12 May 81 V1.3 JPS { Use exceptions rather than MemoryError. { } { 23 Mar 81 V1.2 JPS { Convert to standarStrait { Use exceptions. { } { Date: 19-Jan-81 V2.1 { Who: Diana Connan Forgy { Changed ConCat and SubStr to functions. d documentation form. { } { 13 Jan 81 V1.1 JPS { Fix assignment of nil in New and Dispose. { Change bad constant #200000 { } { Date: 16-Dec-80 V2.0 { Who: Brad A. Myers { Added New procedures: PosC, AppendString, AppendChar, UpperCase, ConvUp to #100000. { Move $R- to private part. { } exports const DynamicVersion = '1.3'; imports Memory from Memory; per. { } { 27-Nov-80 1.1 Don Scelza { Fixed a bug in SubStr. Added calls to UserError for errors. { (Not released) { } procedure NewP( S: SegmentNumber; A: integer; var P: MMPointer; L: integer ); procedure DisposeP( var P: MMPointer; L: in { Date: 30-Apr-80 { Who: Don Scelza { Changed ConCat and SubStr to use temp strings for their hacking. { This will allow teger ); private a use to pass the same string as input and result { parameters. { } { Date: 8-Apr-80 { Who: Don Scelza { Created the string hacking module. { } {------------------------------------------------------------------------- { { Strings in PERQModule PERQ_String; {----------------------------------------------------------------------------- { { PERQ String hackin Pascal are stored a single character per byte with { the byte indexed by 0 being the length of the string. When the routines n { enough free memory to allocate), the segment is increased in { multiples of the segment's increment size untilg routines. { Written by: Donald Scelza { Copyright (C) 1980 { Three Rivers Computer Corporastion { 160 N. Craig Street { P there is enough { free memory to allocate. Similarly, memory that was once allocated { may be deallocated. { {itsburgh, Pa. 15213 { { File: StringRoutines.Text { { Abstract: { This module implements the string hacking routines fo Design: { Free memory within each segment is linked into a circular freelist { in order of address. Each free nor the { Three River PERQ Pascal. { The routines impolemented by this module are: { Adjust Concat Substr {    { in this module must access the length byte they must turn off range { checking. { {------------------------------------------------------------------------} {********************} Exports {********************} Const MaxPStringSize=255; module Memory; {----------------------------------------------------------------------------- { { Memory - Perq memory  { Length of strings} Type PString = String[MaxPStringSize]; Procedure Adjust(Var STR:PString; LEN:Integer); Functionmanager. { J. P. Strait 1 Jan 80. { Copyright (C) Three Rivers Computer Corporation, 1980. { { Abstract:  Concat(Str1,Str2:PString):PString; Function Substr(Source:PString; Index,Size: Integer):PString; Procedure Delete(Var Str:PS { Memory is the Perq memory manager. It supervises the segment tables { and exports procedures for manipulating mtring; Index,Size:Integer); Procedure Insert(Var Source,Dest:PString; Index:Integer); Function Pos(Source,Mask:PString): Inteemory segments. { Perq physical memory is segmented into separately addressable items { (called segments) which mager; FUNCTION PosC(s: PString; c: Char): Integer; PROCEDURE AppendString(var s1: PString; s2: PString); PROCEDURE AppendChay contain either code or data. { { Design: { See the Q-Code reference manual. { {------------------------------------r(var s: PString; c: Char); FUNCTION UpperCase(c: Char): Char; PROCEDURE ConvUpper(Var s: PString); Exception StrBadParm; -----------------------------------------} { 29 Jun 81 V2.5 JPS { Destroy swapping files when swapping is disabled. { {------------------------------------------------------------------------- Abstract: Raised when bad index or length parameter} { 4 Jun 81 V2.4 JPS { Add Virgil headers for exceptions. { } { 26 May 81 V2.3 JPS { Add CurrentSegment function. s passed to procedures or sometimes when string will be too long (other times, StrLong is raised in this { Prevent Memory from being swapped during FindHole calls. { } { 21 may 81 V2.2 JPS { Initialize BootSegId in EnableSwap case -------------------------------------------------------------------------} Function RevPosC(s: PString; c: char): inteping. { } { 14 May 81 V2.1 GGR { Add support for 3 MBaud EtherNet. { } { 12 May 81 V2.0 JPS { 1) Split Memory intoger; {********************} Private {********************}  two modules: Memory (user callable routines, swappable) { and Virtual (system callable routines, unswappable). { 2) Move FileIdToSegId and SegIdToFileId into Memory. { 3) Use exceptions and get rid of MemoryError. { } { 24 Mar 81 V1.9 JPS { Begin adding stuff for virtual memory. { } { 23 Mar 81 V1.8 JPS { Convert to standard documentation form. { Delete DEBUG   6 Feb 81 V1.3 DAS { Changed to use Perq_String from Perq.String { } { 11 Feb 81 DCF { Changed calls to PString totSize = MMMaxBlocks-1; MMMaxExtSize = MMMaxBlocks; type MMBit4 = 0..#17; MMBit8 = 0..#377; MMBit conform to new PString. This module is { compatable with the new System and Compiler. { } { 13 Jan 81 V1.2 JPS { 1) Al12 = 0..#7777; MMIntSize = 0..MMMaxIntSize; MMExtSize = 1..MMMaxExtSize; MMAddress = integer; MMPositionlocate the IOSeg in memory manager initialization as a locked { segment at the high end of memory. Use the last block in me = (MMLowPos, MMHighPos); SegmentNumber = integer; SegmentKind = (CodeSegment, DataSegment); Segmenstuff. { Delete OutputF. { Add "MM" to the beginning of names which are exported but are not needed by { programs which impormory (the { Krnl no longer needs it). { 2) Move $R- to private part. { } { 10 Oct 80 V1.1 JPS { Add support for the t the memory manager. { Remove Concat call from MemoryError. { Remove import of Perq.String. { } { 24 Feb 81 V1.7 JPS {diagnostic display (DDS). { } exports const MemoryVersion = '2.5'; imports SystemDefs from SystemDefs; const 1) Allow the ScreenSeg to change sizes. To allow this, the memory { manager must prevent system segments (those with RefCo SATSeg = 1; { SAT segment } SITSeg = 2; { SIT segement } FontSeg = 3; { fonunt > 1) from { being moved into the area of memory which might be used for the { screen. This is a hack which guarantet segment } ScreenSeg = 4; { screen segment } CursorSeg = 5; { cursor segment } IOSeg =es that the system can expand { the screen to its original size after returning from a user program. { This change was o 6; { IO segment } SysNameSeg = 7; { system segment names } MemoryInBlocks = #1000;riginally made by RFR, but had to be converted for { memory manager version 1.5 and greater. { 2) Remove PrintTable and Pri { amount of memory on this machine } MaxSegment = #137; { should be 2**16 - 1 } SetStkBase = #60; ntFreeList. { } { 23 Feb 81 V1.6 RFR { Added DK and CH to system boot record (they will be filled by the boot { microcod SetStkLimit = #120; {$ifc Ether3MBaud then} IOSegSize = 6; { number of blocks in the IOSeg } {$elsec} {$ie with the disk number and boot character used in booting). { } { 18 Feb 81 V1.5 JPS { Define fields in the SIT to remembfc Ether10MBaud then} IOSegSize = UnImplemented; { number of blocks in the IOSeg } {$elsec} IOSegSize = 3; er names of boot loaded segments. { Remove most of InitMemory since it is done now by MakeBoot. Make IOSeg { a constant. { } { number of blocks in the IOSeg } {$endc} {$endc} SysSegLength = 8; { length of name of a boot-loade { 17 Feb 81 V1.4 DAS { Removed the include file SegNumbers. Placed the segment number { definitions inline. { } { 1d segment } MMMaxBlocks = #400; { maximum number of blocks in a segment } MMMaxCount = #377; MMMaxIn   010 } Kind : SegmentKind; { 020 } Full : boolean; { 040 } InUse : bo = ^SATarray; pSIT = ^SITarray; MMEdge = record H: SegmentNumber; { Head } T: Segmeolean; { 100 } Lost : boolean; { *** } { 200 } BaseLower : MMBit8; BaseUpper : MMBntNumber { Tail } end; SysSegName = packed array[1..SysSegLength] of Char; pSysNames = ^Sysit4; Size : MMBit12 end; SITentry = packed record case integer of { Segment Information Table } NameArray; SysNameArray = array[0..0] of SysSegName; procedure InitMemory; procedure Data { real SIT entry } 1: (NextSeg : SegmentNumber; Increment : MMIntSize; Maximum : MMIntSiSeg( var S: SegmentNumber ); procedure CodeOrDataSeg( var S: SegmentNumber ); procedure ChangeSize( S: SegmentNumber; Fsize:ze; Freelist : MMAddress; RefCount : 0..MMMaxCount; IOCount : 0..MMMaxCount;  MMExtSize ); procedure CreateSegment( var S: SegmentNumber; Fsize, Fincrement, Fmaximum: MMExtSizeMobility : SegmentMobility; BootLoaded : Boolean; case Integer of 1: (BootLowerAddress: Inte ); procedure IncRefCount( S: SegmentNumber ); procedure SetMobility( S: SegmentNumber; M: SegmentMobility ); procedure DetMobility = (UnMovable, UnSwappable, LessSwappable, Swappable); MMFreeNode = record N: MMAddress; L: integger; BootUpperAddress: Integer; BootLogBlock: Integer); 2: (DiskLowerAddress: Integeer end; MMBlockArray = array[0..0] of array[0..127] of integer; pMMBlockArray = ^MMBlockArray;r; DiskUpperAddress: Integer; DiskId: Integer) ); { boot time information }  MMArray = record case Integer of 1: (m: array[0..0] of MMFreeNode); 2: (w: array[0..0 2: (BootBlock: record CS: SegmentNumber; { initial code segment } SS: SegmentNumber; { initi] of Integer) end; pMMArray = ^MMArray; MMPointer = record case integer of 1: (P: ^integal stack segment } XX: Integer; { unused } VN: Integer; { system version number } er); 2: (B: pMMBlockArray); 3: (M: pMMArray); 4: (Offset: MMAddress; Segmen: SegmentNumber)  FF: SegmentNumber; { first free segment number } FC: SegmentNumber; { first system code segment }  end; SATentry = packed record { Segment Address Table } NotResident : boolean; { 001 } Movin DK: integer; { disk system was booted from } CH: integer { char used in booting } g : boolean; { 002 } RecentlyUsed: boolean; { 004 } Sharable : boolean; { end) end; SATarray = array[0..0] of SATentry; SITarray = array[0..0] of SITentry; pSAT  n UnusedSegment( S: SegmentNumber ); {----------------------------------------------------------------------------- { { Abstr--------------------------------------------------------------- { { Abstract: { BadIncrement is raised when a bad Increact: { UnusedSegment is raised when the memory manager encounters a segment { number which references a segment whment value is passed to some { memory manager routine. This usually means that the increment passed { to CreateSeich is not in use. This may mean { that a bad segment number was passed to some memory manager routine { or that gment is greater than 256 or less than one. { { Parameters: { Fincrement - The bad Increment value. { {--------------a bad address was de-referenced. { { Parameters: { S - Segment number of the unused segment. { {------------------------------------------------------------------------------------} exception BadMaximum( S: SegmentNumber; Fmaximum: Integer--------------------------------------------------------} exception NotDataSegment( S: SegmentNumber ); {---------------- ); {----------------------------------------------------------------------------- { { Abstract: { BadMaximum is raise------------------------------------------------------------- { { Abstract: { NotDataSegment is raised when the number d when a bad Maximum value is passed to some memory { manager routine. This usually means that the maximum passed to { of a code segment is passed { to some memory manager routine that requires the number of a data { segment. { { P CreateSegment is greater than 256 or less than one. { { Parameters: { Fmaximum - The bad Maximum value. { {----arameters: { S - Segment number of the code segment. { {----------------------------------------------------------------------------------------------------------------------------------------} exception FullMemory; {-------------------------------------} exception BadSize( S: SegmentNumber; Fsize: Integer ); {------------------------------------------------------------------------------------------------------- { { Abstract: { FullMemory is raised when there is not enough phcRefCount( S: SegmentNumber ); procedure SetIncrement( S: SegmentNumber; V: MMExtSize ); procedure SetMaximum( S: SegmentNum---------------------------- { { Abstract: { BadSize is raised when a bad Size value is passed to some memory { ber; V: MMExtSize ); procedure SetSharable( S: SegmentNumber; V: boolean ); procedure SetKind( S: SegmentNumber; V: SegmentKmanager routine. This usually means that the size passed to { CreateSegment or ChangeSize is greater than the maximum siind ); procedure MarkMemory; procedure CleanUpMemory; procedure FindCodeSegment( var S: SegmentNumber; FId: Integer ); pze or { less than one. { { Parameters: { Fsize - The bad Size value. { {--------------------------------------rocedure EnableSwapping( Where: Integer ); procedure DisableSwapping; function CurrentSegment: SegmentNumber; exceptio---------------------------------------} exception BadIncrement( S: SegmentNumber; Fincrement: Integer ); {--------------  pacting memory. { {-----------------------------------------------------------------------------} exception CantMoveSegm------} exception EdgeFailure; {----------------------------------------------------------------------------- { { Abstrent( S: SegmentNumber ); {----------------------------------------------------------------------------- { { Abstract: { act: { EdgeFailure is raised by MakeEdge when it discovers that the SIT { entries are not linked together into a c CantMoveSegment is raised when the memory manager attempts to move { a segment which is UnMovable or has a non-zero IO ircular list. This is an { error which should never happen in a debugged system. It usually { means that there icount. { { Parameters: { S - The number of the segment which cannot be moved. { {------------------------------------s a bug in the memory manager or that the segment { tables have been clobbered. { {-----------------------------------------------------------------------------} exception PartNotMounted; {--------------------------------------------------------------------------------------------} exception NilPointer; {--------------------------------------------------------------------------------- { { Abstract: { PartNotMounted is raised when { 1) the memory manager attempt---------------------- { { Abstract: { NilPointer is raised when a Nil pointer is used or passed to Dispose. { {-----s to swap a data segment out for { the first time { and 2) the partition which is to be used for sw------------------------------------------------------------------------} exception BadPointer; {------------------------apping is no longer { mounted. { {------------------------------------------------------------------------------------------------------------------------------- { { Abstract: { BadPointer is raised when a bad pointer is passed---} exception SwapInFailure( S: SegmentNumber ); {---------------------------------------------------------------------- to Dispose. { { Parameters: { {-----------------------------------------------------------------------------} excepti------- { { Abstract: { SwapInFailure is raised when the swap file cannot be found for a { segment which is markon FullSegment; {----------------------------------------------------------------------------- { { Abstract: { FullSeged as swapped out. This is an error which { should never happen in a debugged system. It usually means that { thment is raised by New when it discovers that there is not { enough room to allocate and the segment cannot be enlarged (iere is a bug in the memory manager or that the segment tables { have been clobbered. { { Parameters: { S - The nts { size has reached its maximum). { {-----------------------------------------------------------------------------} ysical memory to { satisfy some memory manager request. This is raised only after { swapping segments out and comumber of the segment which could not be swapped in. { {-----------------------------------------------------------------------  andard documentation form. { Delete DEBUG stuff. { Delete OutputF. { Add "MM" to the beginning of names which are exported bumodule Virtual; {----------------------------------------------------------------------------- { { Virtual - Perq virtut are not needed by { programs which import the memory manager. { Remove Concat call from MemoryError. { Remove import of Per exception NoFreeSegments; {----------------------------------------------------------------------------- { { Abstract: al memory manager. { J. P. Strait 1 Jan 80. { Copyright (C) Three Rivers Computer Corporation, 1980. { { { NoFreeSegments is raised when the memory manager discovers that all { of the segment numbers are in use and it neAbstract: { Virtual is the Perq virtual memory manager. It supervises the { segment tables and exports procedureseds another one. This { is equivalent to "Segment table full". { {---------------------------------------------------- for swapping memory segments. { Virtual is the portion of the Perq memory manager which must remain { memory resi-------------------------} exception SwapError; {------------------------------------------------------------------------dent at all times. { Perq physical memory is segmented into separately swappable items { (called segments) which m----- { { Abstract: { SwapError is raised if the one of the memory managers swapping { routines is called when say contain either code or data. { { Design: { See the Q-Code reference manual. { {-----------------------------------wapping is disabled. This is an error which { should never happen in a debugged system. It usually means that { ------------------------------------------} { 3 Jul 81 V2.4 JPS { Fix bug where MMFirst was getting trashed by SwapIn. there is a bug in the memory manager. { {-----------------------------------------------------------------------------}  { } { 28 May 81 V2.3 BAM { New light. { } { 26 May 81 V2.2 JPS { Show swapping with a "light". { } { 21 May 81 var SAT: pSAT; SIT: pSIT; MMFirst, MMFree, MMLast, MMHeap: SegmentNumber; MMHole: MMEdge; MMState: (MMSc V2.1 JPS { Fix various serious bugs in SwapIn procedure. { Delete several unused variables in various procedures. { } {an1, MMScan2, MMScan3, MMScan4, MMScan5, MMScan6, MMScan7, MMScan8, MMScan9, MMScan10, MMScan11,  12 May 81 V2.0 JPS { 1) Split Memory into two modules: Memory (user callable routines, swappable) { and Virtual (system  MMNotFound, MMFound); StackSegment: SegmentNumber; FirstSystemSeg: SegmentNumber; BootFileId: Integcallable routines, unswappable). { 2) Move FileIdToSegId and SegIdToFileId into Virtual. { 3) Use exceptions rather than Memorer; SwappingAllowed: Boolean; SwapId: Integer; private yError. { } { 24 Mar 81 V1.9 JPS { Begin adding stuff for virtual memory. { } { 23 Mar 81 V1.8 JPS { Convert to st  t number { definitions inline. { } { 16 Feb 81 V1.3 DAS { Changed to use Perq_String from Perq.String { } { 11 Feb 8 BootSerialNum: Double; BootSegId: SegId; SwapSId: SegId; private 1 DCF { Changed calls to PString to conform to new PString. This module is { compatable with the new System and Compilmodule MoveMem; {----------------------------------------------------------------------------- { { MoveMem - Move memorer. { } { 13 Jan 81 V1.2 JPS { 1) Allocate the IOSeg in memory manager initialization as a locked { segment at the hiy. { J. P. Strait ca. 1 Jan 80. { Copyright (C) Three Rivers Computer Corporation, 1980, 1981. { { Abstract: gh end of memory. Use the last block in memory (the { Krnl no longer needs it). { 2) Move $R- to private part. { } { 1{ MoveMem is used to move a segment from one location to another in { physical memory. The two locations may overl0 Oct 80 V1.1 JPS { Add support for the diagnostic display (DDS). { } exports const VirtualVersion = '2.4'; imap. { {-----------------------------------------------------------------------------} { 18 May 81 V1.4 BAM { Change iq.String. { } { 24 Feb 81 V1.7 JPS { 1) Allow the ScreenSeg to change sizes. To allow this, the memory { manager musports Memory from Memory; imports IO_Unit from IO_Unit; imports DiskIO from DiskIO; function ReturnSegment: St prevent system segments (those with RefCount > 1) from { being moved into the area of memory which might be used for the egmentNumber; procedure ReleaseSegmentNumber( Seg: SegmentNumber ); function NewSegmentNumber: SegmentNumber; procedure M{ screen. This is a hack which guarantees that the system can expand { the screen to its original size after returning fakeEdge( var E: MMEdge; S: SegmentNumber ); procedure DeleteSegment( var S: SegmentNumber ); procedure SwapOut( var E: MMEdgrom a user program. { This change was originally made by RFR, but had to be converted for { memory manager version 1.5 ae ); procedure SwapIn( E: MMEdge; S: SegmentNumber; P: MMPosition ); procedure Compact; procedure KeepSegments; procedurnd greater. { 2) Remove PrintTable and PrintFreeList. { } { 23 Feb 81 V1.6 RFR { Added DK and CH to system boot record (e FindHole( Fsize: MMIntSize; ForUserSegment: Boolean ); procedure IncIOCount( S: SegmentNumber ); procedure DecIOCount( S: they will be filled by the boot { microcode with the disk number and boot character used in booting). { } { 18 Feb 81 V1.5SegmentNumber ); procedure SwapSegmentsIn( S1, S2, S3, S4: SegmentNumber ); var ScreenLast: Integer; Keep1, Keep2 JPS { Define fields in the SIT to remember names of boot loaded segments. { Remove most of InitMemory since it is done now b, Keep3, Keep4: SegmentNumber; Kludge: record case Integer of 1: (A: DiskAddress); 2: (D: Doubly MakeBoot. Make IOSeg { a constant. { } { 17 Feb 81 V1.4 DAS { Removed the include file SegNumbers. Placed the segmene) end; BlockHeader: IOHeadPtr; BlockAddress: Double; BlockSId: SegId; Status: IOStatPtr;   ary debugger. Abstract: This module contains the procedure Scrounge which allows a small amount of debugging. Sifo at top Proceed command 12-May-81 V0.3 Brad A. Myers Use new IO modules; new ence there are no symbol tables or micro-- code support for breakpoints, you can look at the stack trace and xceptions 6-May-81 V0.2 Brad A. Myers No procedure names for system modules un examine vbles by offsets. The types of the variables have to be specified by the user. Written by: Brad A.til debug since takes too long 1-May-81 V0.1 Brad A. Myers Started by reworking PMD --------------------------------- Myers 1-May-1981 Copyright (C) 1981 Three Rivers Computer Corporation. ---------------------------------------------------------------------------------------------} {////////////////////////} EXPORTS {\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\} Pro----------------------------} {---------------------------------------------------------------------------- Versions: cedure Scrounge(ES, ER, PStart, PEnd, ExcSeg, RaiseAP: Integer); {////////////////////////} PRIVATE {\\\\\\\\\\\\\\\\\\\\\\\\ 30-Jun-81 V0.11 Brad A. Myers Increase screen size for default window Set ^S Pending \\\\\\\\} to false Fix ^Shift-D while ^Shift-D Remove n commanmodule Clock; {----------------------------------------------------------------------------- { { Clock - Perq clock roud (NIY anyway) 5-Jun-81 V0.10 Brad A. Myers Fixed ^C handling More information whtines. { J. P. Strait 1 Feb 81. { Copyright (C) Three Rivers Computer Corporation, 1981. { { Abstract: { mport from IO to IO_Others. { } { 18 Apr 81 V1.3 JPS { Gather statistics. { } { 24 Mar 81 V1.2 JPS { Convert to sten Scrounge aborts 4-Jun-81 V0.9 Brad A. Myers Catch FSNotFnd for lookups Clear andard documentation form. { } { 17 Feb 81 V1.1 JPS { Set R- in private part. { } exports imports Memory from MIO buffer for CleanUp. 1-Jun-81 V0.8 Brad A. Myers Fixed bugs in recursive invocation. 28-May-81 V0.7 Brad A. emory; procedure CopySegment( SrcSeg, DstSeg: SegmentNumber; NewDstBase: Integer ); private Myers Made safer for recursive invocation. Add all handlers 23-May-81 V0.6 John P. Strait Enable keyboard interrupts before reading. 22-May-81 V0.5 John P. Strait Change call to StreamKeyBoardReset. Module Scrounge; {----------------------------------------------------------------------------- Title: PERQ Pascal Prelimin 20-May-81 V0.4 Brad A. Myers New stream reset procedure Compiler switch for run in  rm YY MMM DD HH:MM:SS where MMM is a three (or { more) letter month name and HH:MM:SS is time of day on a 24 hour {  clock. { { The clock module exports routines for setting and reading the current { time as either a TimeStamp or a character string, and exports routines { for converting between TimeStamps and strings. { {-----------------------------------------------------------------------------} { V1.5 12 May 81 Brad Myers. { If invalid time string then module GetTimeStamp; {----------------------------------------------------------------------------- { { GetTimeStamp - raise a signal. { } { V1.4 19 Mar 81 Brad Myers. { PERQ_String. { } { V1.3 2 Mar 81 John Strait. { Don't export IPerq get time routine. { J. P. Strait 1 Feb 81. { Copyright (C) Three Rivers Computer Corporation, 1981. { O from Clock and GetTimeStamp. { } { V1.2 2 Mar 81 John Strait. { Add title, copyright, and abstract. { Add version num { Abstract: { GetTimeStamp implements the read-time-as-TimeStamp function for the { Clock module. See the Clock ber. { Add retroactive change history. { } { V1.1 28 Feb 81 Brian Rosen. { Check for invalid month numbers in StampToStrmodule for more details. { { Design: { GetTimeStamp is a separate module so that it may be imported into the { ring. { } { V1.0 1 Feb 81 John Strait. { Start file. { } exports imports GetTimeStamp from GetTimeStamp; esident system without importing all the other Clock routines. Once { virtual memory is implemented, GetTimeStamp and Cl const ClockVersion = '1.5'; type TimeString = String; procedure SetTStamp( Stamp: TimeStamp ); procedure Setock should be merged { into a single module. { {-----------------------------------------------------------------------TString( String: TimeString); procedure GetTString( var String: TimeString ); procedure StampToString( Stamp: TimeStamp; var S------} { V1.4 1 Jun 81 Brad Myers. { Add comments. { } { V1.3 18 May 81 Brad Myers. { Change IO to IO_Others. {tring: TimeString ); procedure StringToStamp( String: TimeString; var Stamp: TimeStamp); Exception BadTime; {-------------- } { V1.2 2 Mar 81 John Strait. { Don't export IO. { } { V1.1 2 Mar 81 John Strait. { Add title, copyright, abstr Clock implements the Perq human-time clock. Times are represented { internally by a TimeStamp record which has num-------------------------------------- Abstract: Raised when a string passed does not represent a valid time ----------------eric fields for Year, { Month, Day, Hour, Minute, and Second. Times may also be expressed { by a string of the fo------------------------------------} private   l exceptions. The compiler enables { this handler in every main program. { 4) A Pascal routine to search the s18 May 81 V2.2 John Strait. { New exception for Long Integer overflow. { } { 12 May 81 V2.1 Brad A. Myers. { New IO imact. { Add version number. { Add change history retroactively. { } { V1.0 1 Feb 81 John Strait. { Start file. { } tack in when an exception is { raised. { { Design: { The file Except.Dfs is included into Perq.Micro as well  {/////////////////////////} Exports {\\\\\\\\\\\\\\\\\\\\\\\\} const GetTSVersion = '1.4'; type TimeStamp = packed re { as into this module. It defines routine numbers for the exceptions { generated by the microcode. Note that thecord { the fields in this record are ordered this way to optimize bits } Hour: 0..23; Day: 1..31; re must be agreement { between these constants and the routine numbers of the exception { definitions. No program Second: 0..59; Minute: 0..59; Month: 1..12; Year: 0..63; { year since 1980 } end;  checks these--if you add or remove { exception definitions you must be sure to update Except.Dfs { in the appropr TimeReference = record Lower: Integer; Upper: Integer iate way. { { The routine number of RaiseP is also defined in Except.Dfs { as 0. Since the microcode must know t end; procedure GetTStamp( var Stamp: TimeStamp ); var PastStamp: TimeStamp; Past: TimeReference; {///////////his, it is strongly { suggested that it not be modified. { { The routine number of InitExceptions is not needed b//////////////} Private {\\\\\\\\\\\\\\\\\\\\\\\\} y the compiler { or Perq.Micro, but it has been assigned routine number 1 so that { its number will not change when new exceptions are defined. This { means that new exceptions may be defined without requiring that the { operatmodule Except; {----------------------------------------------------------------------------- { { Except - Perq Pascal Excepting system be re-linked. { {-----------------------------------------------------------------------------} { 28 May 81 ion Routines. { J. P. Strait 10 Dec 80. { Copyright (C) Three Rivers Computer Corporation, 1980. { { Abstract: { MV2.5 Brad Myers. { Change name of STLate exception (so no conflict with Qcodes.dfs { } { 28 May 81 V2.4 John Strait. { odule Except provides the following things: { 1) Definitions of the microcode generated exceptions. { 2) A proceduTake out special test for InPmd (exception raised while in Scrounge). { This will be replaced by a handler of All exceptions inre to tell the microcode which segment number these { exceptions are defined in. { 3) The default handler of al Scrounge. { } { 23 May 81 V2.3 John Strait. { Allow StackOverflow while in Scrounge (just like SegmentFault). { } {   lt; { segment fault detected during I/O } exception MParity; { memory parity error } exception EStack; { E-stack wasn' ErrDump = 3; { user dump } ErrSegmentFault = 4; { segment fault } ErrStackOverflow = 5; {t empty at INCDDS } exception OvflLI; { Overflow in conversion to integer from Long Integer } private  stack overflow } ErrDivZero = 6; { division by zero } ErrMulOvfl = 7; { overflow in multiplication } ErrStrIndx = 8; { string index out of range } ErrStrLong = 9; { string to be assigned is too long } ErrInxCase = 10; { array index or case expression out of range } ErrSTLATE = 11; { paraports. { } { 5 May 81 V2.0 Brad A. Myers. { Added preliminary debugger. { } { 23 Mar 81 V1.2 J. P. Strait. { Add support for virtual memory. { } { 14 Mar 81 V1.1 J. P. Strait. { Add PMD and try to get it working. { } { 10 Dec 80 { Exception Definitions. {----------------------------------------------------------------------------- { { Except.Dfs V1.0 J. P. Strait. { Start module as part of a proposal. { } exports const ExceptVersion = '2.5'; procedure Rai- Exception number definitions. { J. P. Strait 10 Dec 80. { Copyright (c) Three Rivers Computer Corporation, 19seP( ES, ER, PStart, PEnd: Integer ); procedure InitExceptions; exception Abort( Message: String ); exception Dump( Message80. { { Abstract: { This file defines exception numbers used by the Perq Q-code { interpreter microcode, the deb: String ); exception XSegmentFault( S1,S2,S3,S4: Integer ); { segment fault } exception XStackOverflow; ugger, the exception handler, and { the post-mortem dumper. These must agree with the corresponding { routine num { stack overflow } exception DivZero; { division by zero } exception MulOvfl; { overflow in multiplication } exceptiobers in Except.Pas. { {-----------------------------------------------------------------------------} { 18 May 81 1.2 n StrIndx; { string index out of range } exception StrLong; { string to be assigned is too long } exception InxCase; { aJohn Strait { Add ErrOvflLI. { } { 14 Mar 81 1.1 John Strait { Add ErrEStk. { } { 10 Dec 80 1.0 John Strait { Starray index or case expression out of range } exception STLATETooDeep; { parameter in STLATE instruction is too large } exceptirt file. { } RNRaise = 0; { routine number of Raise } RNInitException = 1; { routine number ofon UndfQcd; { execution of an undefined Q-code } exception UndfInt; { undefined device interrupt detected } exception IOSF InitException } ErrFirst = 2; { first exception number } ErrAbort = 2; { user abort }   { RD Definitions. {----------------------------------------------------------------------------- { { RD.Dfs - Routine d{ EEB Definitions. {----------------------------------------------------------------------------- { { EEB.Dfs - Exceptiictionary definitions. { Horst Mauersberg, Brian Rosen, Miles Barel ca. 1 Jan 80. { J. P. Strait on enable block definitions. { J. P. Strait 10 Dec 80. { Copyright (c) Three Rivers Computer Corporation, 1980.  rewritten 21 Nov 80. { Copyright (c) Three Rivers Computer Corporation, 1980. { { Abstract: { This { { Abstract: { This file defines offsets within the Exception Enable Blocks { (EEB's) in the Perq memory stack. file defines offsets within routine dictionary entries. { {------------------------------------------------------------------ Only the routine number of the { handler is required (not a full variable routine descriptor) { because the hand-----------} { 6 Jun 80 1.1 Brad Myers { Corrected errors in comments: RDPS is the parameter size. { } { 21 Nov 80 ler is guaranteed to be nested immediately { inside of the routine which enabled it. The handler's segment { numb 1.0 John Strait { Start file. { } RDPS = 0; { Parameter Size - number of words of parameters } RDRPSmeter in STLATE instruction is too large } ErrUndfQcd = 12; { execution of an undefined Q-code } ErrUndfIner is the same as the enabler's segment number, the handler's { static link is the enabler's activation pointer, and the t = 13; { undefined device interrupt detected } ErrIOSFlt = 14; { segment fault detected during I/O }  { handler's global pointer is the same as the enabler's global { pointer. { {----------------------------------- ErrMParity = 15; { memory parity error } ErrEStk = 16; { E-stack not empty at INCDDS } Err------------------------------------------} { 10 Dec 80 1.0 J. P. Strait. { Start file. { } EEBES = 0; OvflLI = 17; { overflow during convert from long to integer } ErrLast = 17; { last exception number { exception segment number } EEBER = 1; { exception routine number } EEBHR = 2; { handler routine }  number } EEBNE = 3; { next exception pointer } EEBLength = 4; { size of an EEB }    = 7; { unused } ---------------} { 14 Mar 81 1.1 J. P. Strait. { Add ACBEP for exceptions. { } { 21 Nov 80 1.0 J. P. Strait. { Start file. { } ACBSL = 0; { static link } ACBLP = 1; { local pointer }  ACBDL = 2; { dynamic link } ACBGL = 3; { global link } ACBTL = 4; { ACB Definitions. {----------------------------------------------------------------------------- { { ACB.Dfs - Activat{ top link } ACBRS = 5; { return segment } ACBRA = 6; { return address } ion control block definitions. { J. P. Strait 21 Nov 80. { Copyright (c) Three Rivers Computer Corporation, 1980ACBRR = 7; { return routine number } ACBEP = 8; { exception pointer } ACBStackSize. { { Abstract: { This file defines offsets within the Activation Control Blocks { (ACB's) in the Perq memory st = 9; { E-stack size } ACBSaveStack = 10; { saved E-stack } ACBReserve = 26; { ACB size +ack. The general form of an ACB { is as follows. { { +0 Static link - address of the ACB of the surrounding pr maximum E-stack } ACBLength = 26; { largest ACB } ocedure. { +1 Local pointer - address of the current local variables. { +2 Dynamic link - address of the previous ACB on the stack. { +3 Global link - address of the previous routine's global data. { +4 Top link - address of the previous top-of-stack. { +5 Return segment - segment number of the previous procedure. { +6 Return ad = 1; { Result + Parameter Size - RDPS + words of result } RDLTS = 2; { Local + Temporary Size - total words dress - offset within the return segment. { +7 Return routine number - previous routine number. { +8 Exceptionof locals } RDEntry = 3; { Entry point address - byte offset from code base } RDExit = 4; { Exit point ad pointer - pointer to list of exception enable blocks. { +9 E-Stack size - number of save words of expression stack. {dress - byte offset from code base } RDLL = 5; { Lexical Level } RDFree6 = 6; { unused } RDFree7 +10..+n+9 E-stack image - previous expression stack. { {--------------------------------------------------------------  module ControlStore; {----------------------------------------------------------------------------- { { ControlStore - Load a TransMicro = { The format of a micro-instruction as needed by the WCS QCode. } packed recond call routines in the PERQ control-store. { J. P. Strait ca. July 80. { Copyright (C) Three Rivers Computer Corporation, 1rd case integer of 0: (Word1: integer; Word2: integer; Word3: integer); 1: (ALU2981. { { Abstract: { The ControlStore module exports types defining the format of PERQ { micro-instructions and proce3: 0..3; ALU0: 0..1; W: 0..1; ALU1: 0..1; A: 0..7; dures to load and call routines in the { control-store. { {------------------------------------------------------------------ Z: 0..255; SFF: 0..63; H: 0..1; B: 0..1; JmpCnd:0..255)-----------} { 3 Jun 81 V1.1 John Strait. { Add Virgil headers and comments. { } { ca. Jul 81 V1.0 John Strait.  end; MicroFile = file of MicroBinary; { A file of micro-instructions. } procedure Loa{ Started file. { } exports type MicroInstruction = { The format of a micro-instruction as produced by dControlStore( var F: MicroFile ); procedure LoadMicroInstruction( Adrs: integer; MI: MicroInstruction ); procedure JumpCont the micro-assembler. } packed record case integer of 0: (Word1: integer; Word2: interolStore( Adrs: integer ); private ger; Word3: integer); 1: (Jmp: 0..15; Cnd: 0..15; Z: 0..255; module RS232Baud; {---------------------------------------------------------------------- RS232Baud - set RS232 baud rate SF: 0..15; F: 0..3; ALU: 0..15; H: 0..1; W: 0..1;  with optional input enable. J. P. Strait 21 Aug 80. Copyright (c) Three Rivers CompB: 0..1; A: 0..7; Y: 0..255; X: 0..255); 2: (JmpCnd: 0..255; uter Corporation 1980. ----------------------------------------------------------------------} {--------------------------- Fill1: 0..255; SFF: 0..63; ALU0: 0..1; ALU1: 0..1; ALU23:------------------------------------------- Versions 13-May-81 Brad A. Myers V1.1 Changed to use exceptions and new IO 0..3) end; MicroBinary = { The format of a micro-instruction and its address as  21-Aug-80 John Strait V1.0 Created ----------------------------------------------------------------------} exporproduced by the micro-assembler. } record Adrs: integer; MI: MicroInstruction end; ts procedure SetBaud(Baud: String; Enable: Boolean); Exception BadBaudRate; {--------------------------------------------   secondary address} gpppc = #005; {parallel poll configure} gpppe = #140; {parallel poll enable} gpppd = gptcs, {Take Control Synchronously} gprpp, {Request Parall #160; {parallel poll disable} gpppu = #025; {parallel poll unconfigure} gpscg = #140; {secondary copmmand groupel Poll} gpsic, {Set Interface Clear} gpsre, {Set Remote E} gpsdc = #004; {selected device clear} gpspd = #061; {serial poll disable} gpspe = #060; {serial poll enable} gprqc, {Request Control} gprlc, {Release Control} -------------------------- Abstract: Raised if string is not a valid baud rate ----------------------------------------------nable} gptct = #011; {take control} gptag = #100; {tahk address group} gpuag = #020; {universal address ------------------------} private group} gpunl = #077; {unlisten} gpunt = #137; {untalk} type { these commands are the major state change contrmodule gpib; { Support routines for Perq GPIB devices writen by Brian Rosen Copyright(C) 1980, Three Rivers Col commands of the TMS9914 chip which forms the interface to the GPIB Consult the TI documentation on the TMomputer Corporation 15-Jun-81 V1.2 DAS Changed to compiler under POS D. 2-Jan-81 V1.1 BR fixed namS9914 for more information} {These definitions are order dependent} gpAuxiliaryCommands = (gpswrst, {es of Controller Command Codes and apAuxiliaryCommands to have "gp" prefix to avChip Reset} gpdacr, {Release DAC holdoff} gprhdf, {Release Roid name conflicts (especially get) } exports const GpibVersion = '1.2'; gpBufSize = 32; gpBufMax = 31; FD holdoff} gphdfa, {Holdoff all data} gphdfe, {Holdoff on E{gpBufSize - 1} { the following codes are the IEE488-1975 Controller Command Codes they are issued by the Controller-In-Chnd} gpnbaf, {Set NewByteAVailable false} gpfget, {Force Grouarge while asserting ATN } gpacg = #000; {addressed group command} gpdcl = #024; {device clear} gpget = p Execute Trigger} gprtl, {Return to Local} gpfeoi, {force #010; {group execute trigger} gpgtl = #001; {go to local} gplag = #040; {listen address group} gpllo = #End or Identify} gplon, {Listen Only} gpton, {Talk Only} 021; {local lockout} gpmla = #040; {my listen address} gpmta = #100; {my talk address} gpmsa = #140; {my gpgts, {GoTo Standby} gptca, {Take Control Asynchronously}   Data bytes (sent with proceedure gpPutByte) or Auxialiary Commands (sent with gpAuxCommand) The buffer is sent to the istener with ListenONly} procedure gpHeTalksIListen(gpAddr: gpDeviceAddress); { turn the BitPad (device addres #9914 when full, or when ghForceBuffer is called. If the buffer has data bytes when gpAuxilairyCommand is called, it w10) off } procedure gpTbltOn; { turn the BitPad back on again } procedure gpTbltOff; { Send a bufferill do a gpForceBuffer. Similarly, when gpPutByte is called, it will force the buffer if auxiliary commands are in gp of user data to the 9914 } procedure gpSend(var gpBuf: gppBuffer; gpCount: gpRange); {Get a buffer of data from tCommandBuffer } { Initialze GPIB package, called once only, turns off tablet } procedure gpInit; he 9914 (Not implemented yet) } procedure gpReceive(var gpBuf: gppBuffer; gpCount: gpRange); { Get a byte of data  { Send an auxiliary command to TMS9914 some commands require a parameter (gpOff/gpOn) } procedure gpAuxCommafrom the GPIB } function gpGetByte: gpByte; private nd(gpCmd: gpAuxiliaryCommands; gpParm:gpParmType); { Put a data byte or a Control byte out on the data bus  gpdai, {Disable All Interrupts} gppts, {Pass Through next S TMS9914 must be in Controller Actives State if the byte is a controller command byte. Must be in Talk Onlecondary} gpstdl, {Set T1 Delay} gpshdw); {Shadow Handshake} y if a data byte } procedure gpPutByte(gpData: integer); { Sends all bytes in buffer } procedure gpFlushBuffe gpParmType = (gpOff, gpOn, gpDontCare); {parameters for Aux Commands} gpByte = 0..255; {Data byte for gpib tr; { Set TMS9914 to be a Talker, set a device to be a listener This procedure takes control of the ransactions} gpRange = 0..gpBufSize; gpDeviceAddress = 0..31; {legal addresses for devices on GPIB} bus, unlistens and untalks all devices (including itself), and sets a listener with MyListenAddress  gpBuffer = packed array [gpRange] of gpByte; gppBuffer = ^gpBuffer; var gpCommandBuffer: gppBuffer; {place then sets TMS9914 to be the talker with TalkONly } procedure gpITalkHeListens(gpAddr: gpDeviceAddress); { Set Tto put commands} gpBufPtr: 0..gpBufSize; {pointer to gpCommandBuffer} gpHaveDataBytes, gpHaveAuxiliaryCMS9914 to be a Listener, set a device to be a talker This procedure takes control of the bus, unlistens and untalkommands: boolean;{true if buffer in use} { The package maintains a buffer (gpCommandBuffer) which holds either s all devices (including itself), and sets a talker with MyTalkAddress then sets TMS9914 to be the l   Module RandomNumbers contains two routines: InitRandom - initializes the random number generator.  Random - a function which returns a new random number each time it is referenced. Module CmdParse; {*************************************************************** { { CmdParse: Simple command parsing rou There is currently no way to seed the generator. Random is a feedback shift-register pseudo-random numtines. { { Written by Don Scelza April 30, 1980 { { Copyright (C) 1980 { Three Rivers Computer Corperation { 160 North ber generator. The algorithm used is one described in the article: 'Generalized Feedback Shift RegistCraig Street { Pittsburgh, Pa. 15213 { {*****************************************************************} { Date: 13-May-er Pseudorandom Number Generator' T. G. Lewis and W. H. Payne JACM Vol. 20, No. 3, Jul81 V2.0 { Who: John Strait { Change length of most strings to be 255 characters in length. The strings { in CmdArrays arey 1973, pp. 456-468. Random produces multidimensional pseudo-random numbers equally distributed in th left as 80 characters because 255 character strings take { a lot of space and we figure that no command names will be longere interval -32768..32767 and has a period of 2^98. --------------------------------------------------------------------- than { 80 characters. { } { Date: 19-Mar-81 { Who: Brad Myers { PERQ_String. { } { Date: 12-Feb-81 { Who: Diana---} {------------------------------------------------------------------------ Change log: 1 Jun 81 BAM  Forgy { Module is now compatable with new PString, System, and Compiler. { } { Date: 23-Sep-80 { Who: Miles Barel { Incr V1.2 Add comments. 17 Sep 80 JPS V1.1 Correct an error in the table. ----------------------------------------------emented MaxCmds to 30. Added the version number. { } { Date: 30-Apr-80 { Who: Don Scelza { Create CmdParse { } {*****--------------------------} {////////////////////////////} exports {\\\\\\\\\\\\\\\\\\\\\\\\\} procedure InitRandom; function Random: integer; {////////////////////////////} private {\\\\\\\\\\\\\\\\\\\\\\\\\} module RandomNumbers; {------------------------------------------------------------------------ RandomNumbers - Random number generator. J. P. Strait 15 Sep 80. Copyright (C) Three Rivers Computer Corporation, 1980.   ype CString = String[MaxCString]; CmdArray = Array[1..MaxCmds] Of String; Procedure CnvUpper(Var Str:CString); Function UniqueCmdIndex(Cmd:CString; Var CmdTable: CmdArray; NumCmds:Integer) :Integer; Procedure RemDelimiters(Var Src:CString; Delimiters:CString; Var BrkChar:CString); Procedure GetSymbol(Var Src,Symbol:CStrmodule Stream; {----------------------------------------------------------------------------- { { Stream - Perq Pasing; Delimiters:CString; Var BrkChar:CString); {********************} Private {********************} cal stream package. { John Strait ca. Jan 80. { Copyright (C) Three Rivers Computer Corporation, 1980. { { { Abstract: { This module implements the low-level Pascal I/O. It is not { intended for use directly by user programs, but rather the { compiler generates calls to these routines when a Reset, { Rewrite, Get, or Put is encountered. Higher-level character { I/O functions (Read and Write) are implemented by the two { modules ReaderModule UtilProgress; {----------------------------------- { { Progress Reporting Routines { Copyright (C) 1981 Three Rivers and Writer. { { In this module, the term "file buffer variable" refers to F^ for { a file variable F. { {----- Computer Corporation { { Abstract: { Routines to show progress of the compiler { {------------------------------------}------------------------------------------------------------------------} { Modification history V1.12 BA { 19-May-81 1.9 Brad Myers { New IO module name. { } { 9-Mar-81 1.8 Don Scelza { Changed module name and added coM 6 Jul 81 Check for IOECBF as well as IOEIOB in RS: output V1.11 BAM 1 Jul 81 Changed IO Screen output device namede to { allow the user to specify the number of scan lines. { } { 20-Feb-81 1.7 Brad A. Myers { New cursor { } { 2-Ja to ScreenOut V1.10 JPS 24 Jun 81 1) Remove reverse video control character code. 2) Fixedn-81 1.6 Miles A. Barel { Initial Creation { } Exports Procedure LoadCurs; Procedure ShowProgress(NumLines: In bug in FullLn. 3) Made EofCh (^Z) echo at Console. V1.9 JPS 4 Jun 81 Add Virgil***************} Exports {********************} Const CmdPVersion = '2.0'; MaxCmds = 30; MaxCString = 255; Tteger); Procedure QuitProgress; Private     ^QPip FileName=TI: For each character:  the CompileRSX constant. } exports imports FileDefs from FileDefs; const StreamVersion = '1 a) Flush RS232 input buffer. b) Send RS232 character. .12'; IdentLength = 8; { significant characters in an identifier } type pStreamBuffer = ^StreamBuffer;  headers and comments. V1.8 JPS 22 May 81 Make StreamKeyBoardReset accept a Text parameter. V1. c) Wait for RS232 echo--in the case of sending a carriage return, wait for 7 BAM 19 May 81 StreamKeyBoardReset turn cursor off. V1.6 JPS 12 May 81 Use exceptions instead of StreamErr a line feed. Send ^Z at end of file. or. Fix bug when EofCh is typed at console. Use new control-C exceptio 2) Add RSX: as an input device, RSX:FileName generates ns. V1.5 BAM 19 Mar 81 PERQ_String V1.4 BAM 17 Mar 81 1) Change to use FSIsFSDev on open  ^QPip TI:=FileName ^S For each line of RS232 input:  2) Change to use new Screen ClearChar routine V1.3 JPS 16 Feb 81 1) Implement FullLn a) Send a ^Q. b) Read from RS232 until end of line.  predicate which tells you if there is a full line in the keyboard input  c) Send a ^S. End of file is indicated by a '>' after an  buffer. 2) Fix bug in reporting "file opened to $ is not a end of line, and the ^S is not sent after the end of file is received.  text file" error. 3) Import the new Loader module. 4) Move $R- to pri 3) In Reset and Rewrite allow filenames of the form :. Thisvate part. 5) Shrink the error routine. V1.2 DCF 11 Feb 81 Conforms to new PStrin allows dumb programs to unconditionally concatenate extensions g; compatable with new System and Compiler. onto filenames typed by the user (e.g. Console:.Map, RSX:.List). 4) V1.1 JPS 6 Nov 80 1) Add RSX: as an output device, RSX:FileName generates  Clean up control character processing some. 5) Make RSX: optional at compile time. See  ! lean; { character is in file window } FEoln : boolean; { end of line flag } Flength in blocks } LastBlockLength:integer; { last block length in bits } SizeInWords : integer; { eEof : boolean; { end of file } FNotReset : boolean; { false if a Reset has been lement size in words, 0 means packed file } SizeInBits : 0..16; { elem performed on this file } FNotOpen : boolean; { false if file is ent size in bits for packed files } ElsPerWord : 0..16; { elements peopen } FNotRewrite: boolean; { set false if a Rewrite has been r word for packed files } Element: { Thing } record case integer of {The File window} 1: (C: char); 2 performed on this file } FExternal : boolean; { not used - will be permanent/temp : (W: array[0..0] of integer) end end; ChArray = packed array[1..1] of char; {For read/write charac StreamBuffer = record case integer of { element size: } 0: (W: array[0..255] of integer); { 1 or more words file flag } FBusy : boolean; { IO is in progress } FKind , or > 8 bits } 1: (B1: packed array[0..0] of 0..1); { 1 bit } 2: (B2: packed array[0..0] of 0..3); { 2 bits : FileKind); 1: (skip1 : 0..3; ReadError : 0..7); 2: (skip2 : 0..15; Wr } 3: (B3: packed array[0..0] of 0..7); { 3 bits } 4: (B4: packed array[0..0] of 0..15); { 4 bits } 5:iteError: 0..3) end; EolCh, EofCh, EraseCh, NoiseCh: ControlChar; {self explanatory} OmitCh : se (B5: packed array[0..0] of 0..31); { 5 bits } 6: (B6: packed array[0..0] of 0..63); { 6 bits } 7: (B7: packedt of ControlChar; FileNum : integer; { POS file number } Index : integer; { current word array[0..0] of 0..127); { 7 bits } 8: (B8: packed array[0..0] of 0..255); { 8 bits } 9: (C: packed array[0..255 in buffer for un-packed files, current element for packed ] of char); { for character structured } end; ControlChar = 0..#37; { ordinal of an ASCII files } Length : integer; { length of buffer in words for un-  control character } FileKind = (BlockStructured, CharacterStructured);  packed files, in elements for packed files } BlockNumber : integer;  FileType = { file of Thing } packed record Flag: packed record case integer of 0: (CharReady : boo{ next logical block number } Buffer : pStreamBuffer;{ I/O buffer } LengthInBlocks: integer; { file ! " C( var F: Filetype ); procedure PutC( var F: FileType ); procedure PReadln( var F: Filetype ); procedure PWriteln( var F: ------------------------- { { Abstract: { Raised when an attempt is made to use a file which is not open. { {--------Filetype ); procedure InitStream; function StreamName( var F: FileType ): PathName; function FullLn( var F: Text ): Boolea---------------------------------------------------------------------} exception NotReset( FileName: PathName ); {-------n; procedure StreamKeyBoardReset( var F: Text ); exception ResetError( FileName: PathName ); {----------------------------------------------------------------------------------------------- { { Abstract: { Raised when an attempt is made t---------------------------------------------------- { { Abstract: { Raised when unable to reset a file--usually file no read a file which is open but { has not been reset. { { Parameters: { FileName - name of the file or device. ot found but { also could be ill-formatted name or bad device name. { { Parameters: { FileName - name of the fil{ {-----------------------------------------------------------------------------} exception NotRewrite( FileName: PathName or device. { {-----------------------------------------------------------------------------} exception RewriteError( Fe ); {----------------------------------------------------------------------------- { { Abstract: { Raised when an attileName: PathName ); {----------------------------------------------------------------------------- { { Abstract: { Raempt is made to write a file which is open but { has not been { rewritten. { { Parameters: { FileName - nised when unable to rewrite a file--usually file unknown device { or partition but also could be ill-formatted name or baame of the file or device. { {-----------------------------------------------------------------------------} exception Pter array} Identifier = string[IdentLength]; IdentTable = array[0..1] of Identifier; d device name. { { Parameters: { FileName - name of the file or device. { {------------------------------------------ var StreamSegment: integer; { Segment buffer for I/O buffers } procedure StreamInit( var F: FileType; -----------------------------------} exception NotTextFile( FileName: PathName ); {--------------------------------------WordSize, BitSize: integer; CharFile: boolean ); procedure StreamOpen( var F: FileType; var Name: Path--------------------------------------- { { Abstract: { Raised when an attempt is made to open a non-text file to a { Name; WordSize, BitSize: integer; CharFile: boolean; OpenWrite: boolean ); pro character-structured device. { { Parameters: { FileName - name of the device. { {------------------------------cedure StreamClose( var F: FileType ); procedure GetB( var F: Filetype ); procedure PutB( var F: Filetype ); procedure Get-----------------------------------------------} exception NotOpen; {----------------------------------------------------" # r device. { {-----------------------------------------------------------------------------} exception UnitIOError( FileN-------------------------------------------} exception NotBoolean( FileName: PathName ); {-------------------------------ame: PathName ); {----------------------------------------------------------------------------- { { Abstract: { Raised---------------------------------------------- { { Abstract: { Raised when a boolean is expected on a file, but somethi when IOCRead or IOCWrite returns an error status. { { Parameters: { FileName - name of the device. { {--------------ng { else is encountered. { { Parameters: { FileName - name of the file or device. { {---------------------------------------------------------------------------------------} exception TimeOutError( FileName: PathName ); {--------------------------------------------------------------} exception BadIdTable( FileName: PathName ); {----------------------------------------------------------------------------------------- { { Abstract: { Raised when a device times out. {-------------------------------------------------------- { { Abstract: { Raised by ReadIdentifier when the identifier t { Parameters: { FileName - name of the device. { {-------------------------------------------------------------------able is bad. { { Parameters: { FileName - name of the file or device. { {------------------------------------------------------} exception UndfDevice; {----------------------------------------------------------------------------- { { Ab---------------------------------} exception IdNotUnique( FileName: PathName; Id: Identifier ); {------------------------stract: { Raised when an attempt is made to reference a file which is open { to a character-structured device, but----------------------------------------------------- { { Abstract: { Raised when non-unique identifier is read. { {  the device number is bad. { In the current system (lacking automatic initialization of file { variables), this maParameters: { FileName - name of the file or device. { Id - the identifier which was read. { {------------------y be caused by referencing a file which has { never been opened. { {--------------------------------------------------------------------------------------------------------------} exception IdNotDefined( FileName: PathName; Id: Identifier );--------------------------} exception NotIdentifier( FileName: PathName ); {--------------------------------------------- {----------------------------------------------------------------------------- { { Abstract: { Raised when an undefinastEof( FileName: PathName ); {----------------------------------------------------------------------------- { { Abstract: {-------------------------------- { { Abstract: { Raised when an identifier is expected on a file, but something {  Raised when an attempt is made to read past the end of the file. { { Parameters: { FileName - name of the file o else is encountered. { { Parameters: { FileName - name of the file or device. { {----------------------------------# $ tring; Field: integer ); procedure WriteX( var F: FileType; X, Field, B: integer ); private ed identifier is read. { { Parameters: { FileName - name of the file or device. { Id - the identifier which was read. { {-----------------------------------------------------------------------------} exception NotNumber( FileName: Pmodule Writer; {----------------------------------------------------------------------------- { { Writer - Stream pathName ); {----------------------------------------------------------------------------- { { Abstract: { Raised when ackage output conversion routines. { J. P. Strait ca. 1 Jan 81. { Copyright (C) Three Rivers Computer Corporatioa number is expected on a file, but something { else is encountered. { { Parameters: { FileName - name of the fin, 1981. { { Abstract: { Writer is the character output module of the Stream package. It { is called by code gele or device. { {-----------------------------------------------------------------------------} exception LargeNumber( Fnerated by the Pascal compiler in response to { a Write or Writeln. It is one level above Module Stream and uses { ileName: PathName ); {----------------------------------------------------------------------------- { { Abstract: { Ra Stream's output routines. { {-----------------------------------------------------------------------------} { 4 Jun 81ised when a number is read from a file, but it is too large. { { Parameters: { FileName - name of the file or device.  V2.2 John Strait. { Add Virgil headers and comments. { } { 19 May 81 V2.1 Brad Myers. { Turn off Range checking so pr{ {-----------------------------------------------------------------------------} exception BadBase( FileName: PathName; inting of chArrays will work. { } { 12 May 81 V2.0 John Strait. { Use exceptions rather than StreamError. { } exportBase: Integer ); {----------------------------------------------------------------------------- { { Abstract: { Raiseds imports Stream from Stream; procedure WriteBoolean( var F: FileType; X: Boolean; Field: integer ); procedure Wri when an attempt is made to read a number with a numeric base { that is not in the range 2..36. { { Parameters: { teCh( Var F: FileType; X: char; Field: integer ); procedure WriteChArray( var F: FileType; var X: ChArray; Max, Field: integer FileName - name of the file or device. { Base - numeric base (which is not in the range 2..36). { {------------------ ); procedure WriteIdentifier( var F: FileType; X: integer; var IT: IdentTable; L, Field: intege-----------------------------------------------------------} private r ); procedure WriteInteger( var F: FileType; X: integer; Field: integer ); procedure WriteString( var F: FileType; var X: S$ %  FileType; var X: integer; var IT: IdentTable; L: integer ); procedure ReadInteger( var F: FileTyp Get PROFILE.PAS PROFILE.PAS Get USERPA.PAS USERPASS.PAS Get LOADER.PAS LOADER.PAS Get CODE.PASe; var X: integer ); procedure ReadString( var F: FileType; var X: String; Max, Len: integer ); procedure ReadX( var F: File CODE.PAS Get RUNREA.PAS RUNREAD.PAS Get RUNWRI.PAS RUNWRITE.PAS Get DYNAMI.PAS DYNType; var X: integer; B: integer ); private AMIC.PAS Get PERQST.PAS PERQ_STRING.PAS Get MEMORY.PAS MEMORY.PAS Get VIRTUA.PAS VIRTUAL.PAS G{ VRD Definitions. {----------------------------------------------------------------------------- { { VRD.Dfs - Variablet MOVEME.PAS MOVEMEM.PAS Get SCROUN.PAS SCROUNGE.PAS Get CLOCK.PAS CLOCK.PAS Get GETTIM.PAS module Reader; {----------------------------------------------------------------------------- { { Reader - Stream pe routine descriptor definitions. { J. P. Strait 10 Dec 80. { Copyright (c) Three Rivers Computer Corporation, 1ackage input conversion routines. { J. P. Strait ca. 1 Jan 81. { Copyright (C) Three Rivers Computer Corporation980. { { Abstract: { This file defines offsets within Variable Routine Descriptors (VRD's). { {----------------------, 1981. { { Abstract: { Reader is the character input module of the Stream package. It is { called by code gen-------------------------------------------------------} { 10 Dec 80 1.0 J. P. Strait. { Start file. { } VRDerated by the Pascal compiler in response to Read { or Readln. It is one level above Module Stream and uses Stream's { SN = 0; { segment number } VRDGP = 1; { global pointer } VRDRN = 2; { routine number } VR lower-level input routines. { {-----------------------------------------------------------------------------} { 4 DSL = 3; { static link } VRDSize = 4; { size of a VRD } Jun 81 V2.1 John Strait. { Add Virgil headers and comments. { } { 12 May 81 V2.0 John Strait. { 1. Use exceptions rather than StreamError. { 2. Fix bug in read routines caused by not clearing CharReady. { } exports imports Stream from Stream; procedure ReadBoolean( var F: FileType; var X: boolean ); procedure ReadCh( var F: FileType; var X: char; FieSides 2 Density SINGLE Fast ! OS.SOURCE - OPERATING SYSTEM SOURCES ! Created 19 Jul 81 17:23:34 Get SYSTEM.PAS ld: integer ); procedure ReadChArray( var F: FileType; var X: ChArray; Max, Len: integer ); procedure ReadIdentifier( var F: SYSTEM.PAS Get SYSDEF.PAS SYSTEMDEFS.PAS Get LIGHTS.PAS LIGHTS.PAS Get ARITH.PAS ARITH.PAS% & module Memory; {----------------------------------------------------------------------------- { { Memory - Perq memory rm. { Delete DEBUG stuff. { Delete OutputF. { Add "MM" to the beginning of names which are exported but are not needed by { manager. { J. P. Strait 1 Jan 80. { Copyright (C) Three Rivers Computer Corporation, 1980. { { Abstract: programs which import the memory manager. { Remove Concat call from MemoryError. { Remove import of Perq.String. { } { 24  { Memory is the Perq memory manager. It supervises the segment tables { and exports procedures for manipulating mFeb 81 V1.7 JPS { 1) Allow the ScreenSeg to change sizes. To allow this, the memory { manager must prevent system segmenemory segments. { Perq physical memory is segmented into separately addressable items { (called segments) which mats (those with RefCount > 1) from { being moved into the area of memory which might be used for the { screen. This is ay contain either code or data. { { Design: { See the Q-Code reference manual. { {------------------------------------ hack which guarantees that the system can expand { the screen to its original size after returning from a user program. { -----------------------------------------} { 26 Jul 81 V2.7 JPS { Fix bug in order of operations in CreateSegment. { } This change was originally made by RFR, but had to be converted for { memory manager version 1.5 and greater. { 2) Remov { 21 Jul 81 V2.6 JPS { Don't use MaxSegment anywhere. { } { 29 Jun 81 V2.5 JPS { Destroy swapping files when swappe PrintTable and PrintFreeList. { } { 23 Feb 81 V1.6 RFR { Added DK and CH to system boot record (they will be filled by  GETTIMESTAMP.PAS Get EXCEPT.PAS EXCEPT.PAS Get EXCEPT.DFS EXCEPT.DFS Get EEB.DFS EEing is disabled. { } { 4 Jun 81 V2.4 JPS { Add Virgil headers for exceptions. { } { 26 May 81 V2.3 JPS { Add CurreB.DFS Get RD.DFS RD.DFS Get ACB.DFS ACB.DFS Get CONTRO.PAS CONTROLSTORE.PAS Get RS232B.ntSegment function. { Prevent Memory from being swapped during FindHole calls. { } { 21 may 81 V2.2 JPS { Initialize BooPAS RS232BAUD.PAS Get GPIB.PAS GPIB.PAS Get RANDOM.PAS RANDOMNUMBERS.PAS Get CMDPAR.PAS tSegId in EnableSwapping. { } { 14 May 81 V2.1 GGR { Add support for 3 MBaud EtherNet. { } { 12 May 81 V2.0 JPS {  CMDPARSE.PAS Get UTILPR.PAS UTILPROGRESS.PAS Get STREAM.PAS STREAM.PAS Get WRITER.PAS WRIT1) Split Memory into two modules: Memory (user callable routines, swappable) { and Virtual (system callable routines, unswapER.PAS Get READER.PAS READER.PAS Get VRD.DFS VRD.DFS pable). { 2) Move FileIdToSegId and SegIdToFileId into Memory. { 3) Use exceptions and get rid of MemoryError. { } { 24 Mar 81 V1.9 JPS { Begin adding stuff for virtual memory. { } { 23 Mar 81 V1.8 JPS { Convert to standard documentation fo& '  inline. { } { 16 Feb 81 V1.3 DAS { Changed to use Perq_String from Perq.String { } { 11 Feb 81 DCF { Changed#377; MMMaxIntSize = MMMaxBlocks-1; MMMaxExtSize = MMMaxBlocks; type MMBit4 = 0..#17; MMBit8 =  calls to PString to conform to new PString. This module is { compatable with the new System and Compiler. { } { 13 Jan 810..#377; MMBit12 = 0..#7777; MMIntSize = 0..MMMaxIntSize; MMExtSize = 1..MMMaxExtSize; MMAddress = integ V1.2 JPS { 1) Allocate the IOSeg in memory manager initialization as a locked { segment at the high end of memory. Use er; MMPosition = (MMLowPos, MMHighPos); SegmentNumber = integer; SegmentKind = (CodeSegment, DataSegment);the last block in memory (the { Krnl no longer needs it). { 2) Move $R- to private part. { } { 10 Oct 80 V1.1 JPS {  SegmentMobility = (UnMovable, UnSwappable, LessSwappable, Swappable); MMFreeNode = record N: MMAddrAdd support for the diagnostic display (DDS). { } exports const MemoryVersion = '2.7'; imports SystemDefs from Syess; L: integer end; MMBlockArray = array[0..0] of array[0..127] of integer; pMMBlockArstemDefs; const SATSeg = 1; { SAT segment } SITSeg = 2; { SIT segement } FontSeg = ray = ^MMBlockArray; MMArray = record case Integer of 1: (m: array[0..0] of MMFreeNode); 3; { font segment } ScreenSeg = 4; { screen segment } CursorSeg = 5; { cursor segm 2: (w: array[0..0] of Integer) end; pMMArray = ^MMArray; MMPointer = record case integer of ent } IOSeg = 6; { IO segment } SysNameSeg = 7; { system segment names } Mem 1: (P: ^integer); 2: (B: pMMBlockArray); 3: (M: pMMArray); 4: (Offset: MMAddress; Segmen:oryInBlocks = #1000; { amount of memory on this machine } MaxSegment = #137; { should be 2**16 - 1 } SetS SegmentNumber) end; SATentry = packed record { Segment Address Table } NotResident : boolean; tkBase = #60; SetStkLimit = #120; {$ifc Ether3MBaud then} IOSegSize = 6; { number of blocks in the IO{ 001 } Moving : boolean; { 002 } RecentlyUsed: boolean; { 004 } Sharable : bthe boot { microcode with the disk number and boot character used in booting). { } { 18 Feb 81 V1.5 JPS { Define fields Seg } {$elsec} {$ifc Ether10MBaud then} IOSegSize = UnImplemented; { number of blocks in the IOSeg } {$elsec} in the SIT to remember names of boot loaded segments. { Remove most of InitMemory since it is done now by MakeBoot. Make IOSegIOSegSize = 3; { number of blocks in the IOSeg } {$endc} {$endc} SysSegLength = 8; { length of  { a constant. { } { 17 Feb 81 V1.4 DAS { Removed the include file SegNumbers. Placed the segment number { definitionsname of a boot-loaded segment } MMMaxBlocks = #400; { maximum number of blocks in a segment } MMMaxCount = ' ( oolean; { 010 } Kind : SegmentKind; { 020 } Full : boolean; { 040 } Tentry; pSAT = ^SATarray; pSIT = ^SITarray; MMEdge = record H: SegmentNumber; { Head }  InUse : boolean; { 100 } Lost : boolean; { *** } { 200 } BaseLower : MMBit8;  T: SegmentNumber { Tail } end; SysSegName = packed array[1..SysSegLength] of Char;  BaseUpper : MMBit4; Size : MMBit12 end; SITentry = packed record case integer of { Segment Inf pSysNames = ^SysNameArray; SysNameArray = array[0..0] of SysSegName; procedure InitMemoormation Table } { real SIT entry } 1: (NextSeg : SegmentNumber; Increment : MMIntSize; ry; procedure DataSeg( var S: SegmentNumber ); procedure CodeOrDataSeg( var S: SegmentNumber ); procedure ChangeSize( S: SMaximum : MMIntSize; Freelist : MMAddress; RefCount : 0..MMMaxCount; IOCount : 0..MMMegmentNumber; Fsize: MMExtSize ); procedure CreateSegment( var S: SegmentNumber; Fsize, Fincrement,axCount; Mobility : SegmentMobility; BootLoaded : Boolean; case Integer of 1: (Bo Fmaximum: MMExtSize ); procedure IncRefCount( S: SegmentNumber ); procedure SetMobility( S: SegmentNumber; M: SegmentMobiliotLowerAddress: Integer; BootUpperAddress: Integer; BootLogBlock: Integer); 2: (Diskty ); procedure DecRefCount( S: SegmentNumber ); procedure SetIncrement( S: SegmentNumber; V: MMExtSize ); procedure SetMaLowerAddress: Integer; DiskUpperAddress: Integer; DiskId: Integer) ); { boot tiximum( S: SegmentNumber; V: MMExtSize ); procedure SetSharable( S: SegmentNumber; V: boolean ); procedure SetKind( S: Segmenme information } 2: (BootBlock: record CS: SegmentNumber; { initial code segment } SS: SegmentNumber; V: SegmentKind ); procedure MarkMemory; procedure CleanUpMemory; procedure FindCodeSegment( var S: SegmentNumber;tNumber; { initial stack segment } XX: Integer; { unused } VN: Integer; { system FId: Integer ); procedure EnableSwapping( Where: Integer ); procedure DisableSwapping; function CurrentSegment: SegmentN version number } FF: SegmentNumber; { first free segment number } FC: SegmentNumber; { first syumber; exception UnusedSegment( S: SegmentNumber ); {---------------------------------------------------------------------stem code segment } DK: integer; { disk system was booted from } CH: integer { char-------- { { Abstract: { UnusedSegment is raised when the memory manager encounters a segment { number which ref used in booting } end) end; SATarray = array[0..0] of SATentry; SITarray = array[0..0] of SIerences a segment which is not in use. This may mean { that a bad segment number was passed to some memory manager routi( )  ); {----------------------------------------------------------------------------- { { Abstract: { BadIncrement is rair has a non-zero IO count. { { Parameters: { S - The number of the segment which cannot be moved. { {----------------sed when a bad Increment value is passed to some { memory manager routine. This usually means that the increment passed -------------------------------------------------------------} exception PartNotMounted; {------------------------------- { to CreateSegment is greater than 256 or less than one. { { Parameters: { Fincrement - The bad Increment value.---------------------------------------------- { { Abstract: { PartNotMounted is raised when { 1) the mene { or that a bad address was de-referenced. { { Parameters: { S - Segment number of the unused segment. { {- { {-----------------------------------------------------------------------------} exception BadMaximum( S: SegmentNumbe----------------------------------------------------------------------------} exception NotDataSegment( S: SegmentNumber )r; Fmaximum: Integer ); {----------------------------------------------------------------------------- { { Abstract: { ; {----------------------------------------------------------------------------- { { Abstract: { NotDataSegment is rai BadMaximum is raised when a bad Maximum value is passed to some memory { manager routine. This usually means that the msed when the number of a code segment is passed { to some memory manager routine that requires the number of a data { aximum passed to { CreateSegment is greater than 256 or less than one. { { Parameters: { Fmaximum - The bad Maxi segment. { { Parameters: { S - Segment number of the code segment. { {-------------------------------------------mum value. { {-----------------------------------------------------------------------------} exception FullMemory; {-------------------------------------} exception BadSize( S: SegmentNumber; Fsize: Integer ); {------------------------------------------------------------------------------------------------------- { { Abstract: { FullMemory is raised when th------------------------------------------------ { { Abstract: { BadSize is raised when a bad Size value is passed to sere is not enough physical memory to { satisfy some memory manager request. This is raised only after { swapping ome memory { manager routine. This usually means that the size passed to { CreateSegment or ChangeSize is greatersegments out and compacting memory. { {-----------------------------------------------------------------------------} ex than the maximum size or { less than one. { { Parameters: { Fsize - The bad Size value. { {------------------ception CantMoveSegment( S: SegmentNumber ); {----------------------------------------------------------------------------- { -----------------------------------------------------------} exception BadIncrement( S: SegmentNumber; Fincrement: Integer { Abstract: { CantMoveSegment is raised when the memory manager attempts to move { a segment which is UnMovable o) * --------------------------} exception EdgeFailure; {----------------------------------------------------------------------- { { Abstract: { NoFreeSegments is raised when the memory manager discovers that all { of the segment numbers -------- { { Abstract: { EdgeFailure is raised by MakeEdge when it discovers that the SIT { entries are not linkare in use and it needs another one. This { is equivalent to "Segment table full". { {--------------------------------ed together into a circular list. This is an { error which should never happen in a debugged system. It usually { ---------------------------------------------} exception SwapError; {---------------------------------------------------- means that there is a bug in the memory manager or that the segment { tables have been clobbered. { {----------------------------------------- { { Abstract: { SwapError is raised if the one of the memory managers swapping { routi-------------------------------------------------------------} exception NilPointer; {-----------------------------------nes is called when swapping is disabled. This is an error which { should never happen in a debugged system. It usually ------------------------------------------ { { Abstract: { NilPointer is raised when a Nil pointer is used or passed tomeans that { there is a bug in the memory manager. { {-----------------------------------------------------------------mory manager attempts to swap a data segment out for { the first time { and 2) the partition which  Dispose. { {-----------------------------------------------------------------------------} exception BadPointer; {----is to be used for swapping is no longer { mounted. { {------------------------------------------------------------------------------------------------------------------------------- { { Abstract: { BadPointer is raised when a b-----------------------} exception SwapInFailure( S: SegmentNumber ); {--------------------------------------------------ad pointer is passed to Dispose. { { Parameters: { {--------------------------------------------------------------------------------------------------- { { Abstract: { SwapInFailure is raised when the swap file cannot be found for a { s-----} exception FullSegment; {----------------------------------------------------------------------------- { { Abstraegment which is marked as swapped out. This is an error which { should never happen in a debugged system. It usually mect: { FullSegment is raised by New when it discovers that there is not { enough room to allocate and the segment cans that { there is a bug in the memory manager or that the segment tables { have been clobbered. { { Parametersannot be enlarged (its { size has reached its maximum). { {------------------------------------------------------------: { S - The number of the segment which could not be swapped in. { {--------------------------------------------------------------------} exception NoFreeSegments; {---------------------------------------------------------------------------* + ------------} var SAT: pSAT; SIT: pSIT; MMFirst, MMFree, MMLast, MMHeap: SegmentNumber; MMHole: MMEdge; MMState: (MMScan1, MMScan2, MMScan3, MMScan4, MMScan5, MMScan6, MMScan7, MMScan8, MMScan9, MMScan10,  MMScan11, MMNotFound, MMFound); StackSegment: SegmentNumber; FirstSystemSeg: SegmentNumber;  BootFileId: Integer; SwappingAllowed: Boolean; SwapId: Integer; private + , , - - . . / / 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 : : ; ; < < = = > > ? ? @ @ A A B B C C D D E E F F G G H H I I J J K K L L