File CREATE.

Directory of image this file is from
This file as a plain text file

/FILE UPDATE MAIN  PROGRAM/
	OCTAL
START,	GOSUB	;INITAL
UPSTART,	PRINT 16	;TEXT '_MORE FILES?  '
	YESNO	;FINAL
	PRINT 10	;TEXT ' DEVICE='
	TYPTEX	;DEVNAM	;4
	PRINT  6	;TEXT ' FILE='
	TYPTEX	;FNAME	;6
	PRINT 5	;TEXT ' EXT='
	TYPTEX	;FNAME+3	;2
	LOAD1	;FNAME+3
	GOPOS	;.+6
	PRINT 2;TEXT 'MA'
	MOVIM	;TEXT 'MA' ;FNAME+3
STAR2,	CLEARW	;CRCONT
	GOSUB	;FOPEN
	GONEG	;OPENER
	INCREM 	;SQFLAG
	GOIFZO	;STAR3	;FILINF+7	/NO INDEX
	PRINT 11	;TEXT ' RANDOM? '
	YESNO	;.+3
	CLEARW	;SQFLAG
	CLEARW	;DCFLAG
STAR3,	CLEARW	;FDPONT
	PRINT 10	;TEXT '_CREATE?'
	YESNO	;AMT
	LOADIM	;3
	GOTO	;SRT
AMT,	PRINT 7	;TEXT ' AMEND?'
	YESNO	;CRT
	LOADIM	;1
	GOTO	;SRT
CRT,	CLEARW	;PRIFLAG
	LOADIM	;2
	PRINT 10	;TEXT ' DELETE?'
	YESNO	;.+3
	GOTO	;SRT
	PRINT 11	;TEXT '_ENQUIRE '
	LOADIM	;4
	INCREM	;PRIFLAG
SRT,	STORE1	;UPTYPE
	PRINT  17	;TEXT '  _RECORD NAME='	 /MAIN FOL.
	CLEARW	;FDPONT
	TYPTEX	;RNAME	;6
	LOAD1	;RNAME
	GOPOS	;.+7
	MOVE3	;FNAME	;RNAME
	PRINTX	;RNAME	;6
	GOSUB	;RSEARCH
	GONEG	;RERR
	DO	;UPDAT2	;UPTYPE	;0;1	/AMEND ONLY
	PRINT 21;TEXT '_SELECTED FIELDS?'
	CLRWDS	;3;QEACHSW
	YESNO	;UPDAT2
	CLRWDS	;16^3;FIXNAM
	CLEARW	;FIXCNT
UPDAT1,	FILZRO
	PRINT 6;TEXT '_NAME='
	TYPTEX	;FDNAME	;6
	GOIFZO	;UPDAT2	;FDNAME
	INCREM	;FIXFSW
	LOADX2	;FIXCNT
	MULTX2 3
	MOVE3	;FDNAME	;FIXNAM
	DO	;UPDAT1	;FIXCNT	;1;15
UPDAT2,	LOAD1	;UPTYPE
	ANDIM	;1	/CREATE,AMEND
	GOZERO	;UPDAT4
	PRINT 22;TEXT '_CHECK EACH FIELD?'
	YESNO	;UPDAT3
	GOTO	;UPDAT4
UPDAT3,	INCREM	;QEACHSW
UPDAT4,	GOTO	;LOOP
UPDAT,	PRINT 2	;TEXT ' _'
	MOVE	;UPTYPE	;WORK1	;1
	DECGOZ	;AMEND	;WORK1
	DECGOZ	;DELETE	;WORK1
	DECGOZ	;CREATE	;WORK1
	GOTO	;DELETE
OPENER,	PRINT 23	;TEXT ' ERROR OPENING FILE'
	GOTO	;UPSTART
FERR,	PRINT 17	;TEXT ' FILE NOT FOUND'
	GOTO	;UPSTART
RERR,	PRINT  21	;TEXT ' RECORD NOT FOUND'
	GOTO	;SRT+2
GETNAM,	0;0
	CLEAR
	GOIFZO	;MANNAM	;FIXFSW
	LOADX1	;FIXCNT
	MULTX1 3
	MOVE3	;FIXNAM	;FDNAME
	GOIFZO	;FIXEND	;FDNAME
	DO	;GETNA2	;FIXCNT	;1;15
FIXEND,	LOADIM	;1
	NEGATE
	GOTO	;GETNAM	/NO MORE NAMES
GETNA2,	PRINT 1;TEXT '_'
	PRINTX	;FDNAME	;6
	GOTO	;GETNAME
MANNAM,	PRINT 5;TEXT '_FLD:'
	TYPTEX	;FDNAME	;6
	GOIFZO	;FIXEND	;FDNAME
	GOTO	;GETNAM
LOOP,	FILL	;0	;RAREA	;200
	GOTO	;UPDAT
LOOP2,	PRINT 20;TEXT '_MORE THIS FILE?'
	YESNO	;.+3
	GOTO	;STAR3
	GOIFZO	;.+4	;DCFLAG
	GOTO	;ORTI
	LOAD1	;UPTYPE
	GOIFEQ	;AMD	;1
	GOIFEQ	;DELC	;2
	GOIFEQ	;DELC	;3
	GOTO	;END
DELC,	GOIFZO	;END	;DCFLAG
	GOTO	;ORTI
ORT15,	PRINT 13;TEXT '_SORT FILE?'
	YESNO	;ORT2
	GOTO	;ORT17
AMD,	PRINT 21	;TEXT '_WAS KEY CHANGED?'
	YESNO	;END
ORTI,	FILL	;0	;WORK	;50
	MOVE-10	;FILINF	;NAMFIL	;11
	GOIFZO-10;ORT15	;NAMFIL+7/ IF NO KEY,ASK SORT
ORT17,	GOSUB	;SORT	/SORT FILE BY KEY
ORT2,	GOSUB	;ENDFND
	MOVE-1	;NAMFIL	;FILINF	;11
	GOSUB	;INDXST
END,	PRINT 21	;TEXT '_CLOSE DATA FILE '
	PRINTX	;DEVNAM	;4
	PRINTC 1	;":
	PRINTX	;FNAME	;6
	PRINTC 1	;".
	PRINTX	;FNAME+3	;2
	MOVE-10	;FILINF	;NAMFIL	;11
	MOVE	;FNAME	;.+3	;4
	CLOSE	;FILENAME	;NAMFIL
	GOTO	;UPSTART
/         
/PROGRAM EXITS HERE
/          
FINAL,	EXIT

/ CREATE, GOSUB ;KEYIN PRINT 1 ;TEXT '_' GOSUB ;FINREC GOIFZO ;.+4 ;SQFLAG GOTO ;.+3 GOZERO ;ERCR LOADIM ;3 STORE1 ;ENTYPE GOSUB ;LINK DISPL, GOIFZO ;.+4 ;QEACHSW GOTO ;WRIT PRINT 20 ;TEXT '_DISPLAY RECORD?' YESNO ;WRIT LOADIM ;2 /LIST STORE1 ;ENTYPE GOSUB ;LINK WRIT, PRINT 13 ;TEXT ' RECORD OK?' YESNO ;LOOP /CREATE FOL. WRIT2, MOVE ;UPTYPE ;WORK1 ;1 DECGOZ ;LAK ;WORK1 GOSUB ;CPUTRC GONEG ;PUTERR INCREM ;DCFLAG GOTO ;LOOP LAK, GOSUB ;UPUTRC GONEG ;PUTERR GOTO ;LOOP ERCR, PRINT 33 ;TEXT ' THIS RECORD ALREADY EXISTS' GOTO ;LOOP AMEND, AMEND2, GOSUB ;KEYIN LOADIM ;1 STORE1 ;ENTYPE GOSUB ;FINREC GONEG ;ERAM GOSUB ;GETRCD GONEG ;GETERR CLEARW ;CHANGE CLEARW ;FIXCNT FLD, GOSUB ;GETNAM GONEG ;FLD3 CLEARW ;FNO GOSUB ;LINK GOTO ;FLD FLD3, GOIFZO ;LOOP ;CHANGE GOTO ;DISPL ERAM, PRINT 25 ;TEXT ' RECORD KEY NOT FOUND' GOTO ;LOOP GETERR, PRINT 12 ;TEXT ' ERROR GET' GOTO ;LOOP PUTERR, PRINT 12 ;TEXT ' ERROR PUT' PRINTC 1;BELL GOTO ;LOOP QEACHSW, 0 FIXCNT, 0 FIXFSW, 0 FIXNAM, ZBLOCK 16^3 KEYIN, 0;0 COMPARE ;FNAME ;BCTEXT;3 GONZRO ;KEYIN2 PRINT 11;TEXT '_C.C.KEY=' TYPIN K30 PRINTN 6 GONEG ;LOOP2 STORE2 ;RKEY PRINT 11;TEXT ' G.L.KEY=' TYPIN K10 STORE1 ;RKEY+2 PRINTN 6 GOTO ;KEYIN BCTEXT, TEXT 'BCMAST' KEYIN2, PRINT 14 ;TEXT '_RECORD KEY=' TYPIN 30 GONEG ;LOOP2 PRINTU ;MASK0 ;14 STORE ;RKEY GOTO ;KEYIN DELETE, GOSUB ;KEYIN PRINT 1 ;TEXT '_' LOADIM ;2 STORE1 ;ENTYPE GOSUB ;FINREC GONEG ;ERAM GOSUB ;GETRCD GONEG ;GETERR GOSUB ;LINK GOIFZO ;.+4 ;PRIFLAG GOTO ;LOOP PRINT 34 ;TEXT ' AUTHORITY TO DELETE RECORD?'
YESNO ;LOOP FILL ;-1 ;RAREA ;200 GOSUB ;UPUTRC GONEG ;PUTERR INCREM ;DCFLAG GOTO ;LOOP /LINK ROUTINE LINK, 0 ;0 GOSUB ;GETRDN GONEG ;GETERR DO ;LINK2 ;UPTYPE ;0;3 /IF<> MOVE1 ;DTABLE+6;RAREA /CREATE RECORD I.D. LINK2, CLRWDS ;24;LTABLE LOADIM ;1 STORE1 ;LENGTH LOADIM ;DTABLE+11 STORE1 ;CURRENT ADDIM ;11 STORE1 ;NEXT LOADIM ;LTABLE-2 STORE1 ;LEVELC GOTO ;LOOPL /LINK FOL. LOOPL, LOADX2 ;NEXT LOADX1 ;CURRENT COMPAR ;LVL ;LVL ;1 GOIF ;.+6 ;MAJ INCREM ;LBACK GOTO ;LOW CLEARW ;LBACK LOW, MOVE ;ENTYPE ;WORK1 ;1 DECGOZ ;LOWA ;WORK1 /AMMEND DECGOZ ;LOWL ;WORK1 /=2,LIST,DELETE GOTO ;LOWC /=3,CREATE MAJ, INCREM ;LEVELC INCREM ;LEVELC LOADX1 ;LEVELC LOAD1 ;0 LCUP, GOIF ;LCO ;FIC /LINK FOL. GOTO ;FIC LCO, LOAD1 ;CURRENT LOADX1 ;LEVELC STORE1 ;0 LOADIM ;1 LOADX1 ;LEVELC STORE1 ;1 FIC, MOVE ;ENTYPE ;WORK1 ;1 DECGOZ ;MAJA ;WORK1 GOTO ;MAJCL POINTUP, LOAD1 ;NEXT STORE1 ;CURRENT ADDIM ;11 STORE1 ;NEXT GOTO ;LOOPL /LINK FOL. LOWRET, GOIFZO ;CHAN ;LTABLE /L/C TABLE EMPTY? GOIFZO ;POINTUP ;LBACK LOADX1 ;CURRENT LOAD1 ;LVL STORE1 ;WORK1 OCCUR, LOADX2 ;LEVELC /L/C COUNT OCCURS? LOADX1 ;LEVELC LOADX1 ;0 COMPAR ;OCS ;1 ;1 GONZRO ;LCCNT CLEAR LOADX1 ;LEVELC /CLEAR LIC ENTRY STORE2 ;0 DECREM ;LEVELC DECREM ;LEVELC DECREM ;WORK1 LOADX2 ;NEXT COMPAR ;WORK1 ;LVL ;1 GOZERO ;CHAN GOTO ;OCCUR LCCNT, LOADX1 ;LEVELC /LIC COUNT + 1 INCREM ;1 LOADX1 ;LEVELC LOAD1 ;0 STORE1 ;CURRENT ADDIM ;11 STORE1 ;NEXT DECREM ;LEVELC DECREM ;LEVELC GOTO ;LOOPL CHAN, LOADX2 ;NEXT /LAST FIELD? GOIFZO ;LAST ;KY GOTO ;POINTUP /UPDATE POINTERS LAST, MOVE ;ENTYPE ;WORK1 ;1 DECGOZ ;AME ;WORK1 GOTO ;LINK /END OF LINK AME, PRINTX ;INVAL ;12 GOTO ;LINK /LOW CREATE/ /LOW CREATE LOWC, CLEARW ;FCOUNT INCREM ;FCOUNT PRTC, GOSUB ;PRI GOTO ;NEWC /LOW CREATE FOL. PRI, 0 ;0 /USED BY LOWC & MAJCL & LOWL PRINT 1 ;TEXT '_' LOADX1 ;CURRENT PRINTX ;NME ;6 LOADX1 ;CURRENT /FIELD OCCURS=1? LOAD1 ;OCS SUBTIM ;1 GOZERO ;PRI PRINT 10 ;TEXT ' FLD NO=' LOAD1 ;FCOUNT PRINTU ;MASK0 ;4
GOTO ;PRI MOVF, 0 ;0 LOADX1 ;CURRENT /LOW CREAT FOL LOADX3 ;SZE LOADX2 ;LENGTH /MOVE FIELD TO RECORD AREA MOVE ;FAREA ; RAREA LI, 0 GOTO ;MOVF NEWC, PRINT 5;TEXT ' NEW=' INCREM ;INFLAG GOSUB ;EDIT GOIFZO ;NEWC2 ;TYP GOIFZO ;NEWC1 ;QEACHSW GOTO ;NEWC2 NEWC1, PRINT 4 ;TEXT ' OK?' YESNO ;REP NEWC2, GOSUB ;MOVF GOSUB ;FLUP GOTO ;PRTC REP, PRINT 10 ;TEXT '_REPEAT?' YESNO ;FI GOTO ;NEWC FI, PRINT 21 ;TEXT ' RECORD CANCELLED' GOTO ;LOOP /EXIT /MAJOR CREATE & LISTING MAJCL, LOADX1 ;LEVELC LOAD1 ;1 STORE1 ;FCOUNT GOSUB ;PRI GOTO ;POINTUP FLUP, 0 ;0 /USED BY LOWC ' LOWL LOADX1 ;CURRENT /ADD SIZE TO LENGTH LOAD1 ;SZE ADDTO1 ;LENGTH LOADX1 ;CURRENT /FCOUNT OCCURS? COMPAR ;OCS ;FCOUNT ;1 GOZERO ;LOWRET /EXIT INCREM ;FCOUNT /ADD 1 TO FCOUNT GOTO ;FLUP /LOW AMEND FOL. LOWA, LOADX1 ;CURRENT COMPAR ;NME ;FDNAME ;3 GONZRO ;AUP CLEARW ;FCOUNT INCREM ;FCOUNT LOADX1 ;CURRENT /FIELD OCCURS=1? LOAD1 ;OCS SUBTIM ;1 GOZERO ;LOOPA PRINT 10 ;TEXT ' FLD NO=' TYPIN 30 /STORES F.NO IN WORK1 GOZERO ;LINK GONEG ;LINK DECREM ;FIXCNT PRINTU ;MASK0 ;4 STORE1 ;WORK1 GOTO ;CHECK AFUP, COMPAR ;WORK1 ;FCOUNT ;1 GOIF ;LOOPA ;LOOPA INCREM ;FCOUNT LOADX1 ;CURRENT /ADD SIZE TO LENGTH LOAD1 ;SZE ADDTO1 ;LENGTH GOTO ;AFUP /LOW AMEND FOL. AUP, LOADX1 ;CURRENT LOAD1 ;OCS STORE1 ;WORK1 AUP6, LOADX1 ;CURRENT /ADD SIZE TO LENGTH LOAD1 ;SZE ADDTO1 ;LENGTH DECGOZ ;LOWRET ;WORK1 GOTO ;AUP6 CHECK, LOADX1 ;CURRENT COMPAR ;OCS ;WORK1 ;1 GOIF ;AFUP ; REPA GOTO ;AFUP REPA, PRINT 20 ;TEXT ' INVALID,REPEAT?' YESNO ;AUP GOTO ;LOWA LOOPA, PRINT 5 ;TEXT ' NOW=' /LOW AMEND FOL. CLEARW ;INFLAG GOSUB ;EDIT PRINT 10 ;TEXT ' CHANGE?' YESNO ;LINK PRINT 6 ;TEXT '_ NEW=' INCREM ;INFLAG GOSUB ;EDIT GOIFZO ;LOOPA1 ;QEACHSW GOTO ;LOOPA2 LOOPA1, PRINT 4 ;TEXT ' OK?' YESNO ;LOOPA LOOPA2, GOSUB ;MOVF INCREM ;CHANGE GOTO ;LINK MAJA, CLEARW ;FCOUNT /MAJOR AMEND LOADX1 ;CURRENT COMPAR ;NME ;FDNAME ;3 GONZRO ;POINTUP INCREM ;FCOUNT LOADX1 ;CURRENT LOAD1 ;OCS SUBTIM ;1
GOIF ;NEXTL ;.+1 GOIFZO ;.+4 ;FNO GOTO ;COM PRINT 10 ;TEXT ' FLD NO=' TYPIN 30 GOZERO ;NEXTL GONEG ;NEXTL DECREM ;FIXCNT PRINTU ;MASK0 ;4 STORE1 ;FNO /MAJOR AMEND FOL COM, LOADX1 ;LEVELC /IFNO = L/C COUNT COMPAR ;1 ;FNO ;1 GOIF ;NEXTL ;POINTUP GOTO ;POINTUP NEXTL, GOSUB ;GETNAM GONEG ;LAST /?????? ?? GOTO ;POINTUP /LOW LISTING LOWL, CLEARW ;FCOUNT INCREM ;FCOUNT PRINTL, GOSUB ;PRI PRINT 5 ;TEXT ' NOW=' CLEARW ;INFLAG GOSUB ;EDIT GOSUB ;FLUP GOTO ;PRINTL EDIT, 0 ; 0 /EDIT LOADX1 ;CURRENT /GET SIZE LOAD1 ;SZE STORE1 ;SIZE STORE1 ;KI GOIF ;ERDESCR ;ERDESCR SUBTIM ;51 /CHECK SIZE GOIF ;ERDESCR ;.+3 GOTO ;ERDESCR GOIFZO ;MI ;INFLAG FILL ;0 ;FAREA KI, 0 GOTO ;ZIT MI, LOAD1 ;SIZE STORE1 ;TI LOADX1 ;LENGTH MOVE ;RAREA ;FAREA TI, 0 ZIT, LOADX1 ;CURRENT LOAD1 ;ABC STORE1 ;TYP GOZERO ;OTYPE DIVIM ;10 REMAIN STORE1 ;DTYP REMAIN DIVIM ;10 REMAIN STORE1 ;CTYP REMAIN DIVIM ;10 STORE1 ;ATYP REMAIN STORE1 ;BTYP LOAD1 ;ATYP STORE1 ;WORK1 DECGOZ ;GBIT ;WORK1 DECGOZ ;GBIT ;WORK1 DECGOZ ;DBIT ;WORK1 DECGOZ ;OCT ;WORK1 /EDIT FOL. GOTO ;BIN OTYPE, PRINTU ;MASK0 ;2 GOTO ;EDIT GBIT, GOIFZO ;GOUT ;INFLAG GOSUB ;IFFIL LOADX2 ;SIZE /INPUT MULTX2 2 TYPTEX ;FAREA ;0 FILZRO GOTO ;EDIT GOUT, LOADX2 ;SIZE /PRINT MULTX2 2 PRINTX ;FAREA ;0 GOTO ;EDIT DBIT, GOIFZO ;DOUT ;INFLAG GOSUB ;IFFIL LOADX2 ;SIZE /INPUT TYPWDS ;FAREA ;0 FILZRO GOTO ;EDIT DOUT, LOADX2 ;SIZE /PRINT PRINTW ;FAREA ;0 GOTO ;EDIT
IFFIL, 0;0 GOIFZO ;IFFIL ;CTYP FILSPC GOTO ;IFFIL BIN, LOAD1 ;SIZE /EDIT FOL. STORE1 ;WORK1 /CHECK SIZE SUBTIM ;4 GONEG ;FOL ERDESCR, PRINT 24 ;TEXT '_ILLEGAL DESCRIPTION' GOTO ;LOOP FOL, LOAD1 ;BTYP /CHECK DEC.PLACES RANGE ;ERDESCR ;0;7 GOIFZO ;BINOUT ;INFLAG /DEC.PLACES LOAD1 ;CTYP /SIGN GOIF ;UNS ;.+1 LOADIM ;20 GOTO ;OUTR UNS, CLEAR DECGOZ ;OUTR ;WORK1 LOADIM ;10 /EDIT FOL. DECGOZ ;OUTR ;WORK1 LOADIM ;20 OUTR, ADD1 ;BTYP STORX1 LOAD1 ;TPIN STORE1 ;RI RI, 0 STORE ;WORK LOAD1 ;SIZE STORE1 ;WORK1 LOAD ;WORK DECGOZ ;SIG1 ;WORK1 DECGOZ ;SIG2 ;WORK1 GOTO ;SIG3 /EDIT FOL. SIG3, STORE ;FAREA GOTO ;BINOUT SIG2, SIGN2 STORE2 ;FAREA GOTO ;BINOUT SIG1, SIGN1 STORE1 ;FAREA GOTO ;BINOUT BINOUT, LOAD1 ;CTYP GOIF ;CI ;.+1 LOADX1 ;SIZE /SIGNED MULTX1 5 GOTO ;SIS-5 CI, LOADX1 ;SIZE /UNSIGNED MULTX1 4 GOTO ;SIZ-4 SIS, LOAD1 ;FAREA /EDIT FOL. SIGN1 GOTO ;RT LOAD2 ;FAREA SIGN2 GOTO ;RT LOAD ;FAREA GOTO ;RT SIZ, LOAD1 ;FAREA GOTO ;RT LOAD2 ;FAREA GOTO ;RT LOAD ;FAREA RT, LOADX1 ;BTYP MULTX1 5 PRINTU ;MASK0 ;16 GOTO ;EDIT TPIN, TYPIN 10 /EDIT FOL. TYPIN 11 TYPIN 12 TYPIN 13 TYPIN 14 TYPIN 15 TYPIN 16 TYPIN 17 TYPIN 20 TYPIN 21 TYPIN 22 TYPIN 23 TYPIN 24 TYPIN 25 TYPIN 26 TYPIN 27 TYPIN 30 TYPIN 31 TYPIN 32 TYPIN 33 TYPIN 34 TYPIN 35 TYPIN 36 TYPIN 37 INITAL, 0;0 PRINT 24 ;TEXT '_ CREATION-UPDATE ' GOSUB ;RSDATP OPEN ;DEVICE SYS ;FILENAME FDESCF.MA ;FDESCF GONEG ;OPENER MOVE-1 ;FDESCF ;FDESCW ;11 GOTO ;INITAL / /RASBOL SYSTEM DATE ROUTINE DECIMAL RSDATE, 0;0 LOAD1 ;4022 /7666 ANDIM ;248 /370 SHIFTR 3 MULTIM ;100 STORE2 ;RSDTEMP LOAD1 ;4022 SHIFTR 8 ADD2 ;RSDTEMP MULTIM ;100 STORE2 ;RSDTEMP LOAD1 ;4022 ANDIM ;7 ADDIM ;78 ADD2 ;RSDTEMP GOTO ;RSDATE RSDATP, 0;0 GOSUB ;RSDATE PRINTU ;RSDMSK ;10 GOTO ;RSDATP RSDMSK,TEXT ' / / -' RSDTEMP, 0;0 OCTAL / OCT, GOIFZO ;OCTOUT ;INFLAG GOSUB ;SOCTIN GOTO ;EDIT OCTOUT, GOSUB ;SOCTOT GOTO ;EDIT / /THIS SUBROUTINE FINDS NEW END OF FILE / ENDFND, 0;0 CLRWDS-10 ;2;NAMFIL+4 /CLEAR POINTERS LOAD1-1 ;NAMFIL+1 /FIRST BLOCK ADD1-1 ;NAMFIL+3 /INDEX BLKS STORE2 ;TEMP LOAD1-1 ;NAMFIL+10 /8 MINUS LENGTH NEGATE ADD1-1 ;NAMFIL+1 /FIRST SUBTIM ;1 STORE1 ;LASTR MOVE1-1 ;NAMFIL ;TEMP /READ EACH BLOCK TILL ALL 7777 FOUND FENDLP, LOAD2 ;TEMP READAB LOAD-1 ;XAREA ADDIM ;1 GOZERO ;FENDSR COMPARE ;LASTR ;TEMP+1 ;1 GOZERO ;FENDSR INCREM-1 ;NAMFIL+4 INCREM ;TEMP+1 GOTO ;FENDLP /SEE IF THIS OR PREVIOUS BLOCK IS END FENDSR, GOIFZO-10;ENDFND ;NAMFIL+4 DECREM ;TEMP+1 LOAD2 ;TEMP READAB CLEARW ;TEMP FENDL2, LOAD1-1 ;NAMFIL+6 /REC LENGTH ADDTO1 ;TEMP LOAD1 ;TEMP RANGE ;ENDFND ;0;400 STORX1 LOAD-1 ;XAREA ADDIM ;1 GONZRO ;FENDL2 MOVE1-10 ;TEMP ;NAMFIL+5 DECREM-1 ;NAMFIL+4 GOTO ;ENDFND TEMP, 0;0 LASTR, 0
/ /THIS SUBROUTINE READS THE FILE /DESCRIPTION FILE SEQUENTIALLY / RSQNFD, ZBLOCK 2 MOVE-10 ;FDESCW ;FDESCF ;11 INCREM ;FDCONT LOAD1 ;FDCONT READSQ ;FDESCF GONEG ;RSQNFD STORX1 MOVE-1 ;XAREA ;FDRCID ;11 GOTO ;RSQNFD / /WORK AREAS COMMON TO FSEARCH AND RSQNFD / FDCONT, 0 FDRCID, ZBLOCK 11 FDPONT, 0 FDESCW, ZBLOCK 11 / /THIS SUBROUTINE OPENS A SPECIFIED FILE /IF THE FILE IS NOT SUCCESSFULLY OPENED /THE ROUTINE EXITS WITH AC = -1 / FOPEN, ZBLOCK 2
FILL-10 ;0 ;NAMFIL ;11 MOVE ;DEVNAME ;OPENFL+1 ;6 OPENFL, OPEN ;DEVICE RKA1 ;FILENAME . ;NAMFIL GONEG ;FOPEN PRINT 3 ;TEXT ' R=' PRINTU ;MASK0 ;6 STORE1 ;SRTNUM MOVE-1 ;NAMFIL ;FILINF ;11 GOTO ;FOPEN / /CONSTANT / SRTNUM, 0 / /THIS SUBROUTINE FINDS A RECORD DESCRIPTION WITHIN /A PARTICULAR FILE DESCRIPTION IN THE FILE /DESCRIPTION FILE. IF THE RECORD DESCRIPTION EXISTS, /THE ROUTINE EXITS WITH AC = 0, BUT IF IT DOESN'T /EXIST, THE ROUTINE EXITS WITH AC = -1. /NEEDS RSQNFD SUBROUTINE / RSEARCH, ZBLOCK 2 MOVE ;FDPONT ;FDCONT ;1 RSLOOP, GOSUB ;RSQNFD GONEG ;RSEARCH LOADIM ;-1 SUBT1 ;FDRCID GOZERO ;RNFOND LOADIM ;6661 SUBT1 ;FDRCID GONZRO ;RSLOOP TSRNAM, COMPAR ;RNAME ;FDRCID+2 ;3 GONZRO ;RSLOOP RFOUND, MOVE ;FDCONT ;FDPONT ;1 GOTO ;RSEARCH RNFOND, LOADIM ;-1 SIGN1 GOTO ;RSEARCH / /THIS ROUTINE FETCHES THE COMPLETE DESCRIPTION OF /A SPECIFIED RECORD INTO A MAIN LINE WORK LOCATION /NEEDS RSQNFD ROUTINE / GETRDN, ZBLOCK 2 FILL ;0 ;DTABLE ;500 LOAD1 ;FDPONT SUBTIM ;1 STORE1 ;FDCONT LOADIM ;-1 STORE1 ;GRDFS CLEARW ;GRDDTI GRDLP, GOSUB ;RSQNFD GONEG ;GETRDN INCGOZ ;GRDSR ;GRDFS LOADIM ;6660 SUBT1 ;FDRCID GOIF ;GETRDN ;.+1 LOADIM ;6661 SUBT1 ;FDRCID GOIF ;GETRDN ;.+1 LOADIM ;-1 SUBT1 ;FDRCID GOIF ;GETRDN ;.+1 GRDSR, LOADX2 ;GRDDTI MOVE ;FDRCID ;DTABLE ;11 LOADIM ;11 ADDTO1 ;GRDDTI GOTO ;GRDLP / /WORK LOCATIONS FOR GET RECORD DESCRIPTION SUBROUTINE / GRDFS, 0 GRDDTI, 0 / /INDEX SET-UP SUBROUTINE: THIS SUBROUTINE MUST /BE INITIALISED BY TRANSFERRING THE 9 WORD FILE /INFORMATION BLOCK TO THE AREA "FILINF" BEFORE USE / INDXST, ZBLOCK 2 FILL ;-1 ;KEYTAB ;400 FILL ;0 ;DBKKNT ;11 GOIFZO ;IBYPASS ;FILINF+3 / /THE LOOP WHICH CONSTRUCTS /THE INDEX IS NOW PREPARED /USING THE F.I.B. / LOAD1 ;FILINF+10 ADD1 ;FILINF+3 STORE1 ;DBKKNT GOIFZO ;ZERKEY ;FILINF+7 LOAD1 ;FILINF+7 MULTIM ;10 ADDIM ;LOADIM STORE1 ;FETKEY LOAD1 ;FILINF+1 ADD1 ;FILINF+3 STORE1 ;DBKNUM LOADIM ;125 STORE1 ;KEYKNT LOAD1 ;FILINF+3 NEGATE STORE1 ;IBKKNT LOAD1 ;FILINF+1 STORE1 ;IBKNUM LOAD1 ;FILINF STORE1 ;RBDATA STORE1 ;WBDATA LOADIM ;KEYTAB STORE1 ;STOKEY+1 / /THIS SECTION READS A DATA BLOCK AND SAVES THE FIRST KEY IN A TABLE / RDBKLP, LOAD1 ;DBKNUM STORE1 ;RBDATA+1 LOAD2 ;RBDATA READAB FETKEY, NOP ;XAREA+1 STOKEY, STORE ;NOP LOADIM ;3 ADDTO1 ;STOKEY+1 DECGOZ ;WINDXB ;KEYKNT RBLCON, INCREM ;DBKNUM INCGOZ ;WINDXB ;DBKKNT GOTO ;RDBKLP / /THIS SECTION WRITES AN INDEX BLOCK AWAY / WINDXB, LOAD1 ;IBKNUM STORE1 ;WBDATA+1 FILL ;125 ;KEYKNT ;1 MOVE-10 ;KEYTAB ;XAREA ;400 LOAD2 ;WBDATA WRITAB INCREM ;IBKNUM INCGOZ ;ERTEST ;IBKKNT
LOADIM ;KEYTAB STORE1 ;STOKEY+1 FILL ;-1 ;KEYTAB ;400 GOIFZO ;SETEND ;DBKKNT GOTO ;RBLCON / /THIS SECTION TESTS THE INDEX FOR OVERFLOW / ERTEST, GOIFZO ;SETEND ;DBKKNT LOADIM ;-2 SIGN1 GOTO ;INDXST / /THIS EXIT IS TAKEN IF NO INDEX IS REQUIRED / IBYPASS, PRINT 23 ;TEXT '_INDEX NOT REQUIRED' GOTO ;INDXST / /THIS EXIT IS TAKEN IF A KEY LENGTH OF ZERO IS FOUND / ZERKEY, LOADIM ;-1 SIGN1 GOTO ;INDXST / /THIS EXIT IS TAKEN IF A CORRECT SET UP IS ACHIEVED / SETEND, CLEAR GOTO ;INDXST / /DATA AREAS REQUIRED BY INDXST (MUST BE IN FIELD 1) / FILINF, ZBLOCK 11 DBKKNT, 0 DBKNUM, 0 KEYKNT, 0 IBKKNT, 0 IBKNUM, 0 RBDATA, ZBLOCK 2 WBDATA, ZBLOCK 2 / /THIS SUBROUTINE FINDS A SPECIFIED RECORD IN A /SPECIFIED FILE. IF THE RECORD IS FOUND, THE /ROUTINE EXITS WITH AC = 0, BUT IF IT IS NOT /FOUND THE ROUTINE EXITS WITH AC = -1 /NEEDS GDRRAN AND FOPEN SUBROUTINES / FINREC, ZBLOCK 2 GOSUB ;GDRRAN GONEG ;FINREC CLEAR GOTO ;FINREC / /THIS SUBROUTINE READS A SPECIFIED FILE RANDOMLY / GDRRAN, ZBLOCK 2 MOVE-10 ;FILINF ;NAMFIL ;11 LOAD ;RKEY GOIFZO ;.+6 ;SQFLAG READSQ ;NAMFIL GOTO ;.+3 READ ;NAMFIL GONEG ;GDRRAN STORE1 ;DRCWDI GOTO ;GDRRAN / /WORK AREAS / DRCWDI, 0 / /THIS SUBROUTINE FETCHES A SPECIFIED RECORD /FROM A SPECIFIED DATA FILE. IF THE RECORD /IS NOT FOUND THE ROUTINE EXITS WITH AC = -1 /IF THE RECORD IS FOUND, IT IS MOVED TO THE /MAIN PROGRAM DATA AREA RAREA /NEEDS GDRRAN SUBROUTINE / GETRCD, ZBLOCK 2 GOSUB ;GDRRAN GONEG ;GETRCD MOVE ;FILINF+6 ;GRFET+3 ;1 LOADX1 ;DRCWDI GRFET, MOVE-1 ;XAREA ;RAREA ;NOP GOTO ;GETRCD / /THIS SUBROUTINE IS USED BY THE CREATION PROGRAM /TO WRITE RECORDS TO A SPECIFIED DATA FILE. THE /RECORD KEY IS IN THE MAIN PROGRAM WORK LOCATION /RKEY, THE RECORD LENGTH IS IN LENGTH AND THE /RECORD ITSELF IS IN RAREA. THE ROUTINE RETURNS /WITH AC = 0 AFTER A SUCCESSFUL WRITE BUT WITH AC / = -1 IF AN ERROR OCCURS. /NEEDS FOPEN ROUTINE / CPUTRC, ZBLOCK 2 MOVE-10 ;FILINF ;NAMFIL ;11 CLEAR READSQ ;NAMFIL GONEG ;CPUTRC STORE1 ;PUTRWI MOVE ;LENGTH ;CPRPUT+3 ;1
LOADX2 ;PUTRWI CPRPUT, MOVE-10 ;RAREA ;XAREA ;NOP WRITSQ MOVE-1 ;NAMFIL ;FILINF ;11 INCREM ;CRCONT PRINT 10 ;TEXT ' WRITTEN' GOTO ;CPUTRC / /WORK LOCATIONS / PUTRWI, 0 CRCONT, 0 / /THIS SUBROUTINE IS USED BY THE UPDATE PROGRAM /TO WRITE RECORDS TO A SPECIFIED DATA FILE. THE /RECORD KEY IS IN THE MAIN PROGRAM WORK LOCATION /RKEY, THE RECORD LENGTH IS IN LENGTH AND THE /RECORD ITSELF IS IN RAREA. THE ROUTINE RETURNS /WITH AC = 0 AFTER A SUCCESSFUL WRITE BUT WITH /AC = -1 IF AN ERROR OCCURS. NEEDS GDRRAN ROUTINE / / UPUTRC, ZBLOCK 2 GOSUB ;GDRRAN GONEG ;UPUTRC MOVE ;FILINF+6 ;UPRPUT+3 ;1 LOADX2 ;DRCWDI UPRPUT, MOVE-10 ;RAREA ;XAREA ;NOP WRITE GOTO ;UPUTRC / /THIS SUBROUTINE PRINTS THE CONTENTS OF SPECIFIED /LOCATIONS IN OCTAL. THE DATA TO BE PRINTED BEGINS /IN MAIN PROGRAM WORK LOCATION FAREA AND THE NUMBER /OF WORDS TO BE PRINTED IS IN SIZE. / SOCTOT, ZBLOCK 2 CLEARW ;OOSIND MOVE ;SIZE ;OOSWKT ;1 OOSLP, LOADX1 ;OOSIND LOAD1 ;FAREA PRINTO DECGOZ ;SOCTOT ;OOSWKT INCREM ;OOSIND GOTO ;OOSLP / /CONSTANTS FOR SOCTOT ROUTINE / OOSIND, 0 OOSWKT, 0 / /INPUT /FOUR DIGIT OCTAL NUMBERS TO SUCCESSIVE LOCATIONS /STARTING AT THE MAIN PROGRAM WORK LOCATION FAREA /THE NUMBER OF LOCATIONS IS IN SIZE. NEEDS GOCTWD / SOCTIN, ZBLOCK 2 CLEARW ;OISWIN MOVE ;SIZE ;OISWKT ;1 OISWLP, CLEAR CLEARW ;OOSIND OIPSL,MULTIM ;10 /8 STORE1 ;OOSWKT TYPCH RANGE ;.-2 ;"0;"7 SUBTIM ;"0 ADD1 ;OOSWKT DO ;OIPSL ;OOSIND;1;3 LOADX1 ;OISWIN STORE1 ;FAREA DECGOZ ;SOCTIN ;OISWKT INCREM ;OISWIN GOTO ;OISWLP / /CONSTANTS...OCTAL INPUT SUBROUTINE / OISWIN, 0
OISWKT, 0 / / NAMFIL=XFILES FDESCF=XFILES+11 FNO,0 OPNAME,ZBLOCK 50 DEVNAME, 0;0 FNAME,0;0;0;0 DCFLAG,0 UPTYPE,0 RNAME,0;0;0 WORK1,0 SIZE,0 PRIFLAG,0 INFLAG,0 CHANGE,0 RKEY,0;0;0 FKEY,0 CURRENT,0 NEXT,0 LEVELC,0 LBACK,0 LTABLE,ZBLOCK 24 FCOUNT,0 WORK,ZBLOCK 50 FAREA,ZBLOCK 50 FDNAME,0;0;0 ENTYPE,0 SQFLAG,0 INVAL,TEXT ' INVALID ' SRFLAG=0 KY=1 NME=2 SZE=5 LVL=6 OCS=7 ABC=10 TYP,0 ATYP,0 BTYP,0 CTYP,0 DTYP,0 MASK0,TEXT ' 0-' MASK1,TEXT ' 0.0-' MASK2,TEXT ' 0.00-' MASK3,TEXT ' 0.000-' MASK4,TEXT ' 0.0000-' MASK5,TEXT ' 0.00000-' MASK6,TEXT ' 0.000000-' MASK7,TEXT ' / /00 ' KEYS, 1;2;3;4;5;6;7;10 KEYTAB, ZBLOCK 400 DTABLE, ZBLOCK 500 RAREA, ZBLOCK 200 SORTA=KEYTAB
SORT, 0;0 CLRWDS ;7;SP1 MOVE1-1 ;NAMFIL+4 ;SORTNB /FIRST UNUSED BLOCK INCREM ;SORTNB LOAD1-1 ;NAMFIL+10 /IS THE FILE FULL? SIGN1 NEGATE SUBT1-1 ;NAMFIL+3 /NO.OF INDEX BLOCKS SUBT1 ;SORTNB GOIF ;SRTB4 ;SRTB4 /YES INCREM ;SORTNB SRTB4, LOAD-1 ;NAMFIL STORE ;BFIRST /DEVICE LOAD1-1 ;NAMFIL+1 /FIRST BLOCK OF FILE ADD1-1 ;NAMFIL+3 SUBTIM ;1 STORE1 ;BFIRST+1 /FIRST DATA BLOCK-1 LOADIM ;400 /256 DIVID1-1 ;LENREC STORE1 ;SORTN MULT1-1 ;LENREC STORE1 ;LENGTH STORE1 ;SL1 STORE1 ;PL1 STORE1 ;PL2 STORE1 ;SL2 LOAD1-1 ;LENREC STORE1 ;SORLEN MOVE ;KEYS ;SORKEY ;10 LOAD1 ;SORTN MULTIM ;2 STORE1 ;SORTN /NO. OF RECORDS IN SORT AREA LOAD1 ;SORTNB STORE1 ;SORTMB SRTB20, LOAD1 ;SORTMB SHIFTR 1 STORE1 ;SORTMB GOZERO ;SORT SRTB30, LOAD1 ;SORTNB SUBT1 ;SORTMB STORE1 ;SORTKB MOVIM ;1;SORTJB SRTB41, MOVE1 ;SORTJB ;SORTIB SRTB49, LOAD1 ;SORTIB ADD1 ;SORTMB STORE1 ;SORTLB GOSUB ;BGETCOM /GET BLOCKS, SORT, WRITE BACK GOIFZO ;SRTB60 ;SWITCH LOAD1 ;SORTIB SUBT1 ;SORTMB STORE1 ;SORTIB SUBTIM ;1 GOZERO ;SRTB49 GOPOS ;SRTB49 SRTB60, LOAD1 ;SORTJB ADDIM ;1 STORE1 ;SORTJB SUBT1 ;SORTKB GOPOS ;SRTB20 GOTO ;SRTB41 BGETCOM, 0;0 LOAD2 ;BFIRST ADD1 ;SORTIB READAB GONEG ;ERT1 MOVE-1 ;XAREA ;SORTA SL1, 200 LOAD2 ;BFIRST ADD1 ;SORTLB READAB GONEG ;ERT1 LOADX2 ;LENGTH MOVE-1 ;XAREA ;SORTA SL2, 200 GOSUB ;CORSORT GOIFZO ;BGETCOM ;SWITCH LOADX1 ;LENGTH MOVE-10 ;SORTA ;XAREA PL2, 400 LOAD2 ;BFIRST ADD1 ;SORTLB WRITAB GONEG ;ERRORT MOVE-10 ;SORTA ;XAREA PL1, 400 LOAD2 ;BFIRST ADD1 ;SORTIB WRITAB GONEG ;ERRORT GOTO ;BGETCOM CORSORT, 0;0 CLEARW 1 ;SWITCH MOVIM ;2;SORTM GOPAL 1 ;SORT20 GOIFZO ;CORSORT ;SWITCH LOAD1 ;SORTN STORE1 ;SORTM GOPAL 1 ;SORT20 GOTO ;CORSORT ERT1, ADDIM ;1 GONEG ;ERRORT PRINT 13;TEXT '_FILE FULL_' GOTO ;BGETCOM ERRORT, PRINT 21 ;TEXT '_SORT DISK ERROR_' EXIT
/PAL SUBROUTINE, CORE SORT (INSERT "PAGE" PSEUDO-OP HERE) PAGE SORT20, 0 CIF CDF 10 SORT21, CLA CLL TAD SORTM /M RAR /DIVIDE BY 2 DCA SORTM /M=M/2 TAD SORTM SPA SNA CLA JMP OUT20 /JMP I SORT20 SORT30, TAD SORTM CIA TAD SORTN DCA SORTK /K=N-M CLA CLL IAC DCA SORTJ /J=1 SORT41, CLA CLL TAD SORTJ DCA SORTI /I=J SORT49, CLA CLL TAD SORTI TAD SORTM DCA SORTL /L=I+M DCA SORSW /CLEAR SW JMS SORCOM CLA CLL TAD SORSW SNA JMP SORT60 CLA CLL TAD SORTM CIA TAD SORTI DCA SORTI /I=I-M CLA CLL CMA TAD SORTI SMA /IF I-1<0 JMP SORT49 /NO SORT60, CLA CLL IAC /=1 TAD SORTJ DCA SORTJ /J=J+1 TAD SORTK CIA TAD SORTJ /IF J-K>0 SPA SNA CLA JMP SORT41 JMP SORT21 OUT20, CDF CIF 0 JMP I SORT20 /OF PAGE LITERALS FIT HERE PAGE SORCOM, 0 CLA CLL CMA TAD SORTI JMS MULLEN /I-1 X LENGTH OF RECORD DCA SXI /START OF RECRD 1 CLA CLL CMA /-1 TAD SORTL JMS MULLEN DCA SXL /ST. OF REC. 2 DCA SX1 /CLEAR SLOOPS, TAD SX1 /KEY COUNT TAD TADKEYS / (TAD KEYS DCA .+1 0 /TAD KEYS INSTR. TAD ADSORTA /ADDRESS OF SORTA DCA SP3 /POINT TO WORD IN REC. TO BE COMPARED TAD SP3 TAD SXI /PLUS REC. 1 DCA SP1 /WORD IN REC 1 TAD SP3 TAD SXL DCA SP2 /WORD IN REC 2 TO BE COMP. /COMPARE KEY WORDS LOGICALLY TAD I SP1 /GET WORD 1 SPA CLA JMP SXGLAM /NEG. TAD I SP2 SPA JMP SXCRES /A<B SXGAB, CIA /NEGATE TAD I SP1 JMP SXCRES /RESULT IN AC. SXGLAM, CLA CLL TAD I SP2 SPA JMP SXGAB / CLA CLL IAC /=1 SXCRES, SPA SNA /RESULT IN AC HERE,SKIP IF A>B JMP SXINC /AROUND SWAP ROUTINE /SWAP TWO RECORDS CLA CLL TAD SXI TAD ADSORTA DCA SP4 /POINT REC. 1 TAD SXL TAD ADSORTA DCA SP5 /REC 2 TAD SORLEN /LENGTH CIA DCA SP3 /COUNT DOWN SWALOP, TAD I SP4 MLD TAD I SP5 DCA I SP4 SWP DCA I SP5 ISZ SP4 ISZ SP5 ISZ SP3 /COUNTER JMP SWALOP ISZ SORSW ISZ SWITCH JMP I SORCOM /OUT /COUNT DOWN KEYS SXINC, SZA /EQUAL COMPARE JMP I SORCOM / NO ISZ SX1 /KEY COUNT + 1 CLA CLL IAC RTL /=4 RAL /=8 CIA /=-8 TAD SX1 SMA CLA JMP I SORCOM /OUT EQUAL COMPARE JMP SLOOPS MULLEN, 0 /MULTIPLY BY LENGTH SPA SNA JMP I MULLEN /EXIT IF ZERO CIA DCA SP3 /COUNTER TAD SORLEN ISZ SP3 JMP .-2 JMP I MULLEN /DATA AREAS----------------- SP1,0 SP2,0 SP3,0 SP4,0 SP5,0 SXI,0 SXL,0 SX1,0 SORSW,0 TADKEYS, TAD SORKEY ADSORTA, SORTA SORLEN,0 SORKEY, ZBLOCK 10 /KEYS SWITCH,0 SORTI,0 SORTJ,0 SORTK,0 SORTL,0 SORTM,0 SORTN,0 SORTNB, 0 SORTIB, 0 SORTMB, 0 SORTLB, 0 SORTJB, 0 SORTKB, 0 LENGTH, 0 BFIRST, 0;0;0 LENREC=NAMFIL+6 /TEMP END $



Feel free to contact me, David Gesswein djg@pdp8online.com with any questions, comments on the web site, or if you have related equipment, documentation, software etc. you are willing to part with.  I am interested in anything PDP-8 related, computers, peripherals used with them, DEC or third party, or documentation. 

PDP-8 Home Page   PDP-8 Site Map   PDP-8 Site Search