IMD 1.17: 14/03/2012 8:35:47 IO: B3466A 3.5" DS      €IO  M“1ETUT______éK “ 7€œ:UCSD_DAMT_éKŠE“ A€DžHPHILT____éKî-“ D€,jSWAP8T____éK“ E€îSEGMENTERTéK2“ H€1ÁALLOCATET_éKO“ P€/EDRIVERT__éKS%“ R€$CLIFDAMT___éKx”“ X€“–MOUSET____éK “  €:MAKE_IOT__éK$“  €ŢSYSBOOTT__éK+“  €HEAPTT____éKA “  €ŕRANDOMT___éKa “  € LOCKMODT__éKl “  €¸UNITIOT___éKu “  € –IOLIBT____éKŒ“  '€‹cEXPORTT___éK “  1€‡KERNELT___éK-Á“  @€ŔŇCOMASMT___éK  H€”áCOMDCLT___éKƒ “  S€žREADMET___Ł“ B€śREADMET___éKĽ“ €í ˙˙ (* (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado *) $COPYRIGHT 'COPYRIGHT (C) 1985 BY HEWLETT-PACKARD COMPANY'$ $SYSPROG$ $DEBUG OFF$ $RANGE OFF$ $ALLOW_PACKED ON$ { JWS 4/10/85 } PROGRAM ETU(KEYBOARD,INPUT,OUTPUT); $SEARCH 'EDRIVER'$ IMPORT SYSGLOBALS,MISC,FS,CI,EDRIVER,ASM,SYSDEVS; VAR KEYBOARD : TEXT; (****************************************************************************) PROCEDURE COMMANDLEVEL; CONST SH_EXC = CHR(27); K16 = 16384; MINSC = 8;      ; LOCKDOWN; END; END; { FIXLOCK } (****************************************************************************) PROCEDURE PRINTIOERRMSG; VAR MSG : STRING[80]; BEGIN IF IORESULT<>ORD(INOERROR) THEN BEGIN GETIOERRMSG(MSG,IORESULT); WRITE ELSE TI := TI * 10 + (ORD(INSTRING[I]) - ORD('0')); INT := TI; END; RECOVER IF ESCAPECODE=-4 THEN BADIO(IBADVALUE) ELSE ESCAPE(ESCAPECODE); END; { READNUMBER } (***********************************************LN('Error: ',MSG,CTEOL); IF STREAMING THEN ESCAPE(-1); END; END; { PRINTIOERRMSG } (****************************************************************************) PROCEDURE SHOWPROMPT(P : PROMPTTYPE); BEGIN WRITE(HOMECHAR,P,CTEOL); END; (*************************************) FUNCTION UNITNUMBER(VAR FVID : VID):BOOLEAN; LABEL 1; VAR SL,I : INTEGER; BEGIN UNITNUMBER := FALSE; SL := STRLEN(FVID); IF SL<2 THEN GOTO 1; IF FVID[1]<>'#' THEN GOTO 1; FOR I:=2 TO SL DO IF (FVID[I]<'0') OR (FVI MAXSC = 31; TYPE PROMPTTYPE = STRING80; BUFTYPE = PACKED ARRAY[0..MAXINT] OF CHAR; BIGPTR = ^BUFTYPE; PASSTYPE = (CHECK,BURN,VERIFY); TYPE EPROMPTR = ^EPROMREC; EPROMREC = RECORD NEXT : EPROMPTR; ********************************************************************) PROCEDURE GOODIO; BEGIN IF IORESULT<>ORD(INOERROR) THEN ESCAPE(0); END; (****************************************************************************) PROCEDURE BADIO(IOCODE : IORSLTWD) BASEADDR : INTEGER; EPSIZE : INTEGER; EPINC : INTEGER; PRESENT : ARRAY[0..7] OF BOOLEAN; ADDRESS : ARRAY[0..7] OF INTEGER; END; DIRSTATUS = (DNEEDED,DWAN; BEGIN IORESULT := ORD(IOCODE); ESCAPE(0); END; (****************************************************************************) PROCEDURE BADMESSAGE(P : PROMPTTYPE); BEGIN WRITELN(P,CTEOL); IF STREAMING THEN ESCAPE(-1) ELSE BADIO(INOERROR); END; { TED,DONTCARE); CONTROL = RECORD CFIB : FIB; PATH : INTEGER; DIROPEN : BOOLEAN; FILEOPEN : BOOLEAN; USEUNIT : BOOLEAN; MOUNTED : BOOLBADMESSAGE } (****************************************************************************) PROCEDURE BADCOMMAND(C:CHAR); BEGIN WRITELN('BAD COMMAND ''',C,'''',CTEOL); IF STREAMING THEN ESCAPE(-1) ELSE BADIO(INOERROR); END; { BADCOMMAND } (*******EAN; CPVOL : VID; CVOL : VID; CFILE : FID; DSTATUS : DIRSTATUS; END; VAR SCODE : INTEGER; OP : CHAR; FASTBURN : BOOLEAN; TEMP : INTE*********************************************************************) PROCEDURE READCHECK; BEGIN IF IORESULT<>ORD(INOERROR) THEN BEGIN SAVEIO := IORESULT; WRITELN; IORESULT := SAVEIO; ESCAPE(0); END; END; { READCHECK } (*****************GER; EPINFO : EPINFOREC; ERROR : EPERROR; HEAPINUSE : BOOLEAN; ININFO : CONTROL; SAVEIO : INTEGER; SAVEESC : INTEGER; LHEAP : ANYPTR; EPROMLIST : EPROMPTR; EPROMDATA : EPROMPTR; ***********************************************************) PROCEDURE READNUMBER(VAR INT : INTEGER); VAR I : INTEGER; TI : INTEGER; INSTRING : STRING[20]; BEGIN READLN(INSTRING); GOODIO; INSTRING:=STRLTRIM(INSTRING); IF STRLEN(INLEFTTOXFER : INTEGER; OUTPOSITION : INTEGER; OUTSTARTA : INTEGER; PASS : INTEGER; (****************************************************************************) PROCEDURE FIXLOCK; BEGIN IF LOCKLEVEL<>0 THEN BEGIN LOCKLEVEL := 1STRING)>0 THEN TRY IF INSTRING[1]=SH_EXC THEN ESCAPE(0); ZAPSPACES(INSTRING); IF STRLEN(INSTRING)>0 THEN BEGIN TI := 0; FOR I:=1 TO STRLEN(INSTRING) DO IF (INSTRING[I]<'0') OR (INSTRING[I]>'9') THEN BADIO(IBADVALUE)      D[I]>'9') THEN GOTO 1; UNITNUMBER := TRUE; 1:END; { UNITNUMBER } (****************************************************************************) PROCEDURE UPCCHAR(VAR CH : CHAR); BEGIN IF ('a'<=CH) AND (CH<='z') THEN CH:=CHR(ORD(CH)-32); END; (**UNIT := FINDVOLUME(TEMPNAME,TRUE); IF CFIB.FUNIT>0 THEN BEGIN IF IORESULT=ORD(INODIRECTORY) THEN BEGIN IF DSTATUS<>DONTCARE THEN WRITELN('NO DIRECTORY ON ',CPVOL); SETSTRLEN(TEMPNAME,0); CASE DSTAT**************************************************************************) PROCEDURE PROMPTREAD(P:PROMPTTYPE; VAR ANSWER:CHAR; LIST:PROMPTTYPE; DEFAULT:CHAR); LABEL 1; VAR I : INTEGER; BEGIN IF (DEFAULT<>SH_EXC) AND STREAMING TUS OF DNEEDED: CFIB.FUNIT := 0; DWANTED: BEGIN PROMPTYORN('Use current media',ANSWER); IF ANSWER='N' THEN CFIB.FUNIT := 0 ELSE DSTATUS := DONTCAREHEN ANSWER:=DEFAULT ELSE BEGIN WRITE(P,CTEOL); REPEAT READ(KEYBOARD,ANSWER); READCHECK; UPCCHAR(ANSWER); IF ANSWER=SH_EXC THEN BEGIN WRITELN; BADIO(INOERROR); END; FOR I:=1 TO STRLEN(LIST) DO { IS CHARACTER IN THE LIST ? } ; END; OTHERWISE END; { CASE DSTATUS } END ELSE BEGIN IF IORESULT<>ORD(INOERROR) THEN BEGIN PRINTIOERRMSG; CFIB.FUNIT := 0; END ELSE  IF ANSWER=LIST[I] THEN GOTO 1; IF STREAMING THEN BADCOMMAND(ANSWER); UNTIL FALSE; 1:WRITELN(ANSWER); END; END; { PROMPTREAD } (****************************************************************************) PROCEDURE PROMPTYORN(P :  BEGIN { FOUND A DIRECTORY } IF CVOL='' THEN CVOL := TEMPNAME ELSE IF CVOL<>TEMPNAME THEN CFIB.FUNIT := 0; END; END; END; UNTIL CFIB.FUNIT>0; CFIB.FVID := CVOL; MOUNTED := TRUPROMPTTYPE; VAR ANSWER :CHAR); BEGIN PROMPTREAD(P+' ? (Y/N) ',ANSWER,'YN','Y'); END; { PROMPTYORN } (****************************************************************************) PROCEDURE MOUNTVOLUME(SD : PROMPTTYPE ;VAR FINFO : CONTROL); VAR ANSWE; END; END; { MOUNT VOLUME } (****************************************************************************) PROCEDURE SPACEWAIT; VAR ANSWER : CHAR; BEGIN PROMPTREAD(' continues, aborts ',ANSWER,' ',' '); END; { SPACEWAIER : CHAR; UNIT : INTEGER; TEMPNAME : VID; BEGIN WITH FINFO DO BEGIN IF STREAMING THEN BEGIN WRITELN('VOLUME ',CPVOL,' NOT ONLINE WHILE STREAMING',CTEOL); ESCAPE(-1); END; TEMPNAME := CPVOL; UNT } (****************************************************************************) PROCEDURE PROMPTFORCHAR(PL : PROMPTTYPE; VAR CH : CHAR); BEGIN FGOTOXY(OUTPUT,0,0); WRITE(PL,' ? ',CTEOL); READ(KEYBOARD,CH); READCHECK; UPCCHAR(CH); WRIIT := FINDVOLUME(TEMPNAME,FALSE); { CHECK FOR BAD UNIT # } IORESULT := ORD(INOERROR); REPEAT { CONSTRUCT THE PROMPT } WRITE('Please mount',SD); IF STRLEN(CVOL)>0 THEN WRITE(' volume ',CVOL); IF ((STRLEN(SD)>0) OR (STRLETELN(CH); FGOTOXY(OUTPUT,0,1); WRITELN(CTEOL); END; { PROMPTFORCHAR } $IOCHECK OFF$ (****************************************************************************) PROCEDURE SETUPFIBFORFILE(FILENAME : FID; VAR LFIB N(CVOL)>0)) AND USEUNIT THEN WRITE(' in'); IF USEUNIT THEN WRITE(' unit ',CPVOL); WRITELN(CTEOL); PROMPTREAD('''C'' continues, aborts ',ANSWER,'C','C'); IF USEUNIT THEN TEMPNAME := CPVOL ELSE TEMPNAME := CVOL; CFIB.F : FIB; VAR VNAME : VID); VAR LKIND : FILEKIND; SEGS : INTEGER; BEGIN SEGS := 0; IORESULT := ORD(INOERROR); WITH LFIB DO IF SCANTITLE(FILENAME,FVID,FTITLE,SEGS,LKIND) THEN BEGIN VNAME := F     (PROMPT,FINFO) ELSE MOUNTED := TRUE; WITH UNITABLE^[FUNIT] DO BEGIN LOCKUP; { LOCK KEYBOARD } FWINDOW := ADDR(DIRCATENTRY); CALL(DAM,CFIB,FUNIT,OPENDIRECTORY); DIROPEN :=  LAST READTOEOL } LEFTTOXFER := LEFTTOXFER - STRLEN(BUFREC^); IF LEFTTOXFER<0 THEN BEGIN { CLIP THIS LINE AND FAKE END OF FILE } SETSTRLEN(BUFREC^,STRLEN(BUFREC^)+LEFTTOXFER); LEFTTOXFER := 0; END; BUFPTR :(IORESULT=ORD(INOERROR)); IF DIROPEN THEN BEGIN PATH := PATHID; SOURCEFILE := FTITLE; CVOL := DIRCATENTRY.CNAME; END; LOCKDOWN; { UNLOCK KEYBOARD } IF NOT DIROPEN THEN ESCAPE(0); = ADDR(BUFPTR^,STRLEN(BUFREC^)); LEFTINBUF := LEFTINBUF - STRLEN(BUFREC^) - 2; IF STRLEN(BUFREC^) = 255 THEN BUFPTR := ADDR(BUFPTR^,-1) ELSE BEGIN IF STRLEN(BUFREC^)=0 THEN BEGIN { DISCARD THE LENGTH BYTE } VID; FUNIT := FINDVOLUME(FVID,TRUE); FKIND := LKIND; FEFT := EFTTABLE^[LKIND]; FOPTSTRING := NIL; FBUFFERED := TRUE; FPOS := SEGS * 512; FREPTCNT := 0; FANONYMOUS := FALSE; FMODIFIED := FAL{ OPENDIRECTORY FAILED } END RECOVER IF ESCAPECODE<>0 THEN ESCAPE(ESCAPECODE); END; { OPENDIR } (****************************************************************************) PROCEDURE INMOUNT(SWAP : BOOLEAN); BEGIN IF NOT ININFO.MOUNTED THSE; FBUFCHANGED:= FALSE; FSTARTADDRESS := 0; FLASTPOS := -1; PATHID := -1; FNOSRMTEMP := TRUE; FLOCKED := TRUE; FEOF := FALSE; FEOLN := FALSE; END ELSE BADIO(IBADTITLE); END; { EN WITH ININFO, CFIB DO BEGIN MOUNTVOLUME(' SOURCE',ININFO); UNITABLE^[FUNIT].UMEDIAVALID := TRUE; END; END; { INMOUNT } (****************************************************************************) PROCEDURE CLOSEINFILE; BEGIN WITH INSETUPFIBFORFILE } (****************************************************************************) PROCEDURE CLOSEDIR; BEGIN WITH ININFO, CFIB DO BEGIN IF DIROPEN THEN BEGIN LOCKUP; { LOCK KEYBOARD FOR THIS OPERATION } PATHID :INFO ,CFIB DO BEGIN IF FILEOPEN THEN BEGIN LOCKUP; FMODIFIED := FALSE; CALL(UNITABLE^[FUNIT].DAM,CFIB,FUNIT,CLOSEFILE); FILEOPEN := FALSE; LOCKDOWN; END; END; END; { CLOSEINFILE } (************************= PATH; { RESTORE PATHID } CALL(UNITABLE^[FUNIT].DAM,CFIB,FUNIT,CLOSEDIRECTORY); DIROPEN := FALSE; LOCKDOWN; END; END; END; { CLOSEDIR } (****************************************************************************) PROCEDURE ****************************************************) PROCEDURE CLOSEALL; BEGIN CLOSEINFILE; CLOSEDIR; END; (****************************************************************************) PROCEDURE ANYTOMEM( FFIB : FIBP; ANYVAR BOPENDIR(FILENAME : FID; VAR SOURCEFILE : FID; PROMPT : PROMPTTYPE; VAR FINFO : CONTROL; VAR DIRCATENTRY : CATENTRY); VAR UNIT : INTEGER; BEGIN { OPENDIR } IORESUFFER : BIGPTR; MAXBUF : INTEGER); VAR BUFREC : ^STRING255; BUFPTR : ^CHAR; LEFTINBUF : INTEGER; BEGIN { ANYTOMEM } BUFPTR := ADDR(BUFFER^); BUFPTR^ := CHR(0); { DATA COMMING } BUFREC := ADDR(BUFPTULT := ORD(INOERROR); WITH FINFO, CFIB DO TRY SETUPFIBFORFILE(FILENAME,CFIB,CPVOL); USEUNIT := UNITNUMBER(CPVOL); DSTATUS := DNEEDED; IF USEUNIT THEN CVOL := '' ELSE CVOL := CPVOL; IF (FUNIT=0) OR UNITNUMBER(FVID) THEN MOUNTVOLUMER^,1); SETSTRLEN(BUFREC^,0); { ZERO LENGTH RECORD } BUFPTR := ADDR(BUFREC^,1); LEFTINBUF := MAXBUF; WITH FFIB^, UNITABLE^[FUNIT] DO BEGIN CALL(AM,FFIB,READTOEOL,BUFREC^,255,FPOS); GOODIO; REPEAT GOODIO; { CHECK IORESULT FROM      BUFPTR := ADDR(BUFREC^,-1); LEFTINBUF := LEFTINBUF + {1} 2; {BUGFIX SFB 5/2/85--SAME AS IN FILER AND FILEPACK} END; { CHECK END OF LINE/FILE } CALL(AM,FFIB,READBYTES,BUFPTR^ (POINT<(ADDRESS[PART]+EPINC)) THEN BEGIN { IT ALL FITS } OKSIZE := SIZE; CHECKSPACE:=TRUE; PART := 8; { FORCE EXIT } END ELSE { FIGURE SPACE SO FAR } BEGIN OKS,1,FPOS); IF FEOLN THEN BEGIN { END OF LINE } BUFPTR^ := CHR(1); FEOLN := FALSE; LEFTINBUF := LEFTINBUF - 1; {BUGFIX SFB 5/2/85--SAME AS IN FILER AND FILEPACK} IF IORESUIZE := (ADDRESS[PART]+EPINC)-START; PART := PART + 1; END; END { IF PRESENT } ELSE PART := 8; { FORCE EXIT } END; { WHILE } END; { IF PRESENT } PART := 8; { FORCE LT = ORD(IEOF) THEN BUFPTR := ADDR(BUFPTR^,1); END; IF (IORESULT=ORD(IEOF)) OR (LEFTTOXFER=0) THEN BEGIN { END OF FILE } BUFPTR^ := CHR(2); IORESULT := ORD(INOERROR); FEOF := TRUE; END; EXIT } END { IF ADDRESS IN RANGE } ELSE PART := PART + 1; END; { WHILE } END; { WITH EPROMDATA } END; { CHECKSPACE } (****************************************************************************) PROCEDURE PASSFAILED(FAI GOODIO; { CHECK IORESULT FROM READBYTES } END; IF NOT ((LEFTINBUF < 259) OR FEOF) THEN BEGIN { SETUP FOR TO READ THE NEXT LINE } BUFPTR := ADDR(BUFPTR^,1); BUFPTR^ := CHR(0); { DATA RECORD } BUFRELCODE:PASSTYPE); VAR PART : INTEGER; UL : CHAR; I : INTEGER; BEGIN WITH EPROMDATA^ DO BEGIN FOR I := 0 TO 7 DO IF (OUTPOSITION>=ADDRESS[I]) AND (OUTPOSITION<(ADDRESS[I]+EPINC)) THEN PART := I; IF ODD(OUTPOSITION) THEC := ADDR(BUFPTR^,1); SETSTRLEN(BUFREC^,0); { ZERO LENGTH RECORD } BUFPTR := ADDR(BUFREC^,1); CALL(AM,FFIB,READTOEOL,BUFREC^,255,FPOS); END; UNTIL (LEFTINBUF < 259) OR FEOF; BUFPTR := ADDR(BUFPTR^,1); BUFPTR^ N UL := 'L' ELSE UL := 'U'; WRITE(FAILCODE,' FAIL'); WRITELN(' AT ABSOLUTE ADDRESS ',OUTPOSITION:1); WRITELN(' BYTE POSITION ',OUTPOSITION-OUTSTARTA:1,' FROM START LOCATION'); WRITELN(' EPROM SOCKET ',PART:1,UL, ' BYTE ',(OUTPOS:= CHR(3); { END BUFFER } END; END; { ANYTOMEM } (****************************************************************************) FUNCTION CHECKSPACE(START,SIZE:INTEGER; VAR OKSIZE:INTEGER):BOOLEAN; VAR POINT : INTEGER; PART : INTEGER; BEGIN { CITION-ADDRESS[PART]) DIV 2:1); END; IF STREAMING THEN ESCAPE(-1) ELSE BADIO(INOERROR); END; { PASSFAILED } (****************************************************************************) PROCEDURE PRINTBR; BEGIN FGOTOXY(OUTPUT,0,4); WRITE('Burn raHECK SPACE } OKSIZE := -1; CHECKSPACE := FALSE; WITH EPROMDATA^ DO BEGIN { FIND THE PART CONTAINING THE START ADDRESS } PART := 0; WHILE PART<8 DO BEGIN IF (START>=ADDRESS[PART]) AND (START<(ADDRESS[PART]+EPINC)) THEN te '); IF FASTBURN THEN WRITE('FAST') ELSE WRITE('SLOW'); WRITELN(CTEOL); END; (****************************************************************************) PROCEDURE BURNIT(ANYVAR BUFFER : WINDOW; SIZE : INTEGER); VAR BEGIN IF PRESENT[PART] THEN BEGIN { FOUND START NOW FIND END POINT } POINT := START + SIZE - 1; { END POINT } WHILE PART<8 DO BEGIN IF PRESENT[PART] THEN BEGIN IF OLDPOSIT : INTEGER; OLDX,OLDY: INTEGER; BEGIN IF PASS=1 THEN BEGIN { CHECK IF CAN BURN } ERROR:=EPROG(SCODE,ECHECK,BUFFER,SIZE,OUTPOSITION); IF ERROR<>ENOERROR THEN PASSFAILED(CHECK); END ELSE BEGIN { TRY TO BURN IT }      = -1; END; 3: BYTES := -1; { END BUFFER } OTHERWISE IORESULT := ORD(IBADREQUEST); END; GOODIO; UNTIL BYTES<0; END; END; { MEMTOEPROM } (***********************************************************************************************************************) PROCEDURE DOCONFIGURE(DOPROMPT:BOOLEAN); VAR DONE : BOOLEAN; OLDSCODE : INTEGER; OP : CHAR; I : INTEGER; {------------------------------------------------------------------*) FUNCTION CHECKCARD(SC:INTEGER):BOOLEAN; VAR ECODE : EPERROR; BEGIN ECODE:=EINIT(SC); CHECKCARD:=(ECODE=ENOERROR) OR (ECODE=ENOEPROM); END; { CHECKCARD } (****************************************************************************)-------} PROCEDURE PRINTSC; BEGIN FGOTOXY(OUTPUT,0,3); WRITELN('Active programmer card at select code ',SCODE:1,CTEOL); END; {-------------------------------------------------------------------------} PROCEDURE PRINTEPINFO OLDPOSIT := OUTPOSITION; { SAVE POSITION FOR RETRY } ERROR:=EPROG(SCODE,ECWRITE,BUFFER,SIZE,OUTPOSITION); IF ERROR<>ENOERROR THEN IF NOT FASTBURN THEN BEGIN IF ERROR=ECFAIL THEN PASSFAILED(VERIFY) E PROCEDURE CHECKSCODE; BEGIN IF NOT CHECKCARD(SCODE) THEN BADMESSAGE('*** NO PROGRAMMER CARD IN SYSTEM ***'); END; (****************************************************************************) PROCEDURE CHECKEPROM; VAR I : ILSE PASSFAILED(BURN); END ELSE BEGIN FASTBURN := FALSE; { SET BURN RATE TO SLOW } FGETXY(OUTPUT,OLDX,OLDY); { UPDATE THE DISPLAY } PRINTBR; FGOTOXY(OUTPUT,OLDX,OLDY); ERROR := EBRATE(SCODNTEGER; DONE : BOOLEAN; BEGIN CHECKSCODE; ERROR:=EGETINFO(SCODE,EPINFO); IF EPINFO.EPSTART=0 THEN BADMESSAGE('NO EPROM CARD ATTACHED TO PROGRAMMER CARD'); EPROMDATA := EPROMLIST; DONE := FALSE; REPEAT IF EPROME,FASTBURN); OUTPOSITION := OLDPOSIT;{ RESET POSITION AND RETRY } ERROR:=EPROG(SCODE,ECWRITE,BUFFER,SIZE,OUTPOSITION); IF ERROR<>ENOERROR THEN IF ERROR=ECFAIL THEN PASSFAILED(VERIFY) ELSE PASSFAILDATA=NIL THEN BEGIN NEW(EPROMDATA); WITH EPROMDATA^ , EPINFO DO BEGIN BASEADDR := EPSTART; EPSIZE := EPEND-EPSTART; EPINC := EPSIZE DIV 8; ADDRESS[0]:= BASEADDR; PRESENED(BURN); END; END; IORESULT:=ORD(INOERROR); { CLEAR I/O RESULT } END; { BURNIT } (****************************************************************************) PROCEDURE MEMTOEPROM(ANYVAR BUFFER : BIGPTR); VAR BYTES : INTEGER; BUFPTT[0]:= TRUE; FOR I:=1 TO 7 DO BEGIN ADDRESS[I]:= ADDRESS[I-1]+EPINC; PRESENT[I]:= TRUE; END; NEXT := EPROMLIST; EPROMLIST := EPROMDATA; DONE := TRUE; END; ENDR: ^CHAR; BEGIN BUFPTR := ADDR(BUFFER^); BEGIN BYTES := 0; REPEAT BUFPTR := ADDR(BUFPTR^,BYTES); BYTES := ORD(BUFPTR^); BUFPTR := ADDR(BUFPTR^,1); CASE BYTES OF 0: BEGIN { DATA BYTES } BYTES : ELSE BEGIN IF EPROMDATA^.BASEADDR=EPINFO.EPSTART THEN DONE := TRUE ELSE EPROMDATA := EPROMDATA^.NEXT; END; UNTIL DONE; END; { CHECKEPROM } (**************************************************************************= ORD(BUFPTR^); { RECORD LENGTH } BUFPTR:= ADDR(BUFPTR^,1); BURNIT(BUFPTR^,BYTES); END; 1: BEGIN { END RECORD } BYTES := 0; END; 2: BEGIN { END FILE } BYTES :**) PROCEDURE FINDCARD(SCODES:BOOLEAN); VAR SC : INTEGER; BEGIN FOR SC:=MINSC TO MAXSC DO IF CHECKCARD(SC) THEN BEGIN IF SCODES THEN WRITE(SC:3); SCODE := SC; END; END; { FINDCARD } (********************************     ; BEGIN FGOTOXY(OUTPUT,0,5); TRY CHECKEPROM; TEMP := EPINFO.EPEND-EPINFO.EPSTART; WRITELN('EPROM at address ',EPINFO.EPSTART:1,' for ', TEMP:1,' bytes',CTEOL); WRITELN('EPROM type XX',TEMP DE IF OP='E' THEN BEGIN IF EPINFO.EPSTART>0 THEN BEGIN I := -1; WRITE('SOCKET (PAIR) NUMBER ? ',CTEOL); READNUMBER(I); IF I>=0 THEN IF (I<0) OR (I>7) THEN BADMESSAGE('SOCKET NUMBER OUT OFIV 2048:1,CTEOL); RECOVER IF ESCAPECODE<>0 THEN ESCAPE(ESCAPECODE); END; {-------------------------------------------------------------------------} PROCEDURE PRINTSOCKETS; VAR I : INTEGER; BEGIN FGOTOXY(OUTPU RANGE') ELSE BEGIN EPROMDATA^.PRESENT[I] := NOT EPROMDATA^.PRESENT[I]; PRINTSOCKETS; END; END ELSE BEEP; END ELSE IF (OP<>'Q') THEN IF STREAMING THENT,0,7); WRITELN('Socket status (UL means EPROM pair present)'); WITH EPROMDATA^ DO FOR I:= 0 TO 3 DO BEGIN WRITE(I:1); IF PRESENT[I] THEN WRITE('UL ') ELSE WRITE(' empty'); WRITE(I+4:4); IF PRESENT BADCOMMAND(OP) ELSE BEEP; RECOVER BEGIN LOCKUP; SAVEIO := IORESULT; SAVEESC := ESCAPECODE; IORESULT := SAVEIO; IF (SAVEESC<>0) AND (SAVEESC<>-10) THEN IORESULT := ORD(INOERROR); [I+4] THEN WRITE('UL ') ELSE WRITE(' empty'); WRITELN; END; END; {-------------------------------------------------------------------------} BEGIN { DOCONFIGURE } FGOTOXY(OUTPUT,0,2); WRITE(CTEOS); CHECKSCODE; OLDSCO LOCKDOWN; PRINTIOERRMSG; FIXLOCK; IF SAVEESC<>0 THEN ESCAPE(SAVEESC) ELSE OP := ' '; END; UNTIL OP='Q'; END; { DOCONFIGURE } (****************************************************************************) PROCEDURE DOTRANDE:=SCODE; WRITE('Programmer card(s) at '); FINDCARD(TRUE); SCODE := OLDSCODE; PRINTSC; PRINTBR; PRINTEPINFO; IF EPINFO.EPSTART>0 THEN PRINTSOCKETS; IF DOPROMPT THEN REPEAT TRY PROMPTFORCHAR('CONFIGURE: SelectcSFER; TYPE HEADREC = PACKED ARRAY[0..17] OF BYTE; HEADP = RECORD CASE BOOLEAN OF TRUE : (BINT:INTEGER); FALSE: (BPTR:^HEADREC); END; VAR FILENAME1 : FID; SOURCEFILE : FID; ode Burnrate Emptysockets Qt',OP); FGOTOXY(OUTPUT,0,13); WRITE(CTEOS); IF OP=SH_EXC THEN OP:='Q'; IF OP='S' THEN BEGIN { NEW SELECT CODE } OLDSCODE := SCODE; WRITE('New select code (',SCODE:1,') ? '); READNUMBER FILEMOVED : BOOLEAN; DONE : BOOLEAN; FORMAT : BOOLEAN; I : INTEGER; J : INTEGER; EPART : INTEGER; INSTATE : INTEGER; OUTSTATE : INTEGER; BUF : BIGP(SCODE); IF (SCODEMAXSC) THEN BEGIN SCODE := OLDSCODE; BADMESSAGE('SELECT CODE OUT OF RANGE'); END; IF NOT CHECKCARD(SCODE) THEN BEGIN SCODE := OLDSCODE; BADMESSAGE('SELECT CODE NOT A PROGRAMMER CTR; POSITION : INTEGER; MOVESIZE : INTEGER; MSIZE : INTEGER; BUFSIZE : INTEGER; OUTSIZE : INTEGER; SAVEIO : INTEGER; SAVEESC : INTEGER; DUMWINDOW : WINDOWP; EDHEADER : ARD'); END; PRINTSC; PRINTBR; PRINTEPINFO; IF EPINFO.EPSTART>0 THEN PRINTSOCKETS ELSE WRITE(CTEOS); END ELSE IF OP='B' THEN BEGIN FASTBURN := NOT FASTBURN; PRINTBR; END ELSHEADREC; MSGLINE : STRING[255]; DIRCATENTRY : CATENTRY; BLANKCHK : HEADP; ANSWER : CHAR; BEGIN { DOTRANSFER } DOCONFIGURE(FALSE); FGOTOXY(OUTPUT,0,13); WRITELN('TRANSFER OPERATION',CTEOS); CHECKEPROM     ':'); END { VOLUME -> EPROM } ELSE BEGIN { FILE -> EPROM } OPENDIR(FILENAME1,SOURCEFILE,' SOURCE',ININFO,DIRCATENTRY); IF NOT DIROPEN THEN ESCAPE(0); IF STRLEN(SOURCEFILE)=0 THEN  END; UNTIL DONE OR (OUTSTARTA>EPEND); IF OUTSTARTA>EPEND THEN BEGIN WRITELN('*** NO BLANK BLOCK ON THIS EPROM CARD ***'); OUTSTARTA:=EPSTART; END; OUTSTARTA := (OUTSTARTA-EPSTAR BADMESSAGE('CAN''T TRANSFER A DIRECTORY'); FTITLE := SOURCEFILE; FINITB(CFIB,DUMWINDOW,-3); PATHID := PATH; LOCKUP; CALL(UNITABLE^[FUNIT].DAM,CFIB,FUNIT,OPENFILE); FILEOPEN := IORET) DIV K16; WRITE('Start at EPROM block offset (',OUTSTARTA:1,') ? '); READNUMBER(OUTSTARTA); OUTSTARTA:=OUTSTARTA*K16; STRWRITE(MSGLINE,1,I,'BLOCK OFFSET NOT IN RANGE 0..', (EPSIZE DIV K16)-1:1; WRITE('Source (',DKVID,':) ? '); READLN(FILENAME1); GOODIO; FILENAME1 := STRLTRIM(STRRTRIM(FILENAME1)); IF STRLEN(FILENAME1)=0 THEN FILENAME1:=DKVID+':'; ZAPSPACES(FILENAME1); IF STRLEN(FILENAME1)>0 THEN WITH EPROMDATA^ DSULT=ORD(INOERROR); LOCKDOWN; GOODIO; FORMAT := (FKIND=ASCIIFILE) OR (FKIND=TEXTFILE); OUTSIZE := FLEOF; FGOTOXY(OUTPUT,0,14); WRITELN('TRANSFERING FILE ',CVOL,':',SOURCEFILE,CTEOL); O BEGIN { HAVE A SOURCE NAME } WITH ININFO DO BEGIN DIROPEN := FALSE; FILEOPEN := FALSE; MOUNTED := FALSE; END; MARK(LHEAP); HEAPINUSE := TRUE; NEWWORDS(DUMWINDOW,1); { DUMMY WINDOW FOR FILE TRANSFER } TRY WITH END; { FILE -> EPROM } END; { WITH ININFO, CFIB -- OPEN THE SOURCE } { ALLOCATE BUFFER SPACE } BUFSIZE := (MEMAVAIL DIV 256) * 256 - 30 * 512; {SAME SOME FOR SLOP} IF BUFSIZE<512 THEN ESCAPE(-2); { NOT ENOU ININFO, CFIB DO BEGIN { OPEN THE SOURCE } SETUPFIBFORFILE(FILENAME1,CFIB,CPVOL); IF STRLEN(FTITLE)=0 THEN BEGIN { VOLUME -> EPROM } USEUNIT := UNITNUMBER(CPVOL); DSTATUS := DWANTED; GH ROOM } NEWWORDS(BUF,BUFSIZE DIV 2); { ALLOCATE BUFFER SPACE } { GET START ADDRESS ON EPROM } MSGLINE := ''; WITH EPINFO DO IF SOURCEFILE='' THEN BEGIN { VOLUME TRANSFER } { SET DEFA IF USEUNIT THEN CVOL := '' ELSE CVOL := CPVOL; MOUNTED := (FUNIT>0) AND NOT(UNITNUMBER(FVID)); IF MOUNTED THEN CVOL := FVID ELSE INMOUNT(TRUE); LOCKUP; { LOCK THE KEYBOARD THEN OPEN THE VOLUME } FBUFFERULT START BLOCK } TEMP := 0; OUTSTARTA := EPSTART ; DONE := FALSE; REPEAT IF PRESENT[TEMP] THEN BEGIN { SOCKET PRESENT, CHECK CONTENTS } BLANKCHK.BINT := OUTSTARTA; ED := FALSE; FKIND := UNTYPEDFILE; FEFT := EFTTABLE^[FKIND]; CALL(UNITABLE^[FUNIT].DAM,CFIB,FUNIT,OPENVOLUME); FILEOPEN := (IORESULT=ORD(INOERROR)); LOCKDOWN; { UNLOCK THE KEYBOARD } GOOD IF (BLANKCHK.BPTR^[0]=255) AND (BLANKCHK.BPTR^[1]=255) THEN DONE := TRUE ELSE BEGIN { INCREMENT TO NEXT BLOCK } OUTSTARTA := OUTSTARTA+K16; IF TEMP<7 THEN IO; { FINISH THE SETUPT } OUTSIZE := FPEOF; SOURCEFILE := ''; FTID := ''; FORMAT := FALSE; FGOTOXY(OUTPUT,0,14); WRITELN('TRANSFERRING VOLUME ',FVID, IF OUTSTARTA>=ADDRESS[TEMP+1] THEN TEMP := TEMP+1; END; END ELSE BEGIN { SKIP EMPTY SOCKET PAIR } IF TEMP<7 THEN TEMP := TEMP+1; OUTSTARTA := OUTSTARTA+EPINC;      ); END ELSE BEGIN { FILE TRANSFER } OUTSTARTA := 0; { DEFAULT VALUE } WRITE('Start at EPROM byte offset (',OUTSTARTA:1,') ? '); READNUMBER(OUTSTARTA); STRWRITE(MSGLINE,1,I,'BYTE OFFSTATE := 1; END; 2: BEGIN { READ THE FILE/VOLUME } WRITE('reading ....',CTEOL,CHR(13)); IF FORMAT THEN BEGIN { FORMATED TRANSFER } SET NOT IN RANGE 0..',EPSIZE-1:1); END; IF OUTSTARTA>(EPSIZE-1) THEN BADMESSAGE(MSGLINE); OUTSTARTA := OUTSTARTA + EPINFO.EPSTART; { CHECK TO SEE IF DATA WILL FIT IN AVAILABLE EPROM SPACE } J := OUTSIZE; { VOL  ANYTOMEM(ADDR(CFIB),BUF,BUFSIZE); DONE := TRUE; IF FEOF THEN LEFTTOXFER := 0; GOODIO; END ELSE BEGIN { UNFORMATED / FILE SIZE } IF SOURCEFILE='' THEN BEGIN J := J + 18; { ADD HEADER } J := J + (J DIV K16)*2; { ADD 16K HEADER GAPS } END; IF NOT CHECKSPACE(OUTSTARTA,J,I) THEN BEGIN IF I<=0 THEN TRANSFER } IF BUFSIZE>LEFTTOXFER THEN MOVESIZE := LEFTTOXFER ELSE MOVESIZE := BUFSIZE; CALL(UNITABLE^[FUNIT].TM,ADDR(CFIB),READBYTES,  BEGIN WRITELN('NO EPROM AT START ADDRESS'); BADIO(INOERROR); END; WRITELN('DATA EXCEEDS EPROM SPACE BY ',J-I:1,' BYTES',CTEOL); IF STREAMING THEN ESCAPE(-1); PROMPTREAD('Abort transfer or Truncate file (A/T) ? ',  BUF^,MOVESIZE,POSITION); GOODIO; LEFTTOXFER := LEFTTOXFER - MOVESIZE; DONE := TRUE; END; END; END; { CASE INSTATE ANSWER,'AT',SH_EXC); IF ANSWER='A' THEN ESCAPE(0); IF SOURCEFILE='' THEN BEGIN OUTSIZE := (I-18); OUTSIZE := OUTSIZE - (OUTSIZE DIV K16)*2; END ELSE OUTSIZE := I; END;  } UNTIL DONE; WRITE(CTEOL); DONE := FALSE; IF NOT FILEMOVED THEN REPEAT IF PASS=1 THEN WRITE('checking ...',CTEOL,CHR(13)) ELSE WRITE('writing INSTATE := 1; PASS := 1; BEGIN { TRY THE TRANSFER } FILEMOVED := FALSE; WITH ININFO, CFIB , EPROMDATA^ DO REPEAT { MOVE THE FILE } DONE := FALSE; REPEAT  ...',CTEOL,CHR(13)); CASE OUTSTATE OF 1: BEGIN { SET BURN RATE } ERROR:=EBRATE(SCODE,FASTBURN); IF SOURCEFILE='' THEN BEGIN { VOLUME CASE INSTATE OF 1: BEGIN { INITIALIZE SOURCE PARAMETERS } FGOTOXY(OUTPUT,0,16); WRITELN('now on pass ',PASS:1,CTEOS); OUTPOSITION := OUTSTARTA;  TRANSFER } { PUT EDISC VOLUME HEADER } FOR I := 0 TO 17 DO EDHEADER[I]:=0; EDHEADER[0]:=HEX('F0'); EDHEADER[1]:=HEX('FF'); EDHEADER[2]:=ORD( LEFTTOXFER := OUTSIZE; POSITION := 0; FEOF := FALSE; FEOLN := FALSE; FLASTPOS := -1; FPOS := 0; INSTATE := 2; OUT' '); EDHEADER[3]:=HEX('18'); EDHEADER[12]:=HEX('01'); EDHEADER[13]:=HEX('02'); BURNIT(EDHEADER,18); END; OUTSTATE := 2;       END; { CASE OUTSTATE } UNTIL DONE; WRITE(CTEOL); UNTIL FILEMOVED; WRITELN('TRANSFER COMPLETED'); IF FORMAT THEN I := OUTPOSITION-OUTSTARTA ELSE I := OUTSIZE;:= ADDRESS[I] ; ENDSCAN := BREC.BINT + EPINC; REPEAT IF BLANKS THEN BEGIN IF BREC.BPTR^[0]<>255 THEN BEGIN WRITELN(BREC.BINT-1-BASEADDR:1,' (',BREC.BINT-OLDSTART:1,')'); BLANKS:=FALSE; WRITELN(I:1,' data bytes programmed and verified'); END; RELEASE(LHEAP); HEAPINUSE := FALSE; CLOSEALL; RECOVER BEGIN LOCKUP; RELEASE(LHEAP); HEAPINUSE := FALSE; SAVEIO  END; END ELSE BEGIN IF BREC.BPTR^[0]=255 THEN BEGIN IF LINES>5 THEN BEGIN LINES := 0; SPACEWAIT; FGOTOXY(OUTPUT,X,Y); WRITE(CTEOS); END;  END; 2: BEGIN { WRITE DATA } IF FORMAT THEN MEMTOEPROM(BUF) ELSE BEGIN IF SOURCEFILE='' THEN BEGIN { TRANS := IORESULT; SAVEESC := ESCAPECODE; CLOSEALL; IORESULT := SAVEIO; LOCKDOWN; PRINTIOERRMSG; IF SAVEESC<>0 THEN ESCAPE(SAVEESC); END; END; { HAVE SOURCE NAME } END; { DOTRANSFER } (*******FERING A VOLUME } I := 0; REPEAT { WATCH FOR 16K BYTE BOUNDARIES } MSIZE:=(((OUTPOSITION+K16) DIV K16)*K16)-OUTPOSITION; IF M*********************************************************************) PROCEDURE PUTMENU(MSTRING:STRING80); BEGIN FGOTOXY(OUTPUT,0,2); WRITE(MSTRING,' ? ',CTEOL); END; (************************************************************************SIZE>MOVESIZE THEN MSIZE:=MOVESIZE; BURNIT(BUF^[I],MSIZE); I := I + MSIZE; MOVESIZE := MOVESIZE - MSIZE; IF ((OUTPOSITION MOD K16)=0) AND ****) PROCEDURE DOBLANKCHECK; TYPE TWOBYTES = PACKED ARRAY[0..1] OF BYTE; VAR OLDSTART : INTEGER; START : INTEGER; ENDSCAN : INTEGER; NBYTES : INTEGER; BLANKS : BOOLEAN; LINES : INTEGER; I  ((MOVESIZE>0) OR (LEFTTOXFER>0)) THEN BEGIN { PUT ZEROES IN BOUNDARY BYTES } J:=0; BURNIT(J,2); END; UNTIL MOVESIZE=0;  : INTEGER; X,Y : INTEGER; BREC : RECORD CASE BOOLEAN OF TRUE:(BPTR : ^TWOBYTES); FALSE:(BINT : INTEGER); END; BEGIN DOCONFIGURE(FALSE);  END ELSE BEGIN { TRANSFERING A FILE } BURNIT(BUF^,MOVESIZE); END; END; DONE:=TRUE;  FGOTOXY(OUTPUT,0,13); WRITELN('BLANK CHECK',CTEOS); CHECKEPROM; OLDSTART := 0; BLANKS := FALSE; FGETXY(OUTPUT,X,Y); LINES := 0; WITH EPROMDATA^ DO FOR I:=0 TO 7 DO { DO ONE SOCKET PAIR AT A TIME } IF NOT PRESENT[I] THEN  IF LEFTTOXFER=0 THEN BEGIN IF PASS=2 THEN FILEMOVED:=TRUE ELSE BEGIN PASS:=2; INSTATE := 1; END; END; END;  BEGIN { CLOSE OFF REPORT OF PREVIOUS PAIR } IF BLANKS THEN WRITELN(BREC.BINT-1-BASEADDR:1,' (',BREC.BINT-OLDSTART:1,')'); BLANKS:=FALSE END ELSE BEGIN { SOCKET PAIR PRESENT SO CHECK IT OUT } BREC.BINT       LINES := LINES + 1; OLDSTART := BREC.BINT; WRITE(OLDSTART-BASEADDR,' - '); BLANKS:=TRUE; END; END; BREC.BINT := BREC.BINT + 1; UNTIL BREC.BINT=ENDSCAN; IF BLANKS AND (I=7) THEN ROM TRANSFER UTILITY (28-Oct-91)'); COMMANDLEVEL; END.  WRITELN(BREC.BINT-1-BASEADDR:1,' (',BREC.BINT-OLDSTART:1,')'); END; { FOR I := ... } IF OLDSTART=0 THEN WRITELN('NO BLANK SPACE FOUND'); END; { DOBLANKCHECK } (****************************************************************************)  (* (c) Copyright Hewlett-Packard Company, 1983. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTEDBEGIN { COMMANDLEVEL } FIXLOCK; WITH ININFO DO BEGIN DIROPEN:=FALSE; FILEOPEN:=FALSE; END; HEAPINUSE := FALSE; IORESULT := ORD(INOERROR); SCODE := 0; TEMP := 0; FASTBURN := FALSE; { DEFAULT BURN RATE } EPROMLIST := NIL; { NO EPRO RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, ColoraM CARD INFO YET } FINDCARD(FALSE); { FIND A PROGRAMMER CARD } TRY DOCONFIGURE(FALSE); { DISPLAY DEFAULT CONFIGURATION } RECOVER IF ESCAPECODE<>0 THEN ESCAPE(ESCAPECODE); FGOTOXY(OUTPUT,0,13); WRITELN('Copyright Hewlett-Packard Compado *) $modcal$ $debug off, range off, ovflcheck off, stackcheck off, iocheck off$ $ALLOW_PACKED ON$ { JWS 4/10/85 } program install_ucsd_dam; module ucsdmodule; {UCSD directory access method} import sysglobals, ny, 1983, 1991.'); WRITELN(' All rights are reserved.'); REPEAT TRY PROMPTFORCHAR('ETU: Transfer Configure Blankcheck Quit',OP); IF OP=SH_EXC THEN OP:='Q'; IF OP='T' THEN DOTRANSFER ELSE IF OP='C' THEN DOCONasm, misc, loader, sysdevs; export procedure ucsd_dam (anyvar f: fib; unum: unitnum; request: damrequesttype); procedure init_ucsd_dam; implement const dirstart = 2*fblksize; (*DISK ADDR OF DIRECTORY*) type strrec = record name: stringFIGURE(TRUE) ELSE IF OP='B' THEN DOBLANKCHECK ELSE IF OP='Q' THEN BEGIN END ELSE IF STREAMING THEN BADCOMMAND(OP) ELSE BEEP; RECOVER BEGIN LOCKUP; IF HEAPINUSE THEN RELEASE(LHEAP); 255; end; srp = ^strrec; ctarec = record catarray: array[0..mmaxint] of catentry; end; ctp = ^ctarec; dtp = ^datetimerec; dirfile = file of direntry; var swapem: boolean; {flag to function swap, means excha HEAPINUSE := FALSE; SAVEIO := IORESULT; SAVEESC := ESCAPECODE; CLOSEALL; IORESULT := SAVEIO; IF (SAVEESC<>0) AND (SAVEESC<>-10) THEN IORESULT := ORD(INOERROR); LOCKDOWN; PRINTIOERRMSG; nge bytes} dir: ^dirfile; function swap8(b: shortint): shortint; external; function swapk(k: filekind): filekind; external; procedure init_ucsd_dam; begin if dir = nil then new(dir); end; (* UCSD format Directory Access Method *) procedure ucsd_ FIXLOCK; IF SAVEESC<>0 THEN ESCAPE(SAVEESC) ELSE OP := ' '; END; UNTIL OP='Q'; END {COMMANDLEVEL} ; (****************************************************************************) BEGIN WRITELN(CLEARSCR); FGOTOXY(OUTPUT,0,1); WRITELN('EPdam(anyvar f: fib; unum: unitnum; request: damrequesttype); var d, d0: direntry; mvb: boolean; function fetchdir: boolean; var ok: boolean; begin ok := false; with fibp(dir)^, unitable^[unum] do begin fisnew := false; fanonymous := true; fre     rocedure cleanup; var i,j: dirrange; begin with unitable^[unum] do if not mvb then begin i := 0; j := 0; while i < swap8(d0.dnumfiles) do begin i := i + 1; readdir(dir^, i+1, d); {RDQ 14dec88 removed year validation} if (strlen(d.<>f.feft) then begin ioresult := ord(ibadfiletype); goto 2; end; cleanup; if swap8(d0.dnumfiles)=maxpos(dir^)-1 then begin ioresult := ord(idirfull); goto 2; end; blocks := f.fpos; if blocks > 0 then blocks := (blocks+(fblksize-1)) div fblksize; fdtid) > 0) then begin j := j + 1; if j < i then writedir(dir^, j+1, d); end; end; d0.dnumfiles := swap8(j); if j < i then writedir(dir^, 1, d0); mvb := true; call (fibp(dir)^.am, fibp(dir), flush, dir, 0, 0); end; end;size := 0; i := 0; last := swap8(d0.dlastblk); seek(dir^, 2); while i < swap8(d0.dnumfiles) do begin i := i + 1; get(dir^); with dir^^ do begin checkspace(swap8(dfirstblk) - last); last := swap8(dlastblk); end; end; i := iadable := true; fwriteable := true; freadmode := false; fbufvalid := false; feof := false; fmodified := false; funit := unum; fileid := dirstart; fpeof := maxint; fleof := fpeof; fpos := 0; am := amtable^[datafile];  procedure setupfib(var d: direntry); begin with f, unitable^[funit], d do begin fileid := swap8(dfirstblk)*fblksize; fpeof := swap8(dlastblk) *fblksize - fileid; if not fbuffered then am := amtable^[untypedfile] else if not fistextv freptcnt := 0; flastpos := -1; fbufchanged := false; fbuffered := true; ureportchange := false; read(dir^, d0); ureportchange := true; umediavalid := true; with d0, unitable^[unum] do {VALIDITY CHECK ON DIRECTORY} begin ar then am := amtable^[datafile] else am := amtable^[fkind]; end; end; function checkname: boolean; begin checkname := false; with f do if ((strlen(ftitle) = 0) or (strlen(ftitle) > fnlength)) then ioresult := ord(ibadtitle) else begin ft if ioresult=ord(inoerror) then begin swapem := dlastblk >= 768; {quick test for reversed byte order} if dfirstblk = 0 then if swapk(dfkind) = untypedfile then if strlen(dvid) > 0 then if strlen(dvid) <= vnlength then if swap8(dnuid := ftitle; upc(ftid); checkname := true; {further syntax may be necessary!} end; end; procedure create_new; label 1,2; var i, finx, sinx, last, flast, slast, blocks, fsize, ssize: integer; temp: arrmfiles) >= 0 then if swap8(deovblk) >= swap8(dlastblk) then begin fpeof := swap8(dlastblk)*fblksize - dirstart; fleof := fpeof; ok := (swap8(dnumfiles)+1)*sizeof(direntry) <= fpeof; end; end; if ok then begin if dvid <> uvid tay[boolean] of direntry; sw: boolean; procedure checkspace(size: integer); begin if blocks > 0 then {FIRST FIT} begin if size >= blocks then begin fsize := blocks; finx := i; flast := last; ghen begin mvb := false; uvid := dvid; uuppercase := true; end; end else begin uvid := ''; mvb := false; if ioresult = ord(inoerror) then ioresult := ord(inodirectory); end; end; end; fetchdir := ok; oto 1; end; end else if size > fsize then {LARGEST HOLE} begin ssize := fsize; fsize := size; sinx := finx; finx := i; slast := flast; flast := last; end else if size > ssize then end; function fetchvolume: boolean; var volname: vid; begin fetchvolume := false; if fetchdir then begin volname := f.fvid; upc(volname); if unitable^[unum].uvid <> volname then ioresult := ord(ilostunit) else fetchvolume := true; end; end; p {SECOND LARGEST} begin ssize := size; sinx := i; slast := last; end; end; begin if not f.fanonymous then if not checkname then goto 2; if not fetchvolume then goto 2; if (f.fstartaddress <> 0) or (efttable^[f.fkind]      + 1; checkspace(swap8(d0.deovblk) - last); if fsize=0 then begin ioresult := ord(inoroom); goto 2; end; if blocks < 0 {RT11ISH} then begin fsize := (fsize+1) div 2; if fsize <= ssize then begin fsize := ssize; finx := sinx; flast := slast; end; nitable^[funit] do if fileid > dirstart then if fetchvolume then begin seek(dir^, 2); linx := 0; found := false; findblock := fileid div fblksize; while (linx < swap8(d0.dnumfiles)) and (finddup or not found) do begin li end; 1: {FOUND THE CORRECT PLACE TO INSERT A NEW FILE} with f, temp[true] do begin dfirstblk := swap8(flast); dlastblk := swap8(flast+fsize); dfkind := swapk(fkind); dtid := ''; fisnew := true; fleof := 0; setupfib(temp[true]); sw := nx := linx + 1; get(dir^); with dir^^ do begin if dtid = ftid then begin dupindex := linx; finddup := false; end; if swap8(dfirstblk) = findblock then if fisnew <> (linx = dupindex) then begin findfile := linx; found := true; endfalse; d0.dnumfiles := swap8(swap8(d0.dnumfiles)+1); for i := finx+1 to swap8(d0.dnumfiles)+1 do begin readdir (dir^, i, temp[sw]); sw := not sw; writedir(dir^, i, temp[sw]); end; end; writedir(dir^, 1, d0); 2: end; function findold; end; end; if not found then ioresult := ord(ilostfile); end; end; procedure stretch; var dup, linx: dirrange; lavailblk: integer; peof: integer; begin linx := findfile(dup, false); if linx > 0 then begin read(dir^, d); : dirrange; var i: dirrange; found: boolean; begin findold := 0; with f do if fetchvolume then begin found := false; seek(dir^, 2); i := 0; while (i < swap8(d0.dnumfiles)) and not found do begin i := i+1; get with d0 do if linx = swap8(dnumfiles) then lavailblk := swap8(deovblk) else lavailblk := swap8(dir^^.dfirstblk); with f, d do begin peof := (lavailblk-swap8(dfirstblk))*fblksize; if peof >= fpos then begin dlastblk := swap8(dir^); found := dir^^.dtid = ftid; end; if found then findold := i else ioresult := ord(inofile); end; end; procedure open_old; var i: dirrange; begin if checkname then begin i := findold; if i>0 then with f, dir^^ do begi(((peof+fpos) div 2 + (fblksize-1)) div fblksize + swap8(dfirstblk)); dlastbyte := swap8(fblksize); fpeof := (swap8(dlastblk) - swap8(dfirstblk)) * fblksize; fmodified := true; writedir(dir^, linx+1, d); end; end;n fisnew := false; fkind := swapk(dfkind); feft := efttable^[fkind]; fstartaddress := 0; setupfib(dir^^); if fkind = textfile then fleof := fpeof else fleof := fpeof - 512 + swap8(dlastbyte); cleanup; end; end; end; proced end; end (*STRETCH*) ; procedure delentry (finx: dirrange); var i: dirrange; temp: array[boolean] of direntry; sw: boolean; begin with d0 do begin sw := false; for i := swap8(dnumfiles)+1 downto finx+1 do begin readdir (dir^ure overwrite; var i: dirrange; begin if checkname then begin cleanup; i := findold; if i>0 then begin d := dir^^; with f, d do begin fisnew := true; dfkind := swapk(fkind); dtid := ''; fleof := 0; , i, temp[sw]); sw := not sw; writedir(dir^, i, temp[sw]); end; dnumfiles := swap8(swap8(dnumfiles)-1); end; writedir(dir^, 1, d0); end (*DELENTRY*) ; procedure purgeit; var dup, linx: dirrange; begin linx := findfile(dup, false); if linx > 0setupfib(d); writedir(dir^, i+1, d); end; end; end; end; function findfile(var dupindex: dirrange; finddup: boolean): dirrange; var found: boolean; linx: dirrange; findblock: integer; begin findfile := 0; dupindex := 0; with f, u then delentry(linx); (*ZAP FILE OUT OF EXISTENCE*) end; procedure closeit; var linx,dupinx: dirrange; begin with f do begin linx := findfile(dupinx, fisnew); if linx > 0 then with f do begin readdir(dir^, linx+1, d); wi     to 1 else swapem := false; dfirstblk := 0; if cextra1 = 0 then cextra1 := 77; dlastblk := swap8((dirstart + (cextra1 + 1) * sizeof(direntry) + (fblksize-1)) div fblksize); dfkind := swapk(untypedfile); if (strlen(cname)=0) or (strlen(cname)>vnlwapk(dfkind); ceft := efttable^[swapk(dfkind)]; cpsize := (swap8(dlastblk) - swap8(dfirstblk)) * fblksize; clsize := cpsize - 512 + swap8(dlastbyte); cstart := swap8(dfirstblk) * fblksize; cblocksize := fblksize; with ccreatedate dength) then begin ioresult := ord(ibadtitle); goto 1; end; dvid := cname; upc(dvid); deovblk := swap8(cpsize div fblksize); if (swap8(dlastblk) <= swap8(dfirstblk)) or (swap8(dlastblk) > swap8(deovblk)) or (cpsize>ueovbytes(funit)) theo begin year := 0; day := 0; month := 0; end; with ccreatetime do begin hour := 0; minute := 0; centisecond := 0; end; clastdate := daccess; clasttime := ccreatetime; cextra1 := -1; cextra2 := -1; if swapem then cinfo := 'UCSD'th d do begin dtid := ftid; sysdate(daccess); dlastbyte := swap8(fleof mod fblksize); if dlastbyte = 0 then dlastbyte := swap8(fblksize); dlastblk := swap8(swap8(dfirstblk)+ ((fleof + (fblksize-1)) div fblksize)); n begin ioresult := ord(ibadvalue); goto 1; end; sysdate(dlastboot); dloadtime := 0; dnumfiles := 0; fleof := swap8(dlastblk) * fblksize; fpeof := fleof; writedir(dir^, 1, d); with fibp(dir)^ do begin call (am, fibp(dir), flush, fbuffer,  end; writedir(dir^, linx+1, d); if fisnew then if dupinx > 0 then delentry(dupinx); end; end; end (*CLOSE*) ; procedure purgeold; var i: dirrange; begin if checkname then begin i := findold; if i>0 then delentry(i); 0, 0); for i := 0 to fblksize do fbuffer[i] := chr(0); fileid := 0; call (am, fibp(dir), writebytes, fbuffer, fblksize, 0); call (am, fibp(dir), writebytes, fbuffer, fblksize, fblksize); end; end; 1: end; procedure opendir; begin with f, c (*ZAP FILE OUT OF EXISTENCE*) end; end; procedure changeit; var i: dirrange; begin with f, srp(fwindow)^ do if (strlen(name)=0) or (strlen(name)>fnlength) then ioresult := ord(ibadtitle) else begin ftid := name; upc(ftid); i := fintp(fwindow)^.catarray[0], d0 do if fetchvolume then begin upc(ftitle); cname := dvid; cextra1 := maxpos(dir^)-1; cpsize := swap8(deovblk) * fblksize; clsize := (swap8(deovblk) - swap8(dlastblk)) * fblksize; cstart dold; if i > 0 then ioresult := ord(idupfile) else if checkname then begin i := findold; if i > 0 then begin d := dir^^; d.dtid := name; upc(d.dtid); writedir(dir^, i+1, d); end; end; end; end; procedu:= swap8(dlastblk) * fblksize; cextra2 := -1; cblocksize := fblksize; with ccreatedate do begin year := 0; day := 0; month := 0; end; with ccreatetime do begin hour := 0; minute := 0; centisecond := 0; end; clastdate := dlasre setname; begin with srp(addr(f))^ do if (strlen(name)=0) or (strlen(name)>vnlength) then ioresult := ord(ibadtitle) else if fetchdir then with unitable^[unum] do begin uvid := name; upc(uvid); d0.dvid := uvid; writedir(dtboot; clasttime := ccreatetime; if swapem then cinfo := 'UCSD' else cinfo := 'WS1.0'; end; end; procedure cat; var i,j: integer; begin with f, ctp(fwindow)^ do if fetchvolume then begin i := -fpos; j := 0; while (i < fpeof) and ir^, 1, d0); end; end; procedure makedir; label 1; var i: integer; begin if f.ftitle <> '' then ioresult := ord(ibadrequest) else with ctp(f.fwindow)^.catarray[0], d, fibp(dir)^ do begin if not fetchvolume then if ioresult<>ord(inodirectory) then go(j < swap8(d0.dnumfiles)) do begin read(dir^, d); j := j + 1; with d do {RDQ 14dec88 removed year validation} if (strlen(dtid) > 0) then begin if i >= 0 then with catarray[i] do begin cname := dtid; ckind := s      else cinfo := 'WS1.0'; end; i := i + 1; end; end; fpeof := i; end; end; procedure crunchit; label 1; var i,j: dirrange; blocks, last, psize, tsize, i1, i2: integer; buf: windowp; heapmark, fp: fibp; begin mark(heapmark);th f, unitable^[unum] do begin mvb := umediavalid; case request of createfile: create_new; openfile: open_old; overwritefile: overwrite; purgefile: purgeit; purgename: purgeold; changename: changeit; closefile: if  new(fp, 0); with unitable^[unum], f do if strlen(ftitle) > 0 then ioresult := ord(ibadtitle) else if fetchvolume then with fp^ do try i := 0; j := 0; blocks := (memavail div fblksize) - 5; if blocks < 1 then escape(-2); newwords(buf, blocks * (fmodified then closeit; stretchit: stretch; makedirectory: makedir; opendirectory: opendir; catalog: cat; closedirectory: {nothing to do}; crunch: crunchit; openunit, openvolume: begin unblockeddam(f, unum, requestfblksize div 2)); funit := unum; fpeof := maxint; fileid := 0; last := swap8(d0.dlastblk); while i < swap8(d0.dnumfiles) do begin i := i + 1; readdir(dir^, i+1, d); with d do {RDQ 14dec88 removed year validation} if (strlen(); mvb := umediavalid; end; setunitprefix: if strlen(ftitle) > 0 then ioresult := ord(ibadtitle); getvolumedate: if fetchdir then dtp(addr(f))^.date := d0.dlastboot; setvolumedate: if fetchdir then begin d0.dlastboot := dtp(addrdtid) > 0) then begin j := j + 1; if swapk(dfkind) <> badfile then if swap8(dfirstblk) > last then begin i1 := swap8(dfirstblk); {source block} psize := swap8(dlastblk) - swap8(dfirstblk); {number of blocks to (f))^.date; writedir(dir^, 1, d0); end; getvolumename: begin if fetchdir then {uvid := D0.dvid} ; srp(addr(f))^.name := uvid; end; setvolumename: setname; stripname: begin if strlen(ftitle) > 15 then ioresult := ordmove} i2 := last; {destination block} dfirstblk := swap8(i2); {new starting block} repeat if psize > blocks then tsize := blocks else tsize := psize; call(tm, fp, readbytes, buf^, tsize*fblksize, i1*fbl(ibadtitle) else begin ftid := ftitle; setstrlen(ftitle,0); end; end; otherwise ioresult := ord(ibadrequest); end; if (ioresult=ord(inoerror)) and (fibp(dir)^.freadable) then call (fibp(dir)^.am, fibp(dksize); if ioresult <> ord(inoerror) then goto 1; call(tm, fp, writebytes, buf^, tsize*fblksize, i2*fblksize); if ioresult <> ord(inoerror) then goto 1; psize := psize - tsize; i1 := i1 + tsize; i2 := i2 + tsize; until psize = 0; dlir), flush, dir, 0, 0); umediavalid:= mvb; end; lockdown; end; end; {module UCSDmodule} import ucsdmodule, loader; begin {program install UCSD DAM} init_ucsd_dam; markuser; end. astblk := swap8(i2); {new ending block} if j = i then writedir(dir^, j+1, d); end; last := swap8(dlastblk); if j < i then writedir(dir^, j+1, d); end; end; d0.dnumfiles := swap8(j); if j < i then writedir(dir^, (* (c) Copyright Hewlett-Packard Company, 1984,1985,1986. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company.  1, d0); mvb := true; 1: call (fibp(dir)^.am, fibp(dir), flush, dir, 0, 0); release(heapmark); recover begin release(heapmark); escape(escapecode); end; end; begin {_UCSD_dam} lockup; ioresult := ord(inoerror); fibp(dir)^.freadable := false; wiRESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Colli     data(loopcmd); { id command } senddata(timeout20); { 20 milli secs } loopcmddone:=false; looperror:=false; sendcmd(trigger); repeat call(kbdpollhook,true); until loopcmddone or looperror; end else loreg.noreconfig:=false; sendcmd(writectrl); senddata(ord(ctrlreg.b)); repeat { wait for polling to stop } cmd_read_1(readbusy,loopdata); until not odd(loopdata div 4); rawmode:=true; setintlevel(oldpriority); { restoreoperror:=true; end; { lcommand } { status6 isr for describe operation } procedure describedata(var statbyte,databyte:byte; var done:boolean); begin { load describe record for the current loop device } WITH LOOPCONTROL^ DO {4/10 interupts } end; end; { rawshift } procedure normshift; { change 8042 to normal mode } var oldpriority : integer; ctrlreg : lpctrltype; tempstuff : byte; begin WITH LOOPCONTROL^ DO {4/6/84 SFB} if rawmode thens, Colorado *) $sysprog$ $stackcheck off$ $heap_dispose off$ $iocheck off$ $range off$ $ovflcheck off$ $debug off$ program loopinit; module hphil; { HP Human Interface Loop } import a804xdvr,sysdevs,sysglobals,asm; export FU/84 SFB} with loopdevices[loopdevice] do {4/6/84 SFB} case devstate of 1: begin descrip.darray[1]:=chr(databyte); devstate:=2; end; 2: begin descrip.darray[2]:=chr(databyte); { header byte } if descrip.numaxes>0 then devstate:=NCTION INITLOOP:BOOLEAN; {4/6/84 SFB} implement const readctrl = hex('FB'); { 8042 COMMANDS } writectrl= hex('EB'); startcmd = hex('E0'); readbusy = hex('02'); trigger = hex('C5'); type stat5datatype = packed record { data bye with stat3 else devstate:=11; end; { low order count } 3: begin descrip.darray[4]:=chr(databyte); devstate:=4; end; 4: begin descrip.darray[3]:=chr(databyte); { high order count } if descrip.abscous 5 } case integer of 0 :(b:byte); 1 :(lerror : boolean; {7} padding : 0..3; {6..5} polling : boolean; {4} command : boolean; {3} devaddr : 0..7); {2..0} ords then devstate:=5 else devstate:=11; end; 5..10:begin { swap even / odd bytes } descrip.darray[devstate-1+(ord(odd(devstate))*2)]:=chr(databyte); devstate:=devstate+1 {+ord(not descrip.size16)}; {bugfix SFB 4/4/85} if end; lpctrltype = packed record { loop control byte } case boolean of true :(b:byte); false:(doreconfigure: boolean; pad6,pad5 : boolean; cookkbd : boolean; pad3 : boolean; noreconfig : boolean; noerrs  (devstate>6) and (descrip.numaxes=1) then devstate:=11 else if (devstate>8) and (descrip.numaxes=2) then devstate:=11; end; 11: begin { prompts & buttons } if descrip.hasprompts then descrip.darray[11]:=chr(databyte); devstate:=12 : boolean; doautopoll : boolean ) end; var oldstatus5isr : kbdhooktype; oldclrio : procedure; procedure dummydataproc(var statbyte,databyte:byte; var done:boolean); begin end; procedure dummyopsproc(op:loopdvrop); begin ; end; otherwise end; { case devstate } end; { describedata } procedure rawshift; { change 8042 to raw mode } var oldpriority : integer; ctrlreg : lpctrltype; tempstuff : byte; begin WITH LOOPCONTROL^ DO end; procedure lcommand; const timeout20= hex('FE'); begin WITH LOOPCONTROL^ DO {4/6/84 SFB} if loopisok or loopinconfig then begin sendcmd(startcmd); senddata(8+loopdevice); { command & address } send{4/6/84 SFB} if not rawmode then begin oldpriority:=intlevel; { lock out interupts } setintlevel(7); cmd_read_1(readctrl,tempstuff); ctrlreg.b:=tempstuff; ctrlreg.doautopoll:=false; ctrlreg.noerrs:=true; ctrl     n begin oldpriority:=intlevel; { lock out interupts } setintlevel(7); cmd_read_1(readctrl,tempstuff); ctrlreg.b:=tempstuff; ctrlreg.doautopoll:=true; ctrlreg.noerrs:=true; ctrlreg.noreconfig:=false; sendcmdf not loopisok then goto 1; rawshift; loopinconfig:=true; { get device description for all (7) devices } for i:=1 to 7 do begin loopdevice:=i; with loopdevices[loopdevice] do {SFB 4/8/85} call(opsproc,uninitdevic(writectrl); senddata(ord(ctrlreg.b)); { start auto polling } rawmode := false; setintlevel(oldpriority); end; end; { normshift } procedure describe; { issue describe for loopdevice } const idcmd = hex('03'); var ole); { tell driver to uninitialize } describe; if looperror then goto 1; { kick out & wait for status5, le_configured } end; { find and attach drivers to devices } for i:=1 to 7 do begin loopdevice:=i; temdpriority : integer; i : 1..11; begin { describe } oldpriority := intlevel; { lockout interupts } setintlevel(7); status6hook:=describedata; WITH LOOPCONTROL^ DO {4/10/84 SFB} with loopdevices[loopdevice] do p:=loopdriverlist; while temp<>nil do with loopdevices[loopdevice] do begin if (temp^.daddr=0) or (temp^.daddr=loopdevice) then if (descrip.id>=temp^.lowid) and (descrip.id<=temp^.highid) then begin { hook up the driver }  begin devstate:=1; opsproc:=dummyopsproc; dataproc:=dummydataproc; for i:=1 to 11 do descrip.darray[i]:=chr(0); { clear the record } loopcmd:=idcmd; lcommand; { send the command and wait for it to finish } end;  opsproc:=temp^.opsproc; dataproc:=temp^.dataproc; call(opsproc,resetdevice); { tell driver to reset } temp:=nil; { cancel the search } end else temp:=temp^.next else temp:=temp^.next; { 3.0 BUG FIX 4/6/84 } status6hook:=dummydataproc; setintlevel(oldpriority); end; { describe } procedure checkloop; const readlstat = hex('FA'); var oldpriority : integer; begin WITH LOOPCONTROL^ DO {4/6/84 SFB} BEGIN loopisok:=false;  end; { while .. with } end; { for } 1:loopinconfig:=false; normshift; IF ODD(OLDMASK) THEN CALL(MASKOPSHOOK,0,KBDMASK); { DISABLE LOOP IF IT WAS PREVIOUSLY OFF - SFB 3/5/84 } END; {4/6/84 S LOOPDATA := 0; {4/24/84 SFB } oldpriority:=intlevel; { lock out interupts } setintlevel(7); cmd_read_1(readlstat,loopdata); loopisok:=loopdata<128; setintlevel(oldpriority); END; {4/6/84FB} end; { configure } procedure resettheloop; { cleario call } begin configure; call(oldclrio); end; procedure endcmdproc(var statbyte,databyte:byte; var done:boolean); begin WITH LOOPCONTROL^ DO {4/6/84 SFB} BEGIN  SFB} end; { checkloop } procedure configure; label 1; CONST READ_INTR_MASK = 4; { SFB 3/5/84 } var temp : loopdvrptr; i : shortint; OLDMASK : BYTE; { SFB 3/5/84 } begin { configure } WITH LOOPCONTROL^ DO  loopcmddone := true; status6hook:=dummydataproc; loopdata := databyte; END; end; PROCEDURE SENDHPHILCMD(OP : HPHILOP); {4/9/84 SFB} BEGIN CASE OP OF RAWSHIFTOP : RAWSHIFT; NORMSHIFTOP : NORMSHIFT; CHECKLOOPOP  {4/6/84 SFB} BEGIN CMD_READ_1(READ_INTR_MASK,OLDMASK);{ SAVE OLD 804X MASK - SFB 3/5/84 } CALL(MASKOPSHOOK,KBDMASK,0); { ENABLE LOOP - SFB 3/5/84 } loopdevreading:=false; { 3.0 BUG #39 3/17/84 } checkloop; i: CHECKLOOP; CONFIGUREOP : CONFIGURE; LCOMMANDOP : LCOMMAND; END; END; procedure status5isr(var statbyte,databyte:byte; var done:boolean); var status : stat5datatype; begin status.b:=databyte; WITH LOOPCONTROL^ DO {4/6/84      tion initloop:boolean; var dev : 1..lmaxdevices; {4/9/85 SFB} begin IF LOOPCONTROL = NIL THEN {4/9/84 SFB} BEGIN NEW(LOOPCONTROL); {4/9/84 SFB} WITH LOOPCONTROL^ DO {4/6/84 SFB} BEGIN for dev := 1 } { 1. 5/24/83 } { Larry Chapman (TAG) reported failure if STOP key was } { hit while segment was loading. John S. verified bug, } { de to lmaxdevices do {4/9/85 SFB} loopdevices[dev].opsproc := dummyopsproc; initloop:=false; rawmode :=false; loopisok :=false; if HIL_PRESENT then { 6/18/86 JWS } begin oldstatus5isr:=status5hook; { save old hook } sttermined hangup was in "loadtext" routine in loader. } { Sam Sands suggested fix that was implemented by John S. } { which repaired loader open file list pointer. Fix appears } { to work, and was verified by Sam, John, and LarrSFB} if status.lerror then begin looperror:=true; status6hook:=dummydataproc; if status.b=le_loopdown then loopisok:=false else if status.b=le_configured then begin { loop has been reconfigured } call(oatus5hook:=status5isr; status6hook:=dummydataproc; oldclrio :=cleariohook; { save old hook } cleariohook:=resettheloop; HPHILCMDHOOK:=SENDHPHILCMD; {4/9/84 SFB} configure; initloop := true; end; END; {WITH LOOPCldstatus5isr,statbyte,databyte,done); { let keyboard proc know } if not loopinconfig then configure; loopdevreading:=false; { 3.0 bug #39 3/17/84 } end; end else if status.command then begin if status.polling ONTROL^} END {IF LOOPCONTROL = NIL} ELSE BEGIN {4/9/84 SFB} CONFIGURE; {IF INITLOOP ALREADY DONE JUST CONFIGURE} INITLOOP := FALSE; {DON'T MARKUSER} END; end; { initlthen { end of polled data } begin status6hook:=dummydataproc; { ignore next data } call(loopdevices[loopdevice].opsproc,dataended); loopdevreading:=false; { 3.0 bug #39 3/17/84 } end else begin { command ending } oop } end; { loopinterface module } import hphil, loader; begin if initloop then markuser; end.  status6hook:=endcmdproc; end; end else if status.polling then begin { polling data starting } { check if device now reading 3.0 bug #39 3/17/84} if loopdevreading then {3.0 bug #39 3/17/ DEF SWAP8,SWAPK BYTE EXCHANGE FOR UCSD REFA UCSDMODULE SWAPEM EQU UCSDMODULE-1 SEE LISTING OF UCSD_DAM SWAPK EQU * SWAP8 MOVEA.L (SP)+,A0 RETURN ADDRESS MOVE.W (SP)+,D0 16 BIT PARAM84} call(loopdevices[loopdevice].opsproc, dataended){3.0 bug #39 3/17/84} else {3.0 bug #39 3/17/84} loopdevreading:=true; {3.0 bug #39 3/17/84} loopdevice:=status.devaddr; statusETER TST.B SWAPEM(A5) TEST FLAG BEQ.S NOSWAP SKIP IF FALSE ROL.W #8,D0 SWAP BYTE FOR BYTE NOSWAP MOVE.W D0,(SP) RETURN FUNCTION VALUE JMP (A0) NOSYMS END 6hook:=loopdevices[loopdevice].dataproc; call(loopdevices[loopdevice].opsproc,datastarting); end else begin { data starting for current command } looperror:= loopdevice<>status.devaddr; end; end; { status5isr } func$modcal$ { SEGMENTER module -- Original author: Sam Sands } { Reviewed by John Schmidt 5/83 } { } { Bug history:       y. } { } { 2. 3/35/85 } { Fixes to flush 68020 I-cache before calling code. jws } { 5/24/83 } export type segment_proc = procedure; proc_name = string[120]; procedure init_segmenter(anyvar lowcode, highcode, lowglobal, highglobal: byte); procedure load_segment (filename: fid); procedure load_heap_segment(f } { 3. 6/10/85 } { The system variable 'INITSTACK' was not getting updated } { for a call going through the segmenter. The following } { ilename: fid); procedure unload_segment; procedure unload_all; procedure call_segment (filename: fid); procedure call_segment_proc(filename: fid; symbol: proc_name); function find_proc(symbol: proc_name): segment_proc; function exists_probug is the result of this. If the entry point being } { called is a main program and if at some point during } { the execution of that program a NON-LOCAL goto is } { executed where the destination is the main proc(p: segment_proc): boolean; procedure segment_space(var code, global: integer); implement external module asm; export function allocate(size: integer): anyptr; procedure newbytes(var p: anyptr; size: integer); procedure flush_icache; functiogram that } { was initially called, register A6 is incorrectly given } { a value which corresponds to original main program. } { This in turn causes the program envoked by the segmenter } { to return to the comman getA7 : integer; { BAR 6/10/85 } end; import asm; type proc = procedure; trick_proc = record case boolean of true: (p: proc); false: (ep, sl: integer); end; state_ptr = ^state_rec; name_ptr = ^proc_name; nd interpreter instead of the } { environment that called it. The fix implemented is to } { save the value of 'INITSTACK', set up a proper new value, } { and restore the original value prior to returning to the } {  state_rec = record savelist: state_ptr; restore_heap: boolean; saveheap: ^integer; saveglob, savecod: integer; saveentry, savedef: moddescptr; savefiles: anyptr; end; var highglob, lowglob: integer; original scope. } { } { 4. 3/16/90 } { The system variables heapbase and heapmax we lowcod, highcod: integer; segment_list: state_ptr; initstack['INITSTACK'] : integer; { BAR 6/10/85 } procedure init_segmenter(anyvar lowcode, highcode, lowglobal, highglobal: byte); begin lowcod := integer(addr(lowcodere not } { getting updated for a call going through the } { segmenter. As a result, when both the segmenter } { application and the called program were using heap_dispose} { the free list for th)); highcod := integer(addr(highcode)); if highcod < lowcod then begin lowcod := integer(addr(highcode)); highcod := integer(addr(lowcode)); end; lowglob := integer(addr(lowglobal)); highglob := integer(addr(highglobal)); if highglob < e application was getting trashed. } { This is only applicable for programs, not library entry } { points (call_segment only) } module segmenter; import loader, ldr, sysglobals, MISC; { JWS lowglob then begin lowglob := integer(addr(highglobal)); highglob := integer(addr(lowglobal)); end; if odd(lowcod) then lowcod := lowcod + 1; if odd(lowglob) then lowglob := lowglob + 1; if odd(highcod) then highcod := highcod - 1      egin if segment_list = nil then escape(121) else with segment_list^ do begin segment_list := savelist; if restore_heap then release(saveheap); highglob := saveglob; lowcod := savecod; sysdefs := savedef; LT:=IOTEMP; { JWS 5/24/83 } LOCKDOWN; { JWS 5/24/83 } escape(ESCTEMP); { JWS 5/24/83 } end; end; procedure release_heap; begin with segment_list^ do begin release(saveheap); restore_heap := false; end; end; pro entrypoint := saveentry; openfileptr := savefiles; end; end; procedure unload_all; begin while segment_list <> nil do unload_segment; end; procedure load_seg(var filename: fid; p: proc); var space: integer; modnum: integer; cedure local(var filename: fid; p: proc); var state: state_rec; procedure loadproc; begin highheap.a := highheap.a - totalreloc; if highheap.a < lowheap.a then escape(-2); release(highheap.p); startreloc := integer(allocate(totalreloc)); loa; if odd(highglob) then highglob := highglob - 1; end; procedure segment_space(var code, global: integer); begin code := highcod - lowcod; global := highglob - lowglob; end; procedure no_proc; begin escape(120); end; function exists_proc(p: segm highheap0: addrec; ESCTEMP: INTEGER; { JWS 5/24/83 } IOTEMP: INTEGER; { JWS 5/24/83 } begin LOADFIB.PHP:=NIL; { JWS 5/24/83 } try space := memavail - 5000; {guess as to requiredent_proc): boolean; begin exists_proc := not(p = no_proc); end; function find_proc(symbol: proc_name): segment_proc; var modp: moddescptr; ptr, valueptr: addrec; found: boolean; proc_rec: trick_proc; begin find_proc := no_proc; found := false; m stack space} if space <= 0 then escape(-2); mark(lowheap.p); highheap.a := lowheap.a + space; release(highheap.p); highheap0 := highheap; newmods := sysdefs; endmod := sysdefs; openlinkfile(filename); if fdirectory = nil then escape(-10)odp := sysdefs; while (modp<>nil) and not found do with modp^ do begin ptr := defaddr; while (ptr.a nil then {SFB} if loadfib.fbp^.freadable then CLOSEFILES; { JWS 5/24/83 } IORESU      dtext(false); highheap.a := highheap.a - totaldefs; if highheap.a < lowheap.a then escape(-2); release(highheap.p); movedefs(integer(allocate(totaldefs))); release_heap; call(p); end; begin save_state(state, 0 , 0); load_seg(filename, loadpr recover_executed := true; { BAR 6/10/85 } initstack := initstack_temp; { BAR 6/10/85 } if recover_executed then { BAR 6/10/85 } escape(escapecode); { BAR 6/10/85 } end; begin p := find_proc(symbol); if exists_prroc); unload_segment; end; procedure call_segment (filename: fid); procedure callit; var proc_rec: trick_proc; modptr: moddescptr; initstack_temp : integer; { BAR 6/10/85 } recover_executed : boolean;{ BAR 6/10/85 } heapmaxsavoc(p) then begin flush_icache; {JWS 3/25/85} recover_executed := false; { BAR 6/10/85 } try { BAR 6/10/85 } initstack_temp := initstack; { BAR 6/10/85 } initstack := getA7 - 8; e:ANYPTR; { DEW 3/16/90 } heapbasesave:ANYPTR; { DEW 3/16/90 } begin modptr := entrypoint; while modptr<>nil do with modptr^ do begin if startaddr <> 0 then with proc_rec do begin sl := 0; ep := startaddr; flu { BAR 6/10/85 } call(p); recover recover_executed := true; { BAR 6/10/85 } initstack := initstack_temp; { BAR 6/10/85 } if recover_executed then { BAR 6/10/85 } escape(escapecode); { BAR 6/10/85 } end sh_icache; recover_executed := false; { BAR 6/10/85 } try { BAR 6/10/85 } initstack_temp := initstack; { BAR 6/10/85 } initstack := getA7 - 8; { BAR 6/10/85 } heapmaxsave := heapmax; {else local(filename, callit); end; procedure load_segment (filename: fid); var state: state_ptr; function code_space(size: integer): anyptr; begin if lowcod + size > highcod then escape(122) else begin code_space := anyptr(lowcod); DEW 3/16/90 } heapbasesave := heapbase; { DEW 3/16/90 } call(p); recover recover_executed := true; { BAR 6/10/85 } initstack := initstack_temp; { BAR 6/10/85 } heapmax := heapmaxsave; { DEW 3/16/90 }  lowcod := lowcod + size; end; end; procedure loadproc; begin startreloc := integer(code_space(totalreloc)); loadtext(false); movedefs(integer(code_space(totaldefs))); release_heap; end; begin state := code_space(sizeof(state_rec) heapbase := heapbasesave; { DEW 3/16/90 } if recover_executed then { BAR 6/10/85 } escape(escapecode); { BAR 6/10/85 } end; if lastmodule then modptr := nil else modptr := link; end; end; begin local(filename, callit); save_state(state^, 0, -sizeof(state_rec)); load_seg(filename, loadproc); end; procedure load_heap_segment(filename: fid); var state: state_ptr; procedure loadproc; begin loadtext(true); movedefs(startreloc+totalreloc); release(anyptr(startd); end; procedure call_segment_proc(filename: fid; symbol: proc_name); var p: segment_proc; initstack_temp : integer; { BAR 6/10/85 } recover_executed : boolean;{ BAR 6/10/85 } procedure callit; begin flush_icache; {JWefs+totaldefs)); end; begin newbytes(state, sizeof(state_rec)); save_state(state^, -sizeof(state_rec), 0); mark(lowheap.p); startreloc := lowheap.a; load_seg(filename, loadproc); end; end. S 3/25/85} recover_executed := false; { BAR 6/10/85 } try { BAR 6/10/85 } initstack_temp := initstack; { BAR 6/10/85 } initstack := getA7 - 8; { BAR 6/10/85 } call(find_proc(symbol)); recove* FUNCTION ASM_ALLOCATE(SIZE: INTEGER): ANYPTR; DEF ASM_ALLOCATE REFA SYSGLOBALS,STACKFUDGE HEAPPOINTER EQU SYSGLOBALS-14 RETURN EQU A0 ADDRESS EQU A1 TEMP EQU A2 SIZE EQU D0 ASM_ALLOCATE EQU * MOVEA.L (SP)+,RETURN MOVE.L        END; EOPTYPE = (EREAD,EWRITE,ECWRITE,EBLANK,ECHECK); EPERROR = (ENOERROR,ENOTPROG,ENOEPROM,ECFAIL,EPFAIL,ENOTBLANK,EBADARGS); FUNCTION EPROG( SCODE : INTEGER; OP : EOPTYPE; ANYVAR BUFFER : WINDOW; BUFSIZE : INTEGERSTART) OR (ENDSCAN>EPEND) THEN BADIO(EBADARGS); PBYTE.INT := POSIT; DONE := FALSE; END; END; PROCEDURE GETINFO(ANYVAR UINFO : EPINFOREC); BEGIN UINFO := INFO^; END; BEGIN { EPPROG } ECODE := ENOERROR; TRY { V; VAR POSIT : INTEGER):EPERROR; FUNCTION EGETINFO( SCODE : INTEGER; VAR INFO : EPINFOREC):EPERROR; FUNCTION EINIT(SCODE : INTEGER):EPERROR; FUNCTION EBRATE(SCODE : INTEGER; BRATE : BOOLEAN):EPERROR; IMPLEMENT TYPEALIDATE THE SELECT CODE } IF (SCODEIOMAXISC) THEN BADIO(ENOTPROG); WITH ISC_TABLE[SCODE] DO BEGIN CARD := CARD_PTR; IF (CARD=NIL) OR (CARD_TYPE=0) THEN BADIO(ENOTPROG); IF ((CARD_TYPE=1) AND (CARD_ID=0)) OR ((C (SP)+,SIZE ADDQ #4,SP POP SPACE FOR RETURNED VALUE ADDQ.L #1,SIZE ROUND UP TO EVEN NUMBER BCLR #0,SIZE NEG.L SIZE BGT.S OVERFLOW DISALLOW NEGATIVE SIZES LEA 0(SP,SIZE.L),ADDRESS LEA -STACKFUDGE(ADDRESS EPOPTYPE = (EPINIT,EPREAD,EPWRITE,EPCWRITE,EPBLANK,EPCHECK,EPBRATE,EPINFO); STATREG= PACKED RECORD B4 : BYTE; { PUT HERE TO MAKE THE COMPILER HAPPY } PAD : 0..15; { 7,6,5,4 } FAST: BOOLEAN; ACCS: BOOLEAN; ),TEMP CMPA.L HEAPPOINTER(A5),TEMP BLE.S OVERFLOW MOVEA.L ADDRESS,SP PEA (ADDRESS) JMP (RETURN) OVERFLOW CLR.L -(SP) RETURN NIL JMP (RETURN) * FUNCTION GETA7 : INTEGER; DEF ASM_GETA7 ASM_GETA7 EQU * LEA 8ENAB: BOOLEAN; BUSY: BOOLEAN; END; EPTYPE = PACKED RECORD B0 : BYTE; ID : BYTE; B2 : BYTE; B3 : BYTE; CASE BOOLEAN OF TRUE:(CONTROL:STATREG); FALSE:(STATUS:STATREG); END; E(A7),A0 MOVE.L A0,4(A7) RTS NOSYMS END PTR = ^EPTYPE; INFOPTR = ^EPINFOREC; PROCEDURE EPPROG( SCODE : INTEGER; OP : EPOPTYPE; ANYVAR BUFFER : WINDOW; BUFSIZE : INTEGER; VAR POSIT : INTEGER; VAR ECODE : EPERROR); CONST LO_ROM = HEX(' (* (c) Copyright Hewlett-Packard Company, 1984. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED 20000'); { 128k } HI_ROM = HEX('200000'); { 2048k } STEPSIZE = HEX('20000');{ 128k } TYPE TWOBYTES = PACKED ARRAY[0..1] OF CHAR; BREC = RECORD CASE INTEGER OF 0: (INT:INTEGER); 1: (BPTR:^BYTE); 2: (WPTR:^TWOBYTES)RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorad; 3: (CPTR:^CHAR); 4: (WINPTR:WINDOWP); END; VAR CARD : EPTR; PBYTE : BREC; DUMMY : INTEGER; DONE : BOOLEAN; ENDSCAN : INTEGER; I : INTEGER; WBYTES : TWOBYTES; o *) $SYSPROG$ $RANGE OFF$ $DEBUG OFF$ $ALLOW_PACKED ON$ {JWS 3/31/87} MODULE EDRIVER; IMPORT SYSGLOBALS,IODECLARATIONS,ASM; EXPORT TYPE EPINFOREC = RECORD BFAST : BOOLEAN; EPSTART : INTEGER; EPEND : INTEGER;INFO : INFOPTR; PROCEDURE BADIO(ECCODE:EPERROR); BEGIN ECODE := ECCODE; ESCAPE(0); END; PROCEDURE SETUP; BEGIN WITH INFO^ DO BEGIN IF EPSTART=0 THEN BADIO(ENOEPROM); ENDSCAN := POSIT + BUFSIZE; IF (POSIT27 THEN BADIO(ENOTPROG); END ELSE BADIO(ENOTPROG); INFO := ADDR(IO_TMP_PTR^.DRV_MISC); END; CASE OP OF EPINIT: { INITIALIZE THE CONTROL RECORD } BEGIN { VALIDATE THE CARD I FROM BUFFER TO EPROM } IF BUFSIZE>0 THEN BEGIN SETUP; WITH CARD^, INFO^ DO BEGIN TRY CONTROL.FAST := BFAST; { SET BURN SPEED } CONTROL.ENAB := TRUE; { ENABLE WRITE } I := 0; IF ODD(PBYTE.INT) THEN D } WITH ISC_TABLE[SCODE] , INFO^ DO BEGIN IF (CARD_TYPE=1) AND (CARD_ID=0) THEN BEGIN { FIX CARD TYPE AND ID } CARD_TYPE := 9; CARD_ID := 27; END; WITH CARD^ DO BEGIN ID := 0; { RESET THE CARD } { INITBEGIN { BURN FIRST BYTE } IF PBYTE.CPTR^<>BUFFER[I] THEN BEGIN { PATTERN NOT SAME SO BURN IT } PBYTE.CPTR^ := BUFFER[I]; WHILE CONTROL.BUSY DO; { WAIT FOR BURN TO FINISH } IF OP = EPCWRITE THEN { CHECK PATTERN AFTER BURN } IFIALIZE THE CONTROL RECORD } BFAST := STATUS.FAST; { SAVE PROGRAMMING SPEED } EPSTART :=0 ; {ADDRESS OF ATTACHED EPROM CARD} EPEND :=0 ; {ADDRESS OF LAST EPROM BYTE + 1} { FINDOUT WHICH EPROM CARD IS PBYTE.CPTR^<>BUFFER[I] THEN BADIO(EPFAIL); END; I := I + 1; PBYTE.INT := PBYTE.INT + 1; END; ENDSCAN := BUFSIZE-1; WHILE IBUFFER[I] THEN BEGIN { PATTERN NOT SAME SO BURN IT } PBYTE.CPTR^ := BUFFER[I]; WHILE CONTROL.BUSY DO; { WAIT FOR BURN TO FINISH } IF OP = EPCWRITE THEN { CHECK PATTERN AFTER BURN } GIN { FOUND THE EPROM CARD } DONE := TRUE; EPSTART := PBYTE.INT; EPEND := EPSTART + STEPSIZE; PBYTE.INT := EPEND; { CHECK FOR xx64 PARTS OR xx128 PARTS } IF EPENDBUFFER[I] THEN BADIO(EPFAIL); END; I := I + 1; PBYTE.INT := PBYTE.INT + 1; END ELSE BEGIN { BURN TWO BYTES } WBYTES[0] := BUFFER[I]; WBYTES[1] := BUFFER[I+1]; IF PBYTE.WPTR^<>WBYTES THEN BEGIN { PATTERNN CONTROL.ACCS := FALSE; { CLEAR THE ACCESS BIT } DUMMY := PBYTE.BPTR^; { ACCESS THE EPROM SPACE } IF STATUS.ACCS THEN EPEND := EPEND + STEPSIZE; END; END ELSE PBYTE.INT := PBYTE.INT + STEPSIZE; RECOVER NOT SAME SO BURN IT } PBYTE.WPTR^ := WBYTES; { BURN BOTH BYTES } WHILE CONTROL.BUSY DO; { WAIT FOR BURN TO FINISH } IF OP=EPCWRITE THEN { CHECK PATTERN AFTER BURN } IF PBYTE.WPTR^<>WBYTES THEN BADIO(EPFAIL); END; I  { IGNORE BUS ERRORS } IF ESCAPECODE<>-12 THEN ESCAPE(ESCAPECODE) ELSE PBYTE.INT := PBYTE.INT + STEPSIZE; DONE:=DONE OR (PBYTE.INT>=HI_ROM); UNTIL DONE; CACHE_ON; { 3.0 BUG FIX 3/13/84 } IF E:= I + 2; PBYTE.INT := PBYTE.INT + 2; END; { BURN TWO BYTES } END; { WHILE I0 THEN BEGIN SETUP; MOVELEFT(PBYTE.CPTR^,BUFFER[0],BUFSIZE); POSIT := ENDSCAN; END; EPWRITE,EPCWRITE: { MOVE DATAOL.ENAB:=FALSE; { TURN OFF WRITE ENABLE } POSIT := PBYTE.INT; { RECORD THE POSITION } IF ESCAPECODE<>0 THEN ESCAPE(ESCAPECODE); END; END; { WITH CARD^, INFO^ } END; EPBLANK: { CHECK THE EPROM SPACE FOR HEX FF } IF BU      ;BRATE : BOOLEAN):EPERROR; VAR I : INTEGER; ECODE : EPERROR; BEGIN I := ORD(BRATE); EPPROG(SCODE,EPBRATE,I,0,I,ECODE); EBRATE:=ECODE; END; FUNCTION EINIT(SCODE : INTEGER):EPERROR; VAR I : INTEGER; ECODE : EPERROR; BEGIN; {sectors/track} cdate : tdate; {volume create time} filler : packed array[21..123] of integer16; sdate : tdate; dummy4 : integer16; end; direntry = packed record fname : lifname;  EPPROG(SCODE,EPINIT,I,0,I,ECODE); EINIT:=ECODE; END; END.  ftype : integer16; fstart : integer; fsize : integer; fdate : tdate; lastvol : boolean; volnumber: word15; extension: integer; end; spacerec = record sstart : integer; ssiFSIZE>0 THEN BEGIN SETUP; REPEAT IF PBYTE.WPTR^[0]<>CHR(255) THEN DONE := TRUE ELSE PBYTE.INT := PBYTE.INT + 1; DONE := DONE OR (PBYTE.INT>=ENDSCAN); UNTIL DONE; POSIT := PBYTE.INT; IF POSIT0 THEN BEGIN SETUP; I := 0; REPEAT IF IOR(ORD(PBYTE.WINPTR^[I]),ORD(BUFFER[I]))=ORD(PBYTE.WINPTR^[I]) THEN I := I + 1 ELSE DONE := TRUE; DONE := DONE OR (I>=BUFSRIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, ColoradIZE); UNTIL DONE; POSIT := PBYTE.INT + I; IF I0; { SET BURN RATE } EPINFO: GETINFO(BUFFER); { GET BURN RATE AND ADDRESS INFO } END; { CASE } RECOVER Bo *) $MODCAL$ $DEBUG OFF, range off, ovflcheck off$ $ALLOW_PACKED ON $ { JWS 4/10/85 } program instlifdam; module lifmodule; import sysglobals, sysdevs, misc, fs; export procedure lifdam(anyvar f: fib; unum: unitnum; requestEGIN IF ESCAPECODE<>0 THEN ESCAPE(ESCAPECODE); END; END; { EPPROG } FUNCTION EPROG( SCODE : INTEGER; OP : EOPTYPE; ANYVAR BUFFER : WINDOW; BUFSIZE : INTEGER; VAR POSIT : INTEGER):EPERROR; VAR EO: damrequesttype); procedure installlifdam; implement const entrysize = 32; uxtype = -5813; { eft for uxfile } type vname =packed array[1..6] of char; lifname = packed array[1..10] of char; bcd = 0..15; word = 0..655P : EPOPTYPE; ECODE : EPERROR; BEGIN CASE OP OF EREAD : EOP:=EPREAD; EWRITE : EOP:=EPWRITE; ECWRITE: EOP:=EPCWRITE; EBLANK : EOP:=EPBLANK; ECHECK : EOP:=EPCHECK; END; EPPROG(SCODE,EOP,BUFFER,BUFSIZE,POSIT,EC35; integer16 = -32768..32767; word15 = 0..32767; tdate = packed array[1..12] of bcd; lvheader=packed record {volume header sector 0} discid : word; volname : vname; dstart : integer; dummy1 : ODE); EPROG:=ECODE; END; FUNCTION EGETINFO( SCODE : INTEGER; VAR INFO : EPINFOREC):EPERROR; VAR I : INTEGER; ECODE : EPERROR; BEGIN EPPROG(SCODE,EPINFO,INFO,0,I,ECODE); EGETINFO:=ECODE; END; FUNCTION EBRATE(SCODE : INTEGERinteger16; dummy2 : integer16; dsize : integer; version : integer16; dummy3 : integer16; tps : integer; {tracks/surface} spm : integer; {surfaces/medium} spt : integer      ze : integer; here : integer; hole : integer; end; catarray = array[1..maxint] of catentry; dirfile = file of direntry; var dir : ^dirfile; {****************************************************************************************************} procedure lifnametostr(anyvar ln :lifname ; var s:string); label 1; var sl : integer; fk : filekind; found : boolean; begin {lifname to str} pactostr(ln,10,s); sl := strlen(s); if sl=10 then*********} procedure goodio; begin if ioresult<>ord(inoerror) then escape(0); end; {****************************************************************************} procedure badio(result : iorsltwd); begin ioresult := ord(result); escape(0); end; { begin if suffix(s)=datafile then begin { rip underscores and try to add suffix } while (sl>=1) and (s[sl]='_') do sl := sl - 1; for fk:=untypedfile to lastfkind do begin if strlen(suffixtable^[fk])>0 then if suffixtable^[fk]****************************************************************************} procedure pactostr(anyvar pc: lifname; l:integer; var s:string); var i : integer; begin setstrlen(s,l); for i:=1 to l do s[i] := pc[i]; i := l; while (i>1) and[1]=s[sl] then begin { found suffix } { change last char to . then append suffix } setstrlen(s,sl); s[sl] := '.'; s := s + suffixtable^[fk]; goto 1; end; end; end; { for } end; 1:end; {lifname to str (s[i]=' ') do i:=i-1; setstrlen(s,i); end; {****************************************************************************} procedure strtopac(anyvar s:string255; l:integer; anyvar pc:lifname; sizechk:boolean); var i,k : integer; begin } {****************************************************************************} procedure strtolifname(var s:string; var ln:lifname); var sl, i : integer; stemp,temp2 : fid; {31jan83 temp2 for case insensitive suffix} fk if sizechk then if (strlen(s)>l) or (strlen(s)=0) then badio(ibadtitle); k:=strlen(s); for i:=1 to l do if i>k then pc[i] := ' ' else pc[i] := s[i]; end; {****************************************************************************} proc: filekind; begin {str to lifname} sl := strlen(s); fk := suffix(s); if fk=datafile then begin { data files have no suffix } if sl>10 then badio(ibadtitle); strtopac(s,10,ln,false); end else begin { reedure strtoany(var s:string; anyvar s2:string255); begin s2:=s; end; {****************************************************************************} procedure setdate(var d:tdate); var doy:daterec; tod:timerec; begin sysdate(doy); move the suffix } sl := strlen(s)-strlen(suffixtable^[fk]); if sl>10 then badio(ibadtitle); strtopac(s,10,ln,false); { pack the name } { replace dot with first char of suffix (to preserve uniqueness)} ln[sl] := suffixtable^[f systime(tod); with doy, tod do begin {LAF 880101 added "mod 10" to "div 10"} d[1] := year div 10 mod 10;d[2] := year mod 10; d[3] := month div 10; d[4] := month mod 10; d[5] := day div 10; d[6] := day mod 10; k][1]; sl := sl+1; for i:=sl to 10 do ln[i] := '_'; { pad with _ } end; lifnametostr(ln,stemp); { decompress the name as a final check } if stemp<>s then begin {31jan83 case insensitive suffix testing}  d[7] := hour div 10; d[8] := hour mod 10; d[9] := minute div 10; d[10] := minute mod 10; d[11] := (centisecond div 100) div 10; d[12] := (centisecond div 100) mod 10; end; end; {******************************************* temp2 := s; { copy s, then remove given suffix } setstrlen(temp2,strlen(temp2)-strlen(suffixtable^[fk])); temp2:= temp2 + suffixtable^[fk]; { add suffix from table } if stemp<>temp2 then badio(ibadtitle); { ch      n vvname := false; end end; {****************************************************************************} function lifvol:boolean; var i : integer; {31jan83 allow all blank volname} begin { read and validate the volume header }  of directory } fleof:=fpeof; fpos:=0; am:=amtable^[datafile]; freptcnt:=0; flastpos:=-1; fbufchanged:=false; fbuffered:=true; end; dindex:=1; read(dir^,dentry); goodio; end else escape(0); end; {  with fibp(dir)^, unitable^[unum] do begin fileid := 0; fpeof := maxint; { initialize dir } if uisblkd then begin call(tm,fibp(dir),readbytes,vol,sizeof(lvheader),0); with vol do ok := ((ioresult=ord(inoerror)) and (discid=327opendir } {****************************************************************************} procedure checkvolid; begin if f.fvid<>volid then badio(ilostunit); end; {****************************************************************************} peck again } end; end; {str to lifname} {****************************************************************************} {****************************************************************************} procedure lifdam(anyvar f: fib; unum: unitnum; req68) and (dummy1=4096) and (dummy2=0) and (dummy3=0) and { dstart=1 -> wsheader or LIF BOOT dir. if byteoffset } { = 0, then dstart=1 OK (LIF BOOT dir); otherwise, } { dstart=1 means wsheader, which we do NOT recognize } (((byteoffset = 0) auest: damrequesttype); var vol : lvheader; volid : vid; ok, mediavalid ,anychange: boolean; dindex, dlast, dend, vsize : integer; dentry : direntry; $iocheck off$ {**********************************nd (dstart >= 1)) or (dstart > 1)) and (dsize>0) and vvname); end else ok := false; ureportchange := true; { now let TM report any mediachanges } umediavalid := true; lifvol := ok; if ok then begin if vol.******************************************} function volsize:integer; begin if vsize=0 then vsize := ueovbytes(unum); volsize := vsize; end; {****************************************************************************} procedure cleanup; volname[1]=' ' then {31jan83 allow all blank volname} begin setstrlen(volid,6); for i:=1 to 6 do volid[i]:=' '; end else pactostr(vol.volname,6,volid); if volid<>uvid then begin mediavalid := false; uvid := volid; end; end else  begin if ioresult=ord(zmediumchanged) then mediavalid := false; unitable^[unum].umediavalid := mediavalid; unitable^[unum].ureportchange := true; end; {****************************************************************************} procesetstrlen(uvid,0); if (not ok) and (ioresult=ord(inoerror)) then ioresult:=ord(inodirectory); end; end; { lifvol } $iocheck on$ {****************************************************************************} procedure opendir; begin dure checkftitle; begin if (strlen(f.ftitle)>tidleng) or (strlen(f.ftitle)=0) then badio(ibadtitle); f.ftid := f.ftitle; end; {****************************************************************************} function vvname:boolean; var iif lifvol then begin dlast:=vol.dsize * 8; { # entries in directory } dend:=vol.dstart + vol.dsize; { directory end sector + 1 } with fibp(dir)^ do begin { initialize the fib ( fake OPEN )} fisnew:=false; fread : integer; b : boolean; begin vvname := true; b := true; for i := 1 to 6 do {1feb83 allow all blank names} begin if b then b := vol.volname[i]>' '; if not b then {1feb83 allow all blank names} if vol.volname[i]<>' ' theable:=true; fwriteable:=true; freadmode:=false; fbufvalid:=false; feof:=false; fmodified:=false; fileid:=vol.dstart*256; if vol.version>0 then vsize := vol.tps*vol.spm*vol.spt*256 else vsize := 0; fpeof:=vol.dsize*256; { end      rocedure flushdir; begin { june 83 fixed to account for ops which don't open the directory RDQ} if fibp(dir)^.freadable { directory open so flush thru AM } then call(fibp(dir)^.am,fibp(dir),flush,ioresult,0,0) { directory not open so flush thruclean dir} {****************************************************************************} procedure crunchv; { assumed to be called from procedure lifdam only 24jan83} var frompos, topos, todindex : integer; bsize, filesize, movesize : in TM } else call(unitable^[unum].tm,fibp(dir),flush,ioresult,0,0); anychange := false; end; {****************************************************************************} procedure getsdate(anyvar svdate:daterec); begin if lifvol then teger; bufptr, heapmark : windowp; changed : boolean; datafib : fibp; begin opendir; checkvolid; if strlen(f.ftitle)<>0 then badio(ibadtitle); cleandir; { allocate the buffer with vol, svdate do begin if not ((sdate[5]=0) and (sdate[6]=0)) then begin {LAF 880101 conditionally add 100 to year; year range is 28..127} year:=sdate[1]*10+sdate[2]; if year<28 then year:=year+100; month:=sdate[3]*10+sdate[4]; day: space } MARK(heapmark); try bsize:=(memavail-(1024*5)); if bsize>=256 then begin { buffer in sector multiples } bsize:=(bsize div 256) * 256; newwords(bufptr,bsize div 2); new(datafib); { set up the data fib } with da=sdate[5]*10+sdate[6]; end; end; end; {****************************************************************************} procedure setsdate(anyvar svdate:daterec); var i : integer; begin if lifvol then with svdate, vol do btafib^ do begin funit:=fibp(dir)^.funit; fileid:=0; fpeof:=volsize; fleof:=fpeof; end; end else escape(-2); { not enough room to run } { krunch it } dindex:=1; todindex:=0; topos:=dend*256; anychanegin {LAF 880101 added "mod 10" to "div 10"} sdate[1]:=year div 10 mod 10; sdate[2]:=year mod 10; sdate[3]:=month div 10; sdate[4]:=month mod 10; sdate[5]:=day div 10; sdate[6]:=day mod 10; for i:=7 to 12 do sdate[i]:=0; {cge:=false; repeat changed:=false; readdir(dir^,dindex,dentry); if dentry.ftype=-1 then dindex:=dlast else if dentry.ftype=efttable^[badfile] then begin { bad sectors ; don't move this file } todindex:=todindex+1; if dindex<>todindex thelear time of day} with unitable^[unum] do begin call(tm,fibp(dir),writebytes,vol,sizeof(lvheader),0); goodio; anychange := true; end; end; end; { setsdate } {**************************************************************n changed:=true; { move the entry } topos:=(dentry.fstart+dentry.fsize)*256; { move topos } end else if dentry.ftype=0 then anychange := true { found purged entry } else begin { move the file ? } todindex:=todindex+1; if din**************} procedure cleandir; var k : integer; tempd : direntry; begin {cleandir} k:=1; seek(dir^,k); repeat read(dir^,tempd); if tempd.ftype=-1 then k:=dlast else if tempd.ftype<>0dex<>todindex then changed:=true; { move the entry} frompos:=dentry.fstart*256; if frompos<>topos then begin { move the data } filesize:=dentry.fsize*256; { bytes to move} dentry.fstart:=topos div 256; { set start}  then begin if (tempd.fdate[3]=9) and (tempd.fdate[4]=9) then begin { temp file so purge it } tempd.ftype:=0; writedir(dir^,k,tempd); anychange := true; end; end; k:=k+1; until k>dlast; mediavalid := true; end; {changed:=true; with unitable^[datafib^.funit] do repeat if filesize>bsize then movesize:=bsize else movesize:=filesize; call(tm,datafib,readbytes,bufptr^,movesize,frompos); frompos:=frompos+movesize; goodio; call(tm,datafib,wri      0; version := 0; end else checkvolid; { directory size checks } dstart := 2; dsize := (((cextra1*entrysize)+255) div 256); if dsize<=0 then dsize := 10; { default directory size } { size checks } actualsize := e.day=0) then begin date.year:=70; date.month:=1; date.day:=1; end; time.hour:=fdate[7]*10+fdate[8]; time.minute:=fdate[9]*10+fdate[10]; time.centisecond:=(fdate[11]*10+fdate[12])*100; end; {********************************************ueovbytes(unum); if (cpsize>actualsize) or (cpsize<1024) then badio(inoroom); if (dstart+dsize+1)*256>=cpsize then badio(inoroom); { fill in the pieces } strtopac(cname,6,volname,true); { volume name } if version>0 then if (tps********************************} procedure doopendirectory(anyvar cat:catentry); begin opendir; checkvolid; with cat do begin { volume info } cname:=volid; cstart:=(vol.dstart+vol.dsize)*256; { start of data area }tebytes,bufptr^,movesize,topos); topos:=topos+movesize; goodio; filesize:=filesize-movesize; until filesize=0; end { move the data } else topos:=topos+dentry.fsize*256; end; { move the file ? } if changed then begin writedir(d*spm*spt*256)<>cpsize then version := 0; setdate(cdate); { fill in create date } for i := 1 to 12 do sdate[i] := 0; { clear system date } if version=0 then begin { create pseudo level 1 header } version := 1; tps := 1; spmir^,todindex,dentry); anychange := true; end; dindex:=dindex+1; until dindex>dlast; if anychange then begin { put end of directory mark } if todindexlastfkind) and (efttable^[fk]<>lt) do fk:=succ(fk); if efttable^[***********************************} procedure domakedirectory(anyvar cat:catentry); var i : integer; actualsize : integer; secbuf : packed array[0..63] of integer; begin if strlen(f.ftitle)>0 then badio(ibadrequest); with vofk]<>lt then fk:=DATAFILE; end; {****************************************************************************} procedure cvtdatetime(var fdate:tdate; var date:daterec; var time:timerec); begin {LAF 880101 conditionally add 100 to year; year rangl, cat do begin if not lifvol then begin if (ioresult<>ord(inoerror)) and (ioresult<>ord(inodirectory)) then escape(0); ioresult := ord(inoerror); { clear header fields } discid := 32768; dummy1 := 4096; dummy2 := 0; dummy3 := e is 28..127} date.year:=fdate[1]*10+fdate[2]; if date.year<28 then date.year:=date.year+100; date.month:=fdate[3]*10+fdate[4]; date.day:=fdate[5]*10+fdate[6]; {LAF 880101 changed default to 1Jan70 from 1Mar00} if (date.month=0) or (dat      cblocksize:=256; { No. of bytes in allocation unit } cpsize:=volsize; { physical size of the volume } clsize:=cpsize-cstart; { data space on the medium } cextra1:=vol.dsize*8; { nuolnumber; if lastvol then cinfo:='' else cinfo := 'continued'; end { with } end { report this entry } else dstart := dstart-1; end; { count this entry } di:=di+1; if di>dlast then done := true; end; { while } endmber of possible files } cextra2:=-1; { unused space available } cvtdatetime(vol.sdate,clastdate,clasttime); { system date } cvtdatetime(vol.cdate,ccreatedate,ccreatetime);{ date created } cinfo:='LIF lev; {docat} {****************************************************************************} function findfile(temporary:boolean; ftypecode:integer16):boolean; var found : boolean; tempname : lifname; begin {find file} if not f.fanonymel '; cinfo[11]:=chr(vol.version+ord('0')); end; { volume info } end; {****************************************************************************} procedure docat(anyvar cat : catarray); var di, dstart, dnum : integer; done ous then strtolifname(f.ftid,tempname); found:=false; dindex:=1; seek(dir^,dindex); repeat read(dir^,dentry); with dentry do begin if ftype=-1 then dindex:=dlast else if ftype<>0 then begin { check this entry }  : boolean; procedure zerodatetime(var dr:daterec; var tr:timerec); begin {LAF 880101 changed default to 1Jan70 from 1Mar00} dr.year:=70; dr.month:=1; dr.day:=1; tr.hour:=0; tr.minute:=0; tr.centisecond:=0; end; begin if f.fanonymous then found:=(dentry.fstart*256 = f.fileid) else if (tempname=fname) then if ((ftypecode=0) or (ftypecode=ftype)) then begin if temporary then found:=(fdate[3]=9) and (fdate[4]=9) else found:=(fdate[3]<>9) or (f {docat} opendir; checkvolid; dstart:=f.fpos; dnum:=f.fpeof; f.fpeof:=0; di:=1; seek(dir^,di); done:=false; while (f.fpeof9); end; end; end; { with } if not found then dindex:=dindex+1; until (dindex>dlast) or found; findfile:=found; end; {find file} {****************************************************************************} pro=-1 then done:=true else { don't show temporary or purged files } if (dentry.ftype<>0) and ((dentry.fdate[3]<>9) or (dentry.fdate[4]<>9)) then begin { count this entry } if dstart<=0 then { skip to start index } begin { recedure purgef; begin dentry.ftype := 0; writedir(dir^,dindex,dentry); flushdir; end; {****************************************************************************} procedure dopurgename; begin opendir; checkvolid; checkftitle; iport this entry } f.fpeof := f.fpeof+1; with dentry, cat[f.fpeof] do begin lifnametostr(fname,cname); ceft := ftype; liftofkind(ceft,ckind); cpsize := fsize*256; if (ftype=-5622) {workstation data} or (ftype=uxtype) f findfile(false,0) then purgef else ioresult := ord(inofile); end; {****************************************************************************} procedure getspace(space:integer; var srec:spacerec); var fixed, done, opening : bo {workstation ux} then clsize:=extension else clsize := cpsize; cstart := fstart*256; cblocksize := 256; zerodatetime(ccreatedate,ccreatetime); cvtdatetime(fdate,clastdate,clasttime); cextra1 := extension; cextra2 := volean; lastused, lastopening : integer; dataspace : integer; mostavail, nextavail : spacerec; procedure shuffle; var tempentry : direntry; increment, here, hole : integer;      { exact fit } or { this space is bigger than previous good fit } (((dataspace-space)>(mostavail.ssize-space)) and (mostavail.ssize<>space)) then allocate(mostavail,eod); if mostavail.hole>0 then done := true; end; { fixed space checiv 256) - lastused - 1; if dataspace>0 then checkspace(true);{check space at end of directory} { set lastopening so outer proc. won't think directory is full } if lastopening=0 then lastopening := dindex; if (mostavail.hole=0) and (mostavail.sstart>0) k } if not fixed then begin { biggest or 2nd biggest } check2 := true; if (dataspace>=mostavail.ssize) then begin { check biggest space } if (dataspace>mostavail.ssize) then begin { new biggest space } nextavail := mostavaithen mostavail.hole := lastopening; if (nextavail.hole=0) and (nextavail.sstart>0) then nextavail.hole := lastopening; done := true; lastused := (volsize div 256) + 1; end else if dentry.ftype=0 then begin { hole in the  begin { move directory entries to open a required space } here := mostavail.here; hole := mostavail.hole; if here<=hole then begin if hole0 then temp := dindex -1 ); if tempentry.ftype=-1 then begin writedir(dir^,hole + 1,tempentry); anychange := true; end; end; increment := -1; end else increment := 1; while hole<>here do begin readdir(dir^,hole+increment,tempentry);  else temp := dindex; if (abs(temp-lastopening)<=abs(mostavail.here-mostavail.hole)) or (lastopening=0) then with mostavail do begin { this causes shorter shuffle } ssize := dataspace; sstart := lastused +writedir(dir^,hole,tempentry); anychange := true; hole := hole + increment; end; tempentry.ftype:=0; writedir(dir^,here,tempentry); anychange := true; end; { shuffle } procedure allocate(var srec : spacerec; eod : bo 1; here := temp; hole := lastopening; end; end; { same size space } end; { check biggest space } if check2 then if (dataspace>=nextavail.ssize) and (space<0) then begin { check 2nd biggest space } if dataspace>olean); begin srec.ssize := dataspace; srec.sstart := lastused + 1; if eod then begin { end of directory allocation } if opening then srec.here := lastopening else srec.here := dindex; srec.hole := srec.here; end nextavail.ssize then allocate(nextavail,eod) else if not eod then begin { same size space } if opening then temp := lastopening else if lastopening>0 then temp := dindex -1 else temp := dindex; if (abs(temp-lastop else begin { middle of directory allocation } if opening then srec.here := lastopening else if lastopening>0 then srec.here := dindex-1 else srec.here := dindex; srec.hole := lastopening; end; end; { allocate } ening)<=abs(nextavail.here-nextavail.hole)) or (lastopening=0) then with nextavail do begin { this causes shorter shuffle } ssize := dataspace; sstart := lastused + 1; here := temp; hole := lastopening; end; procedure checkspace(eod : boolean); var temp : integer; check2 : boolean; begin if fixed and (dataspace>=space) then begin { fixed space check } if (mostavail.ssize=0) { no space yet } or (dataspace=space) end; end; { same size space } end; { biggest or 2nd biggest } end; {checkspace} procedure checkentry; begin { checkentry } if dentry.ftype=-1 then begin { logical end of directory } dataspace := (volsize d     directory } if not opening then begin opening := true; lastopening := dindex; if mostavail.sstart>0 then with mostavail do begin { adjust fixed/biggest space } if hole=0 then hole := lastopening else if (abs(hole-he dindex := dlast + 1; {insurance policy } if (not fixed and (dataspace>mostavail.ssize)) or ((space<0) and (dataspace>nextavail.ssize)) or (fixed and (dataspace>=space)) then checkspace(false); end; end; if mostavail.sstart=0 re)>abs(lastopening-here)) then begin { hole changed direction from entry } here := here + 1; hole := lastopening; end; if fixed then done := true; end; { with } if (space<0) and (nextavail.sstart>0) then with nextavailthen badio(inoroom); if fixed then mostavail.ssize := space else with mostavail do begin { final decision for non fixed space } { watch for [*] type allocation } { biggest of (1/2 biggest or 2nd biggest) } { include any odd s do begin { adjust second biggest space } if hole=0 then hole := lastopening else if (abs(hole-here)>abs(lastopening-here)) then begin { hole changed direction from entry } here := here + 1; hole := lastopening; ector } if space<0 then ssize:=(ssize div 2) + (ssize mod 2); if nextavail.ssize>=ssize then mostavail:=nextavail; end; shuffle; { allign dataspace and directory entry } srec := mostavail; end; end; {getspace} {**************** end; end; end; end { hole in the directory } else begin { have file entry } dataspace := dentry.fstart - lastused - 1; if dataspace>0 then checkspace(false); { if no dataspace yet, move lastopening to end of series } if************************************************************} procedure finishfib; begin f.fileid := dentry.fstart*256; f.fpeof := dentry.fsize*256; if f.fisnew then f.fleof := 0 else f.fleof := f.fpeof; f.fmodified := f.fisn (mostavail.sstart=0) and opening then lastopening := dindex - 1; opening := false; lastused := dentry.fstart + dentry.fsize - 1; end; end; {checkentry} begin {getspace} dindex := 1; seek(dir^,dindex); if space>0 then begin fixew; if not f.fbuffered then f.am := amtable^[UNTYPEDFILE] else if f.fistextvar then f.am := amtable^[f.fkind] else f.am := amtable^[datafile]; end; {finishfib} {***********************************************************************ed:=true; space:=(space+255) div 256; end else fixed:=false; lastused := dend - 1 ; lastopening := 0; mostavail.sstart:= 0; nextavail.sstart:= 0; mostavail.ssize := 0; nextavail.ssize := 0; mostavail.hole := 0; n*****} procedure opennew; var space : spacerec; begin getspace(f.fpos,space); dindex := space.here; { fill in the lif directory entry } {file name} if f.fanonymous then dentry.fname := 'anonymous ' else strtolifnamextavail.hole := 0; mostavail.here := 0; nextavail.here := 0; done := false; opening := false; repeat read(dir^,dentry); checkentry; dindex := dindex + 1; if not done then done := dindex>dlast; e(f.ftid,dentry.fname); dentry.ftype := f.feft; dentry.fstart := space.sstart; dentry.fsize := space.ssize; setdate(dentry.fdate); dentry.fdate[3] := 9; dentry.fdate[4] := 9; { mark as temporary } dentry.lastvol := truuntil done; if lastopening=0 then badio(idirfull) else begin { have at least one directory opening } if (mostavail.sstart=0) or not fixed then begin dataspace := (volsize div 256) - lastused - 1; if dataspace>0 then begin e; dentry.volnumber := 1; dentry.extension := 0; writedir(dir^,dindex,dentry); {write it out} flushdir; { finish the file fib } finishfib; end; {opennew} {****************************************************************************}     tempdentry.fsi*************************} procedure dooverwritefile; begin opendir; checkvolid; if f.fanonymous then badio(ibadrequest); checkftitle; f.fisnew := true; if findfile(false,0) then begin { existing file } if not media procedure openold; var fk:filekind; begin liftofkind(dentry.ftype,fk); f.fkind:=fk; finishfib; with dentry do begin f.fstartaddress := 0; f.feft := ftype; if (ftype=efttable^[datafile]) or (ftype=uxtype) thenze then begin while (not found) and (not eod) do with dentry do begin tempindex := tempindex + 1; if tempindex>dlast then eod := true else begin readdir(dir^,tempindex,dentry); if ftype=-1 then eod := true else if ftyp f.fleof := extension else f.fstartaddress := extension; end; end; {****************************************************************************} procedure openf; begin opendir; checkvolid; if not (f.fanonymous and f.fisnew) then e<>0 then begin found := true; dataspace := dentry.fstart - filestart; end; end; end; { while with } if eod then begin { dataspace is from begining of file to end of volume } found:=true;  checkftitle; if f.fisnew then begin { new temp file } if not mediavalid then cleandir; if f.fanonymous then opennew else if findfile(f.fisnew,0) then ioresult:=ord(idupfile) else opennew; end else { ex {25jan83} dataspace := (volsize div 256) - filestart; {25jan83} end; if found then if dataspace>=reqsize then {25jan83} begin { will stretch } readdir(dir^,dindex,dentry); { allow requestedisting permanent file } begin if findfile(f.fisnew,0) then begin openold; if not mediavalid then cleandir; end else ioresult:=ord(inofile); end; end; { openf } {********************************************************* space + half of excess space 25jan83 } dentry.fsize := (reqsize + dataspace) div 2; {25jan83} writedir(dir^,dindex,dentry); flushdir; f.fpeof := dentry.fsize * 256; end; { will stretch } end; end; { stretchf } {********************************} procedure closef; var temp : integer; begin if f.fisnew then begin { purge old file } temp:=dindex; if findfile(false,0) then purgef; dindex:=temp; readdir(dir^,dindex,dentry); end; if f***************************************************************} procedure changefname(anyvar n:string255); var tempindex : integer; ok : boolean; begin if f.fanonymous then badio(ibadrequest); opendir; checkvolid; check.fmodified then with dentry do begin { rewrite the directory entry } if (ftype=efttable^[datafile]) or (ftype=uxtype) then extension := f.fleof else extension := f.fstartaddress; temp:=(f.fleof+255) div 256; if ftitle; { find the original (permanent file) } if not findfile(false,0) then badio(inofile); { change the name } tempindex := dindex; if (strlen(n)=0) or (strlen(n)>tidleng) then badio(ibadtitle); f.ftid := n; if findfile(false,     valid then cleandir; openold; f.fleof := 0; { setup fib then reset logical eof } setdate(dentry.fdate); dentry.fdate[3] := 9; dentry.fdate[4] := 9; { now a temporary file } writedir(dir^,dindex,dentry); anychange := true; :begin end; makedirectory: domakedirectory(f.fwindow^); openunit, openvolume : begin cleanup; unblockeddam(f,unum,request); mediavalid := unitable^[unum].umediavalid; end; setunitprefix: if strlen(f.ftitle)>0 then badio(ibadtitle end else begin { new file } if not mediavalid then cleandir; opennew; end; end; { dooverwritefile } {****************************************************************************} procedure nowopen; begin opendir; ); stripname : begin checkftitle; setstrlen(f.ftitle,0); strtolifname(f.ftid,dentry.fname); end; otherwise ioresult := ord(ibadrequest); end; { case request } if anychange then flushdir; cleanup; { fix umediava if f.fvid<>volid then ioresult:=ord(ilostfile) else if not findfile(f.fisnew,f.feft) then ioresult:=ord(ilostfile); goodio; end; {****************************************************************************} {****************************lid and ureportchange } recover begin cleanup; { fix umediavalid and ureportchange } if (escapecode<0) and (escapecode<>-10) then begin lockdown; escape(escapecode); end; end; lockdown; end; procedure installlifdam; begi************************************************} begin {lifdam} lockup; mediavalid := unitable^[unum].umediavalid; { tell TM to keep quiet about media changes for a while } unitable^[unum].umediavalid := true; unitable^[unum].urepon if dir=nil then new(dir); end; end; { module } import lifmodule,loader; begin { instlifdam} installlifdam; markuser; end.{ rev 2.2x1 } rtchange := false; fibp(dir)^.funit := unum; fibp(dir)^.freadable := false; ioresult := ord(inoerror); anychange := false; try case request of openfile : begin f.fisnew := false; openf; end; createfile: begin f.fisne(* (c) Copyright Hewlett-Packard Company, 1985, 1986. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTw := true; openf; end; overwritefile : dooverwritefile; closefile : if f.fmodified then begin nowopen; closef; end; purgefile : begin nowopen; purgef; end; stretchit : begin nowopen; stretchf; end; changename: changefname(f.fwindow^); getvolumename: S LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado  begin ok := lifvol; strtoany(unitable^[unum].uvid,f); end; setvolumename: if lifvol then begin strtopac(f,6,vol.volname,true); with unitable^[unum] do begin call(tm,fibp(dir),writebytes,vol,sizeof(lvheader),0);  *) $sysprog$ $stackcheck off$ $heap_dispose off$ $iocheck off$ $range off$ $ovflcheck off$ $debug off$ program mouseinit; module mouse; { mouse module } import sysdevs,sysglobals; export function initmouse:boolean; implement  goodio; anychange := true; end; end; purgename : dopurgename; getvolumedate: getsdate(f); setvolumedate: setsdate(f); crunch : crunchv; catalog : docat(f.fwindow^); opendirectory: doopendirectory(f.fwindow^); closedirectorytype sint = -32768..32767; pollblock = packed record case integer of 0:(d: packed array[1..7] of byte); 1:(twosets : boolean; kcodes : 0..3; filler : 0..7; numaxes : 0..3; xdata : sint; ydata      high byte } begin gdata.d[devstate-1]:=databyte; devstate:=devstate+1; cindex:=cindex+1; if cindex>=gdata.numaxes then devstate:=8; end; 8:begin { keydata } case gdata.kcodes of 0:; { not supposed to be any data } 1:begin data.ydata := - gdata.ydata; {case knob and HIL NIMITZ} {and reverse y-axis} check(2,gdata.ydata); if done then begin call(rpgisrhook,statbyte,databyte,done); gdata.xdata:=0; end; end; end; resetdevice: doreset; { is all ready ascii } statbyte:=0; call(kbdisrhook,statbyte,databyte,doit); {SFB--6/6/85} end; otherwise { key code data } k.b:=databyte; keystate[k.col]:=k.up; { record the state } if not k.up then begin statbyte otherwise begin end; {SFB 4/10/85 for uninitdevice opcode, etc.} end; end; { mopsproc} function initmouse:boolean; const ndrivers=2; type idarraytype = array[1..ndrivers] of integer; const lowids = idarraytype[96,22 : sint; zdata : sint) end; lkeytype = packed record case integer of 0:(b:byte); 1:(row:0..15; col:0..7; up : boolean) end; kmtype = array[0..7] of byte; const mkeymap = kmtype[3,13,{8} 30,0,0,0,0,0:=0; databyte:=mkeymap[k.col]; call(kbdisrhook,statbyte,databyte,doit); {SFB--6/6/85} end; {if not k.up} end; {case gdata.kcodes} end; {case 8} end; {case devstate} end; {mdataproc} procedure mopsproc(op:loopdvrop); v]; { ex,cr,rs,.... } {BUTTON 3 CHANGED FROM bs (LEFT ARROW) TO rs 4/17/85 SFB} var driver : loopdvrptr; keystate : array[0..7] of boolean; cumdata : array[1..3] of integer; gdata : pollblock; cindex : 0..3; procedure dar limit : integer; statbyte,databyte : byte; done : boolean; procedure check(i:integer;d:sint); begin cumdata[i]:=cumdata[i]+d; done:=false; if abs(cumdata[i])>limit then begin done:=true; if (i=1) then begin oreset; var i : sint; begin for i:=0 to 7 do keystate[i]:=true; { all keys up } for i:=1 to 7 do gdata.d[i]:=0; for i:=1 to 3 do cumdata[i]:=0; end; {parameter done changed to doit, SFB--6/6/85} procedure mdataproc(var statbyte,databstatbyte:=hex('FF'); { normal} { x } if d>0 then databyte:=255 else databyte:=1; end else begin statbyte:=hex('EF'); { shift } { y } if d>0 then databyte:=1 else databyte:=255; end; cumdata[i]:=0; end; end; { check } begin { mopyte:byte; var doit:boolean); var k : lkeytype; begin {mdataproc; mouse data proc } if doit then {SFB--6/6/85} WITH LOOPCONTROL^ DO {4/9/84 SFB} with loopdevices[loopdevice] do case devstate of 1:begin gdata.d[sproc; mouse ops } WITH LOOPCONTROL^ DO {4/9/84 SFB} with loopdevices[loopdevice] do case op of datastarting: begin {3.1E BUGFIX SFB--6/6/85} devstate:=1; gdata.xdata := 0; {zero OPTIONAL pollblock value1]:=databyte; cindex:=0; if gdata.numaxes=0 then devstate:=8 else devstate:=2; end; 2,4,6: begin { co-ord data } { low byte } if not descrip.size16 then if databyte>127 then gdata.d[devstate]:=255 { sign extend } else gdata.d[devs SFB} gdata.ydata := 0; {zero OPTIONAL pollblock values SFB} gdata.zdata := 0; {zero OPTIONAL pollblock values SFB} end; dataended: begin if descrip.size16 then limit:=descrip.counts div 8 else limit:=descrip.counts state]:=0; gdata.d[devstate+1]:=databyte; devstate:=devstate+1+ord(not descrip.size16); if not descrip.size16 then begin { 8 bit mode } cindex:=cindex+1; if cindex>=gdata.numaxes then devstate:=8; end; end; 3,5,7: { co-ord data } {div 800; check(1,gdata.xdata); if done then begin call(rpgisrhook,statbyte,databyte,done); gdata.ydata:=0; end else begin if (descrip.id = hex('60')) OR (descrip.id = hex('e0')) then {added 5/2/85 SFB to special} g     4]; highids = idarraytype[127,224]; var i: integer; begin if hil_present and (driver=nil) then begin for i:=1 to ndrivers do begin new(driver); with driver^ do begin { initialize driver log in record } lowid:=lowids[i]; ights reserved. iUCSD_DAM aiSWAP8 alkq lh1 oEDRIVER. iEDRIVER akq ********************************************************************* * Compile ETU down here cause it needs EDRIVER. ********************* ************************************************ { all relative pointers } highid:=highids[i]; daddr:=0; { any device address } opsproc:=mopsproc; { set procedure vars } dataproc:=mdataproc; next:=loopdriverlist; { add to driver list } loopdriverlist:=driver; end; ********************* cETU n lh1 oETU ldx Copyright Hewlett-Packard Co.,1984,1991 All rights reserved. iETU aiEDRIVER alkq lh1 oSEGMENTER. iALLOCATE aiSEGMENTER akq lh50 oLIBRARY. iRANDOM aiHEAPT aiUNITIO aiLOCKMOD akq lh1 oIO. iXKERNEL aiXCOMASM aiIO end; if LOOPCONTROL^.loopisok {4/9/84 SFB} then CALL(HPHILCMDHOOK,CONFIGUREOP); {4/9/84 SFB} initmouse:=true; end else initmouse:=false; end; { initloop } end; { mouse interface module } import mLIB akq ********************************************************************** * DONE LINKING MISC INITLIB THINGS .. ******************************** ********************************************************************** ouse, loader; begin if initmouse then markuser; end. $MODCAL$ $ALLOW_PACKED ON$ $RANGE OFF$ $STACKCHECK OFF$ MODULE SYS_BOOT; EXPORT TYPE string12 = string[12]; function sysboot(name,msus,lanid:string12):integer; IMPLEMENT IMPORT SYSGLOBALS,ASM,IODECLARATIONS; function sysboot(name,msus,lanid:stri*************************************************************** * MISC INITLIB MODULES and Libraries ... ********************** *************************************************************** cEXPORT n cKERNEL n aCOMASM n xEXPORT COMASM.CODE XCOMASM.COng12):integer; CONST hp98643 = 21; TYPE msus_type = packed record case integer of 1:(df : 0..7; { directory format } dt : 0..31; { device type } unum : byte; { unit nuDE xEXPORT KERNEL.CODE XKERNEL.CODE cIOLIB n cLOCKMOD n cHEAPT n aRANDOM n cUNITIO n cSYSBOOT n cHPHIL n cMOUSE n cLIFDAM n cUCSD_DAM n aSWAP8 n cEDRIVER n aALLOCATE n cSEGMENTER n ***********************************************************mber } scode : byte; { select code } baddr : byte); { bus address } 2:(pad1 : byte; vol : 0..15; { volume number } un : 0..15); { unit number } 3:(bytes : packed ar************ * NOW LINKEM ... ****************************************************** *********************************************************************** lh1 oHPHIL. lnHPHIL dx Copyright Hewlett-Packard Co.,1984,1991 All rights reserved. iHPHIL alkq lray [1..4] of char); end; name_type = packed array [1..10] of char; lanid_type= packed array [1..6] of char; lanid_ptr = ^lanid_type; VAR bootmsus [hex('FFFFFEDC')] : msus_type; sysname [hex('FFFFFDC2')] : name_type; h1 oMOUSE. lnMOUSE dx Copyright Hewlett-Packard Co.,1984,1991 All rights reserved. iMOUSE alkq loLIF_DAM. lnLIF_DAM x Copyright Hewlett-Packard Co.,1983,1991 All rights reserved. iLIFDAM alkq loWS1.0_DAM. lx Copyright Hewlett-Packard Co.,1982, 1991 All r farea [hex('FFFFFED4')] : lanid_ptr; bootrec : record case boolean of false :( boot : procedure); true :( op1,op2 : integer); end; newmsus : msus_type; newname : name_type; i, mlen, number : inte     nd; 'S':begin { SCSI } msus.dt := 14; end; 'U':begin { 913X_A } msus.dt := 7; end; 'V':begin { 913X_B } msus.dt := 8; end; 'W':begin { 913X_C } msus.dt := 9; end; otherwise escape] := chr(number); end else number := chr_hex(lanid[i]); end; end; recover if (escapecode = -10) or (escapecode = -8) then escape(3) { bad LAN address } else escape(escapecode); sysname := newname; bootmsus := ne(2); end; { case } end; end; { fsunit_msus } BEGIN { SYSBOOT } try bootrec.op1 := hex('1C0'); bootrec.op2 := 0; { process the system name } name := strrtrim(strltrim(name)); if strlen(name)>10 then escape(1); { bad system name } iwmsus; ci_switch; cache_mode(false); { setup bootrom environment } call(bootrec.boot); recover begin if (escapecode>0) and (escapecode<4) then sysboot := escapecode else escape(escapecode); end; END; { SYSBOOT } END. { ger; { input is pre-filtered to be 0..9, A..F, a..f } function chr_hex(c:char):integer; begin if (c>='0') and (c<='9') then chr_hex := ord(c)-ord('0') else if (c>='A') and (c<='F') then chr_hex := ord(c)-ord('A')+10 else chr_hf name<>'' then begin newname := ' '; for i := 1 to strlen(name) do newname[i] := name[i]; end else newname := sysname; { process the MSUS } newmsus := bootmsus; {default the MSUS} msus := strrtrim(strltrim(msus)); { trim leadingex := ord(c)-ord('a')+10 end; { chr_hex } procedure fsunit_msus(fsunit : unitnum; var msus : msus_type); begin if (fsunit<0) or (fsunit>maxunit) then escape(2); with unitable^[fsunit] do begin msus.df := 0; msus.scode := sc;  & trailing blanks } mlen := strlen(msus); try if (mlen>0) then begin if msus[1]='#' then begin { file system unit } if (mlen=2) or (mlen=3) then strread(msus,2,i,number) else escape(2); fsunit_msus(number,newmsus msus.baddr := ba; msus.unum := du; case letter of 'B':begin { BUBBLE } msus.dt := 22; end; 'E':begin { EPROM } msus.dt := 20; msus.unum := dv; { bootrom uses unit, table uses volume } end; ); end else if msus[1]='$' then begin { constructed MSUS } if mlen<>9 then escape(2); { must have 8 digits } for i := 2 to 9 do if not(msus[i] in ['0'..'9','A'..'F','a'..'f']) then escape(2); for i := 2 to'F':begin { 9885 } msus.dt := 6; end; 'G':begin { SRM } msus.df := 7; msus.dt := 1; end; 'H':begin { 9895 } msus.dt := 4; end; 'J',{ PRINTER } 'R':{ RAM } escape(2); 'M':begin { internal  9 do begin if odd(i) then begin number := (number*16)+chr_hex(msus[i]); newmsus.bytes[i div 2] := chr(number); end else number := chr_hex(msus[i]); end; end else escape(2); end; recover if (escapecode = mini } msus.dt := 0; end; 'N':begin { 8290X } msus.dt := 5; end; 'Q':begin { C280 } msus.vol := dv; msus.un := du; { must force disc access to determine sector size } { will hang system if intlevel is too hig-10) or (escapecode = -8) then escape(2) { bad MSUS } else escape(escapecode); { process the lanid } try if strlen(lanid)>0 then begin if strlen(lanid)<>12 then escape(3); for i := 1 to 12 do if not(lanid[i] ih } if intlevel>2 then escape(2); call(dam,uvid,fsunit,getvolumename); if (ioresult<>0) or (strlen(uvid)=0) or (dvrtemp2<8) then escape(2) else if dvrtemp2=8 then msus.dt := 16 else msus.dt := 17; en ['0'..'9','A'..'F','a'..'f']) then escape(3); for i := 1 to 12 do begin if not odd(i) then begin number := (number*16)+chr_hex(lanid[i]); if i=2 then if odd(number) then escape(3); { can't be multicast } farea^[i div 2     MODULE SYS_BOOT }  true: ( longform: integer ); false: ( highbyte: 0..255; lower3: pointer ) end;} mp = ^memblock; memblock = {packed} record smallsize: 0..255; link: pointer; case {smallsize=0} boolean of true: ( bigsize: in (* (c) Copyright Hewlett-Packard Company, 1986. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHteger ) end; freearray = array [allists] of pointer; dsap = ^dsa; dsa = record fakeone: memblock; freelist: freearray; wordsdisposed: integer; dirty: boolean; end; { procedure Newwords (var p:anyptr; woTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado rdlen:integer); external; } {function longpointer (p:pointer): integer; var t: pointertrick; begin t.lower3 := p; t.highbyte := 255; longpointer := t.longform end;} {function shortpointer (p:integer): pointer; var t: pointertrick; *) (* Roger Ison - 3/2/83 - 3:32 pm *) (* Modified for 32-bit addresses SFB - 9/2/86 *) $modcal,debug off,range off$ $stackcheck off$ (* 2-Mar-83 -- 3:32 pm *) external module sysglobals; export var escapeco:  begin t.longform := p; shortpointer := t.lower3 end;} function getsize (p:pointer): integer; var size: integer; begin with mp(p)^ do begin size := mp(p)^.smallsize; if size = 0 then size := bigsize; getsize := size; end-32768..32767; FIBptr: integer; tryrec: integer; heapmax: integer; heapbase: integer; ioresult: integer; end; module hpm; import heapmax, { integer/anyptr } heapbase; { integer/anyptr } export procedur; end; procedure putsize (p:pointer; size:integer); begin with mp(p)^ do if size > otherlist then begin smallsize := 0; bigsize := size end else smallsize := size; end; procedure Hestablish; const emptydsa = dsa e Hestablish; procedure New (var object:integer; bytesize:integer); procedure Dispose (var object:integer; bytesize:integer); procedure Mark (var nextfreeword:integer); procedure Release (nextfreeword:integer); implement const nilptr = 0; [ fakeone:memblock[smallsize:(smallest-1),link:nilptr], freelist:freearray[(otherlist-smallest+1) of nilptr], wordsdisposed:0, dirty:false ]; var i: allists; begin Newwords(anyptr(heapbase),(sizeof(dsa)+1) div 2); dsap(heapbase)^  {integer equivalent of nil pointer} {maxptr = 16777215; {biggest physical address} {smallest = 2; {smallest allocatable object (words)} smallest = 3; {smallest allocatable object (words)} stdblk = 16; := emptydsa; end; {Hestablish} procedure recombine; label 1,2; var fakeaddr,f,g,this,thislink,flimit,highmark: pointer; fsize,gsize,wordcount: integer; i: allists; begin with dsap(heapbase)^ do begin {highmark := short {largest "standard" object} otherlist = stdblk+1; {for nonstandard objects} type stdlists = smallest..stdblk; allists = smallest..otherlist; pointer = integer {nilptr..maxptr}; {pointertrick = packed record case boolean ofpointer(heapmax);} {fakeaddr := shortpointer(integer(addr(fakeone)));} highmark := heapmax; fakeaddr := integer(addr(fakeone)); fakeone.link := nilptr; fakeone.smallsize := smallest-1; for i := smallest to otherlist do while freelist[i] <> n     ist[list]; freelist[list] := p; end; {with} end; {hreturn} procedure hallocate (var p:pointer; wordlen:integer); var longp: anyptr; function tryit: pointer; label 1,2; var temp,prev,next: pointer; lfrag,j,len,size: s(anyptr(object),wordsize) else begin if wordsize < smallest then wordsize := smallest; if dsap(heapbase)^.wordsdisposed < wordsize then Newwords(anyptr(object),wordsize) else begin hallocate(ptr,wordsize); {object := longpointeinteger; begin with dsap(heapbase)^ do begin len := wordlen; if len < otherlist then begin temp := freelist[len]; if temp <> nilptr then begin freelist[len] := mp(temp)^.link; goto 1 end; end; lfrag := r(ptr);} object := ptr; end; end; end; {New} procedure Dispose {var object:integer; bytesize:integer}; var ptr: pointer; wordsize: integer; begin if heapbase <> nilptr then begin wordsize := (bytesize+1) div 2; if worilptr do begin f := freelist[i]; freelist[i] := mp(f)^.link; this := fakeaddr; thislink := mp(this)^.link; while thislink <> nilptr do if thislink > f then goto 2 else begin this := thislink; thislen+smallest; for size := lfrag to stdblk do begin temp := freelist[size]; if temp <> nilptr then begin freelist[size] := mp(temp)^.link; hreturn(temp+len+len,len-size); goto 1 end; end; prev := nilptr; next :link := mp(this)^.link; end; 2: mp(f)^.link := thislink; mp(this)^.link := f; end; f := fakeone.link; wordcount := 0; while f <> nilptr do begin if highmark < f then goto 1; fsize := getsize(f); flimit := f+f= freelist[otherlist]; while next <> nilptr do begin size := getsize(next); if (size=len) or (size>=lfrag) then goto 2; prev := next; next := mp(next)^.link; end; 2: temp := next; if next <> nilptr then begisize+fsize; while mp(f)^.link = flimit do {adjacent} begin g := mp(f)^.link; mp(f)^.link := mp(g)^.link; gsize := getsize(g); flimit := g+gsize+gsize; end; {while} if highmark <= flimit then begin {heapmax := n if prev = nilptr then freelist[otherlist] := mp(next)^.link else mp(prev)^.link:=mp(next)^.link; if size <> len then hreturn(next+len+len,len-size); end; 1: if temp <> nilptr then wordsdisposed := wordsdisposed-wordlelongpointer(f);} heapmax := f; goto 1; end; fsize := (flimit-f) div 2; wordcount := wordcount+fsize; putsize(f,fsize); if fsize > otherlist then i:=otherlist else i:=fsize; g := mp(f)^.link; mp(f)^.link := freen; tryit := temp; end; {with heapbase} end; {tryit} begin {hallocate} p := tryit; if (p=nilptr) and dsap(heapbase)^.dirty then begin recombine; p := tryit end; if p = nilptr then begin Newwords(longp,wordlen); list[i]; freelist[i] := f; f := g; end; {f<>nil} 1: dirty := false; wordsdisposed := wordcount; end; {with heapbase} end; {recombine} procedure hreturn (p:pointer; wordlen:integer); var list: allists; begin with dsap {p := shortpointer(integer(longp));} p := integer(longp); end; end; {hallocate} procedure Mark {var nextfreeword:pointer}; begin nextfreeword := heapmax; end; procedure Release {nextfreeword:integer}; begin heapmax(heapbase)^,mp(p)^ do begin if wordlen < 0 then wordlen := -wordlen else wordsdisposed := wordsdisposed+wordlen; dirty := true; if wordlen > otherlist then list := otherlist else list := wordlen; putsize(p,wordlen); link := freel := nextfreeword; if heapbase <> nilptr then recombine; end; procedure New {var object:integer; bytesize:integer}; var ptr: pointer; wordsize: integer; begin wordsize := (bytesize+1) div 2; if heapbase = nilptr then Newword     dsize < smallest then wordsize := smallest; {ptr:=shortpointer(object);} ptr:=object; if ptr = nilptr then escape(-3); hreturn(ptr,wordsize) end; object := nilptr; end; {Dispose} end. {heapmanager} s also part of the div sub.l #$7FFFFFFF,d0 so remove it and add it back to bit 0 rnd2 move.l d0,(a1) jmp (a0) ************************************************* * * Function RAND(VAR SEED: INTEGER; * RANGE: SHORTINT): mname rnd src module rnd; src import sysglobals; src export src procedure random(var seed : integer); src function rand( var seed : integer; src range : shortint) : shortint; src end; def rn SHORTINT * * Returns a 16 bit integer which is scaled * to the range 0..RANGE-1 * (RANGE is treated as unsigned!) ************************************************* rnd_rand equ * rand movea.l (sp)+,a2 return address move.w (d_rnd def rnd_random def rnd_rand def random def rand ******************************************************************************* * * Procedure RANDOM(VAR SEED: INTEGER) * * Description: * Generate a pseudsp)+,d2 range parameter bsr.s rnd_random compute into d0 asl.l #1,d0 normalize swap d0 to 16 bits mulu d2,d0 scale to range swap d0 move.w d0,(sp) return result jmp (a2) eo-random number with the formula * Xn <- (16807 * Xn-1) MOD (2^31 - 1), where Xn-1 is the * previous random number. A shortcut computation is: * C <- 16807 * Xn-1. * Xn <- C MOD 2^31 + C DIV 2nd ^31. * If Xn > 2^31 - 1, then Xn <- Xn - (2^31 - 1) * * Parameters: * rndseed - the previous random number * * Error conditions: * There are none. ************************************************* r (* (c) Copyright Hewlett-Packard Company, 1983. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTEDnd_rnd rts rnd_random equ * random movea.l (sp)+,a0 return address movea.l (sp)+,a1 address of seed move.l (a1),d0 get previous random seed Xn move.l d0,d1 leave bottom 16 bits in d0 swap d1 get top 16 RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colora bits into d1 mulu #16807,d0 get one partial product in d0 mulu #16807,d1 high order partial product in d1 swap d1 align middle 16 bits of product in high d1 add.w d1,d1 most of (product div 2^31) is in lowdo *) $copyright 'COPYRIGHT (C) 1983 BY HEWLETT-PACKARD COMPANY'$ $sysprog$ module lockmodule; import sysglobals; export function lock (anyvar f : fib) : boolean; procedure unlock (anyvar f : fib); procedure wa d1 add.l d1,d0 compute (product mod 2^31) + (product div 2^31) bcc.s rnd1 any carries out of 32nd bit are part of the div addq.l #2,d0 (so propagate into appropriate position) rnd1 bpl.s rnd2 bit 31 iitforlock (anyvar f : fib); implement (**********************************************************************) function lock (anyvar f : fib) : boolean; begin ioresult := ord(inoerror); with f do if not flockable then ioresult :      RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colora file; begin with unitable^[u] do begin openfib(f, u); if ioresult = ord(inoerror) then call(tm, addr(f), clearunit, f, 0, 0); end; end; function unitbusy ( u: integer): boolean; var f: file; begin with unitable^[u] do begin unitbusy := trdo *) $ucsd, modcal, range off, iocheck off, debug off$ module uio; import sysglobals; export procedure unitwrite (u: integer; buf: charptr; len: integer; block: integer; async: integer); procedure unitread (u: intue; openfib(f, u); if ioresult = ord(inoerror) then begin call(tm, addr(f), unitstatus, f, 0, 0); unitbusy := fibp(addr(f))^.fbusy; if not fibp(addr(f))^.fbusy then ureportchange := true; end; end; end; procedure unitwait (= ord(inotlockable) else if flocked then ioresult := ord(ifilelocked) else begin fwaitonlock := false; call(unitable^[funit].dam,f,funit,lockfile); end; if ioresult = ord(inoerror) then lock := true else begin loceger; buf: charptr; len: integer; block: integer; async: integer); procedure unitclear (u: integer); procedure unitwait (u: integer); function unitbusy (u: integer): boolean; implement procedure eot(fp: fibp); begin end; k := false; if ioresult <> ord(ifilelocked) then escape(-10); end; end; (**********************************************************************) procedure unlock (anyvar f : fib); begin ioresult := ord(inoerror); with f do if not {do nothing} procedure openfib(anyvar F: fib; unum: unitnum); begin if (unum<=0) or (unum>maxunit) then ioresult := ord(ibadunit) else with F do begin fistextvar := false; funit := unum; feot := eot; call(unitable^[unum].dam, f, unum, open flockable then ioresult := ord(inotlockable) else if not flocked then ioresult := ord(ifileunlocked) else call(unitable^[funit].dam,f,funit,unlockfile); if ioresult <> ord(inoerror) then escape(-10); end; (******************unit); end; end; procedure unitwrite ( u: integer; buf: charptr; len: integer; block: integer; async: integer); var f: file; r: amrequesttype; begin with unitable^[u] do begin openfib(f, u); if ioresult = ord(inoerror) then ****************************************************) procedure waitforlock (anyvar f : fib); begin ioresult := ord(inoerror); with f do if not flockable then ioresult := ord(inotlockable) else if flocked then ioresult := ord(ifibegin if async = 0 then r := writebytes else r := startwrite; ureportchange := false; call(tm, addr(f), r, buf^, len, block*fblksize); if async=0 then begin call(tm, addr(f), flush, f, 0, 0); ureportchange := true; end;lelocked) else begin fwaitonlock := true; call(unitable^[funit].dam,f,funit,lockfile); end; if ioresult <> ord(inoerror) then escape(-10); end; end. {lockmodule}  end; end; end; procedure unitread ( u: integer; buf: charptr; len: integer; block: integer; async: integer); var f: file; r: amrequesttype; begin with unitable^[u] do begin openfib(f, u); if ioresult = ord(inoerror) then  (* (c) Copyright Hewlett-Packard Company, 1983. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTEDbegin if async = 0 then r := readbytes else r := startread; ureportchange := false; call(tm, addr(f), r, buf^, len, block*fblksize); if async=0 then ureportchange := true; end; end; end; procedure unitclear ( u: integer); var f:       u: integer); var busy: boolean; begin repeat busy := unitbusy(u); until (ioresult <> ord(inoerror)) or not busy; end; end. {module unitio}  *) (* module(s) - general_1 *) (* - hpib_1 *) (* - general_2 *) (*  (* (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett- - general_3 *) (* - general_4 *) (* - hpib_0 *) (* - hpib_2 Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEW *) (* - hpib_3 *) (* - serial_0 *) (* - serial_3 *) (* LETT-PACKARD COMPANY Fort Collins, Colorado *) $MODCAL ON$ $PARTIAL_EVAL ON$ $STACKCHECK ON$ $RANGE OFF$ $DEBUG OFF$ $OVFLCHECK OFF$ $PAGE$ (************************************************************************) (*  *) (* author - Tim Mikkelsen *) (* phone - 303-226-3800 ext. 2910 *) (*  *) (* RELEASED VERSION 3.1 *) (* *) (********************************************* *) (* date - June 1 , 1981 *) (* update - June 4, 1984 *) (* release - Jul 12, 1985 ***************************) (* *) (* *) (* IOLIB IOLIB *) (* *) (* *) (* source - IOLIB:IOLIB.TEXT *) (* object - IOLIB:IOLIB.CODE *) (*  *) (* *) (************************************************************************) (*  *) (************************************************************************) $PAGE$ (************************************************************************) (*  *) (* *) (* library - IOLIB *) (* name - IOLIB  *) (* *) (* This is the source code for an external procedures library *) (* to be used for general purpose interfacing on the HP 9826. *) (*      c interface card. There is *) (* also an executable program segment for each driver module. *) (* This program searches the select code table in the static r/w *) (* initialized by the KERNEL general_0 module for all select codes l to request *) (* service. *) (* *) (* 1251 T Mikkelsen HPIB_2 local(7) with sc 7 as *) (* *) (* that have the right interface card ( HPIB drivers will search *) (* for the 98624 interface ). This program will then set up the *) (* driver tables to point to the correct drivers. *) (*  01/08/1982 local sys ctl / not act ctl *) (* 01/26/1982 gives error. *) (* *) (* 1252 T Mikkelsen HPIB_2  *) (* The library consists of 3 primary sets of modules - *) (* *) (* 1. KERNEL modul *) (* The rest of the IOLIB modules are high-level modules that are *) (* used by an end user in his/her application program. *) (* es *) (* 2. driver modules *) (* 3. IOLIB modules *) (*  *) (* The KERNEL and some set of driver modules will exist in the *) (* SYSTEM.INITLIB file as object code ( not EXPORT text ). The *) (* export text will reside on the SYSTEM.LIBRARY file. The rest *) (* of the  *) (* The KERNEL modules consist of the following modules - *) (* *) (* 1. iodeclarations ( contains static r/w space ) *) (* 2. library will reside on the SYSTEM.LIBRARY. *) (* *) (************************************************************************) $PAGE$ (************************************** iocomasm *) (* 3. general_0 ( initialization & low level *) (* routines like ioread/iowrite) *) (* The KERNEL modules also have an executable pro**********************************) (* *) (* *) (* BUG FIX HISTORY - after release gram segement *) (* that gets executed at the time it is loaded. This program *) (* initializes the static read/write memory. This program also *) (* allocates the temporary storage for any card that exists - *) (* in *) (* *) (* *) (* BUG # BY / ON LOCATION DESCRIPTION *) (* ----- ----------dependent of whether there is or is not a driver for it. *) (* *) (* The driver modules consist of the actual assembly or PASCAL *) (* routines that deal with a specifi- -------------- ---------------------- *) (* *) (* 1250 T Mikkelsen HPIB_3 request service allows *) (* 01/08/1982 request_service active ct      remote(7) with sc 7 as *) (* 01/08/1982 remote act ctl / not sys ctl *) (* doesn't give error. *) (* *)  *) (* 0355 T Mikkelsen SERIAL_3 Set parity of one and *) (* 08/20/1982 set_parity zero parity is backwards*) (* for the 98628 card. *) (* (* 1258 T Mikkelsen HPIB_2 pass control sends the *) (* 01/08/1982 pass_control wrong sequence to pass *) (* control to itself. *) (*  *) (* 0359 T Mikkelsen SERIAL_3 Changes for addition *) (* 08/26/1982 set_parity of 98626 drivers. *) (* set_char_length  *) (* 1269 T Mikkelsen SERIAL_3 bad check for a 98626 *) (* 01/08/1982 set_stop_bits card. *) (*  *) (* set_stop_bits *) (* *) (* 0364 T Mikkelsen GENERAL_3 Addition of SRM driver *) (*  *) (* 1270 T Mikkelsen SERIAL_3 make procedures for *) (* 01/08/1982 set_baud_rate data comm consistent *) (* set_stop_bits for buffered control. *) (*  08/23/1982 ioerror_message error codes. See also *) (* IODECLARATIONS. *) (* *) (* 557 T Mikkelsen GENERAL_3 set_parity *) (* set_char_length *) (* *) (* 1281 T Mikkelsen GENERAL_3 W Mistyped. ( typo ) *) (* 10/01/1982 set_parity *) (* *) (* jsjs T Mikkelsen HPIB_2 BUG FIX error in Local rong message for error *) (* 01/08/1982 ioerror_message ioe_not_dvc. *) (* *) (* 0082 T Mikkelsen GENERAL_3 Addition of a link for *) (* *) (* 03/09/1983 local procedure for isc param *) (* and not sys controller. *) (* *) (* tttt J Schmidt  07/23/1982 ioerror_message the error messages. *) (* See also IODECLARATIONS.*) (* *) (* 0083 T Mikkelsen GENE HPIB_1 Use timer on CPU board *) (* 08/03/1983 if available for timeout*) (* checking *) (* RAL_4 Addition of buffer_busy *) (* 07/23/1982 buffer_busy and isc_busy routines. *) (* isc_busy *) (*  *) (* J Schmidt serial modules add code for 98644 *) (* 5/15/84 *) (* 6/4/84 *) (*       ( Bob Hallissy ) *) (* *) (* 6. 9826 HPL Misc. I/O Doc. ( Bob Hallissy ) *) (* *) m : INTEGER); PROCEDURE writeword ( select_code : type_isc ; value : INTEGER); PROCEDURE set_timeout ( select_code : type_isc ; time : REAL ); IMPLEMENT IMPORT general_0; (* 7. 9826 card documentation ( Mfg. Specs. ) *) (* *) (* 8. Pascal I/O Library IRS ( Tim Mikkelsen ) *) (*  PROCEDURE ioinitialize; BEGIN io_system_reset; END; { of ioinitialize } PROCEDURE iouninitialize; BEGIN io_system_reset; END; { of iouninitialize } PROCEDURE ioreset ( select_code : type_isc); BEGIN WITH isc_table[ *) (* D Willis PARALLEL_3 Added for centronics *) (* 12/89 support. *) (*  *) (* *) (* *) (************************************************************* *) (* *) (************************************************************************) $PAGE$ (********************************************************************************) $PAGE$ (************************************************************************) (* *) (* *) (* GEN***) (* *) (* *) (* REFERENCES : *) (* ERAL GROUP *) (* *) (* *) (***************************************** *) (* *) (* 1. 9826 I/O Designers Guide ( Loyd Nelson ) *) (* *******************************) MODULE general_1 ; { by Tim Mikkelsen date 07/15/81 update 11/20/81 purpose This module contains the LEVEL 1 GENERAL GROUP procedures. } {local search{{ $SEARCH  *) (* 2. 68000 Manual ( Motorola ) *) (* *) (* 3. Pascal alpha site ERS ( Roger Ison ) *) (* 'KERNEL.CODE', 'COMASM'$ {system search{{ $SEARCH 'IOLIB:KERNEL.CODE', 'IOLIB:COMASM'$ {} IMPORT iodeclarations ; EXPORT PROCEDURE ioinitialize; PROCEDURE iouninitialize; PROCEDURE ioreset ( select_code : type_isc); PROCEDURE readchar ( *) (* 4. Pascal I/O Library ERS ( Tim Mikkelsen ) *) (* *) (* 5. 9826 HPL EIO & IOD listings  select_code : type_isc ; VAR value : CHAR ); PROCEDURE writechar ( select_code : type_isc ; value : CHAR ); PROCEDURE readword ( select_code : type_isc ; VAR nu     select_code] DO CALL(io_drv_ptr^.iod_init, io_tmp_ptr); END; { of ioreset } PROCEDURE readchar ( select_code : type_isc ; VAR value : CHAR ); BEGIN WITH isc_table[select_code] DO CALL(io_drv_ptr^. *) (* HPIB GROUP LEVEL 1 *) (* *) (* iod_rdb, io_tmp_ptr, value); END; { of readchar } PROCEDURE writechar ( select_code : type_isc ; value : CHAR ); BEGIN WITH isc_table[select_code] DO CALL(io_drv_ptr^.iod_wtb, io *) (************************************************************************) (* *) (* *) (* T_tmp_ptr, value); END; { of writechar } PROCEDURE readword ( select_code : type_isc ; VAR num : INTEGER); VAR my_num : io_word; BEGIN WITH isc_table[select_code] DO CALL(io_drv_ptr^.iod_rdw, his level is included in the *) (* general group because HP-IB *) (* addressing is necessary for *) (* general puropose device speci-  io_tmp_ptr, my_num); num:=my_num; END; { of readword } PROCEDURE writeword ( select_code : type_isc ; value : INTEGER); VAR my_value : io_word; BEGIN my_value:=value; WITH isc_table[sel *) (* fication. *) (* *) (**********************************************************************ect_code] DO CALL(io_drv_ptr^.iod_wtw, io_tmp_ptr, my_value); END; { of writeword } PROCEDURE set_timeout ( select_code : type_isc ; time : REAL { in seconds } ); BEGIN IF time>**) MODULE hpib_1 ; { by Tim Mikkelsen date 07/16/81 update 08/03/83 by J Schmidt purpose This module contains the LEVEL 1 HPIB GROUP procedures. } IMPORT iodeclarations ; EXPORT PROCED8191 { 4 byte timeout - 1 byte left for shifts } THEN BEGIN { error } io_escape(ioe_bad_tmo,select_code); END; { of IF } IF (time>0) AND (time<0.001) THEN BEGIN { error } io_escape(ioe_bURE send_command( select_code : type_isc ; command : CHAR ); FUNCTION my_address ( select_code : type_isc) : type_hpib_addr ; FUNCTION active_controller ( select_code : tyad_tmo,select_code); END; { of IF } WITH isc_table[select_code] DO BEGIN { the table entry used by drivers is in milliseconds } user_time:=ROUND(time*1000); IF io_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout := user_time; ENDpe_isc) : BOOLEAN; FUNCTION system_controller ( select_code : type_isc) : BOOLEAN; FUNCTION addr_to_talk( device : type_device) : type_isc; FUNCTIO; { of WITH DO BEGIN } END; { of set_timeout } END; { of general_1 } $PAGE$ (************************************************************************) (* *) (* N addr_to_listen ( device : type_device) : type_isc; FUNCTION set_to_talk ( device : type_device) : type_isc; FUNCTION set_to_listen ( device       ( select_code : type_isc) : BOOLEAN; BEGIN IF isc_table[select_code].card_type=hpib_card THEN BEGIN active_controller:=bit_set(iostatus(select_code,3),6); END ELSE BEGIN active_controlio_isc); END; { of IF } END ELSE BEGIN END; { of IF } END; { of WITH DO BEGIN } END ELSE BEGIN io_isc:=device; WITH isc_table[io_isc] DO BEGIN { set up userler := TRUE; END; { of IF } END; { of active_controller } FUNCTION system_controller ( select_code : type_isc) : BOOLEAN; BEGIN IF isc_table[select_code].card_type=hpib_card THEN BEG timeout - in case system drivers changed it } IF io_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout:=user_time; IF card_type=hpib_card THEN BEGIN IF NOT active_controller(io_isc) THEN BEGIN  : type_device) : type_isc; FUNCTION end_set ( select_code : type_isc ) : BOOLEAN; IMPLEMENT IMPORT iocomasm , general_0 ; TYPE timeoutrec = record { tttIN system_controller:=bit_set(iostatus(select_code,3),7); END ELSE BEGIN system_controller := TRUE; END; { of IF } END; { of system_controller } FUNCTION end_set ( select_code : type_isc ) t JS 8/3/83 } counter: integer; { tttt JS 8/3/83 } firsttime: boolean; { tttt JS 8/3/83 } end; { tttt JS 8/3/83 } FUNCTION timerexists:  : BOOLEAN ; VAR mybool : BOOLEAN; BEGIN WITH isc_table[select_code] DO CALL ( io_drv_ptr^.iod_end, io_tmp_ptr, mybool); end_set := mybool; END; { of send_command } $PAGE$ FUNCTION addr_to_talk( devicboolean; external; { tttt JS 8/3/83 } FUNCTION timed_out(var rec: timeoutrec): boolean; external; {tttt JS 8/3/83} PROCEDURE send_command( select_code : type_isc ; command : CHAR ); BEGIN WITH isc_table[see : type_device) : type_isc; VAR io_isc : type_isc; timer : INTEGER; hpibrec: timeoutrec; {tttt JS 8/3/83} BEGIN IF device>iomaxisc THEN BEGIN io_isc:=devilect_code] DO CALL ( io_drv_ptr^.iod_send, io_tmp_ptr, command); END; { of send_command } FUNCTION my_address ( select_code : type_isc) : type_hpib_addr ; BEGIN IF isc_table[select_code].io_tmp_ptrce DIV 100; WITH isc_table[io_isc] DO BEGIN IF io_tmp_ptr <> NIL THEN BEGIN { set up user timeout - in case system drivers changed it } io_tmp_ptr^.timeout:=user_time; IF io_tmp_pt <> NIL THEN BEGIN WITH isc_table[select_code].io_tmp_ptr^ DO IF addressed <> -1 THEN BEGIN my_address:=addressed; END ELSE BEGIN { error } io_escape(ioe_r^.addressed <> -1 THEN BEGIN IF ( card_type <> hpib_card ) AND ( device MOD 100 > 31 ) THEN io_escape(ioe_misc,io_isc); send_command(io_isc,CHR(talk_constant+(devnot_hpib,select_code); END; { of IF addressed } END ELSE BEGIN { error } io_escape(ioe_not_hpib,select_code); END; { of IF io_tmp_ptr } END; { of my_address } FUNCTION active_controller ice MOD 100))); send_command(io_isc,'?'); send_command(io_isc,CHR(my_address(io_isc)+listen_constant)); END ELSE BEGIN { error } io_escape(ioe_not_hpib,      { if non controller wait until listener } IF user_time = 0 THEN BEGIN REPEAT { wait forever } UNTIL bit_set(iostatus(io_isc,6),10);  IF io_tmp_ptr <> NIL THEN BEGIN { set up user timeout - in case system drivers changed it } io_tmp_ptr^.timeout:=user_time; IF io_tmp_ptr^.addressed <> -1 THEN BEGIN  END ELSE BEGIN { wait for timeout value } IF timerexists THEN BEGIN {tttt JS 8/3/83} hpibrec.firsttime:=true; {tttt JS 8/3/83}  IF ( card_type <> hpib_card ) AND ( device MOD 100 > 31 ) THEN io_escape(ioe_misc,io_isc); send_command(io_isc,CHR(my_address(io_isc)+talk_constant)); send_command(io_isc,'?');  hpibrec.counter:=user_time; {tttt JS 8/3/83} REPEAT {tttt JS 8/3/83} UNTIL timed_out(hpibrec) OR {tttt JS 8/3/83} bit send_command(io_isc,CHR(listen_constant+(device MOD 100))); END ELSE BEGIN { error } io_escape(ioe_not_hpib,io_isc); END; { of IF } END _set(iostatus(io_isc,6),10); {tttt JS 8/3/83} END {tttt JS 8/3/83} ELSE BEGIN {tttt JS 8/3/83} timer:=user_time*3;  ELSE BEGIN END; { of IF } END; { of WITH DO BEGIN } END ELSE BEGIN io_isc:=device; WITH isc_table[io_isc] DO BEGIN { set up user timeout - in case system drivers changed it } IF io REPEAT timer:=timer-1; UNTIL ( timer = 0 ) OR ( bit_set(iostatus(io_isc,6),10) ) ; END; {tttt JS 8/3/83_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout:=user_time; IF card_type=hpib_card THEN BEGIN IF NOT active_controller(io_isc) THEN BEGIN { if non controller wait until talker } } IF NOT bit_set(iostatus(io_isc,6),10) THEN io_escape(ioe_timeout,io_isc); END; { of IF user_time=0 } END; { of IF } END; { of IF card_type = hpib_card }  IF user_time = 0 THEN BEGIN REPEAT { wait forever } UNTIL bit_set(iostatus(io_isc,6),9); END ELSE BEGIN  END; { of WITH DO BEGIN } END; { of IF } addr_to_talk:=io_isc; { return select code } END; { of addr_to_talk } $PAGE$ FUNCTION addr_to_listen ( device : type_device) : type_isc; V { wait for timeout value } IF timerexists THEN BEGIN {tttt JS 8/3/83} hpibrec.firsttime:=true; {tttt JS 8/3/83} hpibrec.counter:=user_time; {tttt JS 8/AR io_isc : type_isc; timer : INTEGER; hpibrec: timeoutrec; {tttt JS 8/3/83} BEGIN IF device>iomaxisc THEN BEGIN io_isc:=device DIV 100; WITH isc_table[io_isc] DO BEGIN 3/83} REPEAT {tttt JS 8/3/83} UNTIL timed_out(hpibrec) OR {tttt JS 8/3/83} bit_set(iostatus(io_isc,6), 9); {tttt JS 8/3/83}      THEN io_tmp_ptr^.timeout:=user_time; IF card_type=hpib_card THEN BEGIN IF NOT active_controller(io_isc) THEN BEGIN io_escape(ioe_not_act,io_isc); END; { of IF }  value : REAL ) ; PROCEDURE readstring ( device : type_device ; VAR str: STRING ) ; PROCEDURE readstring_until ( term : CHAR ; device : type_dev END; { of IF card_type = hpib_card } END; { of WITH DO BEGIN } END; { of IF } set_to_talk:=io_isc; { return select code } END; { of set_to_talk } $PAGE$ { set to listen exists because of HPIB_2/HPIB_3 - those routinesice ; VAR str: STRING ); PROCEDURE writestring( device : type_device ; str : io_STRING ) ; PROCEDURE readnumberln ( device : type_device ; VAR num: REA END {tttt JS 8/3/83} ELSE BEGIN {tttt JS 8/3/83} timer:=user_time*3; REPEAT timer:=timer-1; are intended to be the controller ( active ) and should not wait for the card to be addressed as listener. addr_to_listen is used by data transfer routines. set_to_listen is used by bus control routines. }  UNTIL ( timer = 0 ) OR ( bit_set(iostatus(io_isc,6),9) ) ; END; {tttt JS 8/3/83} IF NOT bit_set(iostatus(io_isc,6),9)  FUNCTION set_to_listen ( device : type_device) : type_isc; VAR io_isc : type_isc; timer : INTEGER; BEGIN IF device>iomaxisc THEN BEGIN io_isc:=addr_to_listen(device); THEN io_escape(ioe_timeout,io_isc); END; { of IF user_time=0 } END; { of IF } END; { of IF card_type = hpib_card } END; { of WITH DO BEGIN } END; { of IF } addr_to_listen END ELSE BEGIN io_isc:=device; WITH isc_table[io_isc] DO BEGIN { set up user timeout - in case system drivers changed it } IF io_tmp_ptr <> NIL THEN io_tmp_ptr^.timeout:=user_time; IF card_type:=io_isc; END; { of addr_to_listen } $PAGE$ { set to talk exists because of HPIB_2/HPIB_3 - those routines are intended to be the controller ( active ) and should not wait for the card to be addressed as talker. addr_to_talk is used =hpib_card THEN BEGIN IF NOT active_controller(io_isc) THEN BEGIN io_escape(ioe_not_act,io_isc); END; { of IF } END; { of IF card_type = hpib_card } END; { ofby data transfer routines. set_to_talk is used by bus control routines. } FUNCTION set_to_talk ( device : type_device) : type_isc; VAR io_isc : type_isc; BEGIN IF device>io WITH DO BEGIN } END; { of IF } set_to_listen:=io_isc; END; { of set_to_listen } END; { of hpib_1 } $PAGE$ MODULE general_2 ; { by Tim Mikkelsen date 07/15/81 update 11/30/81 purpose Thismaxisc THEN BEGIN io_isc:=addr_to_talk(device); END ELSE BEGIN io_isc:=device; WITH isc_table[io_isc] DO BEGIN { set up user timeout - in case system drivers changed it } IF io_tmp_ptr <> NIL  module contains the LEVEL 2 GENERAL GROUP procedures. } IMPORT iodeclarations; EXPORT PROCEDURE readnumber ( device : type_device ; VAR num: REAL ) ; PROCEDURE writenumber( device : type_device ;      L ); PROCEDURE writenumberln ( device : type_device ; value : REAL ); PROCEDURE writestringln ( device : type_device ; str : io_STRING ); PROCEDURE re AND ( ( IORESULT = ORD(IBADFORMAT) ) OR ( IORESULT = ORD(ISTROVFL) ) ) THEN BEGIN { this is the strread errors - try again } END ELSE BEGIN {aduntil ( term : CHAR ; device : type_device ); PROCEDURE skipfor ( count : INTEGER ; device : type_device ); IMPLEMENT IMPORT sysglobals, hpib_1 , general_1 ; PROCEDU this means something else happened } ESCAPE(ESCAPECODE); END; { of IF my error } END; { of RECOVER } UNTIL numbuilt; END; { of WITH DO BEGIN } END; { of readnumber } PROCEDURE writenumber (device : tRE readnumber ( device : type_device ; VAR num: REAL ) ; VAR io_work_str : STRING[255]; i : INTEGER; p2 : INTEGER; io_isc : type_isc; numbuilt : BOOLEAN; FUNCTION numeric (ype_device ; value : REAL ); VAR i : INTEGER; p2 : INTEGER; io_isc : type_isc; io_work_str : STRING[255]; BEGIN io_isc:=addr_to_listen(device); WITH isc_table[io_isc].io_drv_ character : CHAR) : BOOLEAN; BEGIN CASE character OF '0'..'9', '+','-','.', 'E','e' : numeric:=TRUE OTHERWISE numeric:=FALSE END; { of CASE } END; { of numeric } BEGIN { use TRY RECOVER to bptr^ , isc_table[io_isc] DO BEGIN STRWRITE(io_work_str,1,p2,value); FOR i:=1 TO p2-1 DO CALL ( iod_wtb , io_tmp_ptr , io_work_str[i]); END; { of WITH DO } END; { of writenumber } PROCEDURE readstring uild a number until I find one } io_isc:=addr_to_talk(device); numbuilt := FALSE; WITH isc_table[io_isc].io_drv_ptr^ , isc_table[io_isc] DO BEGIN REPEAT SETSTRLEN(io_work_str,255); i:=1; { ( device : type_device ; VAR str: STRING ) ; VAR i : INTEGER; io_isc : type_isc; BEGIN io_isc:=addr_to_talk(device); WITH isc_table[io_isc].io_drv_ptr^ , isc_table[io_isc skip over non-numeric characters } REPEAT CALL ( iod_rdb , io_tmp_ptr , io_work_str[i]); WHILE io_work_str[i]=' ' DO CALL ( iod_rdb , io_tmp_ptr , io_work_str[i]); UNTIL numeric(io_work_str[i]) ; { ] DO BEGIN SETSTRLEN(str,STRMAX(str)); { so I can do assign to empty string } i:=0; REPEAT i:=i+1; CALL ( iod_rdb , io_tmp_ptr , str[i]); UNTIL ( (i>=STRMAX(str) ) OR ( stread in numeric characters } REPEAT i:=i+1; CALL ( iod_rdb , io_tmp_ptr , io_work_str[i] ); WHILE io_work_str[i]=' ' DO CALL ( iod_rdb , io_tmp_ptr , io_work_str[i]); UNTIL ( (NOT ( numeric(io_work_r[i] = io_line_feed ) ); IF str[i]=io_line_feed THEN i:=i-1; IF i<>0 THEN IF str[i]=io_carriage_rtn THEN i:=i-1; SETSTRLEN(str,i); END; { of WITH DO BEGIN } END; { of readstring } PROCEDURE readstring_until str[i]))) OR ( ( i>=255) ) ); SETSTRLEN(io_work_str,i); io_work_char:=io_work_str[i]; TRY STRREAD(io_work_str,1,p2,num); numbuilt := TRUE; RECOVER BEGIN IF ( ESCAPECODE=-10 ) ( term : CHAR ; device : type_device ; VAR str: STRING ); VAR i : INTEGER; io_isc : type_isc; io_work_char: CHAR; BEGIN io_isc:=addr_to_talk(device); WITH is     io_STRING ); VAR io_isc : type_isc; BEGIN io_isc:=addr_to_listen(device); writestring(io_isc,str); writechar(io_isc,io_carriage_rtn); writechar(io_isc,io_line_feed); END; { of writestringln } PROCEDURE readuntil ( term :ce not sc'; { BUG 1281 TM 1/8/82 } ioe_no_space : my_msg := 'no space left in buffer'; ioe_no_data : my_msg := 'no data left in buffer'; ioe_bad_tfr : my_msg := 'improper transfer attempted'; ioe_isc CHAR ; device : type_device ); VAR io_work_char: CHAR; io_isc : type_isc; BEGIN io_isc:=addr_to_talk(device); WITH isc_table[io_isc].io_drv_ptr^ , isc_table[io_isc] DO BEGIN REPE_busy : my_msg := 'the select code is busy'; ioe_buf_busy : my_msg := 'the buffer is busy'; ioe_bad_cnt : my_msg := 'improper transfer count'; ioe_bad_tmo : my_msg := 'bad timeout value'; ioe_no_dric_table[io_isc].io_drv_ptr^ , isc_table[io_isc] DO BEGIN SETSTRLEN(str,STRMAX(str)); i:=0; REPEAT i:=i+1; CALL ( iod_rdb , io_tmp_ptr , str[i]); UNTIL ( (i>=STRMAX(str) ) OR ( sAT CALL ( iod_rdb , io_tmp_ptr , io_work_char); UNTIL ( io_work_char=term ); END; { of WITH DO BEGIN } END; { of readuntil } PROCEDURE skipfor ( count : INTEGER ; device : type_device ); VAR i tr[i]=term ) ); SETSTRLEN(str,i); END; { of WITH DO BEGIN } END; { of readstring_until } PROCEDURE writestring( device : type_device ; str : io_STRING ) ; VAR i : INTEGER; io_isc: type_isc; BEGIN : INTEGER; io_isc : type_isc; io_work_char: CHAR; BEGIN io_isc:=addr_to_talk(device); WITH isc_table[io_isc].io_drv_ptr^ , isc_table[io_isc] DO BEGIN FOR i:=1 TO count DO CALL ( iod_rdb ,  io_isc:=addr_to_listen(device); WITH isc_table[io_isc].io_drv_ptr^ , isc_table[io_isc] DO BEGIN FOR i:=1 TO STRLEN(str) DO CALL ( iod_wtb , io_tmp_ptr , str[i]); END; { of WITH DO } END; { of writestringio_tmp_ptr , io_work_char); END; { of WITH DO BEGIN } END; { of skipfor } END; { of general_2 } $PAGE$ MODULE general_3 ; { by Tim Mikkelsen date 11/27/81 update 07/23/82 purpose This module cont } PROCEDURE readnumberln ( device : type_device ; VAR num: REAL ); VAR io_isc : type_isc; BEGIN io_isc:=addr_to_talk(device); readnumber(io_isc,num); IF io_work_char <> io_line_feeains the LEVEL 3 GENERAL GROUP procedures. } IMPORT iodeclarations ; EXPORT FUNCTION ioerror_message ( ioerror : INTEGER ) : io_STRING; IMPLEMENT FUNCTION ioerror_message ( ioerror : INTEGER ) : io_STRING; VAR my_msg : io_STRING;d THEN readuntil(io_line_feed,io_isc); END; { of readnumberln } PROCEDURE writenumberln ( device : type_device ; value : REAL ); VAR io_isc : type_isc; BEGIN io_isc:=addr_to_liste BEGIN my_msg:='zzzz' ; { 0082 TM 7/23/82 } IF ( ioerror <= ioe_misc ) AND ( ioerror >= ioe_no_error ) THEN BEGIN CASE ioerror OF ioe_no_error : my_msg := 'no errn(device); writenumber(io_isc,value); writechar(io_isc,io_carriage_rtn); writechar(io_isc,io_line_feed); END; { of writenumberln } PROCEDURE writestringln ( device : type_device ; str : or '; ioe_no_card : my_msg := 'no card at select code'; ioe_not_hpib : my_msg := 'interface should be hpib'; ioe_not_act : my_msg := 'not active controller'; ioe_not_dvc : my_msg := 'should be devi     ver : my_msg := 'no driver for this card'; ioe_no_dma : my_msg := 'no dma'; ioe_no_word : my_msg := 'word operations not allowed'; ioe_not_talk : my_msg := 'not addressed as talker'; ioe_not_lstn  IF my_msg = 'zzzz' { we don't let sleeping msgs lie } { 0082 TM 7/23/82 } THEN CALL(io_error_link , ioerror , my_msg ); { 0082 TM 7/23/82 } ioerror_message := my_msg; END; { ioerror_message } END; { of general_3 } $PA : my_msg := 'not addressed as listener'; ioe_timeout : my_msg := 'a timeout has occurred'; ioe_not_sctl : my_msg := 'not system controller'; ioe_rds_wtc : my_msg := 'bad status or control'; ioe_bad_scGE$ MODULE general_4 ; { by Tim Mikkelsen date 07/17/81 update 07/23/82 purpose This module contains the LEVEL 4 GENERAL GROUP procedures. } IMPORT iodeclarations ; EXPORT PROCEDURE abort_tt : my_msg := 'bad set/clear/test operation'; ioe_crd_dwn : my_msg := 'interface card is dead'; ioe_eod_seen : my_msg := 'end/eod has occured'; ioe_misc : my_msg := 'miscellaneous - value of param error';ransfer ( VAR b_info: buf_info_type ); FUNCTION transfer_setup ( device : type_device; t_tfr : user_tfr_type; t_dir : dir_of_tfr ;  END; { of CASE } END; { of IF } IF ( ioerror >= ioe_dc_fail ) AND ( ioerror <= ioe_dc_rval ) THEN BEGIN CASE ioerror OF ioe_sr_toomany : my_msg := { 0364 TM 87/23/82 }  VAR b_info: buf_info_type ; VAR t_cnt : INTEGER ) : type_isc ; PROCEDURE transfer ( device : type_device; t_tfr : user_tfr_type; t_dir  'too many chars w/o terminator'; { 0364 TM 87/23/82 } ioe_dc_fail : my_msg := 'dc interface failure'; ioe_dc_usart : my_msg := 'USART receive buffer overflow'; ioe_dc_ovfl : my_msg := 'recei : dir_of_tfr ; VAR b_info: buf_info_type; x_count : INTEGER ) ; PROCEDURE transfer_word ( device : type_device; t_tfr : user_tfr_type; ve buffer overflow'; ioe_dc_clk : my_msg := 'missing clock'; ioe_dc_cts : my_msg := 'CTS false too long'; ioe_dc_car : my_msg := 'lost carrier disconnect'; ioe_dc_act : my_msg := 'no activity  t_dir : dir_of_tfr ; VAR b_info: buf_info_type; x_count : INTEGER ) ; PROCEDURE transfer_until ( term : CHAR ; device : type_dedisconnect'; ioe_dc_conn : my_msg := 'connection not established'; ioe_dc_conf : my_msg := 'bad data bits/parity combination'; ioe_dc_reg : my_msg := 'bad status /control register'; ioe_dc_rval : vice; t_tfr : user_tfr_type; t_dir : dir_of_tfr; VAR b_info: buf_info_type ) ; PROCEDURE transfer_end ( device : type_device;  my_msg := 'control value out of range'; END; { of CASE } END; { of IF } IF ioe_result = ioe_sr_fail { 0364 TM 8/23/82 } THEN my_msg := 'data link failure'; { 0364 TM 8/23/82 }  t_tfr : user_tfr_type; t_dir : dir_of_tfr; VAR b_info: buf_info_type ) ; PROCEDURE iobuffer ( VAR b_info: buf_info_type ; t_count : INTEGER ); PROCEDURE buffe     unt; buf_empty := buf_ptr; buf_fill := buf_ptr; drv_tmp_ptr := NIL; eot_proc.dummy_sl := NIL; eot_proc.dummy_pr := NIL; eot_parm := NIL; {JPC 02/22/82} dma_priority  ELSE io_isc := device; IF isc_table[io_isc].io_tmp_ptr = NIL THEN io_escape(ioe_no_driver,io_isc); WITH b_info DO BEGIN { test for tfr count } IF t_cnt=0 THEN BEGIN { error  := FALSE ; END; { of WITH DO } END; { of iobuffer } FUNCTION buffer_data(VAR b_info : buf_info_type ) : INTEGER; BEGIN WITH b_info DO BEGIN buffer_data:=INTEGER(buf_fill)-INTEGER(buf_empty); END; { } io_escape(ioe_bad_cnt,no_isc); END; { test for another tfr on this buffer } IF active_isc <> no_isc THEN BEGIN { error } io_escape(ioe_buf_busy,no_isc); END ELSE BEGIN Ir_reset(VAR b_info: buf_info_type ) ; FUNCTION buffer_space(VAR b_info: buf_info_type) : INTEGER; FUNCTION buffer_data( VAR b_info: buf_info_type) : INTEGER; PROCEDURE readbuffer ( VAR b_info: buf_info_of WITH DO } END; { of buffer_data } PROCEDURE buffer_reset(VAR b_info: buf_info_type ) ; BEGIN WITH b_info DO BEGIN IF active_isc = no_isc THEN BEGIN buf_fill:=buf_ptr; buf_empty:=buf_ptr; END type; VAR value : CHAR); PROCEDURE writebuffer( VAR b_info: buf_info_type; value : CHAR); PROCEDURE readbuffer_string ( VAR b_info: buf_info_type; VAR ELSE BEGIN { error } io_escape(ioe_buf_busy,no_isc); END; { of IF } END; { of WITH DO } END; { of buffer_reset } FUNCTION buffer_space(VAR b_info: buf_info_type) : INTEGER; BEGIN WIT str : STRING; str_count : INTEGER); PROCEDURE writebuffer_string ( VAR b_info: buf_info_type; str : io_STRING); FUNCTION buffer_busy( VAR b_info: buf_info_type ) H b_info DO BEGIN IF ( buffer_data(b_info)=0 ) AND ( active_isc = no_isc ) THEN buffer_reset(b_info); buffer_space:=buf_size+INTEGER(buf_ptr)-INTEGER(buf_fill); END; { of WITH DO } END; { of buffer_space } PROCEDURE ab { 0083 TM 7/23/82 } : BOOLEAN; { 0083 TM 7/23/82 } FUNCTION isc_busy ( isc : type_isc ) { 0083 TM 7/23/82 } : BOOLEAN; ort_transfer ( VAR b_info: buf_info_type ); BEGIN WITH b_info DO BEGIN IF active_isc <> no_isc THEN BEGIN WITH isc_table[active_isc] DO CALL ( io_drv_ptr^.iod_init , io_t { 0083 TM 7/23/82 } IMPLEMENT IMPORT hpib_1 ; PROCEDURE iobuffer ( VAR b_info: buf_info_type ; t_count : INTEGER ) ; PROCEDURE NEW $ALIAS 'ASM_NEWBYTES'$ (VAR p:ANYPTR;v:INTEGER);EXTERNAL; BEGImp_ptr ); END; { of IF } END; { of WITH b_info DO } END; { of abort_transfer } FUNCTION transfer_setup ( device : type_device; t_tfr : user_tfr_type; tN WITH b_info DO BEGIN { what about IOBUFFER to a already existant buffer ? } { - the space will be thrown away. } NEW(buf_ptr,t_count); act_tfr := no_tfr; active_isc:= no_isc; buf_size := t_co_dir : dir_of_tfr ; VAR b_info: buf_info_type ; VAR t_cnt : INTEGER ) : type_isc ; VAR io_isc : type_isc; BEGIN IF device>iomaxisc THEN io_isc := device DIV 100      F buffer_data(b_info)=0 THEN buffer_reset(b_info); END; { of IF } { configure card based on direction and check for available space/data } IF t_dir= to_memory THEN BEGIN IF isc_table[io_isc].io_tmp_ptr^.in_bufptr <> p in transfer_setup } WITH isc_table[io_isc] DO CALL ( io_drv_ptr^.iod_tfr , isc_table[io_isc].io_tmp_ptr, ADDR(b_info) ); END; { of transfer } PROCEDURE transfer_word ( device : type_NIL THEN BEGIN { error } io_escape(ioe_isc_busy,io_isc); END; { of IF } IF buffer_space(b_info) NIL THEN BEGIN : INTEGER; BEGIN t_count:=x_count; io_isc:=transfer_setup(device,t_tfr,t_dir,b_info,t_count); { fix up transfer temporary } b_info.b_w_mode := TRUE; { word mode } WITH isc_table[io_isc] DO CALL ( io_drv_p { error } io_escape(ioe_isc_busy,io_isc); END; { of IF } IF buffer_data(b_info) no_isc ) AND ( direction = to_memory ) THEN BEGIN { error } io_escape( no_isc , ioe_buf_busy { 0083 TM 7/23/82 } IF active_isc <> no_isc THEN buffer_busy := TRUE { 0083 TM 7/23/82 } ELSE buffer_busy := FALSE; { 0083 TM 7/23/82 } END; { of WITH DO BEGIN } L ( io_drv_ptr^.iod_tfr , isc_table[io_isc].io_tmp_ptr, ADDR(b_info) ); END; { of transfer_until } PROCEDURE transfer_end(device : type_device; t_tfr : user_tfr_type;  ); END; { of IF } p:=buf_fill; p^:=value; buf_fill:=ANYPTR(INTEGER(buf_fill)+1); END; { of WITH b_info DO } END; { of IF } END; { of writebuffer } PROCEDURE readbuffer_string  t_dir : dir_of_tfr; VAR b_info: buf_info_type ) ; VAR io_isc : type_isc; t_count : INTEGER; BEGIN IF t_dir=from_memory THEN BEGIN t_count := buffer_data(b_info); END ELSE BEGIN  ( VAR b_info: buf_info_type; VAR str : STRING; str_count : INTEGER); VAR i : INTEGER ; BEGIN IF STRMAX(str) < str_count THEN BEGIN { error - string too small }  t_count := buffer_space(b_info); END; { of IF } io_isc:=transfer_setup(device,t_tfr,t_dir,b_info,t_count); { fix up transfer temporary } b_info.end_mode := TRUE; { EOI } WITH isc_table[io_isc] DO Cio_escape(ioe_misc,no_isc); END; SETSTRLEN(str,str_count); { so I can put chars into empty string } IF buffer_data(b_info) no_isc ) AND ( direction = from_memory ) tebuffer_string ( VAR b_info: buf_info_type; str : io_STRING); VAR i : INTEGER; BEGIN IF buffer_space(b_info) NIL ) OR elect_code : type_isc ; line : type_hpib_line); BEGIN WITH isc_table[select_code] DO CALL(io_drv_ptr^.iod_clr, io_tmp_ptr, ORD(line)); END; FUNCTION hpib_line ( select_code : type_isc ; { 0083 TM 7/23/82 } ( out_bufptr <> NIL ) THEN isc_busy := TRUE { 0083 TM 7/23/82 } ELSE isc_busy := FALSE; { 0083 TM 7/23/82 } END; { of WITH DO BEGIN }  line : type_hpib_line) : BOOLEAN; VAR my_boolean : BOOLEAN; BEGIN WITH isc_table[select_code] DO CALL(io_drv_ptr^.iod_test, io_tmp_ptr, ORD(line), my_boolean); { 0083 TM 7/23/82 } END; { of isc_busy } { 0083 TM 7/23/82 } END; { of general_4 } $PAGE$ (************************************************************************) (*  hpib_line:=my_boolean; END; END; { of hpib_0 } $PAGE$ MODULE hpib_2 ; { by Tim Mikkelsen date 07/17/81 update 03/09/83 purpose This module contains the LEVEL 2 HPIB GROUP proce *) (* *) (* HPIB GROUP *) (* dures. } IMPORT iodeclarations ; EXPORT PROCEDURE abort_hpib ( select_code : type_isc); PROCEDURE clear ( device : type_device); PROCEDURE listen ( select_code : type_isc ; address  *) (* *) (************************************************************************) MODULE hpib_0 ; { by Tim Mikkelsen date 07/17/81 update : type_hpib_addr ); PROCEDURE local ( device : type_device); PROCEDURE local_lockout ( select_code : type_isc); PROCEDURE pass_control ( device : type_device); PROCEDURE ppoll_configure 09/17/81 purpose This module contains the LEVEL 0 HPIB GROUP procedures. } IMPORT iodeclarations ; EXPORT PROCEDURE set_hpib ( select_code : type_isc ; line : type_hpib_line); PROCEDURE c ( device : type_device; mask : INTEGER ); PROCEDURE ppoll_unconfigure ( device : type_device); PROCEDURE remote ( device : type_device); PROCEDURE secondary lear_hpib ( select_code : type_isc ; line : type_hpib_line); FUNCTION hpib_line ( select_code : type_isc ; line : type_hpib_line) : BOOLEAN; IMPLEMENT PR ( select_code : type_isc ; address : type_hpib_addr ); PROCEDURE talk ( select_code : type_isc ; address : type_hpib_addr ); PROCEDURE trigger ( device : type_device); PROCEDURE unlisten(      o_isc:=set_to_listen(device); { BUG 1251 TM 1/8/82 } send_command(io_isc,gtl_message); END ELSE BEGIN io_isc := device; { BUG 1251 TM 1/8/82 } IF system_controller(io_isc) of IF device } { BUG 1258 TM 1/8/82 } send_command(io_isc,tct_message); END; PROCEDURE ppoll_configure ( device : type_device; mask : INTEGER ); VAR io_isc  { BUG jsjs TM 3/9/83 } THEN BEGIN { system controller - drop REN } { BUG jsjs TM 3/9/83 } clear_hpib(io_isc,ren_line); IF active_controller(io_isc) { BUG 1251 TM : type_isc; BEGIN io_isc:=set_to_listen(device); IF io_isc=device THEN BEGIN { error } io_escape(ioe_not_dvc,io_isc); END ELSE BEGIN send_command(io_isc,ppc_message); send_command(io_isc,CHR(ord(select_code : type_isc ); PROCEDURE untalk ( select_code : type_isc ); IMPLEMENT IMPORT hpib_0 , hpib_1 ; PROCEDURE abort_hpib ( select_code : type_isc); BEGIN { what about active tfrs ? } IF system_co 1/26/82 } THEN clear_hpib(io_isc,atn_line); { BUG 1251 TM 1/26/82 } END { BUG jsjs TM 3/9/83 } ELSE BEGIN { BUG jsjs TM 3/9/83 } ntroller(select_code) THEN BEGIN set_hpib(select_code,ifc_line); set_hpib(select_code,ren_line); clear_hpib(select_code,ifc_line); clear_hpib(select_code,atn_line); { all done by ifc } END  { not system controller - send GTL } { BUG jsjs TM 3/9/83 } send_command(io_isc,gtl_message); { BUG jsjs TM 3/9/83 } END; { of IF } { BUG jsjs TM 3/9/83 } END; { of IF } ELSE BEGIN IF active_controller(select_code) THEN BEGIN send_command(select_code, CHR(talk_constant+my_address(select_code))); send_command(select_code,'?'); clear_hpib(select_code,atn_line);  END; { of local } PROCEDURE local_lockout ( select_code : type_isc); BEGIN send_command(select_code,llo_message); END; { of local_lockout } PROCEDURE pass_control ( device : type_device);  END ELSE BEGIN { do nothing } END; { of IF } END; { of IF } END; { of abort_hpib } PROCEDURE clear ( device : type_device); VAR io_isc : type_isc; BEGIN io_isc:=set_to_listen(device); IF devic VAR io_isc : type_isc; BEGIN IF device>iomaxisc { BUG 1258 TM 1/8/82 } THEN BEGIN { BUG 1258 TM 1/8/82 } io_isc := device DIV 100; { BUe>iomaxisc THEN BEGIN send_command(io_isc,sdc_message); END ELSE BEGIN send_command(io_isc,dcl_message); END; { of IF } END; { of clear } PROCEDURE listen ( select_code : type_isc ; addrG 1258 TM 1/8/82 } send_command(io_isc,unl_message); { BUG 1258 TM 1/8/82 } send_command(io_isc, { BUG 1258 TM 1/8/82 } chr((device MOD 100)+talk_constant)); { BUG 1258 TM 1/8/8ess : type_hpib_addr ); BEGIN send_command(select_code,CHR(listen_constant+address)); END; { of listen } PROCEDURE local ( device : type_device); VAR io_isc : type_isc; BEGIN IF device>iomaxisc THEN BEGIN i2 } END { BUG 1258 TM 1/8/82 } ELSE BEGIN { BUG 1258 TM 1/8/82 } io_isc := set_to_talk(device); { BUG 1258 TM 1/8/82 } END; {     ppe_message)+(mask MOD 16))); END; { of IF } END; { of ppoll_configure } PROCEDURE ppoll_unconfigure ( device : type_device); VAR io_isc : type_isc; BEGIN io_isc:=set_to_listen(device); IF device>iomaxi { by Tim Mikkelsen date 07/17/81 update 01/08/82 purpose This module contains the LEVEL 3 HPIB GROUP procedures. } IMPORT iodeclarations ; EXPORT FUNCTION requested sc THEN BEGIN send_command(io_isc,ppc_message); send_command(io_isc,ppd_message); END ELSE BEGIN send_command(io_isc,ppu_message); END; { of IF } END; { of ppoll_unconfigure } PROCEDURE remote ( devic ( select_code : type_isc ) : BOOLEAN ; FUNCTION ppoll ( select_code : type_isc ) : INTEGER ; FUNCTION spoll ( device : type_device) : INTEGER ; PROCEDURE request_se : type_device); VAR io_isc : type_isc; BEGIN IF device>iomaxisc THEN BEGIN io_isc:=device DIV 100; IF NOT system_controller(io_isc) { BUG 1252 TM 1/8/82 } THEN io_escape(ioe_not_sctl,io_iscervice ( select_code : type_isc ; response : INTEGER ); FUNCTION listener( select_code : type_isc ) : BOOLEAN; FUNCTION talker ( select_code : type_isc ) : BOOLEAN ); { BUG 1252 TM 1/8/82 } set_hpib(io_isc,ren_line); io_isc:=set_to_listen(device); END ELSE BEGIN io_isc := device; { BUG 1252 TM 1/8/82 } IF NOT system_controller(io_isc; FUNCTION remoted ( select_code : type_isc ) : BOOLEAN ; FUNCTION locked_out ( select_code : type_isc ) : BOOLEAN ; IMPLEMENT IMPORT iocomasm , general_0 , genera) { BUG 1252 TM 1/8/82 } THEN io_escape(ioe_not_sctl,io_isc); { BUG 1252 TM 1/8/82 } set_hpib(io_isc,ren_line); END; { of IF } END; { of remote } PROCEDURE secondary ( select_codel_1 , hpib_0 , hpib_1 ; FUNCTION requested ( select_code : type_isc ) : BOOLEAN ; BEGIN IF active_controller(select_code) THEN BEGIN requested:=hpib_line(select_code,srq : type_isc ; address : type_hpib_addr ); BEGIN send_command(select_code,CHR(address+96)); END; { of secondary } PROCEDURE talk ( select_code : type_isc ; address : type_hpib_addr ); BEG_line); END ELSE BEGIN { error - not active controller when look at srq } io_escape(ioe_not_act,select_code); END; { of IF } END; { of requested } FUNCTION ppoll ( select_code : type_isc ) :IN send_command(select_code,CHR(address+talk_constant)); END; { of talk } PROCEDURE trigger ( device : type_device); BEGIN send_command(set_to_listen(device),get_message); END; { of trigger } PROCEDURE unlisten( select_code : ty INTEGER ; VAR my_byte : CHAR; BEGIN WITH isc_table[select_code] DO CALL(io_drv_ptr^.iod_ppoll, io_tmp_ptr, my_byte); ppoll:=ORD(my_byte); END; { of ppoll } FUNCTION spoll ( device : type_device) pe_isc ); BEGIN send_command(select_code,unl_message); END; { of unlisten } PROCEDURE untalk ( select_code : type_isc ); BEGIN send_command(select_code,unt_message); END; { of untalk } END; { of hpib_2 } $PAGE$ MODULE hpib_3 ;  : INTEGER ; VAR io_isc : type_isc; io_work_char: CHAR; BEGIN io_isc:=set_to_talk(device); send_command(io_isc,spe_message); readchar(io_isc,io_work_char); send_command(io_isc,spd_message); send_command(io_isc,un      *) (* SERIAL GROUP *) (* *) (*  IF (isc_table[select_code].card_id = hp98628_async) THEN BEGIN CASE line OF rts_line: mybit := 1; dtr_line: mybit := 2; drs_line: mybit := 4; OTHERWISE io_escape(ioe_bad_sct,s*) (************************************************************************) (* *) (* *) (* The 98626 code in thelect_code); END; { of CASE line } dummy := iostatus(select_code,8); dummy := binior(dummy,mybit); iocontrol(select_code,8+256,dummy); END ELSE BEGIN IF (card_id = hp98626) OR (card_id = t_message); spoll:=ord(io_work_char); END; { of spoll } PROCEDURE request_service ( select_code : type_isc ; response : INTEGER ); BEGIN IF isc_table[select_code].card_type=hpib_card e serial_0 and serial_3 modules has NOT *) (* been tested and is included in the hopes that it is correct *) (* and that someone will do the 98626 card drivers sometime. *) (*  THEN BEGIN IF NOT active_controller(select_code) { BUG 1250 TM 1/8/82 } THEN iocontrol(select_code,1,response) { BUG 1250 TM 1/8/82 } ELSE io_escape(ioe_misc,select_code); { BUG 1250 TM 1/8/82 }  *) (* There is a good chance that the 98626 will require a re- *) (* release of the IOLIB:IOLIB file ( serial modules only ). *) (* *) (************** END ELSE BEGIN { error } io_escape(ioe_not_hpib,select_code); END; { of IF } END; { of request_service } FUNCTION listener( select_code : type_isc ) : BOOLEAN; BEGIN listener:=bit_set(iostat**********************************************************) MODULE serial_0 ; { by Tim Mikkelsen date 07/22/81 update 11/06/81 purpose This module contains the LEVEL 0 SERIAL GROUP procus(select_code,6),10); END; { of listener } FUNCTION talker ( select_code : type_isc ) : BOOLEAN ; BEGIN talker:=bit_set(iostatus(select_code,6),9); END; { of talker } FUNCTION remoted ( select_code : type_isc edures. } IMPORT iodeclarations ; EXPORT PROCEDURE set_serial ( select_code : type_isc ; line : type_serial_line); PROCEDURE clear_serial( select_code : type_isc ; line ) : BOOLEAN ; BEGIN remoted:=bit_set(iostatus(select_code,6),15); END; { of remoted } FUNCTION locked_out ( select_code : type_isc ) : BOOLEAN ; BEGIN locked_out:=bit_set(iost : type_serial_line); FUNCTION serial_line ( select_code : type_isc ; line : type_serial_line) : BOOLEAN; IMPLEMENT IMPORT iocomasm , general_0 ; PROCEDURE set_serial ( selatus(select_code,6),14); END; END; { of hpib_3 } $PAGE$ (************************************************************************) (* *) (* ect_code : type_isc ; line : type_serial_line); VAR mybit : INTEGER; dummy : INTEGER; BEGIN WITH isc_table[select_code] DO BEGIN IF card_type <> serial_card THEN io_escape(ioe_bad_sct,select_code);      hp98644) THEN BEGIN CASE line OF rts_line: mybit := 2; dtr_line: mybit := 1; drs_line: mybit := 8; OTHERWISE io_escape(ioe_bad_sct,select_code);  ORD(line) ); END; { of IF } END; { of IF } END; { of WITH isc_table BEGIN } END; { of clear_serial } FUNCTION serial_line ( select_code : type_isc ; line : type_serial_line ) END; { of CASE line } dummy := iostatus(select_code,5); dummy := binior(dummy,mybit); iocontrol(select_code,5,dummy); END ELSE BEGIN CALL ( io_drv_ptr^.iod_set ,  : BOOLEAN ; VAR mybit : INTEGER; dummy : INTEGER; reg : INTEGER; mybool : BOOLEAN; BEGIN WITH isc_table[select_code] DO BEGIN IF card_type <> serial_card THEN io_escape(ioe_bad_sct,select_code) io_tmp_ptr , ORD(line) ); END; { of IF } END; { of IF } END; { of WITH isc_table BEGIN } END; { of set_serial } PROCEDURE clear_serial( select_code : type_isc ; ; IF isc_table[select_code].card_id = hp98628_async THEN BEGIN CASE line OF rts_line: BEGIN reg := 8; mybit := 0; END; dtr_liline : type_serial_line); VAR mybit : INTEGER; dummy : INTEGER; BEGIN WITH isc_table[select_code] DO BEGIN IF card_type <> serial_card THEN io_escape(ioe_bad_sct,select_code); IF isc_table[select_code].card_id = hp98628ne: BEGIN reg := 8; mybit := 1; END; drs_line: BEGIN reg := 8; mybit := 2; END; _async THEN BEGIN CASE line OF rts_line: mybit := 1; dtr_line: mybit := 2; drs_line: mybit := 4; OTHERWISE io_escape(ioe_bad_sct,select_code); END; { of CASE line }  dsr_line: BEGIN reg := 7; mybit := 0; END; dcd_line: BEGIN reg := 7; mybit := 1;  dummy := iostatus(select_code,8); dummy := binand(dummy,bincmp(mybit)); iocontrol(select_code,8+256,dummy); END ELSE BEGIN IF (card_id = hp98626) or (card_id = hp98644) THEN BEGIN  END; cts_line: BEGIN reg := 7; mybit := 2; END; ri_line: BEGIN reg := 7; mybit := 3;  CASE line OF rts_line: mybit := 2; dtr_line: mybit := 1; drs_line: mybit := 8; OTHERWISE io_escape(ioe_bad_sct,select_code); END; { of CASE line } d END; OTHERWISE io_escape(ioe_bad_sct,select_code); END; { of CASE line } dummy := iostatus(select_code,reg); mybool:= bit_set(dummy,mybit); END ELSE BEGIN IF (cummy := iostatus(select_code,5); dummy := binand(dummy,bincmp(mybit)); iocontrol(select_code,5,dummy); END ELSE BEGIN CALL ( io_drv_ptr^.iod_clr , io_tmp_ptr , ard_id = hp98626) or (card_id = hp98644) THEN BEGIN CASE line OF rts_line: BEGIN reg := 5; mybit := 1; END;      pdate 10/01/82 purpose This module contains the LEVEL 3 SERIAL GROUP procedures. } IMPORT iodeclarations ; EXPORT PROCEDURE set_baud_rate ( select_code : type_isc ; rocontrol(select_code,21,dummy); { BUG 1270 TM 1/8/82 } END ELSE BEGIN IF (isc_table[select_code].card_id = hp98626) OR (isc_table[select_code].card_id = hp98644) THEN BEGIN date : REAL ); PROCEDURE set_stop_bits ( select_code : type_isc ; num_bits : REAL ); PROCEDURE set_char_length ( select_code : type_isc ; num_char_bit: INTEGERummy:=ROUND(rate); IF dummy = 0 THEN io_escape(ioe_misc,select_code); iocontrol(select_code,3,dummy); { what about 134.5 ? } END ELSE BEGIN io_escape(ioe_misc,select_code);  dtr_line: BEGIN reg := 5; mybit := 0; END; drs_line: BEGIN reg := 5; mybit := 3 ); PROCEDURE set_parity ( select_code : type_isc ; parity_mode : type_parity); PROCEDURE send_break ( select_code : type_isc ); PROCEDURE abort_serial ( select_code :; END; dsr_line: BEGIN reg := 11; mybit := 5; END; dcd_line: BEGIN reg type_isc ); IMPLEMENT IMPORT iocomasm , general_0 ; PROCEDURE set_baud_rate ( select_code : type_isc ; rate : REAL ); VAR dummy : INTEGER; FUNCTION calc_rate ( r : REAL ) : INTEG := 11; mybit := 7; END; cts_line: BEGIN reg := 11; mybit := 4; END; rER; VAR myrate : INTEGER; BEGIN myrate := 0; IF r=50 THEN myrate := 1; IF r=75 THEN myrate := 2; IF r=110 THEN myrate := 3; IF r=134.5 THEN myrate := 4; IF r=150 THEN myrate := 5; IF r=200 THEN i_line: BEGIN reg := 11; mybit := 6; END; OTHERWISE io_escape(ioe_bad_sct,select_code); END; { of CASE line } dummy :myrate := 6; IF r=300 THEN myrate := 7; IF r=600 THEN myrate := 8; IF r=1200 THEN myrate := 9; IF r=1800 THEN myrate :=10; IF r=2400 THEN myrate :=11; IF r=3600 THEN myrate :=12; IF r=4800 THEN myrate :=13= iostatus(select_code,reg); mybool:= bit_set(dummy,mybit); END ELSE BEGIN CALL ( io_drv_ptr^.iod_test , io_tmp_ptr , ORD(line) , mybool ); ; IF r=9600 THEN myrate :=14; IF r=19200 THEN myrate :=15; calc_rate := myrate; END; { of calc_rate } BEGIN WITH isc_table[select_code] DO BEGIN IF card_type <> serial_card THEN io_escape(ioe_misc,select_code);  END; { of IF } END; { of IF } END; { of WITH isc_table BEGIN } serial_line := mybool; END; { of serial_line } END; { of serial_0 } $PAGE$ MODULE serial_3 ; { by Tim Mikkelsen date 07/22/81 uIF isc_table[select_code].card_id = hp98628_async THEN BEGIN dummy:=calc_rate(rate); IF dummy = 0 THEN io_escape(ioe_misc,select_code); iocontrol(select_code,20,dummy); { BUG 1270 TM 1/8/82 } i      END; { of IF 98626 } END; { of IF 98628_async } END; { of WITH isc_table BEGIN } END; { of set_baud_rate } PROCEDURE set_stop_bits ( select_code : type_isc ; num_bits : REAL )END; { of IF 1.5 } END; { of IF 1 } dummy:=iostatus(select_code,4); dummy:=binand(dummy,251)+myval*4; { 0359 TM 8/26/82 } iocontrol(select_code,4,dummy); END ; VAR myval : INTEGER; dummy : INTEGER; BEGIN WITH isc_table[select_code] DO BEGIN IF card_type <> serial_card THEN io_escape(ioe_misc,select_code); IF isc_table[select_code].card_id = hp98628_async THEN BEGIN  ELSE BEGIN io_escape(ioe_misc,select_code); END; { of IF 98626 } END; { of IF 98628_async } END; { of WITH isc_table BEGIN } END; { set_stop_bits } PROCEDURE set_char_length ( se IF num_bits = 1 THEN BEGIN myval := 0; END ELSE BEGIN IF num_bits = 1.5 THEN BEGIN myval := 1; END ELSE BEGIN lect_code : type_isc ; num_char_bit: INTEGER ); VAR myval : INTEGER; dummy : INTEGER; BEGIN WITH isc_table[select_code] DO BEGIN IF card_type <> serial_card THEN io_escape(ioe_misc,select_code); CASE num_ch IF num_bits = 2 THEN BEGIN myval :=2 END ELSE BEGIN io_escape(ioe_misc,select_code); END; { of IF 2 } END; { oar_bit OF 5: myval := 0; 6: myval := 1; 7: myval := 2; 8: myval := 3; OTHERWISE io_escape(ioe_misc,select_code); END; { of CASE } IF isc_table[select_code].card_id = hp98628_async f IF 1.5 } END; { of IF 1 } iocontrol(select_code,35,myval); { BUG 1270 TM 1/8/82 } END ELSE BEGIN IF (isc_table[select_code].card_id = hp98626) { BUG 1269 TM 1/8/82 } OR ( THEN BEGIN iocontrol(select_code,34,myval); END ELSE BEGIN IF(isc_table[select_code].card_id = hp98626) or (isc_table[select_code].card_id = hp98644) THEN BEGIN dummy:=iostatus(isc_table[select_code].card_id = hp98644) THEN BEGIN IF num_bits = 1 THEN BEGIN myval:=0; END ELSE BEGIN IF num_bits = 1.5 THEselect_code,4); dummy:=binand(dummy,252)+myval; { 0359 TM 8/23/82 } iocontrol(select_code,4,dummy); { 557 TM 10/1/82 } END ELSE BEGIN io_escape(ioe_misN BEGIN IF binand(iostatus(select_code,4),3)<>0 THEN io_escape(ioe_misc,select_code); myval:=1; END ELSE BEGIN IF num_bits = 2c,select_code); END; { of IF 98626 } END; { of IF 98628_asnync } END; { of WITH isc_table BEGIN } END; { set_char_length } PROCEDURE set_parity ( select_code : type_isc ; parity_ THEN BEGIN myval:=1; END ELSE BEGIN io_escape(ioe_misc,select_code); END; { of IF 2 } mode : type_parity); VAR myval : INTEGER; dummy : INTEGER; BEGIN WITH isc_table[select_code] DO BEGIN IF card_type <> serial_card THEN io_escape(ioe_misc,select_code); IF isc_table[select_code].card_id = hp98628_async TH     erial_card THEN io_escape(ioe_misc,select_code); IF isc_table[select_code].card_id = hp98628_async THEN BEGIN iocontrol(select_code,6,1); END ELSE BEGIN IF (card_id = hp98626) or (card_id = hp98644) egisters. Registers 0 - 9 are system defined registers. } {-----------------------------------------------------------------} const PLLEL_REG_CARD_ID = 0; PLLEL_REG_RESET = 0; PLLEL_REG_INTDMA_STATU THEN BEGIN iocontrol(select_code,1,1); END ELSE BEGIN io_escape(ioe_misc,select_code); END; { of IF } END; { of IF } END; { of WITH isc_table BEGIN } END; { of sendS = 1; const { for use with PLLEL_REG_CARD_ID } PARALLEL_CARDID = 6; type { for use with: PLLEL_REG_INTDMA_STATUS } intdma_status_type = packed record case integer of 0:(w:EN BEGIN CASE parity_mode OF no_parity: myval := 0; odd_parity: myval := 1; even_parity: myval := 2; zero_parity: myval := 3; { 0355 TM 8/20/82 } one_p_break } PROCEDURE abort_serial ( select_code : type_isc ); BEGIN { what about active tfrs } WITH isc_table[select_code] DO BEGIN IF card_type <> serial_card THEN io_escape(ioe_misc,select_code); IF isc_tabarity: myval := 4; { 0355 TM 8/20/82 } OTHERWISE io_escape(ioe_misc,select_code); END; { of CASE } iocontrol(select_code,36,myval); END ELSE BEGIN IF (isc_table[selele[select_code].card_id = hp98628_async THEN BEGIN iocontrol(select_code,256+125,1); { BUG xxxx TM 1/26/82 } END ELSE BEGIN IF (card_id = hp98626) or (card_id = hp98644) { BUG FIX 6/4/84 } ct_code].card_id = hp98626) or (isc_table[select_code].card_id = hp98644) THEN BEGIN CASE parity_mode OF no_parity: myval := 0; odd_parity: myval := 1; even_parity THEN BEGIN iocontrol(select_code,0,1); END ELSE BEGIN io_escape(ioe_misc,select_code); END; { of IF } END; { of IF } END; { of WITH isc_table BEGIN } END; { of abort_se: myval := 3; one_parity: myval := 5; zero_parity: myval := 7; OTHERWISE io_escape(ioe_misc,select_code); END; { of CASE } dummy:=iostatus(select_code,4); dummrial } END; { of serial_3 } $PAGE$ (************************************************************************) (* *) (* y:=binand(dummy,199)+myval*8; { 0359 TM 8/23/82 } iocontrol(select_code,4,dummy); END ELSE BEGIN io_escape(ioe_misc,select_code); END; { of IF 98626 } END; { of IF  *) (* PARALLEL GROUP *) (* *) (* *) (********************98628_asnync } END; { of WITH isc_table BEGIN } END; { set_parity } PROCEDURE send_break ( select_code : type_isc ); BEGIN { what about active tfrs } WITH isc_table[select_code] DO BEGIN IF card_type <> s****************************************************) module parallel_3; import iodeclarations; export { IOCONTROL and IOSTATUS register definitions. } {-----------------------------------------------------------------} { level 0 r      io_word); 1:(bh: io_byte; bl: io_byte); 2:(b: io_byte; {upper byte unused} ie: boolean; fofull: boolean; fifoempty: boolean; nstrobe_low: boolean; {true = asserted low} busy_high: boolean; nack_low: boolean); e ir: boolean; intlvl: 0..3; pad: 0..3; de1: boolean; de0: boolean); end; {--------nd; type { for use with: PLLEL_REG_HOST_LINE_CONTROL } host_line_type = packed record case integer of 0:(w: io_word); 1:(bh: io_byte; ---------------------------------------------------------} { level 10 registers. Register 10 - 19 are for hardware status and control. } {-----------------------------------------------------------------} const P bl: io_byte); 2:(b: io_byte; {upper byte unused} pad: 0..hex('1F'); ninit_low: boolean; nselectin_low:boolean; LLEL_REG_PERIPHERAL_STATUS = 10; PLLEL_REG_COMM_STATUS = 11; PLLEL_REG_HOST_LINE_CONTROL = 12; PLLEL_REG_IO_CONTROL = 13; PLLEL_REG_FIFO = 14; type { for use with: PLLEL wr_nrd_high: boolean); end; type { for use with: PLLEL_REG_IO_CONTROL } io_control_type = packed record case integer of 0:(w: io_word); _REG_PERIPHERAL_STATUS } peripheral_status_type = packed record case integer of 0:(w: io_word); 1:(bh: io_byte; bl: io_byte);  1:(bh: io_byte; bl: io_byte); 2:(b: io_byte; {upper byte unused} pad: 0..hex('3F'); modify_io: boolean; 2:(b: io_byte; {upper byte unused} pad: 0..hex('1F'); nerror_low: boolean; select_high: boolean; perror_high input_high: boolean); end; {-----------------------------------------------------------------} { level 20 registers. Register 20 - 29 are for driver status and control. } : boolean); end; const PLLEL_PERIPHERAL_ONLINE = HEX('02'); type { for use with: PLLEL_REG_COMM_STATUS } comm_status_type = packed record case integer of 0:(w: {-----------------------------------------------------------------} const PLLEL_REG_PERIPHERAL_TYPE = 20; PLLEL_REG_TYPE_RESET = 21; PLLEL_REG_PERIPHERAL_RESET = 22; PLLEL_REG_INTERRUPT_STATE = 23 io_word); 1:(bh: io_byte; bl: io_byte); 2:(b: io_byte; {upper byte unused} pad: 0..7; fi; PLLEL_REG_DRIVER_OPTIONS = 24; PLLEL_REG_OPTIONS_RESET = 25; PLLEL_REG_DRIVER_STATE = 26; const { for use with: PLLEL_REG_PERIPHERAL_TYPE PLLEL_REG_TYPE_RESET } NOT_     n); end; type { for use with: PLLEL_REG_DRIVER_OPTIONS PLLEL_REG_OPTIONS_RESET } driver_options_type = packed record case integer of 0:(w: io_word);_REG_USER_ISR_STATUS = 32; const { for use with PLLEL_REG_HOOK_STATUS } USER_ISR_HOOK_INACTIVE = 0; USER_ISR_HOOK_ACTIVE = 1; type { for use with: PLLEL_REG_USER_ISR_ENABLE PLLEL_REG_US 1:(bh: io_byte; bl: io_byte); 2:(b: io_byte; {upper byte unused} pad: 0..hex('f'); ignore_ER_ISR_STATUS } user_isr_status_type = packed record case integer of 0:(w: io_word); 1:(bh: io_byte; bl: io_byte); PRESENT = 0; OUTPUT_ONLY = 1; HP_BIDIRECTIONAL = 2; USER_SPEC_NO_DEVICE = 10; USER_SPEC_OUTPUT_ONLY = 11; USER_SPEC_HP_BIDIRECTIONAL = 12; OUTPUT_SET =pe: boolean; write_verify:boolean; wr_nrd_low: boolean; use_nack: boolean); end; type { for use with PLLEL_REG_DRIVER_STATE } driver_st [OUTPUT_ONLY, HP_BIDIRECTIONAL, USER_SPEC_OUTPUT_ONLY, USER_SPEC_HP_BIDIRECTIONAL]; INPUT_SET = [HP_BIDIRECTIONAL, ate_type = packed record case integer of 0:(w: io_word); 1:(bh: io_byte; bl: io_byte); 2:(b: io_byte; { USER_SPEC_HP_BIDIRECTIONAL]; USER_SET = [NOT_PRESENT, USER_SPEC_NO_DEVICE, USER_SPEC_OUTPUT_ONLY, USER_SPEupper byte unused} disabled: boolean; error: boolean; write: boolean; read: boolean; pad: 0C_HP_BIDIRECTIONAL]; type { for use with PLLEL_REG_INTERRUPT_STATE } driver_int_state_type = packed record case integer of 0:(w: io_word); 1:(bh: io_byte..7; active_xfer: boolean); end; const DISABLED_BY_USER = hex('80'); INACTIVE_ERROR = hex('40'); INACTIVE_WRITE = hex('20'); ACTIVE_WRITE = ; bl: io_byte); 2:(b: io_byte; {upper byte unused} fifo_full: boolean; fifo_empty: boolean; pad: hex('21'); INACTIVE_READ = hex('10'); ACTIVE_READ = hex('11'); {-----------------------------------------------------------------} { level 30 registers. Registers 30 - 39 are for User IS boolean; busy_low: boolean; nack_low_trans:boolean; nerror_trans:boolean; select_trans:boolean; pe_trans: booleaR status and control } {-----------------------------------------------------------------} const PLLEL_REG_HOOK_STATUS = 30; PLLEL_REG_HOOK_CLEAR = 30; PLLEL_REG_USER_ISR_ENABLE = 31; PLLEL       2:(b: io_byte; {upper byte unused} fifo_full: boolean; fifo_empty: boolean; xfer_extend: boolean; busy_low: boolean; _type <> pllel_card) then io_escape(ioe_no_card, sc); end; procedure set_user_isr(sc:type_isc; p:parallel_user_isr_type); type pxlate_type = record case integer of 1:( nack_low_trans:boolean; nerror_trans:boolean; select_trans:boolean; pe_trans: boolean); end; {--------------------------------------pproc:parallel_user_isr_type); 2:(ioproc:io_proc); end; var pxlate:pxlate_type; begin sc_check(sc); pxlate.pproc := p; with isc_table[sc] do begin io_t---------------------------} { All together now. } {-----------------------------------------------------------------} type p3regs_type = packed record case integer of 1:(w: io_word); mp_ptr^.user_isr.real_proc := pxlate.ioproc; call(io_drv_ptr^.iod_wtc, io_tmp_ptr, PLLEL_REG_USER_ISR_ENABLE, 0); end; end; procedure clear_user_isr(sc:type_isc); begin sc_check(sc); with isc_table[sc] do b 2:(bh: io_byte; bl: io_byte); 3:(intdma_status: intdma_status_type); 4:(peripheral_status: peripheral_status_type); 5:(comm_status: egin call(io_drv_ptr^.iod_wtc, io_tmp_ptr, PLLEL_REG_HOOK_CLEAR, 0); end; end; function nack_set(sc:type_isc):boolean; var b:boolean; begin sc_check(sc); b := false; with isc_table[sc] do  comm_status_type); 6:(host_line: host_line_type); 7:(io_control: io_control_type); 8:(driver_int_state: driver_int_state_type); 9:(driver_options: driver_option call(io_drv_ptr^.iod_end, io_tmp_ptr, b); nack_set := b; end; end. {of PARALLEL_3} s_type); 10:(driver_state: driver_state_type); 11:(user_isr_status: user_isr_status_type); end; {-----------------------------------------------------------------} { HP Parallel i$debug off$ $ucsd,modcal$ program export_text(input,output); const vidleng = 7; tidleng = 15; fblksize = 512; type byte = 0..255; shortint = -32768..32767; filekind = (UNTYPEDFILE,XDSKFILE,CODEFILE,TEXTFILE, fkind4,DATAFILE,fkind6,fkind7,fknterface support routines. } {-----------------------------------------------------------------} type PARALLEL_USER_ISR_TYPE = PROCEDURE(SC:TYPE_ISC); PROCEDURE SET_USER_ISR(SC:TYPE_ISC; P:PARALLELind8); errcode = (ERRLIBREAD, ERRMODDIRREAD, ERRDIRSIZE, ERRDIRWRITE, ERRCOPYREAD, ERRCOPYWRITE, ERRLIBWRITE); dirrange = 0..235; string255 = string[255]; dirptr = ^moduledirectory; fdirptr = ^filedirectory; entryptr = ^direntry; strptr = _USER_ISR_TYPE); PROCEDURE CLEAR_USER_ISR(SC:TYPE_ISC); FUNCTION NACK_SET(SC:TYPE_ISC):BOOLEAN; implement procedure sc_check(sc:type_isc); begin with isc_table[sc] do if (card_ptr = NIL) or (card^string255; vid = string[vidleng]; tid = string[tidleng]; daterec = packed record year: 0..127; day : 0..31; month: 0..12; end; direntry = record dfirstblk: shortint; dlastblk: shortint; case dfkind: filekind of       tbytes $alias 'asm_newbytes'$ (var p : anyptr; bytes : integer); external; begin mark(start.p); getbytes(libptr.p, fblksize); blk_cnt := blockread(infile, libptr.p^, 1, 0); if (blk_cnt <> 1) or (ioresult <> 0) then escape(ord(ERRLIBREAD)); libfblksize); blk_cnt := blockread(infile, bufptr.p^, number_of_blocks, start_block); if (blk_cnt <> number_of_blocks) or (ioresult <> 0) then escape(ord(ERRCOPYREAD)); blk_cnt := blockwrite(outfile, bufptr.p^, number_of_blocks, output_start); if (blk_c_blks := libptr.e^.dlastblk; release(start.p); getbytes(libptr.p, lib_blks * fblksize); blk_cnt := blockread(infile, libptr.p^, lib_blks, 0); if (blk_cnt <> lib_blks) or (ioresult <> 0) then escape(ord(ERRLIBREAD)); module_count := libptr.e^.dnnt <> number_of_blocks) or (ioresult <> 0) then escape(ord(ERRCOPYWRITE)); release(start.p); end; $page$ procedure process_modules(libptr : addrec; module_count : dirrange; var total_blocks : integer; offset : integer); var entry : dirrange; cu UNTYPEDFILE: (dvid: vid; deovblk: shortint; dnumfiles: dirrange; dloadtime: shortint; dlastboot: daterec); XDSKFILE,CODEFILE,TEXTFILE,DATAFILE: (dtid: tid; dlastbyte: 1..fblksize; daccess: daterec) end; modulediumfiles; read_libdirectory := lib_blks; end; $page$ function read_module_directory(start_block : integer; modptr : addrec) : integer; var blk_cnt, diff : integer; tmp_ptr : addrec; begin blk_cnt := blockread(infile, modptr.p^, 1, start_block);rectory = packed record date: daterec; revision: daterec; producer: char; systemid: byte; notice: string[80]; directorysize: integer; modulesize: integer; executable: boolean; relocatablesize, relocatablebase: integer; globalsize, globa if (blk_cnt <> 1) or (ioresult <> 0) then escape(ord(ERRMODDIRREAD)); tmp_ptr.a := modptr.a + sizeof(moduledirectory); tmp_ptr.a := tmp_ptr.a + length(tmp_ptr.s^) + 2 + ord(odd(length(tmp_ptr.s^))); diff := tmp_ptr.a - modptr.a; if diflbase: integer; extblock, extsize: integer; defblock, defsize : integer; sourceblock, sourcesize : integer; textrecords: integer; { mname: string [ (variable) ]; } { startaddress: gvr; (if executable) } { repeat for eaf > fblksize then escape(ord(ERRDIRSIZE)); read_module_directory := diff; end; $page$ procedure update_module_directory(mdirp : addrec; start_block, dir_size, ext_blks : integer); var blk_cnt, blks : integer; begin with mdirp.m^ do begin directch text record } { textstart,textsize : integer; } { refstart,refsize : integer; } { loadaddress: gvr; } end; addrec = record case integer of 1: (i:integer); 2: (a:integer); 3orysize := dir_size; modulesize := (ext_blks + 1) * fblksize; executable := false; relocatablesize := 0; relocatablebase := 0; globalsize := 0; globalbase := 0; extblock := 0; extsize := 0; defblock := 0; defsize := 0; sourceblock := : (p:^integer); 4: (m:dirptr); 5: (e:entryptr); 6: (l:fdirptr); 7: (s:strptr); end; filedirectory = array[dirrange] of direntry; var infile, outfile : file; infile_name, outfile_name : string[40]; position : integer; errstr : string[81; textrecords := 0; end; blks := (dir_size + fblksize -1) div fblksize; blk_cnt := blockwrite(outfile, mdirp.p^, blks, start_block); if (blk_cnt <> blks) or (ioresult <> 0) then escape(ord(ERRDIRWRITE)); end; $page$ procedure copy_export_text(s0]; libptr : addrec; lib_blks : integer; module_count : dirrange; total_blocks : integer; $page$ function read_libdirectory(var libptr : addrec; var module_count : dirrange) : integer; var start : addrec; blk_cnt, lib_blks : integer; procedure getart_block, number_of_blocks, output_start : integer); var blk_cnt : integer; start, bufptr : addrec; procedure getbytes $alias 'asm_newbytes'$ (var p : anyptr; bytes : integer); external; begin mark(start.p); getbytes(bufptr.p, number_of_blocks * !     rrent_position : integer; export_blocks : integer; module_directory_size : integer; new_firstblk : integer; export_offset : integer; mdirp : addrec; directory_buffer : packed array[1..fblksize] of char; begin total_blocks := 0; current_position := reset(infile,infile_name); if ioresult <> 0 then escape(escapecode); write(output,'output file: '); readln(input,outfile_name); position := pos('.CODE',outfile_name); if position = 0 then outfile_name := concat(outfile_name,'.CODE');  offset; mdirp.p := addr(directory_buffer); for entry := 1 to module_count do with libptr.l^[entry] do begin if dfkind = CODEFILE then begin writeln(output,'MODULE ',dtid); module_directory_size := read_module_directory(dfirstblk,mdirp);rewrite(outfile,outfile_name); if ioresult <> 0 then escape(escapecode); lib_blks := read_libdirectory(libptr, module_count); process_modules(libptr, module_count, total_blocks, lib_blks); write_libdirectory(libptr,total_blocks, lib_blks); cl export_blocks := (mdirp.m^.sourcesize + fblksize - 1) div fblksize; { save export relative start and output file } { position before updating the module directory } export_offset := mdirp.m^.sourceblock; new_firstblk := current_ose(outfile,'lock'); end; recover begin case escapecode of ord(ERRLIBREAD): errstr := 'Error reading library directory'; ord(ERRMODDIRREAD): errstr := 'Error reading module directory'; ord(ERRDIRSIZE): errstr := 'Module diposition; update_module_directory(mdirp, current_position, module_directory_size, export_blocks); current_position := current_position + (module_directory_size + fblksize - 1) div fblksize; copy_export_text(dfirstblk + exporectory > 512 bytes'; ord(ERRDIRWRITE): errstr := 'Error writing module directory'; ord(ERRCOPYREAD): errstr := 'Error reading export text'; ord(ERRCOPYWRITE): errstr := 'Error writing export text'; ord(ERRLIBWRITE): errstr :rt_offset, export_blocks, current_position); current_position := current_position + export_blocks; { update library directory entry with new start and } { end blocks. set dlast to fblksize always. } dfirstblk := new_fir= 'Error writing library directory'; otherwise escape(escapecode); end; writeln(output,errstr); end; end. stblk; dlastblk := current_position; dlastbyte := fblksize; { keep a running total of blocks written to output file } { used to update dlastblk in library directory entry 0 } total_blocks := total_blocks + (module_directory_siz (* (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTEDe + fblksize - 1) div fblksize + export_blocks; end else writeln(output,'ILLEGAL TYPE : ',ord(dfkind)); end; end; $page$ procedure write_libdirectory(libptr : addrec; module_blocks, lib_blks : integer); var blk_cnt : integer; begin libp RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Coloratr.l^[0].dlastblk := total_blocks; blk_cnt := blockwrite(outfile, libptr.p^, lib_blks, 0); if (blk_cnt <> lib_blks) or (ioresult <> 0) then escape(ord(ERRLIBWRITE)); end; begin try begin write(output,'input file: '); readln(input,infile_name);do *) $MODCAL ON$ $PARTIAL_EVAL ON$ $RANGE OFF$ $DEBUG OFF$ $OVFLCHECK OFF$ $STACKCHECK OFF$ $PAGE$ (************************************************************************) (* !      - June 1 , 1981 *) (* update - June 5 , 1985 *) (* release - Jul 12 , 1985 *) (* e time it is loaded. This program *) (* initializes the static read/write memory. This program also *) (* allocates the temporary storage for any card that exists - *) (* independent of whether there is or is not a driver for  *) (* source - IOLIB:KERNEL.TEXT *) (* object - IOLIB:KERNEL.CODE *) (* *) (**it. *) (* *) (* The driver modules consist of the actual assembly or PASCAL *) (* routines that deal with a specific interface card. There is *) (* also an exe *) (* RELEASED VERSION 3.1 *) (* *) (************************************************************************) (* **********************************************************************) $PAGE$ (************************************************************************) (* *) (*  *) (* *) (* IOLIB KERNEL *) (*  *) (* This is the source code for an external procedures library *) (* to be used for general purpose interfacing on the HP 9826. *) (*  *) (* *) (************************************************************************) (* * *) (* The library consists of 3 primary sets of modules - *) (* *) (* 1. KERNEL modules *) (* ) (* *) (* library - IOLIB *) (* name - KERNEL *) (* module(s) - iodec 2. driver modules *) (* 3. IOLIB modules *) (* *) (* The KERNEL modules consist of the follarations *) (* - iocomasm *) (* - general_0 *) (* lowing modules - *) (* *) (* 1. iodeclarations ( contains static r/w space ) *) (* 2. iocomasm *) ( *) (* author - Tim Mikkelsen *) (* phone - 303-226-3800 ext. 2910 *) (* *) (* date * 3. general_0 ( initialization & low level *) (* routines like ioread/iowrite) *) (* The KERNEL modules also have an executable program segement *) (* that gets executed at th"     cutable program segment for each driver module. *) (* This program searches the select code table in the static r/w *) (* initialized by the KERNEL general_0 module for all select codes *) (* that have the right interface card ( HPIB  module - code change in *) (* GENERAL_3. *) (* *) (* aaaa T Mikkelsen kernel_ No bug sheet. drivers will search *) (* for the 98624 interface ). This program will then set up the *) (* driver tables to point to the correct drivers. *) (* *) (*  *) (* 05/24/82 initialize The CRT and keyboard *) (* select codes were *) (* interchanged. Should *) (*  The rest of the IOLIB modules are high-level modules that are *) (* used by an end user in his/her application program. *) (* *) (* The KERNEL and some set of dr have no effect. *) (* *) (* bbbb T Mikkelsen kernel_ No bug sheet. *) (* 07/09/82 initialize Addiniver modules will exist in the *) (* INITLIB file as object code ( not EXPORT text ). The *) (* export text will reside on the IO file. The rest *) (* of the library will reside on the IO file. g machine id info *) (* iodeclarations for Bob Morain and the *) (* Ganglia drivers. *) (* *) (* j *) (* *) (************************************************************************) $PAGE$ (************************************************************************) (* w Jeff Wu kernel_ No bug sheet. *) (* 07/12/82 initialize Adding temp type for *) (* iodeclarations 626 drivers. *) (*  *) (* *) (* BUG FIX HISTORY - after release 1.0 *) (*  *) (* 0082 T Mikkelsen kernel_ Adding a link for the *) (* 07/23/82 initialize error message function. *) (* iodeclarations See also GENERAL_3.  *) (* *) (* BUG # BY / ON LOC DESCRIPTION *) (* ----- ----------- -------------- ---------------------- *) (*  *) (* end_error_link *) (* *) (* cccc T Mikkelsen iodeclarations Allowing the 98629 card *) (* 08/16/82  *) (* 1281 T Mikkelsen IODECLARATIONS bad error message. *) (* 01/08/82 No code change in this *) (*  and the 98628_dsndl as *) (* identifiable cards. *) (* See DC_DRV modules also.*) (* "      *) (* jws J Schmidt iodeclarations Add card id's and types *) (* 03/25/83 general_0 for EPROM programmer *) (* an *) (************************************************************************) $PAGE$ (************************************************************************) (* d bubble cards. *) (* Add initialization code.*) (* *) (* jws2 J Schmidt general_0 Add test for internal *) (*  *) (* *) (* REFERENCES : *) (* *) (*  *) (* 0350 T Mikkelsen general_0 Fundamental flaw with *) (* 08/19/82 the dummy drivers. *) (* *) (* 0364  06/28/83 HP-IB present. *) (* *) (* jws3 J Schmidt iodeclarations Deleted io_model_number *) (* 02/09/84 gener T Mikkelsen iodeclarations Addition of SRM errors. *) (* 08/23/82 See also GENERAL_3. *) (* *) (* 0367 T Mikkelsen iolibrary_keral_0 and io_model_name stuff *) (* Added GATOR id, init. *) (* jws4 J Schmidt iodeclarations Added id and init for *) (* 03/05/84 general_0 98644 card nel *) (* 09/22/82 Allow kernel to install *) (* itself - probably will *) (* not be used much. *) ( *) (* *) (* ----------- changes for release 3.1 *) (* jws5 J Schmidt iodeclarations added new temp type *) (* 06/05/85* *) (* tttt T Mikkelsen kbd_rdb Change in the handling *) (* 09/22/82 of the keyboard end of *) (*  to allow space for *) (* default settings on *) (* 98644, 98626 *) (*  line condition from 1.0.*) (* *) (* uuuu T Mikkelsen iodeclarations Differentiate between a *) (* 09/28/82 628 async and 6 *) (* ----------- changes for release 3.23 *) (* DEW Dave Willis iodeclarations added support for the *) (* 09/89 scsi interfaces. *) (* 29 srm *) (* card type (srm/serial). *) (* See also DC_DRV. *) (* ------- changes for release 3.0 *) (*  *) (* DEW1 Dave Willis iodeclarations added support for the *) (* 12/89 HP Parallel interfaces *) (* #      *) (* 1. 9826 I/O Designers Guide ( Loyd Nelson ) *) (* *) (* 2. 68000 Manual ( Mon date 07/15/81 update 03/05/84 by John Schmidt purpose This module contains the common declarations to be used by the rest of the I/O library. } IMPORT sysglobals; EXPORT CONST iominisc = 0 ; { 0 - 7 itorola ) *) (* *) (* 3. Pascal alpha site ERS ( Roger Ison ) *) (* *) (* nternal } iomaxisc = 31; { 8 - 31 external 8..31 } minrealisc = 7 ; maxrealisc = 31; { 7..31 are real isc.s with temps } io_line_feed = CHR(10); io_carriage_rtn = CHR(13); $PAGE$ { escape code constants } io4. Pascal I/O Library ERS ( Tim Mikkelsen ) *) (* *) (* 5. 9826 HPL EIO & IOD listings ( Bob Hallissy ) *) (* escapecode = -26; ioe_no_error = 0; { no error } ioe_no_card = 1; { no card at select code } ioe_not_hpib = 2; { interface should be hpib } ioe_not_act = 3;  *) (* 6. 9826 HPL Misc. I/O Doc. ( Bob Hallissy ) *) (* *) (* 7. 9826 card documentation ( Mfg. Specs. )  { not active controller } ioe_not_dvc = 4; { should be device not isc } { BUG 1281 TM 1/8/82} ioe_no_space = 5; { no space left in buffer } ioe_no_data = 6; { no data left in buffer  *) (* *) (* *) (************************************************************************) $PAGE$ PROGRAM iolibrary_k} ioe_bad_tfr = 7; { improper transfer attempted } ioe_isc_busy = 8; { the select code is busy } ioe_buf_busy = 9; { the buffer is busy } ioe_bad_cnt = 10; { improper transfer ernel ( INPUT , OUTPUT ); { the PROGRAM surrounds the following modules because there needs to be a start address for this set of modules to allow initialization to occur } $PAGE$ (****************************************************************count } ioe_bad_tmo = 11; { bad timeout value } ioe_no_driver = 12; { no driver for this card } ioe_no_dma = 13; { no dma } ioe_no_word = 14; { word o********) (* *) (* *) (* GENERAL GROUP IODECLARATIONS *) (* perations not allowed } ioe_not_talk = 15; { not addressed as talker } ioe_not_lstn = 16; { not addressed as listener } ioe_timeout = 17; { a timeout has occurred } ioe_not_sctl = 18;  *) (* *) (************************************************************************) MODULE iodeclarations ; { by Tim Mikkelse { not system controller } ioe_rds_wtc = 19; { bad status or control } ioe_bad_sct = 20; { bad set/clear/test operation } ioe_crd_dwn = 21; { interface card is dead } ioe_eod_seen #      ); ppe_message = CHR( 96 ); ppd_message = CHR(112 ); talk_constant = 64; listen_constant = 32; $PAGE$ { card type constants } no_card = 0 ; other_card = 1 ; system_card = 2 ; hpib_card = 3 ; gpio_card  = 0..255 ; io_word = -32768..32767 ; io_string = STRING[255]; io_proc_type = PROCEDURE; errlnk_type = PROCEDURE ( errorcode : INTEGER ; { 0082 TM 7/23/82 } VAR s : io_string ); { 0082 TM 7/23/82 } { card i= 4 ; serial_card = 5 ; graphics_card = 6 ; srm_card = 7 ; { shared resource mgr } { uuuu TM 9/28/82 } bubble_card = 8 ; { bubble memory } { jws 3/25/83} eprom_prgmr = 9 ; { eprom programmer d and type declarations } type_of_card = io_word; type_card_id = io_word; { hpib type declarations } type_hpib_addr = 0..31 ; type_hpib_line = ( ren_line , ifc_line , srq_line , eoi_line , nrfd_line , nda= 22; { end/eod has occured } ioe_misc = 23; { miscellaneous - } { value of param error } ioe_sr_toomany = 304; { too many chars w/o terminator } { 0364 TM 8/23/82 } ioe_dc_fai} { jws 3/25/83} scsi_card = 10; { 09/89 DEW - added SCSI support} pllel_card = 11; { 12/89 DEW1 - added Parallel Centronics support} { card id constants } { } { positive id's l = 306; { dc interface failure } ioe_dc_usart = 313; { USART receive buffer overflow } ioe_dc_ovfl = 314; { receive buffer overflow } ioe_dc_clk = 315; { missing clock }are the actual } { card id's } hp98628_dsndl = -7; { DSN/DL } { cccc TM 8/16/82 } hp98629 = -6; { shared resource mgr } { cccc TM 8/16/82 } hp_datacomm = -5; hp98620 = -4; i ioe_dc_cts = 316; { CTS false too long } ioe_dc_car = 317; { lost carrier disconnect } ioe_dc_act = 318; { no activity disconnect } ioe_dc_conn = 319; { connection not estanternal_kbd = -3; internal_crt = -2; internal_hpib = -1; no_id = 0; hp98624 = 1; { hpib } hp98626 = 2; { serial } hp98622 = 3; { gpio } hp98623 = 4; { bblished } ioe_dc_conf = 325; { bad data bits/par combination } ioe_dc_reg = 326; { bad status /control register } ioe_dc_rval = 327; { control value out of range } ioe_sr_fail = 353; { data licd } hpPARALLEL = 6; { parallel centronics } { DEW1 12/89 } hp98658 = 7; { scsi - also includes hp98265 DEW 09/89 - added SCSI support} hp98625 = 8; { disk } hp98628_async = 20; { hp9862nk failure } { 0364 TM 8/23/82 } no_isc = 255; { used for ioe_isc within io errors } $PAGE$ { hpib message constants } gtl_message = CHR( 1 ); sdc_message = CHR( 4 ); ppc_message = CHR( 5 ); get_messa8 } hpGATOR = 25; { bitmap display -- need number jws3 } hp98253 = 27; { EPROM programmer } { jws 3/25/83 } hp98627 = 28; { graphics } hp98259 = 30; { bubble memory } { jws ge = CHR( 8 ); tct_message = CHR( 9 ); llo_message = CHR( 17 ); dcl_message = CHR( 20 ); ppu_message = CHR( 21 ); spe_message = CHR( 24 ); spd_message = CHR( 25 ); unl_message = CHR( 63 ); unt_message = CHR( 953/25/83 } hp98644 = 66; { serial -- pri. id=2, sec. id=2 jws4 } $PAGE$ TYPE { general declarations } type_isc = iominisc..iomaxisc ; type_device = iominisc..iomaxisc*100+99; io_bit = 0..15 ; io_byte $     c_line , dav_line , atn_line ) ; { serial type declarations } type_parity = ( no_parity , odd_parity , even_parity , zero_parity , one_parity ); type_serial_line= ( rts_line , cts_line , SR procedures } { Note that the current definition of EOT / ISR procedures is that they will execute ( probably ) inside an ISR and will therefore be at that interrupt level. This has several side effects - such as READ from the keyboard not wo dcd_line , dsr_line , drs_line , ri_line , dtr_line ); $PAGE$ { driver declarations } io_proc = PROCEDURE ( temp : ANYPTR ); io_proc_c = PROCEDURE ( temp : ANYPTR; v : CHAR ); io_rking- since they depend on interrupts occuring. The ISR / EOT procedures will work best if they set a flag that the user program will periodically check. Basically this means the user needs to implement his own end-of-line searching. Theproc_vc = PROCEDURE ( temp : ANYPTR; VAR v : CHAR); io_proc_w = PROCEDURE ( temp : ANYPTR; v : io_word ); io_proc_vw = PROCEDURE ( temp : ANYPTR; VAR v : io_word ); io_proc_s = PROCEDURE ( temp  ISR / EOT procedure is allowed to have a NON-ZERO static link. This means it can be a nested procedure. This is potentially dangerous if the user program is no longer in that chain. CAVEAT EMPTOR.  : ANYPTR; reg : io_word ; v : io_word ); io_proc_vs = PROCEDURE ( temp : ANYPTR; reg : io_word ; VAR v : io_word ); io_proc_l = PROCEDURE ( temp : ANYPTR; line : io_bit ); io_proc_ } { interface driver space } io_temp_type = PACKED RECORD myisrib : ISRIB ; user_isr : io_funny_proc; {JPC 2/22/82} user_parm : ANYPTR ; {JPC 2/22/82} card_addr : ANYPTR ; in_bufptr :vl = PROCEDURE ( temp : ANYPTR; line : io_bit ; VAR v : BOOLEAN ); io_proc_vb = PROCEDURE ( temp : ANYPTR; VAR v : BOOLEAN ); io_proc_ptr = PROCEDURE ( temp : ANYPTR; v : ANYPTR ); drv_table ANYPTR ; out_bufptr: ANYPTR ; eirbyte : CHAR ; my_isc : io_byte ; timeout : INTEGER ; { in milliseconds } addressed : io_word ; drv_misc : ARRAY[1..32] OF CHAR ; END; io_temp_type2 _type = RECORD iod_init : io_proc ; iod_isr : ISRPROCTYPE ; iod_rdb : io_proc_vc ; iod_wtb : io_proc_c ; iod_rdw : io_proc_vw ; iod_wtw : io_proc_w ; iod_rds : io_proc_vs ; iod_wtc : i= PACKED RECORD myisrib : ISRIB ; user_isr : io_funny_proc; {JPC 2/22/82} user_parm : ANYPTR ; {JPC 2/22/82} card_addr : ANYPTR ; in_bufptr : ANYPTR ; out_bufptr: ANYPTR ; eirbyte o_proc_s ; iod_end : io_proc_vb ; iod_tfr : io_proc_ptr ; iod_send : io_proc_c; iod_ppoll : io_proc_vc ; iod_set : io_proc_l ; iod_clr : io_proc_l ; iod_test : io_proc_vl ; END; { procedure : CHAR ; my_isc : io_byte ; timeout : INTEGER ; { in milliseconds } addressed : io_word ; drv_misc : ARRAY[1..128] OF CHAR ; END; io_temp_type3 = PACKED RECORD {jw 7/12/82} definition for DMA termination procedure } io_funny_proc = RECORD CASE BOOLEAN OF TRUE: ( real_proc : io_proc ); FALSE: ( dummy_pr : ANYPTR ; dummy_sl : ANYPTR ) END; { procedure definition for user EOT/I myisrib : ISRIB ; {jw 7/12/82} user_isr : io_funny_proc; {JPC 2/22/82} user_parm : ANYPTR ; {JPC 2/22/82} card_addr : ANYPTR ; {jw 7/12/82} in_bufptr : ANYPTR ; $     { serial INTR } serial_DMA , serial_FHS , serial_FASTEST , dummy_tfr_2 , { serial OVERLAP } overlap_INTR , overlap_DMA , overlap_FHS , overlap_FASTEST , OVERLAP ) ; actual_tfr_tybrary ) and the kernel code. Each driver module will append an indication of its revision like 'G1.0' for GPIO. So - a typical system would have a io_revid of 'IO 1.0 : D1.0 H1.0 G1.0 S1.0'. known ids - pe = ( no_tfr , INTR_tfr , DMA_tfr , BURST_tfr , FHS_tfr ) ; dir_of_tfr = ( to_memory, { input = BOOLEAN false } from_memory { output= BOOLEAN true } ) ; buf_type = PAC main io lib 'IO 1.0 : ' dma driver ' D1.0' hpib driver ' H1.0' gpio driver ' G1.0' 628 driver ' S1.0' 626 driver ' R1.0' Parallel driver ' P1.0' DEW1 12/89 } io_error_link : errlnk_t {jw 7/12/82} out_bufptr: ANYPTR ; {jw 7/12/82} eirbyte : CHAR ; {jw 7/12/82} my_isc : io_byte ; {jw 7/12/82} timeout : INTEGER ; { in milliseconds KED ARRAY[0..maxint] OF CHAR; buf_info_type = RECORD drv_tmp_ptr : pio_tmp_ptr; active_isc : io_byte; act_tfr : actual_tfr_type ; usr_tfr : user_tfr_type ; b_w_mode : BOOLEAN ; { word = BOOLEAN} addressed : io_word ; {jw 7/12/82} drv_misc : ARRAY[1..160] OF CHAR ; {jw 7/12/82} END; {jw 7/12/82} io_temp_type4 = PACKED RECORD {jws5 6/5/85} myisrib true } end_mode : BOOLEAN ; { eoi = BOOLEAN true } direction : dir_of_tfr ; term_char : -1..255 ; { -1 = no termination char } term_count : INTEGER ; buf_ptr : ^buf_type ; buf_ : ISRIB ; {jws5 6/5/85} user_isr : io_funny_proc; {jws5 6/5/85} user_parm : ANYPTR ; {jws5 6/5/85} card_addr : ANYPTR ; {jws5 6/5/85} in_bufptr : ANYPTR ; size : INTEGER ; buf_empty : ANYPTR ; buf_fill : ANYPTR ; eot_proc : io_funny_proc; {JPC 2/22/82} eot_parm : ANYPTR ; {JPC 2/22/82} dma_priority: BOOLEAN; END; $PAGE$ VAR { d {jws5 6/5/85} out_bufptr: ANYPTR ; {jws5 6/5/85} eirbyte : CHAR ; {jws5 6/5/85} my_isc : io_byte ; {jws5 6/5/85} timeout : INTEGER ; { in milliseconds } ma driver variables - used by DMA_DRV module and by assembly language drivers. ---------- DON'T MOVE ---------- } dma_ch_0 : io_funny_proc ; dma_isc_0 : io_byte ; dma_ch_1 : io_funny_proc ; dma_isc_1 : io_byte ; dma_isaddressed : io_word ; {jws5 6/5/85} drv_misc : ARRAY[1..164] OF CHAR ; {jws5 6/5/85} END; {jws5 6/5/85} pio_tmp_ptr = ^io_temp_type; isc_table_type = RECORD io_drv_ptr: ^drv_tablrib0 : ISRIB ; dma_isrib1 : ISRIB ; dma_here : BOOLEAN; io_work_char : CHAR; { io escape access variables } ioe_result : INTEGER; ioe_isc : INTEGER; { must be integer because the sc could be no sc ( e_type; io_tmp_ptr: pio_tmp_ptr; card_type : type_of_card; user_time : INTEGER; card_id : type_card_id; card_ptr : ANYPTR; END; $PAGE$ { transfer declarations } user_tfr_type = ( dummy_tfr_1 , 255 ) or a device like 701 etc. } isc_table : PACKED ARRAY [type_isc] OF isc_table_type; io_revid : STRING[96]; { revision string - added 2/5/82 - TM meaning - 'IO 1.0 refers to the IO library ( in system.li%     ype; { error msg extension } { 0082 TM 7/23/82 } { Will be initialized to a call to a proc in kernal_initialize. To extend error messages, copy old proc value into local var and put in your new proc ( type errlnk_type ).  *) (* *) (* *) (************************************************************************) MO Your proc should see if it can handle code and return the error msg string, if it can't it should call your local link. } PROCEDURE io_escape ( my_code : INTEGER ; select_code: INTEGER); FUNCTION io_find_isDULE general_0 ; { by Tim Mikkelsen date 07/15/81 update 03/05/84 by J. Schmidt purpose This module contains the LEVEL 0 GENERAL GROUP procedures. } IMPORT iodeclarations; EXPORT VAR { driver tables } kbd_crt_drivers :c ( iod_temp : ANYPTR ): io_byte; $PAGE$ IMPLEMENT PROCEDURE io_escape ( my_code : INTEGER ; select_code: INTEGER); BEGIN ioe_isc := select_code; ioe_result := my_code; ESCAPE(ioescapecode); END; { of io_escape } FUN drv_table_type; dummy_drivers : drv_table_type; FUNCTION ioread_word ( select_code: type_isc ; register : io_word ) : io_word ; PROCEDURE iowrite_word( select_code: type_isc ; register : io_word ; value : io_word);CTION io_find_isc ( iod_temp : ANYPTR ): io_byte; VAR my_ptr : pio_tmp_ptr; BEGIN IF iod_temp = NIL THEN BEGIN io_find_isc := no_isc ; END ELSE BEGIN my_ptr := iod_temp; io_find_isc := my_ptr^.my_isc; END; { of IF } FUNCTION ioread_byte ( select_code: type_isc ; register : io_word ) : io_byte ; PROCEDURE iowrite_byte( select_code: type_isc ; register : io_word ; value : io_byte); FUNCTION iostatus ( select_code: type_isc ; r END; { of io_find_isc } END; { of iodeclarations } $PAGE$ EXTERNAL MODULE iocomasm ; { by Tim Mikkelsen date 10/29/81 update 10/29/81 purpose This module contains the iocomasm code ( binary functions & dma control ) } IMPOegister : io_word ) : io_word ; PROCEDURE iocontrol ( select_code: type_isc ; register : io_word ; value : io_word); PROCEDURE kernel_initialize; PROCEDURE io_system_reset; IMPLEMENT IMPORT sysglobals , iocomasm ; RT iodeclarations; EXPORT FUNCTION dma_request ( temp : ANYPTR ) : INTEGER; PROCEDURE dma_release ( temp : ANYPTR ); FUNCTION bit_set ( v : INTEGER ; b : INTEGER ) : BOOLEAN ; FUNCTION binand ( x : INTEGER ; y : INTEGER  $PAGE$ { these are dummy driver procedures used by the kernel } PROCEDURE kbd_rdb ( iod_temp : ANYPTR ; VAR value : CHAR ); BEGIN { tttt TM 9/22/82 } IF EOLN(input) THEN) : INTEGER ; FUNCTION binior ( x : INTEGER ; y : INTEGER ) : INTEGER ; FUNCTION bineor ( x : INTEGER ; y : INTEGER ) : INTEGER ; FUNCTION bincmp ( x : INTEGER ) : INTEGER ; END; { of iocomasm } $PAGE$ (***************** BEGIN READ(value); value:=io_carriage_rtn; END ELSE BEGIN READ(value); END; { of IF EOLN } END; { of kbd_rdb } { tttt TM 9/22/82 } PROCEDURE crt_wtb ( iod_temp : ANYPTR ; val*******************************************************) (* *) (* *) (* GENERAL GROUP GENERAL_0 ue : CHAR ); BEGIN WRITE(value); END; { of crt_wtb } PROCEDURE simple_init ( temp : ANYPTR ); BEGIN { this initialization will do nothing } END; { of simple_init } { addition of new dummy drivers %     D; $PAGE$ FUNCTION ioread_word ( select_code: type_isc ; register : io_word ) : io_word ; VAR p : ^io_word; BEGIN p := ANYPTR(isc_table[select_code].card_ptr); IF p = NIL THEN BEGIN { error } io_escape(ioe_no_card,sele WITH isc_table[select_code] DO CALL(io_drv_ptr^.iod_wtc, io_tmp_ptr, register, my_value); END; { of iocontrol } $PAGE$ PROCEDURE end_error_link ( errorcode : INTEGER ; { 0082 TM 7/23/82 } VAR s : io_string ); ct_code); END ELSE BEGIN p:=ANYPTR(INTEGER(p)+register); ioread_word:=p^; END; { of IF } END; { of ioread_word } PROCEDURE iowrite_word( select_code: type_isc ; register : io_word ; value : io_word); VAR p : ^i { 0082 TM 7/23/82 } BEGIN { 0082 TM 7/23/82 } s := 'unrecognized error'; { 0082 TM 7/23/82 } END; { of end_error_link }  0350 TM 8/19/82 } PROCEDURE dummy_driver( temp : ANYPTR ); { 0350 TM 8/19/82 } BEGIN { 0350 TM 8/19/82 } io_escape(ioe_no_driver,io_find_isc(temp)); END; PROCEDURE do_word; BEGIN p := ANYPTR(isc_table[select_code].card_ptr); IF p = NIL THEN BEGIN { error } io_escape(ioe_no_card,select_code); END ELSE BEGIN p:=ANYPTR(INTEGER(p)+register); p^:=value; END; { of IF } END; { of iowriummy_driver_c( temp : ANYPTR ; dummy : CHAR ); BEGIN { 0350 TM 8/19/82 } dummy_driver(temp); END; PROCEDURE dummy_driver_a( temp : ANYPTR ; ANYVAR dummy : ANYPTR ); BEGIN te_word } FUNCTION ioread_byte ( select_code: type_isc ; register : io_word ) : io_byte ; TYPE mycharptr = ^CHAR; VAR p : ^CHAR; BEGIN p := ANYPTR(isc_table[select_code].card_ptr); IF p = NIL THEN BEGIN { error { 0350 TM 8/19/82 } dummy_driver(temp); END; PROCEDURE dummy_driver_w( temp : ANYPTR ; dummy : io_word ); BEGIN { 0350 TM 8/19/82 } dummy_driver( } io_escape(ioe_no_card,select_code); END ELSE BEGIN ioread_byte:=ORD(mycharptr(ADDR(p^,register))^); END; { of IF } END; { of ioread_word } PROCEDURE iowrite_byte( select_code: type_isc ; register : io_word ; value temp); END; PROCEDURE dummy_driver_dw(temp : ANYPTR ; dummy,d2 : io_word ); BEGIN { 0350 TM 8/19/82 } dummy_driver(temp); END; PROCEDURE dummy_driver_wa(temp : ANYPTR ; dummy : io_wor : io_byte); TYPE mycharptr = ^CHAR; VAR p : ^CHAR; BEGIN p := ANYPTR(isc_table[select_code].card_ptr); IF p = NIL THEN BEGIN { error } io_escape(ioe_no_card,select_code); END ELSE BEGIN p:=ANYPTR(INTEGER(p)+d ; VAR d2 : io_word ); BEGIN { 0350 TM 8/19/82 } dummy_driver(temp); END; PROCEDURE dummy_driver_b( temp : ANYPTR ; dummy : io_bit ); BEGIN register); p^:=CHR(value); END; { of IF } END; { of iowrite_byte } FUNCTION iostatus ( select_code: type_isc ; register : io_word ) : io_word ; VAR value : io_word; BEGIN WITH isc_table[select_code] DO CALL(io_drv_pt { 0350 TM 8/19/82 } dummy_driver(temp); END; PROCEDURE dummy_driver_ba(temp : ANYPTR ; dummy : io_bit ; VAR d2 : BOOLEAN ); BEGIN { 0350 TM 8/19/82 } dummy_driver(temp); ENr^.iod_rds, io_tmp_ptr, register, value); iostatus:=value; END; { of iostatus } PROCEDURE iocontrol ( select_code: type_isc ; register : io_word ; value : io_word); VAR my_value : io_word; BEGIN my_value:=value; &      { 0082 TM 7/23/82 } PROCEDURE kernel_initialize; VAR io_isc : type_isc; dc_dummy : INTEGER; dummy : INTEGER; double : BOOLEAN; { indicates an int. that takes 2 s.c. } bigtemp : ^io_temp_type2; bigtemp3 : ^io_temp_type3; bigt:=serial_card; card_id :=hp98626; NEW(bigtemp4); {jws5 6/5/85} { get temp space } io_tmp_ptr := ANYPTR(bigtemp4); {jws5 6/5/85} END; 3: BEGIN card_type:=gpio_card; card_id emp4 : ^io_temp_type4; { jws5 06/05/85 } BEGIN io_revid := 'IO 3.2: '; { io library revision/id - jws 8/03/83 } io_error_link := end_error_link; { error msg extension } { 0082 TM 7/23/82 } doubl:=hp98622; NEW(io_tmp_ptr); { get temp space } END; 6: BEGIN { DEW1 12/89 added centronics parallel support } card_type:= pllel_card; card_id := hpPARALLEL; Ne := FALSE; { determine what interfaces are present } FOR io_isc:=iominisc TO iomaxisc DO WITH isc_table[io_isc] DO BEGIN user_time :=0; card_id := no_id; IF io_isc 30 ) AND { jws4 3/5/84 } ( dummy <> 52 ) AND ( dummy<>66 ) AND ( dummy <> 39 ) THEN BEGIN NEW(bigtemp3); { TM 8/20/82 } io_tmp_ptr := ANYPTR(bigtemp3); {  { jws 3/25/83 } card_id:=hp98259; { jws 3/25/83 } card_type:=bubble_card; { jws 3/25/83 } NEW(bigtemp); { jws 3/25/83 } io_tmp_ptr:=ANYPTR(bigtemp); { jws 3/25/83 } END;  TM 8/20/82 } { note - this card WILL get LARGE temp space } card_type:=other_card; END; END; { of IF dummy <= 8 } RECOVER BEGIN IF ( escapecode=-11 ) OR ( escapecode=-12 ) THEN BEGIN { no card at this OTHERWISE { jws 3/25/83 } BEGIN { jws 3/25/83 } NEW(bigtemp3); { jws 3/25/83 } io_tmp_ptr:=ANYPTR(bigtemp3); { jws 3/25/83 } card_type:=other_card;  address } END ELSE BEGIN { some other problem } ESCAPE(escapecode); END; END; { of RECOVER BEGIN } END; { of IF double } END; { of IF io_isc=7 } END; { of IF io_isc NIL THEN WITH isc_table[io_isc].io_tmp_ptr^ DO BEGIN card_addr := isc_table[io_isc].card_ptr; eirbyte := CHR( 0 ); my_isc := io_isc ; timeout := 0 ; addressed := -1; in_bufptr := NI WITH isc_table[io_isc] DO BEGIN IF io_drv_ptr^.iod_init <> dummy_driver THEN BEGIN CALL ( io_drv_ptr^.iod_init , io_tmp_ptr ); END; { of IF } END; { of FOR WITH BEGIN } { In case - for some messed up reason ( typically this L ; out_bufptr:= NIL ; user_isr.dummy_sl := NIL; user_isr.dummy_pr := NIL; user_parm := NIL; {JPC 2/22/82} myisrib.INTREGADDR:= NIL; END; { of IF WITH io_tmp_ptr^ DO } END; { of FOR DO BEGIN } dma_isribis when the user doesn't call ioinitialize/iouninitialize ) - the dma resources are not relinquished by the init routines then this will free the resources. } IF dma_isc_0 <> no_isc THEN BEGIN dma_release(isc_table[dma_isc_0].io_tm0.INTREGADDR := NIL; dma_isrib1.INTREGADDR := NIL; { note - because of the ISRs - this routine can only be called once - at INITLIB time. If it is called again after that invocation the ISR structure will be in very bad shape and p_ptr); END; { of IF } IF dma_isc_1 <> no_isc THEN BEGIN dma_release(isc_table[dma_isc_1].io_tmp_ptr); END; { of IF } END; { of io_system_reset } END; { of general_0 } $PAGE$ (******************************************** will probably hang the machine } kbd_crt_drivers:=dummy_drivers; WITH kbd_crt_drivers DO BEGIN iod_rdb := kbd_rdb; iod_wtb := crt_wtb; iod_init := simple_init; END; { of WITH } isc_table[1].io_drv_ptr := ADDR(****************************) (* *) (* *) (* IOLIBRARY_KERNEL *) (kbd_crt_drivers); isc_table[2].io_drv_ptr := ADDR(kbd_crt_drivers); { set up clear i/o hook to do an io system reset } cleariohook := io_system_reset; END; { of kernel_initialize } $PAGE$ PROCEDURE io_system_reset; VAR io_isc :* *) (* *) (************************************************************************) IMPORT general_0 , LOADER  type_isc; BEGIN { initialize the interfaces } FOR io_isc:=iominisc TO iomaxisc DO WITH isc_table[io_isc] DO BEGIN user_time := 0; { user timeout } IF io_tmp_ptr <> NIL THEN WITH io_tmp_ptr^ DO BEGIN; { 367 TM 9/22/82 } BEGIN kernel_initialize; MARKUSER; { 367 TM 9/22/82 } END. { of iolibrary_kernel }  eirbyte := CHR( 0 ); my_isc := io_isc ; timeout := 0 ; { driver timeout } user_isr.dummy_sl := NIL; user_isr.dummy_pr := NIL; user_parm := NIL; {JPC 2/22/82} END; TTL IOLIB IOCOMASM - common assembly routines PAGE ******************************************************************************** * * COPYRIGHT (C) 1985, 1985 BY HEWLETT-PACKARD COMPANY * ******************************************** { of IF THEN WITH BEGIN } END; { of FOR WITH BEGIN } { these two FOR blocks are seperate in case two HPIB interfaces are connected in one machine - no funny user isr's will happen. } FOR io_isc:=iominisc TO iomaxisc DO ************************************ * * * IOLIB IOCOMASM * * ******************************************************************************** * * * * Library - IOLIB * Module - IOCOMASM * Author - Tim Mikkelsen * Phone '     NCTION bincmp ( x : INTEGER ) : INTEGER ; SRC FUNCTION binasr ( Object : INTEGER ; SRC Amount_of_shift : INTEGER ) : INTEGER ; SRC FUNCTION binasl ( Object : INTEGER ; SRC ROUTINE IN POWERUP REFA ASM_FLUSH_ICACHE USED TO FLUSH 68020 AFTER DMA XFR * JWH 9/24/90 : LMODE CHECK_TIMER LMODE ASM_FLUSH_ICACHE LMODE save_dtt1 jwh 9/24/90 TTL IOLIB IOCOMASM - pascal  Amount_of_shift : INTEGER ) : INTEGER ; SRC FUNCTION binlsr ( Object : INTEGER ; SRC Amount_of_shift : INTEGER ) : INTEGER ; SRC FUNCTION binlsl ( Object : INTEGER ; SRCbinary functions PAGE * * module initialization * IOCOMASM_IOCOMASM EQU * RTS * * bit test * IOCOMASM_BIT_SET EQU * MOVEA.L (SP)+,A0 save return address MOVE.L (SP)+,D0 get bit - 303-226-3800 ext. 2910 * * Purpose - This set of assembly language * code is intended to be used as * a support module for I/O drivers * * Date - 08/18/81 * Update - 03/25/85 * Release - 7/1 Amount_of_shift : INTEGER ) : INTEGER ; SRC END; { IOCOMASM } SPC 5 DEF IOCOMASM_iocomasm DEF IOCOMASM_dma_request DEF IOCOMASM_dma_release DEF IOCOMASM_bit_set D2/85 * * * Source - IOLIB:COMASM.TEXT * Object - IOLIB:COMASM.CODE * * ******************************************************************************** * * * RELEASED * VERSION 3.1 * * ************************************EF IOCOMASM_binand DEF IOCOMASM_binior DEF IOCOMASM_bineor DEF IOCOMASM_bincmp DEF IOCOMASM_binasr DEF IOCOMASM_binasl DEF IOCOMASM_binlsr DEF IOCOMASM_binlsl PAGE ******************************************************** PAGE ******************************************************************************** * * PASCAL DEFINITION OF MODULE * *********************************************************************************************************************************************** * * SYMBOLS FOR EXPORT - COMMON ASSEMBLY LANGUAGE ROUTINES * * THE SYMBOLS DO NOT HAVE PASCAL ENTRY * POINTS SINCE THEY ARE ONLY USED BY * ASSEMBLY LANGUAGE MODULE***** MNAME IOCOMASM SRC MODULE IOCOMASM; SRC IMPORT iodeclarations; SRC EXPORT SRC FUNCTION dma_request ( temp : ANYPTR ) : INTEGER; SRC PROCEDURE dma_release ( temp : ANYPTR ); S OR WITH EXTERNAL DECLARATIONS * ******************************************************************************** DEF DROPDMA DEF GETDMA DEF TESTDMA DEF LOGINT DEF LOGEOT DEF STBSY  SRC FUNCTION bit_set ( v : INTEGER ; SRC b : INTEGER ) : BOOLEAN ; SRC FUNCTION binand ( x : INTEGER ; SRC y : INTEGER ) : INTEGER ; SR DEF STCLR DEF DMA_STBSY DEF ITXFR DEF ABORT_IO DEF WAIT_TFR DEF CHECK_TFR DEF TIMEREXISTS USED AS PASCAL EXTERNAL PROC DEF TIMED_OUT USED AS PASCAL EXTERNAL PROC C FUNCTION binior ( x : INTEGER ; SRC y : INTEGER ) : INTEGER ; SRC FUNCTION bineor ( x : INTEGER ; SRC y : INTEGER ) : INTEGER ; SRC FU SPC 3 * ***************************************************************************** * * IMPORTED SYMBOLS * ***************************************************************************** * REFA CHECK_TIMER USED TO GET AT TIMER (      # MOVE.L (SP)+,D1 get numeric value CLR.B D2 clear indicator BTST D0,D1 test bit in value BEQ.S BITT_EXIT MOVEQ #1,D2 if bit set se************************** * * Error escapes * ******************************************************************************** CTMO_ERR MOVEQ #TMO_ERR,D0 timeout BRA.S ESC_ERR TERR_C MOVEQ #TCNTERR,D0 bad transt indicator BITT_EXIT MOVE.B D2,(SP) push result JMP (A0) return * * binary and * IOCOMASM_BINAND EQU * MOVEA.L (SP)+,A0 save return address MOVE.L (SP)+,D0 fer specification BRA.S ESC_ERR TERR_B MOVEQ #TFR_ERR,D0 bad transfer specification BRA.S ESC_ERR TERR_D MOVEQ #NO_DMA,D0 DMA not installed * BRA.S ESC_ERR SPC 4 ESC_ERR EXT.L D0 get last param MOVE.L (SP)+,D1 get first param AND.L D0,D1 perform AND MOVE.L D1,(SP) push result JMP (A0) return * * binary inclusive or *  MOVE.L D0,IOE_RSLT(A5) save io error MOVE.B IO_SC(A2),D0 \ get sc for error MOVE.L D0,IOE_SC(A5) / MOVE.W #IOE_ERROR,ESC_CODE(A5) give i/o error TRAP #10 escIOCOMASM_BINIOR EQU * MOVEA.L (SP)+,A0 save return address MOVE.L (SP)+,D0 get last param MOVE.L (SP)+,D1 get first param OR.L D0,D1 perform OR ape TTL IOLIB IOCOMASM - transfer support PAGE ******************************************************************************** * * ABORT_IO * * USED DURING INITIALIZATION/RESET TO MAKE SURE THERE * IS NO ACMOVE.L D1,(SP) push result JMP (A0) return * * binary exclusive or * IOCOMASM_BINEOR EQU * MOVEA.L (SP)+,A0 save return address MOVE.L (SP)+,D0 get last paTIVE BUFFER LEFT AROUND. * * ENTRY: A2.L = TEMP POINTER * * USES: D1,D2,D3 AND ROUTINE DROPDMA (WHICH USES A0) * * HPL ROUTINE ( MODIFIED ) * ******************************************************************************** ABORTram MOVE.L (SP)+,D1 get first param EOR.L D0,D1 perform XOR MOVE.L D1,(SP) push result JMP (A0) return * * binary complement * IOCOMASM_BINCMP_IO TRAP #11 GET INTO SUPERVISOR MODE, SAVE SR scs * scs MOVE SR,-(SP) \ PREVENT INTERRUPTS FOR A MOMENT. ORI #$2700,SR / ABORT_IO3 BSR ITXFR IS THERE A TRANSFER IN PR EQU * MOVEA.L (SP)+,A0 save return address MOVE.L (SP)+,D0 get param NOT.L D0 perform complement MOVE.L D0,(SP) push result JMP (A0) OGRESS? BEQ.S ABORT_IO2 IF NOT, DO NOTHING CMP.B #TT_DMA,D1 ELSE IS IT A DMA? BEQ.S ABORT_IO1 IF NOT, SKIP BSR DROPDMA ELSE FREE UP THE DMA CH, GET COUNT  return SPC 5 TTL IOLIB IOCOMASM - common equates and definitions PAGE INCLUDE COMDCL TTL IOLIB IOCOMASM - error escape PAGE ****************************************************** MOVE.L D4,TCNT_OFF(A3) fix up count SUB.L D4,D3 fix up actual count TST.B TDIR_OFF(A3) BNE.S AB_OUT ADD.L D3,TFIL_OFF(A3) if input then update fill BRA.S ABORT_(     .S CHKWAIT IF SO , THEN WAIT SPC 2 CHKT_IN LEA BUFI_OFF(A2),A4 is there an input tfr MOVE.L (A4),D1 * BRA.S CHKWAIT SPC 3 CHKWAIT BEQ.S CHKEXIT exit if no tfr  * * USES: NO REGS OTHER THAN RETURN VALUES. * * ******************************************************************************** WAIT_TFR BSR ITXFR quick check for tfr BEQ.S WT_DONE and exit  MOVE.L TIMEOUT(A2),D2 get timeout value BEQ.S CHECK_TFR if timeout = 0 then try forever BTST #TIMER_PRESENT,SYSFLAG2 CHECK IF TIMER PRESENT JS 8/3/83 BEQ.S CHKT_TIM IF SO TH MOVE.L TIMEOUT(A2),D6 get timeout value BEQ.S WAIT_TFR if timeout = 0 then try forever BTST #TIMER_PRESENT,SYSFLAG2 IF TIMER PRESENT USE IT JS 8/3/83 BEQ.S WT_TIM BRANCH IF WE HAIO1 AB_OUT ADD.L D3,TEMP_OFF(A3) if output then update empty ABORT_IO1 MOVE.B #255,T_SC_OFF(A3) UNBUSY THE BUFFER CLR.B TACT_OFF(A3) SET TRANSFER TYPE TO NONE CLR.L (A4) clear buffer ptr EN USE IT JS 8/3/83 LSL.L #8,D2 CHKLOOP MOVE.L (A4),D1 check the buffer again BEQ.S CHKEXIT if finished in time then return SUBQ.L #1,D2 decrement BNE.S  BRA ABORT_IO3 see if there is another ABORT_IO2 MOVE (SP)+,SR RESTORE USER MODE scs RTS scs * scs RTE RES CHKLOOP BRA CTMO_ERR CHKEXIT RTS SPC 3 CHKT_TIM MOVE.B #1,-(SP) SET UP TIMER RECORD JS 8/3/83 MOVE.L D2,-(SP) JS 8/3/83 CHKT_TIM1 MOVE.L (A4),D1 TORE INTERRUPT LEVEL & RETURN PAGE ******************************************************************************** * * CHECK_TFR * * ROUTINE TO CHECK FOR ACTIVE TRANSFER IN THE OPPOSITE DIRECTION. * ( this is called b TRANSFER ACTIVE ? JS 8/3/83 BEQ.S CHKT_TIM2 NO -- EXIT JS 8/3/83 PEA (SP) ELSE CHECK TIMER JS 8/3/83 JSR CHECK_TIMER y a tfr routine on cards * that can't do bi-directional tfrs ) * ( gpio and hpib modules use this routine ) * ( with a timeout wait ) * * ENTRY: A2.L = TEMP POINTER * A3.L = BUF CTL BLK P JS 8/3/83 BPL CHKT_TIM1 BRANCH IF NOT TIMED OUT JS 8/3/83 BRA CTMO_ERR ELSE DO TIMEOUT ESCAPE JS 8/3/83 CHKT_TIM2 ADDQ.L #6,SP CLEAN TIMER RECORD FROM SOINTER * * EXIT : IF NOT TRANSFER, RETURN * IF TRANSFER, THEN wait until finished * or until timeout ( if any ) * *************************************************************************TACK JS 8/3/83 RTS AND RETURN JS 8/3/83 PAGE ******************************************************************************** * * WAIT_TFR * * ROUTINE TO CHECK FOR ACTIVE TRANSFE******* CHECK_TFR TST.B TDIR_OFF(A3) base test on direction BNE.S CHKT_IN ( if this is in , check out ) CHKT_OUT LEA BUFO_OFF(A2),A4 IS THERE AN output BUFFER ACTIVE? MOVE.L (A4),D1 BRAR. * ( with a timeout wait ) * * ENTRY: A2.L = TEMP POINTER * * EXIT : IF NOT TRANSFER, RETURN * IF TRANSFER, THEN wait until finished * or until timeout ( if any ))     VE IT JS 8/3/83 LSL.L #5,D6 WT_LOOP BSR.S ITXFR try BEQ.S WT_DONE if finished in time then return SUBQ.L #1,D6 decrement BNE.S WT_LOOP BRA CTMO BEQ.S ITXFR1 -no ITXFR3 MOVEA.L D1,A3 \ CLR.L D1 ELSE GET BUFFER TYPE WORD MOVE.B TACT_OFF(A3),D1 / CLR.L D2 MOVE.W TCHR_OFF(A3),D2 G_ERR WT_DONE RTS SPC 3 WT_TIM MOVE.B #1,-(SP) SET UP TIMER RECORD JS 8/3/83 MOVE.L D6,-(SP) JS 8/3/83 WT_TIM1 BSR.S ITXFR CHECK FOR ACTIVE TRANSFET TERMINATING CHAR MOVE.L TCNT_OFF(A3),D3 GET COUNT MOVEA.L TEMP_OFF(A3),A0 GET EMPTY POINTER TST.B TDIR_OFF(A3) check direction BNE.S ITXFR2 \ IF INPUT MOVEA.L TFIER JS 8/3/83 BEQ.S WT_TIM2 NONE -- EXIT JS 8/3/83 PEA (SP) CHECK TIMER JS 8/3/83 JSR CHECK_TIMER JS 8/3/83 L_OFF(A3),A0 / THEN GET FILL POINTER ITXFR2 MOVEQ #1,D5 set not zero STCLR1 EQU * ITXFR1 RTS PAGE ******************************************************************************** * * STCLR * *  BPL WT_TIM1 LOOK AGAIN IF NOT TIMED OUT JS 8/3/83 BRA CTMO_ERR ELSE DO TIMEOUT ESCAPE JS 8/3/83 WT_TIM2 ADDQ.L #6,SP CLEAN UP TIMER RECORD JS 8/3/83 RTS  ROUTINE TO SET A BUFFER & SELECT CODE NOT BUSY * * ENTRY: gets buf ptr from ITXFR routine * * assumes only one tfr per select code * * USES: A3,D0 * * HPL ROUTINE ( MODIFIED ) * ********************************** AND RETURN JS 8/3/83 PAGE ******************************************************************************** * * ITXFR * * ROUTINE TO CHECK FOR ACTIVE TRANSFER. * * ENTRY: A2.L = TEMP POINTER * * ********************************************** STCLR BSR ITXFR GET BUFFER POINTER FROM TEMPS BEQ.S STCLR1 IF ALREADY CLEAR, SKIP MOVE.B #255,T_SC_OFF(A3) CLEAR S.C. INDICATOR IN THE BUF CTL  EXIT : IF NOT TRANSFER, RET with zero flag set * IF TRANSFER, RET with not zero * D1.W = ACTUAL TFR TYPE * D2.W = TERMINATING CHAR FROM TEMPS * D3.L = TRANSFER COUNT FROBLK CLR.B TACT_OFF(A3) clear tfr type CLR.L (A4) CLEAR BUF POINTER IN SC TEMPS *RTS SPC 5 ******************************************************************************** * * LOGEOT *M TEMPS * A0.L = DATA POINTER FROM TEMPS ( either emtpy or fill ) * A3.L = BUF CTL BLK POINTER FROM TEMPS * * HPL ROUTINE ( MODIFIED ) * ************************************************************************* * CALL THE USER PROC AT END OF TRANSFER * * PASCAL ROUTINE * * modified to pass a user parameter: JPC 02/22/82 * ******************************************************************************** LOGEOT LEA T_PR_OFF(A3),A0 ******* ITXFR LEA BUFI_OFF(A2),A4 IS THERE AN input BUFFER ACTIVE? MOVE.L (A4),D1 BNE.S ITXFR3 IF NOT, SKIP LEA BUFO_OFF(A2),A4 is there an output tfr MOVE.L (A4),D1  point to procedure/static link/parameter H_EOT1 MOVE.L (A0),D0 is there a proc? BEQ.S H_EOT3 skip if not MOVEM.L A1-A4,-(SP) save dedicated regs (8/10/82 JPC) MOVE.L 8()     ************************************************************* DMA_STBSY MOVE.L A4,DMAISR(A0) SAVE THE TERMINATION ROUTINE CLR.L DMASL(A0) CLEAR THE STATIC LINK * BRA.S STBSY SET THE BUFFER BUSY ardware SPC 2 DMA0 EQU iodeclarations-8 DMAISR_0 EQU iodeclarations-8 \ DMASL_0 EQU iodeclarations-4 channel 0 temps DMA_SC_0 EQU iodeclarations-9 / SPC 2 DMA1 EQU iodeclarations-18 SPC 5 ******************************************************************************** * * STBSY * * ROUTINE TO SET A BUFFER BUSY * * ENTRY: * D0.W = TRANSFER COUNT TO BE PUT IN TCNT_OFF(A2) *  DMAISR_1 EQU iodeclarations-18 \ DMASL_1 EQU iodeclarations-14 channel 1 temps DMA_SC_1 EQU iodeclarations-19 / SPC 2 DMAISR EQU 0 isr pointer DMASL EQU 4 stA0),-(SP) push the parameter MOVE.L 4(A0),D1 is there a static link? BEQ.S H_EOT2 Roger Ison says it is okay to try MOVE.L D1,-(SP) and call proc with static link H_ AND TO BE ADDED TO E/F COUNT. * A2.L = POINTER TO DRIVER TEMPS * A3.L = POINTER TO BUFFER CTL BLOCK * * HPL ROUTINE ( MODIFIED ) * *****************************************************************************EOT2 MOVEA.L D0,A0 procedure address JSR (A0) call it MOVEM.L (SP)+,A1-A4 restore dedicated regs (8/10/82 JPC) H_EOT3 RTS PAGE ********************************************* STBSY MOVE.L D0,TCNT_OFF(A3) COPY TFR COUNT INTO TEMPS. TST.B TDIR_OFF(A3) \ BNE.S STBSY1 \ MOVE.L A3,BUFI_OFF(A2) MAKE SELECT CODE BUSY BRA.S STBSY2 ************************************** * * LOGINT * * THIS ROUTINE WAS CALLED H_LOG * * CALL THE USER PROC WHEN AN ISR SAYS TO * * PASCAL ROUTINE * * modified to pass a user parameter: JPC 02/22/82 * **************** / STBSY1 MOVE.L A3,BUFO_OFF(A2) / STBSY2 MOVE.B IO_SC(A2),T_SC_OFF(A3) SET UP BUFFER ACTIVE SELECT CODE RTS DONE! TTL IOLIB IOCOMASM - dma support PAGE ********************************************************************************************* LOGINT LEA H_ISR_PR(A2),A0 point to procedure/static link/parameter BRA H_EOT1 call it (if it exists) PAGE *********************************************************************************** * * DMA RESOURCE MANAGEMENT ROUTINES * * ******************************************************************************** SPC 3 ************************************************************************************************************ * * DMA_STBSY * * ROUTINE TO SET A BUFFER BUSY * * ENTRY: * D0.W = TRANSFER COUNT TO BE PUT IN TCNT_OFF(A2) * AND TO BE ADDED TO E/F COUNT. * ******************** * * DMA RESOURCE temporaries * * These resource temporaries need to be aligned with the offsets * generated by the main Pascal library. This is not an automatic * operation - it must be done by hand if AN A0.L = pointer to DMA temps * A2.L = POINTER TO DRIVER TEMPS * A3.L = POINTER TO BUFFER CTL BLOCK * A4.L = POINTER TO TERMINATION ROUTINE * * HPL ROUTINE ( MODIFIED ) * *******************Y new declarations are * added in the iodeclarations in front of the dma resource temps. * ******************************************************************************** DMAFLAG EQU iodeclarations-61 boolean indicating presence of dma h*     atic link DMA_SC EQU -1 allocated s.c. SPC 2 DMACH0 EQU $500000 address of dma channel 0 DMACH1 EQU $500008 address of dma channel 1 ******************************************h return address BRA DROPDMA release it SPC 4 TTL IOLIB IOCOMASM - assembly dma procedures PAGE ******************************************************************************** * * GETDMA ************************************** * * ADDRESS CONSTANTS * ******************************************************************************** H_INT_CA EQU $478000 ADDRESS OF INTERNAL HPIB INTERFACE TTL IOLIB IOCOMASM - * * ROUTINE TO OBTAIN CONTROL OF A DMA CHANNEL * GET EITHER DMA CHANNEL, TRYING FOR CH 1 FIRST. * * ENTR: CONDITIONS ARE THE SAME AS FOR THE tfr DRIVER ENTRY POINT. * * EXIT: IF DMA IS NOT INSTALLED, 'no dma' escape is gpascal dma procedures PAGE * * request a dma channel * IOCOMASM_DMA_REQUEST EQU * MOVEA.L (SP)+,A4 save return address MOVEA.L (SP)+,A2 get sc temp MOVEA.L C_ADR(A2),A1 get caenerated. * IF DMA IS INSTALLED, THE ALGORITHM WAITS FOR A CHANNEL TO * BECOME AVAILABLE AND THEN: * LOGS USE OF DMA CHANNEL * SETS UP ADDRESS AND COUNT REGISTERS. * Crd ptr TRAP #11 GET INTO SUPERVISOR MODE scs * scs MOVE SR,-(SP) JUST IN CASE CALLER DIDN'T DISABLE ORI #$2700,SR INTERRUPTS, I WILL. BSR TESTDMA ONSTRUCTS CARD ARM AND DMA ARM MASKS AS FOLLOWS: * D2.W = DMA ARM BYTE WITH BITS 1, 2 DEFINED BY * CONTENTS OF D1 AND BIT 0 = 1. * D3.B = CARD ENABLE BYTE WITH BITS 0, 1 D SEE IF DMA IS INSTALLED BEQ.S DR_FAIL IF NOT, return -1 SUBQ.W #1,D3 turn $82/$81 to $81/$80 ANDI.W #1,D3 determine channel EXT.L D3 MOVE.B IO_SC(A2),DEFINED BY * WHICH DMA CHANNEL WAS GRANTED AND BIT 7=1. * A4.L = ADDRESS OF DMA CHANNEL ARM WORD. * * NOTE: IF THE REQUEST IS FOR INTERNAL HP-IB AS INDICATED BY A1, * ONLY CHANNELMA_SC(A0) ELSE CLAIM THIS CHANNEL FOR CALLER * following 3 lines for 68040 support JWH 2/15/91 btst #3,SYSFLAG2 bne no_40 jsr WRITE_68040 jsr ASM_FLUSH_ICACHE no_40 BRA.S DR_GOOD DR_FAIL MOVE.L  0 WILL BE GRANTED. * * HPL ROUTINE ( MODIFIED ) * ******************************************************************************** GETDMA TRAP #11 GET INTO SUPERVISOR MODE scs * scs MOVE SR,-(SP) #-1,D3 return -1 DR_GOOD MOVE (SP)+,SR restore int. state MOVE.L D3,(SP) assign return value - channel ( or -1 ) JMP (A4) return addr SPC 4 * * relJUST IN CASE CALLER DIDN'T DISABLE ORI #$2700,SR INTERRUPTS, I WILL. CMPI.L #$010001,D0 \ make sure count <=65536 BPL TERR_C / BSR.S TESTDMA SEE IF DMA ISease a dma channel * IOCOMASM_DMA_RELEASE EQU * MOVEA.L (SP)+,A0 save return address MOVEA.L (SP)+,A2 get sc temp MOVEA.L C_ADR(A2),A1 get card ptr PEA (A0) pus INSTALLED BEQ TERR_D IF NOT, GIVE ERROR MOVE.B IO_SC(A2),DMA_SC(A0) ELSE CLAIM THIS CHANNEL FOR CALLER * added for 68040 support JWH 2/15/91 btst #3,SYSFLAG2 bne not_40 jsr WR*     . * * ENTRY: A1 = CARD ADDRESS * * EXIT: IF NO DMA IS INSTALLED, RET with zero flag set * IF DMA IS INSTALLED, RET with not zero set * A0.L = ADDRESS OF DMA FLAG FOR AVAILABLE CHANNEL *  ORI #$2700,SR INTERRUPTS, I WILL. BTST #GOT_68020,SYSFLAG2 CHECK IF WE HAVE 68020 BEQ.S DODROP IF NOT THEN SKIP JSR ASM_FLUSH_ICACHE FLUSH ICACHE ON 68020 MOVE CACHE D2.L = ADDRESS OF AVAILABLE DMA CHANNEL * D3.B = CARD ENABLE BYTE FOR AVAILABLE CHANNEL * * HPL ROUTINE ( MODIFIED ) * ******************************************************************************** TESTDMA LEA _CTL,D4 GET EXT. CACHE CONTROL WORD ANDI #$63,D4 SET DISABLE MOVE D4,CACHE_CTL TURN CACHE OFF BSET #2,D4 SET ENABLE BIT MOVE D4,CACHE_CTL TURN CACITE_68040 jsr ASM_FLUSH_ICACHE not_40 MOVEA.L D2,A4 A4 = ADDRESS OF DMA CHANNEL HARDWARE. SPC 1 MOVE.L TEMP_OFF(A3),D2 \ TST.B TDIR_OFF(A3) \ BNE.S GETDMA1 DMAFLAG(A5),A0 \ TST.B (A0) DO RET 1 IF NO DMA BEQ.S TESTDMA_C / CMPA.L #H_INT_CA,A1 IF THIS IS A REQUEST FOR THE INTERNAL BEQ.S TESTDMA_A HP-IB, THEN SET UP ADDRESS MOVE.L TFIL_OFF(A3),D2 / GETDMA1 MOVE.L D2,(A4)+ / SPC 1 SUBQ.L #1,D0 COUNT REGISTERS (COUNT REG MOVE.W D0,(A4)+ MUST BE COUNT CAN'T TRY FOR CH 1 SO SKIP. LEA DMA1(A5),A0 ELSE ASSUME WE CAN GET CH 1 MOVE.L #DMACH1,D2 * tm MOVEQ #$82,D3 MOVE.B #$82,D3 CMPI.B #255,DMA_SC(A0) CAN WE? BEQ.S TESTDMA_B -1) ADDQ.L #1,D0 SPC 2 CLR.W D2 MOVE.B TDIR_OFF(A3),D2 MOVE DIRECTION BIT INTO B2 OF D2 LSL #2,D2 IN ORDER TO CONSTRUCT DMA ARM SPC 2 TST.B T_BW_OFF(A3 IF SO, THEN RET 3 TESTDMA_A LEA DMA0(A5),A0 ELSE ASSUME WE CAN GET CH 0 MOVE.L #DMACH0,D2 * tm MOVEQ #$81,D3 MOVE.B #$81,D3 CMPI.B #255,DMA_SC(A0) CAN WE? BEQ.S TESTDMA_B IF HAR) IF BYTE TRANSFER BEQ.S GETDMA2 THEN SKIP ADDQ.W #2,D2 ELSE SET BIT 1 OF DMA ARM. GETDMA2 TST.B T_DMAPRI(A3) check for dma priority requested BEQ.S GETDMA3 ADDWARE PRESENT BUT BUSY,same as not there CLR D5 RTS TESTDMA_B MOVEQ #1,D5 ELSE WE GOT A CH TESTDMA_C RTS SPC 6 ******************************************************************************** * * DQ.W #8,D2 if set then set pri bit GETDMA3 ADDQ.W #1,D2 SET BIT0 OF DMA ARM MOVE (SP)+,SR scs RTS DROPDMA * * ROUTINE TO FREE UP A DMA CHANNEL * * ENTRY: A2.L = POINTER TO DRIVER TEMPS * * EXIT: D4.W = FINAL DMA CHANNEL COUNT * CHANNEL IS DISARMED. * * USES: A0 * * HPL ROUTINE ( MODIFIED ) *  scs * scs RTE SPC 6 ******************************************************************************** * * TESTDMA * * THIS ROUTINE TESTS FOR PRESENCE OF DMA HARDWARE AND WAITS FOR * A CHANNEL TO BECOME AVAILABLE******************************************************************************** DROPDMA EQU * TRAP #11 scs * scs MOVE SR,-(SP) JUST IN CASE CALLER DIDN'T DISABLE +     HE BACK ON DODROP MOVEQ #0,D4 ASSUME DMA CHA ALREADY DROPPED... MOVE.B DMA_SC_0(A5),D0 \ CMP.B IO_SC(A2),D0 / IS IT CH 0? BNE.S DROPDMA0 IF NOT, SKIP LEA DMA0 * actually been claimed. Note - we do not call this from * TESTDMA because TESTDMA does not assign channels * * ALGORITHM: ASSUMES 68040 (PUT TEST BEFORE CALLING) * * IF DTT1 CONTAIN(A5),A4 GET A POINTER TO THE CHANNEL R/W LEA DMACH0,A0 POINT A0 TO CH 0 BRA.S DROPDMA1 GO DO IT SPC 2 DROPDMA0 MOVE.B DMA_SC_1(A5),D0 \ CMP.B IO_SC(A2),D0 S SOMETHING NON-ZERO * SAVE CONTENTS OF DTT1 (IN SAVE_DTT1) * PUT 0 (WRITETHROUGH MODE) IN DTT1 * EXIT ********************************************************************************  / IS IT CH 1? BNE.S DROPDMA2 IF NOT, DO NOTHING LEA DMA1(A5),A4 GET A POINTER TO THE CHANNEL R/W LEA DMACH1,A0 POINT A0 TO CH 1 DROPDMA1 equ * * next 3 lines for 68040 supportSAVE_DTT1 DC.L $00000000 save place for DTT1 * WRITE_68040 trap #11 supervisor mode move.l d0,-(sp) save d0 movec DTT1,d0 grab DTT1 cmpi.l #$00000000,d0 if 0 JWH 2/15/91 btst #3,SYSFLAG2 bne same_old jsr copy_68040 same_old MOVE.B #255,DMA_SC(A4) clear s.c. CLR.L DMASL(A4) clear static link CLR.L DMAISR(A4) clear isr p don't ... beq bag_it bother, already in writethrough move.l d0,SAVE_DTT1 else saveit move.l #0,d0 and force ... movec d0,DTT1 writethrough mode bag_it ointer MOVE.L (A0)+,D4 DISARM CH BY READING ADDRESS CLR.L D4 MOVE.W (A0),D4 GET FINAL COUNT INTO D0 ADD.W #1,D4 FIX UP COUNT TO INDICATE LEFT OVER TFR'S DROPDMA2 MOVE move.l (sp)+,d0 restore d0 move (sp)+,SR and SR also RTS ********************************************************************************* * COPY_68040 JEFF HENDERSHOT 2/15 (SP)+,SR scs RTS scs * scs RTE PAGE * ******************************************************************************* * /91. * * THIS ROUTINE IS CALLED IN CASE WE HAVE A 68040 AND WE ARE * DROPPING A DMA CHANNEL. BASICALLY, ONCE A DMA CHANNEL HAS ACTUALLY * BEEN ASSIGNED, WE HAVE TO FORCE WRITETHROUGH CACHING MODE AND * FLUSH CACHES. WHEN ALL WRITE_68040 JEFF HENDERSHOT 2/15/91. * * THIS ROUTINE IS CALLED IN CASE WE HAVE A 68040 AND WE HAVE ACTUALLY * CLAIMED A DMA CHANNEL. BASICALLY, ONCE A DMA CHANNEL HAS ACTUALLY * BEEN ASSIGNED, WE HAVE  DMA CHANNELS ARE RELEASED WE CAN RESTORE * COPYBACK MODE (IF THAT MODE WAS SAVED EARLIER) * * CALLED BY : DROPDMA, right after the channel is released * * ENTRY: A0 contains DMACH0 or DMACH1 * * ALGORITHM: ASSUMES 68040 TO FORCE WRITETHROUGH CACHING MODE AND * FLUSH CACHES. WHEN ALL DMA CHANNELS ARE RELEASED WE CAN RESTORE * COPYBACK MODE IF THAT WAS THE MODE WE ENCOUNTERED HERE. * * CALLED BY : DMA_REQUEST and GETDMA, right after a DMA channel has(PUT TEST BEFORE CALLING) * * IF SAVE_DTT1 HAS A NON-ZERO VALUE (COPYBACK MODE) * IF CHANNEL 0 RELEASED * IF CHANNEL 1 NOT IN USE * RESTORE DTT1 * +     e.l (sp)+,d0 restore d0 RTS ****************************************************************************** * * TIMEREXISTS: PASCAL FUNCTION TO SEE IF TIMER EXISTS * * FUNCTION TIMEREXISTS: BOOLEAN; EXTERNAL; * *  move.l (sp)+,d1 Pop the value to shift asr.l d0,d1 Shift the value move.l d1,(sp) Push the resulting return value jmp (a0) Return IOCOMASM_binlsr equ * movea.l (sp RETURNS TRUE IF TIMER PRESENT, ELSE FALSE * * J SCHMIDT 8/2/83 * ***************************************************************************** * TIMEREXISTS EQU * BTST #TIMER_PRESENT,SYSFLAG2 CHECK BIT FOR TIMER PRESENT )+,a0 Save return address move.l (sp)+,d0 Pop # of bits to shift move.l (sp)+,d1 Pop the value to shift lsr.l d0,d1 Shift the value move.l d1,(sp) Push the resulting return value  ZERO OUT SAVE_DTT1 * EXIT * IF CHANNEL 1 RELEASED * IF CHANNEL 0 NOT IN USE * RESTORE DTT1 *  SEQ 4(SP) SET FUNCTION RESULT 0=>TRUE RTS AND RETURN * *************************************************************************** * * TIMED_OUT: PASCAL FUNCTION TO SEE IF TIMEOUT HA ZERO OUT SAVE_DTT1 * EXIT ******************************************************************************** COPY_68040 equ * move.l d0,-(sp) save d0 move.l SAVE_DTT1,d0 cmpi.S OCCURRED * * FUNCTION TIMED_OUT(VAR REC: TIMEOUTREC): BOOLEAN; EXTERNAL; * * TIMEOUTREC= PACKED RECORD * COUNT: INTEGER { SET TO TIMEOUT IN MS } * FIRSTTIME: BOOLEAN; {SET THIS TO l #0,d0 anything there ? beq OUTTA_HERE bail out if not move.l a1,-(sp) a1 needed in either case cmpa.l #DMACH0,a0 was it channel 0 released ? bne hadta_bTRUE FOR FIRST * CALL } * END; * * RETURNS: TRUE IF TIMEOUT PERIOD EXPIRED, ELSE FALSE * * CAUTION: WILL SMASH BOTH PARTS OF TIMEOUTREC PARAMETER * * e_one if not then one lea DMA1(A5),a1 see if .. CMPI.B #$FF,DMA_SC(a1) channel 1 busy BNE DONT if so don't restore DTT1 BRA PUT_IT otherwise do re J SCHMIDT 8/2/83 * * REMOVED ADDQ.L #4,SP AFTER SMI JWS 5/3/84 ***************************************************************************** * TIMED_OUT MOVEA.L (SP)+,A0 SAVE RETURN ADDRESS JSR CHECK_Tstore it hadta_be_one equ * no other choice lea DMA0(A5),a1 CMPI.B #$FF,DMA_SC(a1) channel 0 busy ? BNE DONT if so don't restore DTT1 PUT_IT trap #11 IMER CALL CHECK_TIMER USING PARAMETER ON STK SMI (SP) SET RESULT OF FUNCTION JMP (A0) AND RETURN WITH SP POINTING TO RESULT * ********************************************************************otherwise do save it movec d0,DTT1 d0 has SAVE_DTT1 move.l #0,SAVE_DTT1 clear save spot move (sp)+,SR restore SR also DONT movea.l (sp)+,a1 restore a1 OUTTA_HERE mov********* * * Bit shifting routines * ***************************************************************************** * IOCOMASM_binasr equ * movea.l (sp)+,a0 Save return address move.l (sp)+,d0 Pop # of bits to shift,      jmp (a0) Return IOCOMASM_binasl equ * movea.l (sp)+,a0 Save return address move.l (sp)+,d0 Pop # of bits to shift move.l (sp)+,d1 Pop the value to shift asl.l d0,d1  In addition to the A1/A2 convention, Pascal will use * A3 for a pointer to the buffer control block. * The HPL system kept much of the transfer * information in the s.c. temps. * * TIMEOUT(A2) = co Shift the value move.l d1,(sp) Push the resulting return value jmp (a0) Return IOCOMASM_binlsl equ * movea.l (sp)+,a0 Save return address move.l (sp)+,d0 Pop # of bits to ntains timeout information * Timeout was a global temp in HPL and a timeout * generated an error. * In PASCAL each card has a timeout value stored in * its temporary area. A timeout error * shift move.l (sp)+,d1 Pop the value to shift lsl.l d0,d1 Shift the value move.l d1,(sp) Push the resulting return value jmp (a0) Return end  generates an ESCAPE ( which can be trapped ). * * ******************************************************************************** PAGE ******************************************************************************** * * * DRIVER TEMPS TTL IOLIB COMDCL - common equates and definitions PAGE ******************************************************************************** * * modified: 02/22/82 JPC added parm to user EOT & ISR proc's * 08/01/83 JS added  TEMPLATE * * OFFSET FROM A2 * * HPL DECLARATIONS ( MODIFIED ) * * ******************************************************************************** ISR_ENTRY EQU 0 ..19 PASCAL ISR LINK & UNLINK area USER_ISR EQU 20 timer_present and sysflag2 equ's * 03/25/85 JS added got_68020, cache_ctl equ's * * ******************************************************************************** * * HPL CONVENTIONS * * * Much of this code is taken in user ISR: do NOT change the proc/stat link/parm ordering!!! H_ISR_PR EQU 20 ..23 procedure ptr H_ISR_SL EQU 24 ..27 static link H_ISR_PM EQU 28 ..31 parameter C_ADR EQU 32 ..35 card addretact from the 9826 HPL * language system EIO ROM ( extended I/O ROM ). * This was written by Bob Hallissy ( originally John Nairn ). * The Pascal that will be calling this code uses * the stack for parameter passage. The HPss BUFI_OFF EQU 36 ..39 buffer pointer offset BUFO_OFF EQU 40 ..43 buffer pointer offset EIRB_OFF EQU 44 eir byte IO_SC EQU 45 select code ( i.e. 7, 22, etc. ) TIMEOUT EQU 46 ..49 timeoutL code * uses the Ax and Dx registers for all parameters. * The Pascal driver entry points on the previous pages * take care of getting the parameters into the correct * registers. * * * GENERAL HPL ENTRY/EXIT CONDITIO value * =0 : no timeout * #0 : value of timeout MA_W EQU 50 ..51 word access to my address MA EQU 51 byte access to my address AVAIL_OFF EQU 52 .NS: * * A1.L = CARD ADDRESS * A2.L = DRIVER TEMP ADDRESS * UNLESS OTHERWISE INDICATED, THESE REGISTERS ARE UNALTERED. * * * NEW ENTRY/EXIT CONDITIONS FOR PASCAL USE : * * A3.L = BUFFER CONTROL BLOCK ADDRESS * .?? standard space taken from temps * 52 ..83 normal cards ( 32 bytes ) * 52 ..179 98628 card ( 128 bytes ) PAGE ******************************************************************************** * * ,      -1 = no termination character TCNT_OFF EQU 16 ..19 transfer count TBUF_OFF EQU 20 ..23 transfer buffer pointer TBSZ_OFF EQU 24 ..27 transfer buffer maximum size TEMP_OFF EQU 28 ..31 transfer empty poin no driver NO_DMA EQU 13 no dma installed NO_WORD EQU 14 no word transfers allowed NOT_TALK EQU 15 not addressed as talker NOT_LSTN EQU 16 not addresseter pointer TFIL_OFF EQU 32 ..35 transfer fill pointer T_PR_OFF EQU 36 ..39 transfer pointer to eot procedure * NIL no procedure T_SL_OFF EQU 40 ..43 transfer eot proc static link T_PM_OFF d as listener TMO_ERR EQU 17 timeout NO_SCTL EQU 18 not system controller BAD_RDS EQU 19 bad read status / write control BAD_SCT EQU 20 bad set/clear/test C TRANSFER OFFSETS IN BUFFER CONTROL BLOCK * * OFFSET FROM A3 * * PASCAL DECLARATION * ******************************************************************************** TTMP_OFF EQU 0 ..3 pointer to driver temp offset T_SCEQU 44 ..47 transfer eot proc parameter T_DMAPRI EQU 48 dma priority request * * TRANSFER EQUATES * TT_INT EQU 1 interrupt TT_DMA EQU 2 DMA TT_BURST EQU 3 burst TT_FHS _OFF EQU 5 transfer select code TACT_OFF EQU 7 actual transfer mode TUSR_OFF EQU 9 transfer mode * 00 - not used * 01  EQU 4 fast handshake TTL IOLIB IOCOMASM - escape support PAGE ******************************************************************************** * * EXTERNAL REFERANCES for escape * ********************************************serial DMA * 02 serial FHS * 03 serial FASTEST ( DMA or FHS ) * 04 - not used * ---------------- * ************************************ REFA iodeclarations reference the io lib var. area REFA sysglobals SPC 2 ******************************************************************************** * * Escape code values * ************** 05 overlp INTR * 06 overlp DMA * 07 overlp FHS ( BURST ) * 08 overlp FASTEST ( DMA or BURST ) * ****************************************************************** NO_CARD EQU 1 no interface NOT_HPIB EQU 2 not an hpib interface NO_ACTL EQU 3 no active controller NO_DVC EQU 09 overlp OVERLAP ( DMA or INTR ) T_BW_OFF EQU 10 transfer byte/word indicator * 0 = byte / 1 = word TEND_OFF EQU 11 transfer EOI/END indicator *  4 sc ( not device ) specified NO_SPACE EQU 5 not enough space in the buffer NO_DATA EQU 6 not enough data left in the buffer TFR_ERR EQU 7 tfr error SC_BU 0 = no eoi / 1 = eoi sent or searched for TDIR_OFF EQU 13 transfer direction * 0 = input / 1 = output TCHR_OFF EQU 14 ..15 transfer terminate character * SY EQU 8 sc is currently busy BUF_BUSY EQU 9 the buffer is busy TCNTERR EQU 10 bad count BADTMO EQU 11 bad timeout value NO_DRV EQU 12 -     RD_DWN EQU 21 interface is dead EOD_SEEN EQU 22 end of data has happened IO_MISC EQU 23 misc. error SPC 3 IOE_ERROR EQU -26 io sub system error escape codation, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado e SPC 3 IOE_RSLT EQU IODECLARATIONS-66 IOE_SC EQU IODECLARATIONS-70 SPC 3 ESC_CODE EQU SYSGLOBALS-2 RCVR_BLK EQU SYSGLOBALS-10 TIMER_PRESENT EQU 1 JS 8/1/83 SYSFLAG2 BIT -- 0=>TIMER PRESENT GOT_68020 EQU 4  JS 3/25/85 SYSFLAG2 BIT -- 1=>68020 PRESENT SYSFLAG2 EQU $FFFFFEDA JS 8/1/83 CACHE_CTL EQU $5F400E JS 3/25/85  This floppy contains the source for various Pascal Workstation drivers (HPHIL, MOUSE, LIF_DAM, WS1.0_DAM, EDRIVER), utilities (ETU.CODE, SEGMENTER), and libraries (LIBRARY, IO). The modcal version of the PaWS Pascal compiler is required to build the various drivers. A copy of this compiler can be found on the SCSI: source floppy disk. A stream file (MAKE_ALL.TEXT) which shows how to build and link the drivers is also included.  This floppy contains the source for various Pascal Workstation drivers (HPHIL, MOUSE, LIF_DAM, WS1.0_DAM, EDRIVER), utilities (ETU.CODE, SEGMENTER), and libraries (LIBRARY, IO). The modcal version of the PaWS Pascal compiler is required to build the various drivers. A copy of this compiler can be found on the SCSI: source floppy disk. A stream file (MAKE_IO.TEXT) which shows how to build and link the drivers is also included. ************************************************************** Copyright Hewlett-Packard Company, 1994. All rights are reserved. Copying or other reproduction of this product except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplic-     .     .     /     /     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     M  M  N  N  Oghijklmnopabcdef˙˙˙˙˙˙˙˙˙˙ć˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙PˆŁŁć25˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙Oghijklmnopabcdef˙˙˙˙˙˙˙˙˙˙ć˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙PˆŁŁć25˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙