github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-01-31 05:52:12 +00:00
Code Issues Releases Wiki Activity
Files
e82ebb56d42ee0c2857566f669bbbcad37e5bc62
PDP-10.its/src/draw/body.500
Lars Brinkhoff 33074b453f SUDS - Stanford University Drawing System.
2018-05-05 19:19:09 +02:00

1516 lines
30 KiB
Plaintext
Raw Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
;<DRAW>BODY.FAI.70, 19-NOV-75 19:34:58, EDIT BY HELLIWELL
VERSION(BODY,6)
SUBTTL PIN SWAPPING
PSWAPA:
MD,< TRZA TFLG
PSWAPB: TRO TFLG ;PIN NUMBER SWAP ONLY
>;MD
PUSHJ P,PUSHM ;SET DISPLAY MODE
PUSHJ P,GETCLS
JRST POPME
TLNN M,DSKACT!MACACT
MD,< OUTSTR[ASCIZ/FIRST PIN ID?/] >
MPC,< OUTSTR[ASCIZ/FIRST PIN NAME?/] >
PUSHJ P,READP
JRST POPM ;ALTMODE
JRST POPME ;ERROR
JUMPE T,POPM ;LET HIM OUT ON 0
MOVEM T,N1
TLNN M,DSKACT!MACACT
MD,< OUTSTR[ASCIZ/SECOND PIN ID?/] >
MPC,< OUTSTR[ASCIZ/SECOND PIN NAME?/] >
PUSHJ P,READP
JRST POPM ;ALTMODE
JRST POPME ;ERROR
PUSHJ P,POPM
JUMPE T,CPOPJ ;LET HIM OUT ON 0
MOVEM T,N2
SETZM L1
SETZM L2
MOVEM A,CURBOD ;STO BODY POINTER HERE FOR NOW
MOVEI B,RADDR(A,BLNK,BPLNK) ;PIN LIST OFF OF BODY
JRST FNDPN2
FNDPN1: MOVE A,B ;CURRENT POINT
FETCH(T,B,BPLOC) ;GET PIN-LOC BLOCK IN TYPE
FETCH(T,T,TPID) ;WE'RE DISPLAYING "REAL" PINIDS
CAME T,N1
JRST NOTN1
MPC,< SKIPN L1 ;SAME PIN MAYBE ON BOTH SIDES
JRST [ MOVEM A,L1
JRST FNDPN2]
HRLM A,L1 ;GOTH BOTH POINTS FOR #1
SKIPN TT,L2
JRST FNDPN2
TLNE TT,-1 ;ALSO GOT BOTH FOR #2?
TLNN TT,-1
JRST FNDPN2
JRST GOTBOT
NOTN1: CAME T,N2
JRST FNDPN2
SKIPN L2
JRST [ MOVEM A,L2
JRST FNDPN2]
HRLM A,L2
SKIPN TT,L1
JRST FNDPN2
TLNE TT,-1
TLNN TT,-1
JRST FNDPN2
JRST GOTBOT
>;MPC
MD,< MOVEM A,L1
SKIPN TT,L2
JRST FNDPN2
JRST GOTBOT
NOTN1: CAME T,N2
JRST FNDPN2
MOVEM A,L2
SKIPN TT,L1
JRST FNDPN2
JRST GOTBOT
>;MD
FNDPN2: FETCH(B,B,BPLNK)
JUMPN B,FNDPN1
OUTSTR[ASCIZ/CAN'T FIND BOTH PINS ON THIS BODY!
/]
POPJ P,
GOTBOT:
MPC,< HRRZ T,L1
FETCH(T,T,BPBIT)
HRRZ TT,L2
FETCH(TT,TT,BPBIT)
EQV TT,T
TRNN TT,FRONT ;IF NOT ON SAME SIDE
MOVSS L1 ;MAKE THEM SUCH
PUSHJ P,SWPPIN
MOVSS L1
MOVSS L2
PUSHJ P,SWPPIN
MOVE A,CURBOD
PUSHJ P,BODFIX ;FIX BODY PINS
TRO MCHG!NEEDCL
POPJ P,
>;MPC
SWPPIN: MOVE T,L1 ;FIRST POINT
FETCH(TT,T,BPPN)
MOVE TTT,L2 ;SECOND POINT
FETCH(A,TTT,BPPN)
MD,< TRNE TFLG ;JUST CHANGING NUMBERS?
JRST PNCHNG
>;MD
STORE(A,T,BPPN)
STORE(TT,TTT,BPPN) ;PIN #'S STAY WITH ID'S IN CASE BUSSED THROUGH
FETCH(TT,T,BPLOC)
FETCH(A,TTT,BPLOC)
STORE(A,T,BPLOC)
STORE(TT,TTT,BPLOC)
MPC,< POPJ P, >
MD,< MOVE A,CURBOD
PUSHJ P,BODFIX ;FIX BODY PINS
MOVE A,L1 ;AND MOVE RESULTS
FETCH(TT,A,BPXY)
PUSHJ P,PMOVX
PUSHJ P,PMOVY
MOVE A,L2
FETCH(TT,A,BPXY)
PUSHJ P,PMOVX
PUSHJ P,PMOVY
TRO MCHG!NEEDCL
POPJ P,
PNCHNG: PUSH P,TT ;NEW NAME FOR PIN #2
PUSH P,TTT ;PIN #2
EXCH T,A ;SO THAT T = PIN#1, A = NEW PIN NAME
PUSHJ P,STPNN1 ;SPREAD PIN# OVER NEW ID (SECOND)
POP P,A
POP P,T
TRO MCHG
JRST STPNN1 ;AND FIRST ONE
>;MD
;SAVE AND RESTORE FLAG REGISTER M
PUSHM: MOVE H,M ;SAVE COPY OF LH M
HRR H,0 ;AND RH 0
MD,< TLZE M,PINIDS!PLOCS ;TURN OFF PINS
TRO MCHG
TLON M,RPINID
TRO MCHG
>;MD
MPC,< TLON M,PLOCS ;TURN ON PINS
TRO MCHG
>;MD
POPJ P,
POPME: PUSHJ P,POPM
JRST PERRET
POPM:
MD,< TRNN H,TFLG
TRZA TFLG
TRO TFLG
TLNE H,PINIDS
TLOA M,PINIDS
CAIA
TRO MCHG
TLNE H,PLOCS
TLOA M,PLOCS
CAIA
TRO MCHG
TLNN H,RPINID
TLZA M,RPINID
>;MD
MPC,< TLNN H,PLOCS
TLZA M,PLOCS
>;MPC
POPJ P,
TRO MCHG
POPJ P,
READP:
MD,< PUSHJ P,READN >
MPC,< MOVE C,[PUSHJ P,GETLCH]
MOVEM C,GTCHRX
PUSHJ P,RPNAM
JRST CPOPJ1
>;MPC
CAIE C,12
JRST SCARF
MOVE B,T
JRST CPOPJ2
SUBTTL PLACE A BODY
BODPLC: TRNE INMOV
JRST PERRET
MD,< MOVEI T,[ASCIZ/TYPE BODY NAME
/] >
PUSHJ P,BODYGT ;GET BODY NAME & POINTER
POPJ P, ;ALTMODE
POPJ P, ;NULL
JRST OOPS1 ;NX
TRZ INMOV
MOVEM A,CURBOD ;SAVE POINTER TO TYPE
SETZM CURORT ;ZERO ORIENTATION
PUSHJ P,BPYES ;PLANT BODY
MOVE T,LSTBOD
PUSHJ P,SCLOSE
MOVE A,CLOSES
JRST BMOVEP ;START MOVING NEW BODY
;BPYES - PLANT BODY
;CURBOD = TYPE
;HSHFLG = 1 IF IN HASH BUCKET, ELSE JUST ON LIST
BPYESF: AOSA HSHFLG
BPYES: SETZM HSHFLG
MOVE A,CURBOD ;GET POINTER TO TYPE
MOVEI T,BODM
PUSHJ P,CHNGMD ;GO BACK TO BODY MODE
TRO MCHG
PUSHJ P,MAKBDY ;GET BODY BLOCK IN B
MOVEM B,LSTBOD ;SAVE POINTER
AOS F,BID ;GET A UNIQUE BODY ID
SKIPE HSHFLG
JRST BPYES1
MOVEI D,DBODPN
HRLM D,LSTBOD ;FOR CONSISTANCY SAKE
MOVE D,DBODPN ;GET BODY LIST POINTER
STORE (D,B,BNXT) ;PUT NEW ONE IN THE LIST
MOVEM B,DBODPN ;...
BPYES1: MOVE T,CURSE ;GET CURSOR POSITION
TDZ T,[1,,1] ;FOO ON INPUT!
STORE (T,B,BXY) ;STORE AS CENTER OF BODY
STORE (F,B,BID)
STORE (A,B,BTYP) ;DEPOSIT POINTER TO TYPE DEFINITION
MOVE F,CURORT ;GET ORIENTAION
MD,< ANDI F,7 >
MPC,< ANDI F,3 >
STORE (F,B,BORI) ;STORE ORIENTATION
;Now create all the POINTS on the BODY
MD,<
FETCH (A,A,TPIN) ;GET PIN/LOC LIST FROM TYPE
JUMPE A,CPOPJ
MOVEI C,RADDR(B,BLNK,BPLNK) ;LINK IN HERE
HRLI B,ISPIN
BLOPP1: FETCH(T,A,TPXY) ;POINT X,Y IN DEF
PUSHJ P,ORIENT
ADJUST(ADD,T,CURSE) ;TO BODY CENTER
PUSH P,T
PUSHJ P,PUTPNT ;CREATE THE POINT
POP P,T
STORE(T,D,BPXY) ;SET X,Y
STORE(D,C,BPLNK) ;ADD TO BODY POINT LIST
MOVE C,D
FETCH(A,A,TPNX) ;GET TO NEXT PIN
JUMPN A,BLOPP1 ;LOOP IF SOME LEFT
POPJ P,
>;MD
MPC,<
FETCH (A,A,TPIN) ;GET POINTER TO PINS
MOVEI C,RADDR(B,BLNK,BPLNK)
PUSH P,A
PUSHJ P,BLOPP2
SWITCH
POP P,A
PUSHJ P,BLOPP2
SWITCH
MOVEI T,ANGLPG
JRST HYDPOG
BLOPP2: JUMPE A,CPOPJ ;NONE?
HRLI B,ISPIN ;ISPIN,,BODY
BLOPP1: FETCH(T,A,TPXY)
PUSHJ P,ORIENT
ADJUST(ADD,T,CURSE) ;TO BODY CENTER
PUSH P,T
PUSHJ P,PUTPNT ;CREATE THE POINT (TYPIN IN A)
POP P,T
STORE(T,D,BPXY) ;SET X,Y
FETCH(TT,A,TPID) ;PIN # FROM DEF
MOVEI T,1 ;INITIALLY USE NORMAL PAD FOR PIN
CAIN TT,1 ;PIN 1?
MOVEI T,3 ;MAKE IT END UP PAD TYPE 3 (SQUARE)
STORE(T,D,BPPN)
STORE(D,C,BPLNK) ;LINK ONTO END OF BODY'S POINTS
MOVE C,D
FETCH(A,A,TPNX)
JUMPN A,BLOPP1 ;LOOP IF SOME LEFT
POPJ P,
>;MPC
SUBTTL MAKE BODY
;CONSTRUCT A BODY BLOCK, RETURN POINTER IN B
MAKBDY: PUSH P,A
GETBLK (B,BODY)
BCLEAR (A,B,BODY) ;JUST TO MAKE SURE
MOVEI A,V.BORI(B) ;SETUP DUMMY POINTERS
STORE (A,B,BOD1)
MOVEI A,V.BID(B)
STORE (A,B,BOD2)
MD,< MOVEI A,V.BBRS(B)
STORE(A,B,BOD3)
>;MD
JRST POPAJ
SUBTTL BODY AND DIP NAME STUFF SUBRS
MD,<
STODIP: PUSHJ P,GETCLS
JRST PERRET
FETCH(A,A,BTYP)
STTDIP: PUSHJ P,FNDIPT
TDZA T,T
FETCH(T,T,TXVAL)
JRST STODEF
STONAM: PUSHJ P,GETCLS
JRST PERRET
FETCH(A,A,BTYP)
STTNAM: FETCH(T,A,TNAM)
STODEF: PUSHJ P,SETTT
JUMPE T,ITSTUF
JRST STOTX0
>;MD
MPC,<
STODIP: PUSHJ P,GETCLS
JRST PERRET
FETCH(T,A,BNAM) ;DIP TYPE POINTER
STODEF: PUSHJ P,SETTT
JUMPE T,ITSTUF
JRST STOTX0
STONAM: PUSHJ P,GETCLS
JRST PERRET
FETCH(D,A,BTYP)
PUSHJ P,SETTT
PUSHJ P,STFNAM
JRST ITSTUF
STFNAM: FETCH(B,D,TNAM) ;# OF PADS
PUSHJ P,PUTTTN
FETCH(T,D,TNAM)
CAIE T,2 ;2 PIN DIP?
POPJ P,
PUTBYT 12 ;YES, GIVE SEPARATION
FETCH(T,D,TPIN)
FETCH(B,T,TPY) ;Y OF PIN1
FETCH(T,T,TPNX)
FETCH(C,T,TPY) ;Y OF PIN2
SUB B,C
MOVMS B
IMULI B,5 ;5 MILS PER POINT
ASH B,-1
JRST PUTTTN
>;MPC
SUBTTL COPY PINIDS TO PIN #'S -- TRANSPOSE -- BROT -- BODFIX
MD,<
BPINS: PUSHJ P,GETCLS
JRST PERRET
BPINS0: FETCH(A,A,BLNK) ;DEFAULT ALL PINS ON BODY
JUMPE A,CPOPJ
TLNE M,PLOCS
TRO MCHG
BPINS1: FETCH(B,A,BPLOC) ;PIN IN TYPE DEF
FETCH(T,B,TPNAM) ;DEFAULT PIN NAME
STORE(T,A,BPPN)
FETCH(A,A,BPLNK)
JUMPN A,BPINS1
POPJ P,
;SET ALL DIP PIN NUMBERS (SETPINS)
BPINSA: SKIPN C,DBODPN
JRST PERRET
BPNSA1: MOVE A,C
PUSHJ P,BPINS0
FETCH(C,C,BNXT)
JUMPN C,BPNSA1
POPJ P,
;CLEAR ALL DIP PIN NUMBERS (-SETPINS)
PINZ: SKIPN A,PONPNT
POPJ P,
TRO MCHG
PINZ1: FETCH(T,A,BPBIT)
TRNE T,ISPIN
CLEAR(A,BPPN)
FETCH(A,A,BPNXT)
JUMPN A,PINZ1
POPJ P,
NIL,<
;TRANSPOSE PIN NUMBERS FROM 14 PIN DIP TO 16 PIN SOCKET
;FOR "L" 12,1415 FOR "R" 11,1416
TRANSPOSE:
PUSHJ P,GETCLS
JRST PERRET
PUSHJ P,GETLR
JRST PERRET
GOTPOF: HLRZ B,(A)
HLRZ B,1(B)
MOVE T,1(B)
TLZ T,L1416!R1416
TDO T,C
MOVEM T,1(B)
TRO MCHG
POPJ P,
GETLR: TLNN M,DSKACT!MACACT
OUTSTR[ASCIZ/L, R, OR <CR>?/]
PUSHJ P,GETCHR
TLNN M,DSKACT!MACACT
OUTSTR[ASCIZ/
/]
CAIE C,"L"
JRST CKR
MOVSI C,L1416
JRST CPOPJ1
CKR: CAIE C,"R"
JRST CHKCR
MOVSI C,R1416
JRST CPOPJ1
CHKCR: CAIE C,12
POPJ P,
SETZ C, ;LET HIM CLEAR BITS
JRST CPOPJ1
>;NIL
;TRANSPOSE ALL BODIES OF A CERTAIN NAME
NIL,<
TRANALL:
MOVEI T,[ASCIZ/NAME OF BODY TO TRANSPOSE?/]
PUSHJ P,BODYGT
POPJ P, ;ALTMODE
POPJ P, ;NULL
JRST OOPS1
PUSHJ P,GETLR
JRST PERRET
MOVEM A,DY1 ;STUFF AWAY HERE FOR NOW
SKIPN A,DBODPN
POPJ P, ;NOTHING TO DO
TRANA1: HLRZ T,(A)
HRRZ T,1(T)
CAMN T,DY1 ;SAME BODY?
PUSHJ P,GOTPOF ;YES
HRRZ A,(A)
JUMPN A,TRANA1
POPJ P,
>;NIL
>;MD
BROT: TRNE INMOV
JRST [ MOVE A,CLOSES
JRST BROTA]
PUSHJ P,GETCLS
JRST PERRET
BROTA: FETCH(T,A,BORI)
ADDI T,1
MD,< ANDI T,7 >
MPC,< ANDI T,3 >
STORE(T,A,BORI)
TRO MCHG
MD,< FETCH(B,A,BLOC) ;ANY LOC SET ?
JUMPE B,BROTB
MOVE F,BLCROT(T) ;GET PROPER ROTATION NUMBER FROM TABLE
FETCH(T,A,BLXY)
PUSHJ P,ORIENT
STORE(T,A,BLXY)
BROTB:
>;MD
PUSHJ P,BODFIX
MD,< JRST STRAIGHTEN ;GO FIX THE WORLD NOW>
MPC,< POPJ P,>
MD,<
BLCROT: 7 ;7 - 0
1 ;0 - 1
1 ;1 - 2
1 ;2 - 3
7 ;3 - 4
1 ;4 - 5
1 ;5 - 6
1 ;6 - 7
>;MD
;CALL WITH POINTER TO BODY IN A
BODFIX: FETCH(B,A,BLNK)
JUMPE B,CPOPJ
FETCH(D,A,BXY)
FETCH(F,A,BORI)
BODFX2: FETCH(T,B,BPLOC)
FETCH(T,T,TPXY)
PUSHJ P,ORIENT
ADJUST(ADD,T,D)
MPC,< STORE(T,B,BPXY) >
MD,< PUSH P,A
PUSH P,F
MOVE A,B ;POINTER TO POINT MUST BE IN A
PUSHJ P,PMOVRL
POP P,F
POP P,A
>;MD
BODFX1: FETCH(B,B,BPLNK)
JUMPN B,BODFX2
POPJ P,
;GET PIN #'S FROM DIP DEF FILE
MD,<
SETSEC: PUSHJ P,GETCLS
JRST PERRET
PUSHJ P,GETDEF ;GET DEFINITION FROM DIPS.DIP
POPJ P, ;LOSE
SECAGN: TLNE M,DSKACT!MACACT
JRST SETSCP
OUTSTR[ASCIZ/SECTION # (0-/]
FETCH(T,H,DDMAX) ;GET # OF SECTIONS
PUSHJ P,DECOUT
OUTSTR[ASCIZ/)?/]
SETSCP: PUSHJ P,READN
CAIN C,ALTMOD
POPJ P, ;LET HIM OUT ON ALTMODE
CAIE C,12
JRST [ PUSHJ P,INNERR
JRST SECAGN]
;Enter here with sec# in T after having called GETDEF
;FALLS THRU
SETSCN: FETCH(TT,H,DDMAX)
CAMLE T,TT
JRST [ OUTSTR[ASCIZ/SECTION # TOO LARGE!
/]
JRST SECAGN]
MOVE B,T ;SAVE SEC #
MOVE T,[OUTCHR TTT]
MOVEM T,PUTCHR ;WHERE TO OUTPUT PIN NAME
MOVE D,TYPE ;BODY
MOVEI D,RADDR(D,BLNK,BPLNK)
JRST SETSC4
SETSC7: FETCH(A,D,BPLOC)
FETCH(A,A,TPNAM)
MOVEI TTT,RADDR(H,DDNXT,DPNXT) ;PREPARE TO SEARCH DEF LIST
STSC10: FETCH(TTT,TTT,DPNXT) ;DEFINITION MAKER MADE SURE THERE WERE ENOUGH PINS
JUMPE TTT,[STORE(A,D,BPPN) ;USE DEFAULT PIN NAME
TRO MCHG
TLNE M,DSKACT!MACACT
JRST SETSC4
OUTSTR[ASCIZ/DEFAULT PIN /]
PUSHJ P,BPINPN ;PRINT AS BODY PIN
OUTSTR[ASCIZ/ DOES NOT EXIST ON THIS DIP.
WILL USE DEFAULT PIN NAME.
/]
JRST SETSC4]
FETCH(T,TTT,DPNM)
CAME T,A ;CORRECT PIN NAME?
JRST STSC10 ;NO, KEEP LOOKING
FETCH(T,TTT,DPPIN) ;SECTION PIN NAME
JUMPE T,[STORE(A,D,BPPN) ;USE DEFAULT PIN NAME
TRO MCHG
TLNE M,DSKACT!MACACT
JRST SETSC4
OUTSTR[ASCIZ/DEFAULT PIN /]
PUSHJ P,BPINPN ;PRINT AS BODY PIN
OUTSTR[ASCIZ/, NO SECTION INFO, USING AS PIN #.
/]
JRST SETSC4]
FETCH(E,H,DDNXT) ;NOW FIND SAME PIN SECT # WITH CORRECT SECT BITS
SETSC5: FETCH(TTT,E,DPPIN) ;GET SECT PIN #
CAME T,TTT ;SAME AS OURS?
JRST SETSC6 ;NO
MOVN TTT,B ;GET NEG OF DESIRED SECTION
MOVEI TT,400000 ;GET BIT FOR SECTION 0
LSH TT,(TTT) ;POSITION TO CORRECT SECTION
FETCH(TTT,E,DPSEC) ;IN THIS SECTION?
TDNE TT,TTT ;TEST FOR THAT SECTION ON THIS PIN
JRST [ FETCH(TT,E,DPNM) ;YES, GET PIN NAME
STORE(TT,D,BPPN) ;AND STORE FOR THIS PIN
TRO MCHG ;THIS CHANGES THINGS
JRST SETSC4] ;TRY ANOTHER PIN
SETSC6: FETCH(E,E,DPNXT)
JUMPN E,SETSC5
OUTSTR[ASCIZ/DEFAULT PIN /]
PUSHJ P,BPINPN ;PRINT AS BODY PIN
OUTSTR[ASCIZ/, NOT IN THIS SECTION.
/]
SETSC4: FETCH(D,D,BPLNK)
JUMPN D,SETSC7
POPJ P,
;GETDEF - GET BODY DEF FROM DIPS.DIP FILE
SKPBDY: PUSHJ P,SKPBD2 ;SKIP PROPERTIES
SKPBD1: PUSHJ P,WORDIN ;SKIP PIN NAME
PUSHJ P,SKPSOM ;SKIP REG STUFF
PUSHJ P,WORDIN ;SKIP SECTS,,SECT PIN #
SOJG D,SKPBD1 ;SKIP THEM ALL
JRST SETSC1
SKPBD2: PUSHJ P,SKPSTR ;SKIP PACKAGE NAME
JFCL
SKPBD3: PUSHJ P,SKPSTR ;SKIP ALL PROPERTY NAMES
CAIA
JRST SKPBD3
; NOW SKIP RECURSIVELY NESTED <PROP-VAL,SUB-PROP-VAL,...>
MOVEI A,1 ;DEPTH
SKPTRE: PUSHJ P,SKPSTR
JRST [ SOJG A,SKPTRE
POPJ P,]
PUSHJ P,WORDIN ;SKIP VALUE BITS
AOJA A,SKPTRE
SKPSOM: PUSHJ P,WORDIN ;BITS,,PS#
PUSHJ P,WORDIN ;HI,,LOW LOADING
JRST WORDIN ;USE
;GETDEF - GET DIPDEF LIST FROM DIPS.DIP FILE
;A = BODY POINTER
;SETS UP DIP DEF TABLE, SKIP RETURNS IF ALL OK
;H = DIPDEF LIST PTR
GETDEF: HRRZM A,TYPE ;STORE BODY POINTER HERE
GETDF1: FETCH(H,A,BDEF) ;ALREADY IN?
JUMPN H,CPOPJ1
FETCH(H,A,BTYP) ;MAYBE ON TYPE
FETCH(H,H,TDEF)
JUMPN H,CPOPJ1
PUSHJ P,FNDDIP
JRST [OUTSTR [ASCIZ /NO DIPTYPE ON BODY!!
/]
POPJ P,]
GETBLK(H,GETDIP) ;PUT THIS BODY ON INPUT LIST
CLEAR(H,GNXT)
STORE(A,H,GBDY)
CLEAR(H,GFLAG) ;MARK AS BODY
JUMPGE T,GETDF2 ;DIPTYPE WAS ON BODY
FETCH(A,A,BTYP) ;FOUND DIPTYPE ON TYPE?
STORE(A,H,GBDY)
STOREL(T,H,GFLAG) ;THIS STUFF IS FOR TYPE
GETDF2: FETCH(T,T,TXVAL) ;VALUE OF "DIPTYPE"
STORE(T,H,GDIP)
MOVEM H,GETLST
PUSHJ P,DIPIN ;READ DIPDEF AND PACKAGE PROPS
JFCL
MOVE A,TYPE
FETCH(H,A,BDEF) ;ALREADY IN?
JUMPN H,CPOPJ1
FETCH(H,A,BTYP) ;MAYBE ON TYPE
FETCH(H,H,TDEF)
JUMPN H,CPOPJ1
POPJ P,
;INDIP - READIN PACKAGE AND DIPDEF STUFF FOR ALL TYPES
INDIP: SETZ H, ;LIST OF TYPES TO READIN
SKIPN G,BODPNT ;BODIES
POPJ P,
INDIP1: FETCH(T,G,TYP1) ;USED?
JUMPE T,INDIP9
MOVE A,G
PUSHJ P,FNDIPT ;ANY DIPTYPE?
JRST INDIP9
FETCH(T,T,TXVAL) ;THE DIPTYPE
FETCH(TT,T,TSASC)
CAMN TT,[ASCII /*/] ;FLUSH COMMENT DIPS
JRST INDIP9
GETBLK(A,GETDIP)
STORE(G,A,GBDY)
STORE(T,A,GDIP)
MOVEI T,400000
STORE(T,A,GFLAG) ;FLAG AS FROM TYPE
STORE(H,A,GNXT)
MOVE H,A
INDIP9: FETCH(G,G,TNXT)
JUMPN G,INDIP1
MOVEM H,GETLST
PUSHJ P,DIPIN
JFCL
POPJ P,
;DIPIN - READ DIPDEF AND PACKAGE STUFF FOR THIS LIST OF BODIES
;GETLST - LIST OF BODIES/TYPES TO GET FOR
;SKIPS IF GOT ALL THE BODIES
; (RECLAIMS GETLST AS IT GOES)
; PUTS DIPDEF LIST, PACKAGE CODE ON BODY IF IT HAD DIPTYPE,
; ELSE PUTS STUFF ON TYPE, COMPLAINS ABOUT UPDATING PACKAGE CODE
; ON LIBRARY TYPE.
DIPIN: PUSHJ P,PUSHIT
PUSHJ P,DIPRED
JFCL
DIPIN3: SKIPN G,GETLST
JRST [ PUSHJ P,POPIT
JRST CPOPJ1]
OUTSTR [ASCIZ /NOT ALL DIPS FOUND! /]
DIPIN4: FETCH(T,G,GDIP)
PUSHJ P,OUTTXT
OUTSTR [ASCIZ /, /]
FETCH(G,G,GNXT)
JUMPN G,DIPIN4
OUTSTR [ASCIZ /
/]
MOVE B,GETLST
PUSHJ P,PUTFS
PUSHJ P,POPIT
POPJ P,
;DIPMAP - SET THE NAME OF THE DIPS.DIP FILE TO USE
STORAGE(IMPURE)
DIPFNM: 0
DIPEXT: 0
DIPPPN: 0
STORAGE(PURE)
CLRDPF: SETZM DIPFNM
POPJ P,
SETDIP: TLNN M,DSKACT!MACACT
OUTSTR[ASCIZ/New DIPs /]
MOVSI T,EXTDIP
PUSHJ P,SETNAM
POPJ P,
ENTPPN
MOVE B,FILNAM
MOVEM B,DIPFNM
HLLZ C,FILEXT
MOVEM C,DIPEXT
MOVE D,FILPPN
MOVEM D,DIPPPN
POPJ P,
;DIPRED - READ A DIP DEF LIST FROM DIPS.DIP FILE
;GETLST = LIST OF BODIES/TYPES (AND THEIR DIPTYPES) TO SEARCH FOR
;SKIPS IF DIPS.DIP FILE FOUND OK
; (REMOVES ENTRIES ON GETLST AS IT FINDS THEM)
; (CHECKS FOR UPDATING PACKAGE CODE ON LIBRARY TYPES)
DIPRED: MOVEM P,PERRSAV ;RETURN UP FROM HERE
INIT DAT,10
'DSK '
IOHD
JRST [ OUTSTR [ASCIZ/CAN'T GET DISK!
/]
JRST SECLEV]
MOVEI T,IOBUF ;USE COMPILED IN BUFFER
EXCH T,.JBFF
INBUF DAT,2
MOVEM T,.JBFF
SKIPN T,DIPFNM ;ANY MAPPING SET?
MOVE T,['NDIPS '] ;NO, USE DEFAULT
MOVEM T,FILNAM
MOVSI T,EXTDIP
SKIPE DIPFNM
HLLZ T,DIPEXT
MOVEM T,FILEXT
SETZB T,FILDAT
NODEC,<
NOSTAN,<
DSKPPN T, ;TRY HIS PPN FIRST
TLOA A,400000
>;NOSTAN
>;NODEC
SKIPE DIPFNM
MOVE T,DIPPPN
DIPRD2: MOVE T,LIBPPN
MOVEM T,FILPPN
DIPRD: TLNE M,DSKACT!MACACT
JRST DIPRD1
OUTSTR [ASCIZ/READING /]
PUSH P,A
HRRI A,FILNAM
JSR FPRINT
POP P,A
OUTSTR[ASCIZ/
/]
DIPRD1: MOVE T,FILPPN
LOOKUP DAT,FILNAM
JRST [ PUSHJ P,LOOKER
NODEC,< TLZE A,400000 ;WAS THIS LIBRARY?
JRST DIPRD2 ;NO, TRY LIBRARY
>;NODEC
OUTSTR[ASCIZ/TRY ANOTHER DIPS.DIP FILE /]
MOVSI T,EXTDIP
PUSHJ P,SETNAM
JRST SECLEV
SETZ A,
JRST DIPRD]
DEC,< JSR DAT,LOOKCK >
MOVEM T,FILPPN
PUSHJ P,WORDIN
MOVN TTT,TTT
CAIE TTT,DIPVER ;CORRECT VERSION?
JRST [ OUTSTR[ASCIZ/WRONG VERSION DIP DEFINITION FILE.
/]
JRST SECLEV]
;Scan thru file, inputing dips on GETLST
SETSC1: SKIPN G,GETLST ;STUFF TO GET FOR
JRST SECWIN
PUSHJ P,WORDIN
JUMPE TTT,SECWIN ;DONE!
MOVE D,TTT ;SAVE # OF PINS HERE
PUSHJ P,RSTR ;NEXT DIP NAME
JFCL
MOVEM T,TYPNAM
SETSE2: MOVE A,TYPNAM
FETCH(B,G,GDIP)
JUMPE B,SETSE1 ;DIDN'T HAVE DIPTYPE
PUSHJ P,TXTMAT
CAIA
JRST SETSC0 ;THIS IS THE DIP WE'RE GETTING FOR
SETSE1: FETCH(G,G,GNXT)
JUMPN G,SETSE2
MOVE B,TYPNAM ;THIS ISN'T ONE WE'RE LOOKING FOR
PUSHJ P,PUTFS ;RETURN DIP TYPE
JRST SKPBDY ; SKIP THIS ONE
SETSC0: GETBLK(H,DDEF)
STORE(D,H,DDNPN) ;SAVE # PINS DEFINED
CLEAR(H,DDMAX) ;MAX SEC #
PUSHJ P,RSTR ;GET PACKAGE NAME
JFCL
MOVEM T,PKGTEM
MOVEI E,RADDR(H,DDNXT,DPNXT)
PUSHJ P,SKPBD3 ;SKIP PROP STUFF
SETSC2: PUSHJ P,WORDIN ;PIN NAME
PUSH P,TTT
PUSHJ P,SKPSOM ;SKIP BORING STUFF
PUSHJ P,WORDIN ;SECT BITS,,SECT PIN #
GETBLK(T,DIPDEF)
STORE(T,E,DPNXT)
CLEAR(T,DPNXT)
MOVE E,T
POP P,T
STORE(T,E,DPNM)
STORE(TTT,E,DPPIN)
HLRZ T,TTT
STORE(T,E,DPSEC)
HLLZS TT,TTT
SUBI TT,1
XOR TT,TTT
JFFO TT,SETSC8 ;THIS FINDS RIGHTMOST BIT FROM TTT
JRST SETSC3 ;NO BITS
SETSC8: FETCH(T,H,DDMAX)
CAMLE TTT,T
STORE(TTT,H,DDMAX) ;STORE MAX SO FAR!
SETSC3: SOJG D,SETSC2
MOVEM H,DEFLST
SETZM PKGCOD
SKIPN T,PKGTEM ;ANY PACKAGE PROP?
JRST SECPT1
PUSHJ P,MATPAK ;LOOKUP PACKAGE TYPE
JRST [ OUTSTR [ASCIZ /PACKAGE TYPE I DON'T KNOW ABOUT!! /]
MOVE T,PKGTEM
PUSHJ P,OUTTCR
JRST SECPT1]
MOVEM A,PKGCOD
SECPT1: MOVEI G,GETLST-V.GNXT
SECPT0: MOVE H,G ;SAVE BACK POINTER
FETCH(G,G,GNXT)
JUMPE G,SECPT9
FETCH(A,G,GDIP) ;UPDATE ALL TYPES/BODIES WITH THIS DIPTYPE
MOVE B,TYPNAM
PUSHJ P,TXTMAT
JRST SECPT0
;store DIPDEF list on TYPE/BODY, check package code
FETCH(A,G,GFBDY) ;FLAG AND BODY/TYPE POINTER
MOVE B,DEFLST ;SETUP DIP DEF LIST IN ALL
MOVE C,PKGCOD
JUMPL A,SECPTT ;STUFF GOES ON TYPE
PUSHJ P,COPDEF ;MAKE COPY OF DIPDEF LIST
STORE(B,A,BDEF)
FETCH(T,A,BPAK)
CAMN C,T ;CHANGE PACKAGE?
JRST SECPT2 ;THIS GETLST ENTRY SATISFIED, DELETE
STORE(C,A,BPAK)
MOVEI T,CPAKAG
PUSHJ P,RECMPB ;YES, BUT MIGHT BE SUPERCEEDED BY EXPLICIT PROP
TRO MCHG
JRST SECPT2 ;THIS GETLST ENTRY SATISFIED, DELETE
SECPTT: PUSHJ P,COPDEF
STORE(B,A,TDEF)
FETCH(T,A,TPAK)
CAMN C,T ;CHANGE PACKAGE?
JRST SECPT2
FETCH(TT,A,TLIB) ;LIBRARY BODY?
SKIPN MODLIB
JUMPN TT,[OUTSTR [ASCIZ /PACKAGE WRONG ON LIBRARY BODY! /]
FETCH(T,A,TNAM)
PUSHJ P,OUTTCR
JRST SECPT2]
STORE(C,A,TPAK)
MOVEI T,CPAKAG
PUSHJ P,RECMPT ;BUT MIGHT HAVE EXPLICIT PACKAGE
TRO MCHG
FETCH(T,A,TPAK)
CAMN T,C
JRST SECPT2
OUTSTR [ASCIZ /TYPE HAS DIFFERENT PACKAGE THAN DIPS.DIP! /]
FETCH(T,A,TNAM)
PUSHJ P,OUTTXT
SECPT2: FETCH(T,G,GNXT)
STORE(T,H,GNXT)
RETBLK(G,GETDIP)
MOVE G,H ;BACKUP
JRST SECPT0
SECPT9: MOVE B,TYPNAM
PUSHJ P,PUTFS
MOVE B,PKGTEM
PUSHJ P,PUTFS
MOVE B,DEFLST
PUSHJ P,PUTFS
JRST SETSC1 ;GET SOME MORE DIPS
SECWIN: RELEASE DAT, ;RELEASE DEF FILE
JRST CPOPJ1 ;GIVE WIN RETURN
SECLEV: RELEASE DAT,
POPJ P,
;DDFREL - RECLAIM DIP DEF LIST
;C = DIP DEF LIST
DDFREL: JUMPE C,CPOPJ
FETCH(T,C,DDNXT)
RETBLK(C,DDEF)
DDFRL1: JUMPE T,CPOPJ
MOVE C,T
FETCH(T,T,DPNXT)
RETBLK(C,DIPDEF)
JRST DDFRL1
;COPDEF - COPY DIPDEF LIST
;B = LIST
COPDEF: JUMPE B,CPOPJ
PUSH P,C
PUSH P,D
GETBLK(C,DDEF)
FETCH(T,B,DDNPN)
STORE(T,C,DDNPN)
FETCH(T,B,DDMAX)
STORE(T,C,DDMAX)
MOVEI D,RADDR(C,DDNXT,DPNXT)
COPDF1: FETCH(B,B,DPNXT)
JUMPE B,COPDF2
MOVE T,D
GETBLK(D,DIPDEF)
STORE(D,T,DPNXT)
FOR I IN (DPNM,DPSEC,DPPIN)
< FETCH(T,B,I)
STORE(T,D,I)
>
JRST COPDF1
COPDF2: CLEAR(D,DPNXT)
MOVE B,C
POP P,D
POP P,C
POPJ P,
>;MD
SUBTTL SET BODY LOCATION
BNUMS: PUSHJ P,GETCLS
JRST PERRET
MOVEM A,CURBOD
MOVE T,[PUSHJ P,GETLCH]
MOVEM T,GTCHRX
TLNE M,DSKACT!MACACT
JRST BNUMS1
OUTSTR [ASCIZ / Body location as "/]
OUTSTR @BODCUE
OUTSTR [ASCIZ /"? /]
BNUMS1: PUSHJ P,GTSLTL
JRST INNERR
JRST [ CAIE C,12
JRST INNERR
MPC,< MOVE A,CURBOD
CLEAR(A,BLN) ;CLEAR LOCN
TRO MCHG
POPJ P, ]
>;MPC
MD,< MOVE A,CURBOD
FETCH(B,A,BLOC)
JUMPE B,CPOPJ
CLEAR(A,BLOC)
FETCH (T,A,BBIT)
TRO T,FIXLOC!FIXBLO
STORE (T,A,BBIT)
TLNE M,BLOCS
TRO MCHG
TRNE TMOVE!LMOVE ;IF WE WERE MOVING OFFSET,
TRZN INMOV ;THEN STOP AND FIND CLOSEST AGAIN
POPJ P,
TRO NEEDCL
POPJ P, ]
MD,< JFCL > ;WE DON'T CARE IF THERE WAS A BRS OR NOT
SETO T, ;ASSUME NO SEC STUFF
CAIE C,"-" ;SETTING SECTION #?
JRST SECNUM
PUSHJ P,GETLIN ;YES, GET IT
CAIL C,"A"
CAILE C,"Z"
JRST [ CAIL C,"0" ;ACCEPT NUMERIC SECTIONS TOO!
CAILE C,"9"
JRST INNERR
PUSHJ P,CREADN
JRST SECNUM ]
MOVEI T,-"A"(C)
PUSHJ P,GETLIN
SECNUM: MOVEM T,NUMBER ;SAVE SECTION # HERE
>;MD
CAIE C,12 ;NOW IT MUST BE A LF
JRST INNERR
MD,< MOVE TT,LETTER
TLNE TT,-1
SKIPN T,CRDLOC
JRST NOGLOB
XOR T,TT
TLNE T,-1
JRST [ OUTSTR[ASCIZ/SORRY, CAN'T CHANGE CARD LOC WHILE GLOBAL CARD LOC IS IN FORCE!
/]
JRST CHKSCN] ;GO CHECK SECTION ANYWAY
HRRZS LETTER
NOGLOB:
>;MD
;FALLS THRU - PC
MPC,< MOVE T,LETTER
STORE(T,A,BLN) ;STORE IT
>;MPC
MD,< FETCH(B,A,BLOC)
JUMPN B,GTNMBK ;DO WE HAVE A BLOCK ALREADY?
MOVEI B,-1+ADDR(A,BLXY) ;NO
STORE(B,A,BLOC) ;MARK AS LOCN SET
CLEAR(A,BLO) ;CLEAR CHARACTER OFFSET
FETCH(TT,A,BBIT)
TRO TT,FIXBLO ;DEFAULT IS RECENTER LOCATION TEXT
STORE(TT,A,BBIT)
PUSHJ P,STLCOF ;SET LOCATION OFFSET FROM TYPE DEF
GTNMBK: HLRZ T,LETTER
STORE(T,A,BBRS) ;SET BAY-RACK-SLOT
HRRZ T,LETTER
STORE(T,A,BSOC) ;SET SOCKET
MOVE T,CURBOD ;SETUP T FOR OFFBLO
PUSHJ P,OFFBLO ;CHECK FOR RECALC CHAR OFFSET
>;MD
TLNE M,BLOCS
TRO MCHG
MPC,< POPJ P, >
MD,<
CHKSCN: SKIPGE NUMBER ;ANY SECTION #?
POPJ P,
MOVE A,CURBOD
PUSHJ P,GETDEF
POPJ P, ;LOSE
MOVE T,NUMBER
JRST SETSCN ;TRY TO SET SECTION!
;OFFSET BODY LOCNS
OFFLOC: SKIPN H,DBODPN
POPJ P,
OFFLC1: HRRZ A,H
FETCH(B,A,BLOC) ;ANY LOC SET??
JUMPE B,OFFLC2 ;ANY?
PUSHJ P,STLCOF ;YES, SET TO FOLLOW DEFINITION
SETBIT(FIXBLO,TT,H,BBIT) ;CAUSE LOC TEXT TO BE AUTO CENTERED
MOVE T,H
PUSHJ P,OFFBLO ;OFFSET TEXT MAYBE
OFFLC2: HRRZ H,(H)
JUMPN H,OFFLC1
TLNE M,BLOCS
TRO MCHG
POPJ P,
;RESET LOCATION OFFSET OF CLOSEST BODY TO DEFAULT
BLCOFF: PUSHJ P,GETCLS
JRST PERRET
MOVEM A,CURBOD ;SAVE BODY HERE FOR OFFBLO
FETCH(B,A,BLOC) ;ANY LOCN SET?
JUMPE B,CPOPJ ;LEAVE IF NONE
TLNE M,BLOCS
TRO MCHG
PUSHJ P,STLCOF ;SET OFFSET
HRRZ T,CURBOD
SETBIT(FIXBLO,TT,T,BBIT) ;AND DEFAULT IS AUTO CENTER
JRST OFFBLO
;STLCOF - SET LOCN TEXT POSITION FROM TYPE DEFINITION
; A = BODY PTR
STLCOF: PUSH P,T
PUSH P,TT
FETCH(TT,A,BTYP) ;TYPE
FETCH(T,TT,TXY) ;DEFAULT LOCN TEXT X,Y
FETCH(F,A,BORI) ;ORIENTATION
PUSHJ P,ORIENT ;ADJUST T FOR ROTATION IN F
STORE(T,A,BLXY) ;SET LOCN TEXT X,Y
FETCH(T,A,BBIT)
TRO T,FIXLOC ;CONTINUE FIXING OFFSET LOCN
STORE(T,A,BBIT)
POP P,TT
POP P,T
POPJ P,
>;MD
STOBLC: PUSHJ P,GETCLS
JRST PERRET
MOVE B,A
PUSHJ P,SETTT
MD,< FETCH(D,B,BLOC) ;ANY LOC SET?
JUMPE D,ITSTUF
PUSH P,A
FETCH(A,B,BRSLOC)
>;MD
MPC,< FETCH(D,B,BLN)
JUMPE D,ITSTUF
PUSH P,A
MOVE A,D
>;MPC
PUSHJ P,SLTLPN
POP P,A
JRST ITSTUF
;BODY LOCATION OFFSET (D)
MD,<
;RESET LOCATION OFFSET OF CLOSEST BODY TO DEFAULT
BLOOFF: PUSHJ P,GETCLS
JRST PERRET
FETCH(B,A,BLOC) ;ANY LOC SET?
JUMPE B,CPOPJ ;LEAVE IF NONE
SETBIT(FIXBLO,TT,A,BBIT)
MOVE T,A
;FALLS THRU
;OFFBLO - CHAR OFFSET FOR BODY LOCN TEXT
;T = POINTER TO BODY
OFFBLO: FETCHL(TT,T,BBIT)
TLNN TT,FIXBLO
POPJ P, ;NOT BEING FIXED
TLNE M,BLOCS
TRO MCHG
TLNN TT,FIXLOC ;DON'T FOLLOW BODY DEF OFFSET UNLESS FOLLOWING BODY DEF LOC
JRST OFFBL1
FETCH(TT,T,BTYP)
FETCH(TTT,TT,TYP3) ;CHARACTER OFFSET IN TYPE DEF?
JUMPE TTT,OFFBL1 ; NO
FETCH(TTT,TT,TOXY)
STORE(TTT,T,BLO) ;YES, USE IT
POPJ P,
OFFBL1: SETZM CHRCNT
PUSH P,PUTCHR
PUSH P,T
MOVE TTT,[AOS CHRCNT]
MOVEM TTT,PUTCHR
FETCH(A,T,BRSLOC) ;B-R-S,,BSOC
PUSHJ P,SLTLPN
POP P,T
POP P,PUTCHR
MOVN A,CHRCNT
MOVE TTT,STDBIG
IMUL A,VIRPTX(TTT)
ASH A,-1
STORE(A,T,BLOX) ;X PART OF OFFSET
MOVN A,VIRPTY(TTT)
ASH A,-1
STORE(A,T,BLOY)
POPJ P,
>;MD
SUBTTL DELETE BODY
C2BDEL: SETOM PINLEV
PUSHJ P,GETCLS
POPJ P,
MOVE B,CLAST
TRO NEEDCL
JRST BCLR1
BODDEL: PUSHJ P,GETCLS ;ANY TO DELETE?
JRST PERRET ;NO
MOVE B,CLAST
TRO NEEDCL
BDELET: SETZM PINLEV
BCLR1: PUSH P,B ;SAVE LAST
TRZE INMOV ;TURN OFF MOVING
TRO NEEDCL
ROUTE,<MPC,<TLZ M,%ROUTE>> ;MAKE HIM ROUTE AGAIN
PUSHJ P,REMBOD ;REMOVE BODY FROM ANY SETS
TRO TFLG!MCHG ;DELETE PINS
PUSH P,A ;SAVE THIS
SKIPN PINLEV ;LEAVING PINS AS POINTS?
JRST [ MOVEI B,PONPNT ;NO, DELETING
PUSHJ P,BODDLP ;DELETE ALL PINS WHICH POINT TO THIS BODY
MPC,< MOVEI B,PONPN2
PUSHJ P,BODDLP
>;MPC
JRST BODDLE] ;NOW GIVE BACK BODY
FETCH(B,A,BLNK)
JUMPE B,BODDLE
BODDL2: FETCH(A,B,BPLNK)
PUSHJ P,PINPNT ;CHANGE BPIN INTO POINT !!!
MOVE B,A
BODDL1: JUMPN B,BODDL2
BODDLE: POP P,A ;HERE WE GIVE BACK THE BODY
FETCH(F,A,BNXT) ;GET POINTER TO NEXT BODY
POP P,B ;RESTORE LAST POINTER
STORE(F,B,BNXT) ;LINK AROUND
MD,< FETCH(C,A,BTXT)
PUSHJ P,TXTREL ;RELEASE PROPERTIES
FETCH(C,A,BDEF)
PUSHJ P,DDFREL
>;MD
RETBLK(A,BODY)
POPJ P,
BODDLQ: FETCHL(T,B,PBIT)
TLNN T,ISPIN
JRST BODDLP
FETCH(T,B,BBODY)
CAME T,-1(P) ;THIS IS WHERE BODY POINTER WAS STORED
JRST BODDLP ;TRY ANOTHER
PUSH P,A ;SAVE LAST POINTER
TRO TFLG ;ALLOW DELETE PIN
PUSHJ P,DELPNT ;DELETE (CURRENT AND LAST ALREADY SETUP)
POP P,B
BODDLP: MOVE A,B ;SAVE LAST
FETCH(B,B,PNXT)
JUMPN B,BODDLQ
POPJ P,
SUBTTL BODY RENAME
MD,<
BODREN: MOVEI T,[ASCIZ/TYPE BODY NAME.
/]
PUSHJ P,BODYGT
POPJ P, ;ALTMODE
POPJ P, ;NULL
JRST OOPS1 ;NX
SKIPE MODLIB ;ALLOW MODIFICATION?
JRST RENOK
FETCH(T,A,TLIB)
JUMPE T,RENOK
OUTSTR[ASCIZ/CAN'T RENAME LIBRARY BODY!
/]
POPJ P,
RENOK: MOVEI T,[ASCIZ/TYPE NEW BODY NAME.
/]
PUSH P,A
PUSHJ P,BODYGT
JRST RENOKB ;ALTMODE
JRST RENOKB ;NULL
JRST RENOKA ;NX
OUTSTR[ASCIZ/NAME ALREADY IN USE!!!
/]
RENOKB: POP P,(P)
POPJ P,
RENOKA: POP P,C ;BODY TO RENAME
MOVE D,B
FETCH(B,C,TNAM)
PUSHJ P,PUTFS
STORE(D,C,TNAM)
TLNE M,%IDENT ;DISPLAYING NAMES?
TRO MCHG ;YES, REFRESH
POPJ P,
>;MD
SUBTTL GET BODY
;BODYGT - FIND BODY USER ASKS FOR
;T = PROMPT STRING
;RETURNS
; Alt
; Null string
; Not found
; Body found
;A = POINTER TO TYPE (previous in LH)
;(B = NAME STRING IF BODY NOT FOUND)
MD,<
BODYGT: TLNN M,DSKACT!MACACT
OUTSTR (T)
SETZ A, ;IN CASE NO NAME
PUSHJ P,TREADU ;READ IN THE TEXT FOR THE BODY NAME
POPJ P, ;ALTMODE
JRST CPOPJ1 ;NULL STRING
AOS (P)
AOS (P) ;AT LEAST 2 SKIPS
MOVEI A,BODPNT-V.TNXT
JRST BLOP2
BLOP1: PUSH P,A
PUSH P,B ;BODY'S NAME
FETCH(A,A,TNAM) ;GET POINTER TO STRING
PUSHJ P,TXTMAT
JRST BLOP3 ;NO MATCH
POP P,B
POP P,A
PUSHJ P,PUTFS ;RETURN STRING
FETCH(T,A,TYP1) ;NON-ZERO IF BODY IN
JUMPE T,BDYGET ;GET BODY FROM LIBRARY IF NOT ALL IN
HRRZS A ;CLEAR PREVIOUS LINK
JRST CPOPJ1 ;FOUND
BLOP3: POP P,B ;YES, MATCH, RESTORE B
POP P,A ;RESTORE A, THE POINTER TO THE FOUND BODY
BLOP2: MOVE T,A
FETCH(A,A,TNXT) ;GO TO NEXT BODY
HRL A,T ;SAVE OLD IN LH FOR BDYGET
TRNE A,-1
JRST BLOP1 ;LOOP IF ANY LEFT TO COMPARE WITH
POPJ P, ;ELSE LEAVE
>;MD
MPC,<
BODYGT: TLNN M,DSKACT!MACACT
OUTSTR [ASCIZ /NO. OF PINS?
/]
SETZ A, ;THIS IS "NO" ANSWER
PUSHJ P,READN ;READ IN THE TEXT FOR THE BODY NAME
CAIN C,ALTMOD
POPJ P,
JUMPE T,[ CAIN C,12 ;JUST BLANK?
JRST CPOPJ1 ;LET HIM OUT
CAIN C,"R"
MOVEI T,=400/5
CAIN C,"C"
MOVEI T,=300/5
CAIN C,"T"
MOVEI T,3
PUSHJ P,GETLIN
CAIE C,12
JRST INNERR
JUMPE T,INNERR
CAIE T,3 ;3 PIN DIP?
JRST IS2PIN ;NO, 2 PIN AND WE HAVE SEPERATION
JRST BLOP0]
CAIE C,12
JRST INNERR
CAIN T,2 ;2 PIN DIP?
JRST ASKWID
BLOP0: MOVE A,BODPNT ;GET POINTER TO THE STRING OF BODIES
AOS (P)
AOS (P)
BLOP1: JUMPE A,CPOPJ ;DOESN'T EXIST
FETCH(TT,A,TNAM)
CAIN TT,(T)
JRST CPOPJ1 ;EXISTS
FETCH(A,A,TNXT)
JRST BLOP1
ASKWID: TLNN M,DSKACT!MACACT
OUTSTR[ASCIZ/PIN SEPERATION IN MILS (DIVISIBLE BY 10)?/]
PUSHJ P,READNC
IDIVI T,=10
JUMPE T,INNERR
JUMPN TT,INNERR
ASH T,1
IS2PIN: AOS (P)
AOS (P)
AOS (P) ;ALWAYS EXISTS
G2PIN: SKIPN A,BODPNT
JRST MAKE2D
B2LOP: FETCH(TT,A,TNAM)
CAIE TT,2
JRST B2LOP1
FETCH(TT,A,TPIN)
FETCH(TT,TT,TPY) ;HRRE?
CAIN TT,(T)
POPJ P,
B2LOP1: HRRZ A,(A)
JUMPN A,B2LOP
MAKE2D: PUSHJ P,MAKTYP
MOVE A,TT
MOVE TT,BODPNT
STORE(TT,A,TNXT)
MOVEM A,BODPNT
MOVEI TT,2 ;2 PIN DIP
STORE(TT,A,TNAM)
PUSHJ P,MAKTPN
STORE(T,TT,TPY)
STORE(TT,A,TPIN)
MOVEI TTT,1 ;PIN 1
STORE(TTT,TT,TPID)
PUSH P,B
MOVE B,TT
PUSHJ P,MAKTPN
STORE(TT,B,TPNX)
MOVEI TTT,2 ;PIN 2
STORE(TTT,TT,TPID)
MOVNS T
STORE(T,TT,TPY)
JRST POPBJ
;SET DIP TYPE
SETDIP: PUSHJ P,GETCLS
JRST PERRET
TLNN M,DSKACT!MACACT
OUTSTR[ASCIZ/TYPE DIP TYPE
/]
PUSHJ P,TREADU
POPJ P, ;ALTMODE
SETZ B, ;NULL
TLNE M,%IDENT
TRO MCHG
MOVE TT,B
FETCH(B,A,BNAM)
STORE(TT,A,BNAM)
JUMPN B,PUTFS
POPJ P,
>;MPC
OOPS1: OUTSTR[ASCIZ/NO SUCH BODY, CHARLY
/]
MD,< JRST PUTFS ;PUT NON-EX NAME BACK IN FREE STORAGE >
MPC,< POPJ P, >
SUBTTL ASSOCIATIVE BODY SET
;PUT THE BODY AND ALL LOOSE STUFF CONNECTED TO IT IN A SET
ASSET: PUSHJ P,GETCLS
JRST PERRET
TRZE INMOV
TRO NEEDCL
GETFS(T) ;MAKE A NEW SET
HRLZM A,1(T) ;STARTING WITH THIS BODY
SETZM (T)
GETFS(TT)
HRLM T,(TT)
SETZM 1(TT)
EXCH TT,SETPNT
HRRM TT,@SETPNT
MOVE H,T ;SET LIST
MOVE G,H ;END OF THIS SET LIST
MOVEM A,TRCBDY
FETCH(A,A,BLNK) ;TRACE FROM ALL OF THIS BODY'S PINS
JRST ASSET5
ASSET2: PUSHJ P,ASSTRC ;TRACE FROM THIS POINT
ASSET1: FETCH(A,A,BPLNK)
ASSET5: JUMPN A,ASSET2
MOVEI T,SETM
PUSHJ P,CHNGMD ;GO INTO SET MODE
MOVE A,SETPNT
PUSHJ P,RECNTR ;CALC CENTER
MOVE A,SETPNT
MOVE T,1(A) ;LOC OF CENTER
JRST CHKON
;TRACE FROM POINT (A) AND ADD TO SET (H,G)
;(ALL OF WIRE FAILS IF IT TERMINATES IN ANOTHER BODY)
ASSTRC: TRZ TFLG ;WIRE FAILS IF TRACED TO BODY
HRLM G,(P) ;CURRENT END OF SET LIST
PUSHJ P,ASSTR1
TRNN TFLG ;RAN INTO SOMETHING?
POPJ P,
HLRZ G,(P) ;FLUSH THOSE ADDED POINTS
HRRZ B,(G)
HLLZS (G)
JRST PUTFS
ASSTR1: JUMPE A,CPOPJ ;TRACE LINES FROM THIS POINT
HRLM A,(P)
MD,< FOR @' I IN (D,U,L,R)
< FETCH(C,A,PN'I)
PUSHJ P,ASSPUT
HLRZ A,(P)
>
>;MD
MPC,< FETCH(B,A,PNEB)
JUMPE B,CPOPJ
ASSET3: MOVEI D,2
ASSET4: XCT (D)[HLRZ C,(B)
HRRZ C,1(B)
HLRZ C,1(B)]
PUSH P,B
HRLM D,(P)
PUSHJ P,ASSPUT
HLRZ D,(P)
POP P,B
SOJGE D,ASSET4
HRRZ B,(B)
JUMPN B,ASSET3
HLRZ A,(P)
>;MPC
POPJ P,
ASSPUT: TRNE TFLG ;ALREADY FAILED?
POPJ P,
JUMPE C,CPOPJ
FETCH(T,C,BPBIT)
MPC,< TRNN T,CPIN ;CAN'T PICKUP WIRE TO CONNECTOR
JRST ASSPT4
>;MPC
TRNN T,ISPIN ;STOP HERE?
JRST ASSPT3
FETCH(T,C,BBODY)
CAME T,TRCBDY ;RAN INTO OURSELF?
ASSPT4: TRO TFLG ;THIS WIRE ISN'T LOOSE!
POPJ P,
ASSPT3: MOVE T,H ;ALREADY IN SET?
ASSPT1: HRRZ TT,1(T)
CAMN TT,C
POPJ P, ;ALREADY IN, SKIP IT
MOVE TT,T
HRRZ T,(T)
JUMPN T,ASSPT1
GETFS(T)
HRRM T,(TT)
SETZM (T)
SETZM 1(T)
MOVE G,T ;NEW END OF LIST
ASSPT2: HRRM C,1(T)
HRRZ A,C
JRST ASSTR1 ;RECURSE
Reference in New Issue View Git Blame Copy Permalink