Context Navigation

ctest.lisp @ 252

Revision 252, 36.7 KB (checked in by rjs, 22 months ago)
Initial versions.

Line
1	;;-- MODE: LISP; PACKAGE: USER; IBASE: 10.; BASE: 10. --
2
3	(DEFCONST CTEST-BOARD-TYPE 'LG684) ;OR MPG216
4
5	;Continuity Tester Interface
6
7	(DEFUN BYTE-FIELD (BITS OVER)
8	(+ BITS (LSH OVER 6)))
9
10	(defconst ctest-%%pin (byte-field 7 00)) ;pin number (all type boards)
11
12	;The below code basically copied from NEWWL;MPG216 >. The fields are the
13	; same altho the names have been changed to protect the innocent.
14
15	;SOME BYTE POINTERS FOR EXTRACTING FIELDS
16
17	(defconst mpg216-%conn (byte-field 1 25)) ;connector bit. (sign on 10).
18	(defconst mpg216-%DIPPNL (byte-field 3 22)) ;PANEL NUMBER
19	(defconst mpg216-%DIPG (byte-field 3 19)) ;DIP GROUP
20	(defconst mpg216-%DIPS (byte-field 6 13)) ;DIP SLOT
21	(defconst mpg216-%DIPOF (byte-field 6 07)) ;DIP OFFSET
22
23	(defconst mpg216-%CNPPNL (byte-field 3 22)) ;PANEL NUMBER (MUST BE SAME AS DIP)
24	(defconst mpg216-%CNPG (byte-field 3 19)) ;CONN GROUP ( " " )
25	(defconst mpg216-%CNPJK (byte-field 1 07)) ;CONNECTOR JACK BIT
26	;(defconst mpg216-%CONP (byte-field 9 00)) ;CONNECTOR PIN #
27	; (AND JACK NUMBER <PINS 1-2*26>)
28
29	(defconst mpg216-GPINS 400) ;NOMEN FOR "G" PINS ON BOARD STARTS AT 400
30	; 401 IS "G1", ETC.
31	(defconst mpg216-MXPNL 5) ;max number of panels wrappable at once
32	(defconst mpg216-NGRPS 6) ;PG216-180 HAS 6 GROUPS
33	(defconst mpg216-GRPCOL 5) ;# COLS IN GROUP
34	(defconst mpg216-GRPROW 6) ;# ROWS IN GROUP
35	(defconst mpg216-GRPDIP (* mpg216-GRPROW mpg216-GRPCOL)) ;# DIPS IN GROUP
36	(defconst mpg216-MXCNP1 40) ;MAX # CONNECTOR PINS FOR J1
37	(defconst mpg216-MXCNP2 50) ;MAX # CONNECTOR PINS FOR J2
38	(defconst mpg216-J1TO2 2) ;J1 IS OFFSET 2 PINS TO RIGHT OF J2
39
40	;JACKSZ: MXCNP1
41	; MXCNP2
42
43
44	;The 8136-PG216 consists of 180 dip slots, organized into
45	;6 groups of 30 dips each.
46	;The groups are labeled A-F, with group A to left
47	;Withhin a group, slots are numbered:
48	; 5 4 3 2 1
49	; 10 9 .... 6
50	; 15 .... 11
51	; 20 .... 16
52	; 25 .... 21
53	; 30 .... 26
54
55	;(All coordinates are from DIP side, assuming Scotchflex conns
56	; are at the top)
57
58
59	;AUGAT-X8136-PG216 CONNECTOR PIN FORMAT PRINTS AS #LJ#-#
60	;WHERE L IS THE GROUP. THE J IS LITERAL. THE FIRST DIGIT IS THE PANEL
61	;AND THE SECOND IS THE JACK. PIN IS LAST
62
63	; 15 12 9 0 LM bit numbering
64	;______\|_____\|_____\|_____\|_____\|_____\|
65	;\| 20 23 26 35 PDP-10 bit numbering
66	;\| 3 \| 3 \| \| \| 9 \|
67	;\|_____\|_____\|___\|_\|_________________\|
68	; \| \| \| \|
69	; \| \| \| \|------------>PIN
70	; \| \| \|
71	; \| \| \|-------------------JACK 01, 12
72	; \| \|
73	; \| \|--------------------------># GROUP
74	; \|
75	; \|-------------------------------># PANEL
76
77	(DEFUN CTEST-LOC (LOC)
78	(SELECTQ CTEST-BOARD-TYPE
79	(MPG216 (MPG216-PRNLOC LOC))
80	(LG684 (LG684-PRNLOC LOC))
81	(OTHERWISE (FERROR NIL ""))))
82
83	(DEFUN CTEST-GETLOC (STR &OPTIONAL BEG LIM)
84	(SELECTQ CTEST-BOARD-TYPE
85	(MPG216 (MPG216-GETLOC STR BEG LIM))
86	(LG684 (LG684-GETLOC STR BEG LIM))
87	(OTHERWISE (FERROR NIL ""))))
88
89	(DEFUN CTEST-MAPLOC (LOC)
90	(SELECTQ CTEST-BOARD-TYPE
91	(MPG216 (MPG216-MAPLOC LOC))
92	(LG684 (LG684-MAPLOC LOC))
93	(OTHERWISE (FERROR NIL ""))))
94
95
96	(defun mpg216-prnloc (loc &aux ans)
97	(let ((panel (ldb mpg216-%DIPPNL loc))
98	(group (ldb mpg216-%DIPG loc))
99	(conn (ldb mpg216-%CONN loc))
100	(pin (ldb ctest-%%pin loc)))
101	(cond ((zerop conn)
102	(let ((slot (ldb mpg216-%DIPS loc))
103	(offset (ldb mpg216-%DIPOF loc)))
104	(setq ans (format nil "~D~C~2,48D" panel (+ #/@ group) slot))
105	(cond ((not (zerop offset))
106	(setq ans (string-append ans (format nil "@~2,48D" offset)))))))
107	(t (setq ans (format nil "~D~CJ~D"
108	panel (+ #/@ group) (1+ (ldb mpg216-%CNPJK loc))))))
109	(cond ((and (zerop conn)
110	(>= pin mpg216-GPINS))
111	(SETQ ANS (format nil "~A-~1D" ANS (- pin mpg216-GPINS))))
112	(t (SETQ ANS (format nil "~A-~2,48D" ANS pin)))))
113	ANS)
114
115	;All calculations are done from the dip side.
116
117	;(0,0) at lower left hand corner in left handed coordinate system.
118	;Dip sockets are arranged in 5x6 groups. These 30 dip groups come
119	;in pairs. Each group comes with a pair of Scotch Flex(R) connectors
120	;labeled "J1" and "J2". There can be up to 6 30 dip groups on one
121	;board. The horizontal spacing between groups is 2.700".
122
123	;There are 5 panels, vertically arranged. The vertical spacing
124	;is 7.500".
125
126	;5A30(8) is at (0,0). 5AJ2-26 is at (500,6100). 5AJ1-26 is at (500, 6400).
127	;--5A30(10)
128	;It follows that 5B30(8) is at (2700,0)
129
130	;UMLCOL__GRPROW ;UML INTERCHANGES ROWS AND COLUMNS
131	;UMLROW__GRPCOL
132	(defconst mpg216-PNLOFT 8100) ;8.100" VERTICAL SPACING BETWEEN PANELS
133	(defconst mpg216-GXOFST 2700) ;2.700" GROUP HORIZONTAL SPACING
134	(defconst mpg216-XDIPSP 500) ; .500" DIP HORIZONTAL SPACING
135	(defconst mpg216-YDIPSP 1100) ;1.100" DIP VERTICAL SPACING
136	(defconst mpg216-GNDXOF 100) ; .100" X OFFSET FOR TWP GROUND PINS
137	(defconst mpg216-BRDGND 10) ; PIN 10 IS DEDICATED GROUND
138	(defconst mpg216-BRDPWR 20) ; PIN 20 IS DEDICATED POWER
139	;CONNECTORS
140	(defconst mpg216-JXOFST 0) ; .000" X OFFSET FOR JACKS
141	(defconst mpg216-JYOFST 6700) ;6.700" Y OFFSET FOR J2
142	(defconst mpg216-JYOFS1 300) ; .300" Y OFFSET FROM J2 TO J1
143
144	(defvar twenty-pin-socket-xoff nil)
145	(defvar twenty-pin-socket-yoff nil)
146	(defconst twenty-pin-dipsoc-xpinsp 300) ; .300" DIP PIN HORIZONTAL SPACING
147	(defconst twenty-pin-dipsoc-ypinsp 100) ; .100" DIP PIN VERTICAL SPACING
148	(defvar flat-cable-conn-xoffs nil)
149	(defvar flat-cable-conn-yoffs nil)
150	(defconst flat-cable-pxpnsp 100) ; .100" CONNECTOR PIN VERTICAL SPACING
151	(defconst flat-cable-pypnsp 100) ; .100" CONNECTOR PIN HORIZONTAL SPACING
152
153	(defun ctest-conn-and-socket-init nil
154	(setq twenty-pin-socket-xoff (make-array nil art-q 20)
155	twenty-pin-socket-yoff (make-array nil art-q 20)
156	flat-cable-conn-xoffs (make-array nil art-q 51)
157	flat-cable-conn-yoffs (make-array nil art-q 51))
158	(dotimes (p 20.)
159	(as-1 (* (cond ((<= p 9) 0) ;First col of pins is on the left (DIP side)
160	(t 1))
161	twenty-pin-dipsoc-xpinsp)
162	twenty-pin-socket-xoff
163	p)
164	(as-1 (* (cond ((<= p 9)
165	(- 9 p))
166	(t (- p 10.)))
167	twenty-pin-dipsoc-ypinsp)
168	twenty-pin-socket-yoff
169	p))
170	(dolist (maxp '(50 40 26))
171	(let ((xoff-arr (make-array nil art-q maxp))
172	(yoff-arr (make-array nil art-q maxp))
173	(hmaxp (// maxp 2)))
174	(dotimes (p maxp)
175	(as-1 (- (* (- (1- hmaxp) (\ p hmaxp)) flat-cable-pxpnsp)
176	flat-cable-pxpnsp) ;Pin 25 (which doesnt really exist) is one click
177	xoff-arr ; to the right of the 1a5-1 to 10 line of pins
178	p)
179	(as-1 (* (cond ((< p hmaxp) 1)
180	(t 0))
181	flat-cable-pypnsp)
182	yoff-arr
183	p)
184	(as-1 xoff-arr flat-cable-conn-xoffs maxp)
185	(as-1 yoff-arr flat-cable-conn-yoffs maxp)))))
186
187	(defun mpg216-getloc (STR BEG LIM &AUX C VAL-LIST IDX)
188	(IF (NULL BEG) (SETQ BEG 0))
189	(IF (NULL LIM) (SETQ LIM (ARRAY-ACTIVE-LENGTH STR)))
190	(MULTIPLE-VALUE (C VAL-LIST IDX)
191	(LNPARSE '("#L#-#(#L#-#)" "#L#-#(#)" "#L#-#"
192	"#L#@#-#(#)" "#L#@#-#" "#LJ#-#") STR BEG LIM))
193	(SELECTQ C (0 (SETQ VAL-LIST (CDDDDR VAL-LIST)) ;ADAPTOR FROB, FLUSH THAT ONE
194	(DPB (CAR VAL-LIST) MPG216-%CNPPNL
195	(DPB (CADR VAL-LIST) MPG216-%CNPG
196	(DPB (CADDR VAL-LIST) MPG216-%DIPS
197	(DPB (CADDDR VAL-LIST) CTEST-%%PIN 0)))))
198	(1 (DPB (CAR VAL-LIST) MPG216-%CNPPNL
199	(DPB (CADR VAL-LIST) MPG216-%CNPG
200	(DPB (CADDR VAL-LIST) MPG216-%DIPS
201	(DPB (CAR (CDDDDR VAL-LIST)) CTEST-%%PIN 0)))))
202	(2 (DPB (CAR VAL-LIST) MPG216-%CNPPNL
203	(DPB (CADR VAL-LIST) MPG216-%CNPG
204	(DPB (CADDR VAL-LIST) MPG216-%DIPS
205	(DPB (CADDDR VAL-LIST) CTEST-%%PIN 0)))))
206	(3 (DPB (CAR VAL-LIST) MPG216-%CNPPNL
207	(DPB (CADR VAL-LIST) MPG216-%CNPG
208	(DPB (CADDR VAL-LIST) MPG216-%DIPS
209	(DPB (CADDDR (CDDR VAL-LIST)) CTEST-%%PIN 0)))))
210	(4 (DPB (CAR VAL-LIST) MPG216-%CNPPNL
211	(DPB (CADR VAL-LIST) MPG216-%CNPG
212	(DPB (CADDR VAL-LIST) MPG216-%DIPS
213	(DPB (CADDDR VAL-LIST) MPG216-%DIPOF
214	(DPB (CAR (CDDDDR VAL-LIST)) CTEST-%%PIN 0))))))
215	(5 (DPB (CAR VAL-LIST) MPG216-%CNPPNL
216	(DPB (CADR VAL-LIST) MPG216-%CNPG
217	(DPB 1 MPG216-%CONN
218	(DPB (1- (CADDR VAL-LIST)) MPG216-%CNPJK
219	(DPB (CADDDR VAL-LIST) CTEST-%%PIN 0)))))))
220	)
221
222	(defun mpg216-maploc (loc) ;returns x and y, but swap these to get tester coords
223	(prog (x y panel group conn pin slot offset)
224	(setq panel (ldb mpg216-%DIPPNL loc)
225	group (ldb mpg216-%DIPG loc)
226	conn (ldb mpg216-%CONN loc)
227	pin (ldb ctest-%%pin loc))
228	(cond ((> panel mpg216-MXPNL)
229	(ferror nil "panel number too high ~s" panel))
230	((> group mpg216-NGRPS)
231	(ferror nil "group number too high ~s" group)))
232	(setq y (* mpg216-PNLOFT (- mpg216-MXPNL panel))
233	x (* (1- group) mpg216-GXOFST))
234	(cond ((zerop conn)
235	(setq slot (1- (ldb mpg216-%DIPS loc))
236	offset (ldb mpg216-%DIPOF loc))
237	(let ((xpos (\ slot mpg216-grpcol))
238	(ypos (// slot mpg216-grpcol)))
239	(setq x (+ x (* (1- (- mpg216-grpcol xpos)) mpg216-XDIPSP)
240	(ar-1 TWENTY-PIN-SOCKET-xoff (1- pin)))
241	y (+ y (* (1- (- mpg216-grprow ypos)) mpg216-YDIPSP)
242	(ar-1 TWENTY-PIN-SOCKET-yoff (1- pin))))))
243	(t (let ((jack (ldb mpg216-%CNPJK loc)))
244	(setq y (+ y mpg216-jyofst)) ;vert offset to j2
245	(cond ((= jack 0)
246	(setq y (+ y mpg216-jyofs1)) ;additional offset to j1
247	(cond ((> pin (// mpg216-mxcnp1 2)) ;in bottom row?
248	(setq pin (+ pin 5)))) ;j2's bottom row starts
249	; +5 pins w.r.t j1
250	(setq pin (+ pin mpg216-j1to2)))) ;and j1 is displaced 2 pins right
251	(setq x (+ x (ar-1 (ar-1 flat-cable-conn-xoffs 50.) (1- pin)))
252	y (+ y (ar-1 (ar-1 flat-cable-conn-yoffs 50.) (1- pin)))))))
253	(return x y)))
254
255
256	(DEFUN LNPARSE (PATTERN-LIST STR BEG LIM)
257	(PROG (PL MATCHP ANS IDX C)
258	(SETQ PL PATTERN-LIST C 0)
259	L (COND ((NULL PL) (RETURN NIL)))
260	(MULTIPLE-VALUE (MATCHP ANS IDX)
261	(LN-PMATCH (CAR PL) STR BEG LIM))
262	(COND (MATCHP (RETURN C ANS IDX)))
263	(SETQ PL (CDR PL) C (1+ C))
264	(GO L)))
265
266	(DEFUN LN-PMATCH (PAT STR BEG LIM)
267	(PROG (PIDX PLIM IDX ANS MATCHP VAL)
268	(SETQ PIDX 0 PLIM (ARRAY-ACTIVE-LENGTH PAT)
269	IDX BEG)
270	L (COND ((NOT (< IDX LIM)) (RETURN NIL)))
271	(MULTIPLE-VALUE (MATCHP VAL IDX)
272	(LN-PMATCH-CH (AR-1 PAT PIDX) STR IDX LIM))
273	(COND ((NULL MATCHP) (RETURN NIL)))
274	(COND (VAL (SETQ ANS (NCONC ANS (LIST VAL)))))
275	(COND ((= (SETQ PIDX (1+ PIDX)) PLIM)
276	(RETURN T ANS IDX)))
277	(GO L)))
278
279	(DEFUN LN-PMATCH-CH (CH STR IDX LIM)
280	(COND ((EQ CH #/#)
281	(LN-PMATCH-NUM STR IDX LIM))
282	((EQ CH #/L) ;any DEC letter
283	(LN-PMATCH-LET STR IDX LIM))
284	((EQ CH #/P) ;"paddle" letter ABCDEF
285	(LN-PMATCH-LET STR IDX LIM 6))
286	((= CH (CHAR-UPCASE (AR-1 STR IDX)))
287	(PROG NIL (RETURN T NIL (1+ IDX))))
288	))
289
290
291	(DEFUN LN-PMATCH-NUM (STR IDX LIM)
292	(PROG (ANS CH)
293	(COND ((OR (NOT (< IDX LIM))
294	(NOT (AND (>= (SETQ CH (AR-1 STR IDX)) #/0)
295	(<= CH #/9))))
296	(RETURN NIL)))
297	(SETQ ANS (- CH #/0))
298	L (COND ((OR (NOT (< (SETQ IDX (1+ IDX)) LIM))
299	(NOT (AND (>= (SETQ CH (AR-1 STR IDX)) #/0)
300	(<= CH #/9))))
301	(RETURN T ANS IDX)))
302	(SETQ ANS (+ (* ANS 10.) (- CH #/0)))
303	(GO L)))
304
305	(DEFUN LN-PMATCH-LET (STR IDX LIM &OPTIONAL (MAX 22.))
306	(PROG (CH)
307	(COND ((AND (< IDX LIM)
308	(>= (SETQ CH (CHAR-UPCASE (AR-1 STR IDX))) #/A)
309	(<= CH (+ #/A MAX)))
310	(RETURN T (CTEST-DEC-LETTER-TO-NUMBER (- CH #/@)) (1+ IDX))))))
311
312	(DEFUN MATCH-TEST NIL
313	(DO ((x) (y) (loc)) (())
314	(PRINT (CTEST-LOC (setq loc (CTEST-GETLOC (READLINE)))))
315	(multiple-value (x y)
316	(ctest-maploc loc))
317	(format t "x=~d,y=~d~%" x y)
318	))
319
320	(DECLARE (SPECIAL LEFT-PROBE RIGHT-PROBE))
321
322	(DEFUN LOC-TEST (&optional (probe-ob left-probe))
323	(DO ((x) (y) (loc) (XE) (YE)) (())
324	(CTEST-LOC (setq loc (CTEST-GETLOC (READLINE))))
325	(multiple-value (y x) ;Y and X swapped
326	(ctest-maploc loc))
327	(format t "x=~d,y=~d" x y)
328	(<- PROBE-OB ':GOTO-LOC LOC)
329	(<- PROBE-OB ':PROBE-DOWN)
330	(MULTIPLE-VALUE (XE YE)
331	(<- PROBE-OB ':CLIMB-ON-PIN))
332	(FORMAT T "~%XERR ~S, YERR ~S" XE YE))
333	)
334
335	(defvar ctest-retry-count 0)
336
337	;SIGNAL-NAME is for printouts, plus it does different things for power and ground
338	(DEFUN TEST-WIRE (SIGNAL-NAME LOC1 LOC2)
339	(MULTIPLE-VALUE-BIND (Y1 X1)
340	(CTEST-MAPLOC LOC1)
341	(MULTIPLE-VALUE-BIND (Y2 X2)
342	(CTEST-MAPLOC LOC2)
343	(COND ((< X1 X2) ;left probe takes wire with greater X
344	(SETQ X1 (PROG1 X2 (SETQ X2 X1)))
345	(SETQ Y1 (PROG1 Y2 (SETQ Y2 Y1)))))
346	(setq ctest-retry-count 0)
347	(error-restart
348	(prog (lx rx lxdiff rxdiff cxdiff lxe lye rxe rye)
349	(cond ((equal signal-name "NC") (return t))) ;that one isnt there!
350	L0 (setq lx (<- left-probe ':xpos)
351	rx (<- right-probe ':xpos))
352	(setq lxdiff (- x1 lx)
353	rxdiff (- x2 rx)
354	cxdiff (- lx rx)) ;current dist between probes
355	;In code below, we assume if probes are 250. mills apart in x direction, they cannot
356	; collide even if y's cross.
357	(cond ((and (> lxdiff 0) ;left probe moving away,
358	(> (+ lxdiff cxdiff) 250.)) ;and far enuf away
359	(<- left-probe ':goto x1 y1) ;safe to move it.
360	(<- right-probe ':goto x2 y2))
361	((and (> (minus rxdiff) 0) ;same stuff, right probe
362	(> (+ (minus rxdiff) cxdiff) 250.))
363	(<- right-probe ':goto x2 y2)
364	(<- left-probe ':goto x1 y1))
365	((> (min cxdiff (- x1 rx) (- lx x2) (- x1 x2)) 250.)
366	(<- right-probe ':goto x2 y2) ;they are far apart and will stay far apart
367	(<- left-probe ':goto x1 y1))
368	;Try to arrange the second motion to involve a x-motion of at least 250 mills toward
369	; the other arm.
370	((> (minus lxdiff) 250.)
371	(<- right-probe ':goto x2 y2)
372	(<- left-probe ':goto x1 y1))
373	((> rxdiff 250.)
374	(<- left-probe ':goto x1 y1)
375	(<- right-probe ':goto x2 y2))
376	;cause one arm to step away from the other by 20 steps (about .2 inch), then try again.
377	((zerop lxdiff)
378	(<- right-probe ':step-x -20.)
379	(go L0))
380	(t (<- left-probe ':step-x 20.)
381	(go L0)))
382	(<- left-probe ':probe-down)
383	(multiple-value (lxe lye) (<- left-probe ':climb-on-pin))
384	(<- right-probe ':probe-down)
385	(multiple-value (rxe rye) (<- right-probe ':climb-on-pin))
386	(cond ((eq (ctest-test-cont signal-name t) 'win)
387	(<- LEFT-PROBE ':APPARENT-ERROR LXE LYE) ;WON, SO PROBES MUST BE IN RIGHT
388	(<- RIGHT-PROBE ':APPARENT-ERROR RXE RYE) ;PLACE
389	(return t))))))))
390
391	;definitions below basically copied from MC;WL;LG684 517
392
393	(DEFCONST LG684-%DIPG (BYTE-FIELD 4 19)) ;DIP GROUP (The letter)
394	(DEFCONST LG684-%DIPS (BYTE-FIELD 6 13)) ;DIP SLOT (The number)
395	(DEFCONST LG684-%DIPOF (BYTE-FIELD 6 07)) ;DIP OFFSET
396
397	(DEFCONST LG684-%CONT (BYTE-FIELD 1 07)) ;CONNECTOR TYPE 0 DEC 1 FLAT CABLE "J"
398	(DEFCONST LG684-%CONN (BYTE-FIELD 4 23)) ;CONNECTOR NUMBER (LETTER OR JACK #)
399	;(DEFCONST LG684-%CONP (BYTE-FIELD 9 00)) ;CONNECTOR PIN #
400
401	(DEFCONST LG684-GPINS 400) ;NOMEN FOR "G" PINS ON BOARD STARTS AT 400
402	; 401 IS "G1", ETC.
403	;BRDGND__=10 ; PIN 10 IS DEDICATED GROUND
404	;BRDPWR__=20 ; PIN 20 IS DEDICATED POWER
405	(DEFCONST LG684-MXDPIN 36) ;MAXIMUM NUMBER OF DEC PINS/CONNECTOR
406	(DEFCONST LG684-NGRPS 6) ;max for group (the letter)
407	(DEFCONST LG684-MAXCON 12) ;max for the jack (Jnn)
408
409	;The L8X30 board has an area of 16 pin DIP's, in 7 rows (A-H), columns 5-30
410	; and an 2 areas of 20 pin dips: rows A-F cols 1-4, and row J cols 1-30
411	; (There is no H row for columns 1-4)
412
413	;The LG684 board consists of 6 rows of 30 dips
414	;Row A, slot1 is the upper left (with connector paddles up,
415	; and from DIP side)
416
417	;AUGAT-LG684 CONNECTOR PIN FORMAT PRINTS AS J#-# OR LL#
418	;THE J IS LITERAL.
419
420	; 15 12 9 0 LM bit numbering
421	;______\|_____\|_____\|_____\|_____\|_____\|
422	;\| 22 26 35 PDP-10 bit numbering
423	;\| \|1\| 4 \| 9 \|
424	;\|_______\|_\|_______\|_________________\|
425	; \| \| \|
426	; \| \| \|------------>PIN
427	; \| \|
428	; \| \|----------------------CONNECTOR NUMBER (JACK OR ROW LETTER)
429	; \|
430	; \|--------------------------->CONNECTOR TYPE 0 DEC, 1 FLAT CABLE
431
432
433
434
435
436	;All calculations are done from the DIP side.
437
438	;(0,0) at LOWER left hand corner in left handed coordinate system.
439	;X+ to right, Y+ is up
440	;0,0 corresponds to FV1 of DEC connectors.
441
442	(DEFCONST LG684-XDIPSP 500) ; .500" DIP HORIZONTAL SPACING
443	(DEFCONST LG684-YDIPSP 1100) ;1.100" DIP VERTICAL SPACING
444	(DEFCONST LG684-XGRPOF 200) ;HORIZONTAL DISTANCE FROM ORIGIN TO DIP PIN10 OF F1
445	(DEFCONST LG684-YGRPOF 600) ;VERTICAL DISTANCE FROM ORIGIN TO DIP PIN10 OF F1
446
447	(DEFCONST LG684-XPINSP 300) ; .300" DIP PIN HORIZONTAL SPACING
448	(DEFCONST LG684-YPINSP 100) ; .100" DIP PIN VERTICAL SPACING
449	(DEFCONST LG684-XGNDOFF -100) ;OFFSET FROM DIP SLOT ORIGIN (ON EXTRA GROUND ROW) TO
450	; FIRST DIP PIN ROW
451	;CONNECTORS, SCOTCHFLEX
452	(DEFCONST LG684-FCXOFF 100) ;.1" RIGHT FOR FIRST PIN OF FLAT CABLE CONNECTORS
453	(DEFCONST LG684-FCYOFF 7400) ;7.4" up to first pin of J2 relative to origin
454	(DEFCONST LG684-FCYOF2 300) ;.3" up for first pin of J1 relative to J2
455	(DEFCONST LG684-FCJ3OF 2800) ;2.8" RIGHT FOR FIRST PIN OF J3
456	(DEFCONST LG684-FCGOF 5100) ;5.1" RIGHT FOR FIRST PIN OF J5
457
458	;CONNECTORS, DEC
459	(DEFCONST LG684-DECCNY 0) ;0.0" UP TO BOTTOM ROW OF DEC CONNECTORS
460	(DEFCONST LG684-DCPINO 200) ;.2" UP FROM BOTTOM TO SECOND ROW
461	(DEFCONST LG684-DECX1 2700) ;2.7" LEFT FOR LARGE CONNECTOR SPACES
462	(DEFCONST LG684-DECX2 2600) ;2.6" LEFT FOR SMALL CONNECTOR SPACES
463	(DEFCONST LG684-GAP1T2 (- LG684-DECX2 1900)) ; THE SMALLER GAP BETWEEN DEC PADDLES
464	(DEFCONST LG684-DCPINS 1900) ;1.9" RIGHT FOR PIN A1 RELATIVE TO START OF CONNECTOR
465	(DEFCONST LG684-DCPNSP 100) ;.1" BETWEEN PINS HORIZONTALLY
466	(DEFCONST LG684-DCGRSP 200) ;.2" BETWEEN GROUPS OF PINS
467
468	(DEFVAR LG684-PADDLE-XOFFS NIL)
469	(DEFVAR LG684-PADDLE-YOFFS NIL)
470
471	(DEFVAR LG684-JACKSZ NIL) ;array, for each J, max # pins. J0 illegal.
472	(DEFVAR LG684-JACK-XOFFS NIL)
473	(DEFVAR LG684-JACK-YOFFS NIL)
474
475
476	(DEFUN LG684-PRNLOC (LOC &AUX ANS)
477	(let ((group (ldb LG684-%DIPG loc))
478	(conn (ldb LG684-%CONN loc))
479	(pin (ldb ctest-%%pin loc)))
480	(cond ((zerop conn)
481	(let ((slot (ldb LG684-%DIPS loc))
482	(offset (ldb LG684-%DIPOF loc)))
483	(setq ans (format nil "~C~2,48D" (+ #/@ group) slot))
484	(cond ((not (zerop offset))
485	(setq ans (string-append ans (format nil "@~2,48D" offset)))))))
486	((ZEROP (LDB LG684-%CONT LOC)) ;DEC edge connector
487	(SETQ ANS (FORMAT NIL "~C" (+ #/@ CONN)))) ;paddle letter just ABCDEF
488	(t (setq ans (format nil "J~D" CONN))))
489	(cond ((and (zerop conn)
490	(>= pin LG684-GPINS))
491	(SETQ ANS (format nil "~A-~1D" ANS (- pin LG684-GPINS)))) ;ground pin
492	((AND (NOT (ZEROP CONN))
493	(ZEROP (LDB LG684-%CONT LOC)))
494	(SETQ ANS (FORMAT NIL "~A~C~D"
495	ANS
496	(CTEST-NUMBER-TO-DEC-LETTER (LSH PIN -1))
497	(1+ (LOGAND PIN 1)))))
498	(t (SETQ ANS (format nil "~A-~2,48D" ANS pin)))))
499	ANS)
500
501	(DEFUN LG684-INIT (&AUX JN DX)
502	(SETQ LG684-JACKSZ (MAKE-ARRAY NIL ART-Q 13.)) ;J0 illegal
503	(DOTIMES (C 12.)
504	(AS-1 (IF (BIT-TEST 1 C) 40 50)
505	LG684-JACKSZ
506	(1+ C)))
507	(SETQ LG684-JACK-XOFFS (MAKE-ARRAY NIL ART-Q 13)
508	LG684-JACK-YOFFS (MAKE-ARRAY NIL ART-Q 13))
509	(SETQ JN 1)
510	(DOTIMES (JGROUP 3) ;3 groups, 4 connectors each
511	(AS-1 (+ LG684-FCXOFF (* LG684-FCGOF JGROUP)) LG684-JACK-XOFFS JN) ;eg J1
512	(AS-1 (+ LG684-FCYOFF LG684-FCYOF2) LG684-JACK-YOFFS JN)
513	(SETQ JN (1+ JN))
514	(AS-1 (+ LG684-FCXOFF (* LG684-FCGOF JGROUP)) LG684-JACK-XOFFS JN) ;eg J2
515	(AS-1 LG684-FCYOFF LG684-JACK-YOFFS JN)
516	(SETQ JN (1+ JN))
517	(AS-1 (+ LG684-FCXOFF LG684-FCJ3OF (* LG684-FCGOF JGROUP)) LG684-JACK-XOFFS JN) ;eg J3
518	(AS-1 (+ LG684-FCYOFF LG684-FCYOF2) LG684-JACK-YOFFS JN)
519	(SETQ JN (1+ JN))
520	(AS-1 (+ LG684-FCXOFF LG684-FCJ3OF (* LG684-FCGOF JGROUP)) LG684-JACK-XOFFS JN) ;eg J4
521	(AS-1 LG684-FCYOFF LG684-JACK-YOFFS JN)
522	(SETQ JN (1+ JN)))
523	(SETQ LG684-PADDLE-XOFFS (MAKE-ARRAY NIL ART-Q 6)
524	LG684-PADDLE-YOFFS (MAKE-ARRAY NIL ART-Q 6))
525	(SETQ JN 0
526	DX 0)
527	(DOTIMES (JGROUP 3)
528	(AS-1 DX LG684-PADDLE-XOFFS JN)
529	(AS-1 LG684-DECCNY LG684-PADDLE-YOFFS JN)
530	(SETQ JN (1+ JN)
531	DX (+ DX LG684-DECX1))
532	(AS-1 DX LG684-PADDLE-XOFFS JN)
533	(AS-1 LG684-DECCNY LG684-PADDLE-YOFFS JN)
534	(SETQ JN (1+ JN)
535	DX (+ DX LG684-DECX2))))
536
537	(DEFUN LG684-GETLOC (STR BEG LIM &AUX C VAL-LIST IDX)
538	(IF (NULL BEG) (SETQ BEG 0))
539	(IF (NULL LIM) (SETQ LIM (ARRAY-ACTIVE-LENGTH STR)))
540	(MULTIPLE-VALUE (C VAL-LIST IDX)
541	(LNPARSE '("P#-#(P#-#)" "P#-#(#)" "P#-#" "P#@#-#(#)" "P#@#-#" "PL#" "J#-#")
542	STR BEG LIM))
543	(SELECTQ C
544	(0 (SETQ VAL-LIST (CDDDR VAL-LIST)) ;flush adaptor cruft
545	(SI:DESTRUCTURING-BIND (LET NUM PIN) VAL-LIST
546	(DPB LET LG684-%DIPG
547	(DPB NUM LG684-%DIPS
548	(DPB PIN CTEST-%%PIN 0)))))
549	(1 (SI:DESTRUCTURING-BIND (LET NUM IGNORE PIN) VAL-LIST
550	(DPB LET LG684-%DIPG
551	(DPB NUM LG684-%DIPS
552	(DPB PIN CTEST-%%PIN 0)))))
553	(2 (SI:DESTRUCTURING-BIND (LET NUM PIN) VAL-LIST
554	(DPB LET LG684-%DIPG
555	(DPB NUM LG684-%DIPS
556	(DPB PIN CTEST-%%PIN 0)))))
557	(3 (SI:DESTRUCTURING-BIND (LET NUM IGNORE IGNORE PIN) VAL-LIST
558	(DPB LET LG684-%DIPG
559	(DPB NUM LG684-%DIPS
560	(DPB PIN CTEST-%%PIN 0)))))
561	(4 (SI:DESTRUCTURING-BIND (LET NUM IGNORE PIN) VAL-LIST
562	(DPB LET LG684-%DIPG
563	(DPB NUM LG684-%DIPS
564	(DPB PIN CTEST-%%PIN 0)))))
565	(5 (SI:DESTRUCTURING-BIND (LET PADDLE-LET PADDLE-SIDE) VAL-LIST
566	(DPB LET LG684-%CONN
567	(DPB (+ (LSH (CTEST-DEC-LETTER-TO-NUMBER PADDLE-LET) 1)
568	(1- PADDLE-SIDE))
569	CTEST-%%PIN
570	0)))) ;LG684-%CONT => 0
571	(6 (SI:DESTRUCTURING-BIND (J-NUM PIN) VAL-LIST
572	(DPB J-NUM LG684-%CONN
573	(DPB PIN CTEST-%%PIN
574	(DPB 1 LG684-%CONT 0))))))
575	)
576
577	(DEFUN LG684-MAPLOC (LOC) ;returns x and y, but swap these to get tester coords
578	(prog (x y group conn pin slot offset)
579	(setq group (ldb LG684-%DIPG loc)
580	conn (ldb LG684-%CONN loc)
581	pin (ldb ctest-%%pin loc))
582	(setq y 0 x 0)
583	(cond ((zerop conn)
584	(if (> group LG684-NGRPS)
585	(ferror nil "group number too high ~s" group))
586	(setq slot (ldb LG684-%DIPS loc)
587	offset (ldb LG684-%DIPOF loc))
588	(setq x LG684-XGRPOF y LG684-YGRPOF)
589	(setq x (+ x (* (1- slot) LG684-XDIPSP)
590	(ar-1 twenty-pin-socket-xoff (1- pin)))
591	y (+ y (* (- 6 group) LG684-YDIPSP)
592	(ar-1 twenty-pin-socket-yoff (1- pin)))))
593	((ZEROP (LDB LG684-%CONT LOC)) ;DEC edge connector
594	(IF (OR (ZEROP CONN)
595	(NOT (<= CONN LG684-MAXCON)))
596	(FERROR NIL "bad conn number"))
597	(SETQ X (+ X (AR-1 LG684-PADDLE-XOFFS (1- CONN))
598	(* LG684-DCPNSP (LSH PIN -1)))
599	Y (+ Y (AR-1 LG684-PADDLE-YOFFS (1- CONN))
600	(* LG684-DCPINO (LOGAND PIN 1)))))
601	(t (let ((maxp (ar-1 lg684-jacksz conn)))
602	(if (> pin maxp) (ferror nil "PIN NUMBER TOO HIGH"))
603	(setq x (+ x (ar-1 (ar-1 flat-cable-conn-xoffs maxp) (1- pin))
604	(AR-1 LG684-JACK-XOFFS CONN))
605	y (+ y (ar-1 (ar-1 flat-cable-conn-yoffs maxp) (1- pin))
606	(AR-1 LG684-JACK-YOFFS CONN)))
607	)))
608	(return x y)))
609
610
611	(DEFUN CTEST-NUMBER-TO-DEC-LETTER (NUM)
612	(IF (>= NUM #/G) (SETQ NUM (1+ NUM)))
613	(IF (>= NUM #/I) (SETQ NUM (1+ NUM)))
614	(IF (>= NUM #/O) (SETQ NUM (1+ NUM)))
615	(IF (>= NUM #/Q) (SETQ NUM (1+ NUM)))
616	(+ #/@ NUM))
617
618	(DEFUN CTEST-DEC-LETTER-TO-NUMBER (NUM)
619	(COND ((MEMQ NUM '(#/G #/I #/O #/Q))
620	(FERROR NIL "~C invalid DEC letter" NUM)))
621	(IF (> NUM #/Q) (SETQ NUM (1- NUM)))
622	(IF (> NUM #/O) (SETQ NUM (1- NUM)))
623	(IF (> NUM #/I) (SETQ NUM (1- NUM)))
624	(IF (> NUM #/G) (SETQ NUM (1- NUM)))
625	NUM)
626
627	;---
628
629	(DEFVAR CTEST-LINES NIL)
630	(DEFVAR CTEST-RUNS NIL)
631	(DEFVAR CTEST-BAD-RUNS NIL)
632	(DEFVAR CTEST-FILE NIL)
633
634	(DEFUN CTEST-READIN (&OPTIONAL (FILE "CADRWD;ICMEM3 WLR")
635	(SKIP-COUNT 0)
636	(READ-COUNT 2000000))
637	(LET ((STREAM (OPEN FILE '(IN))))
638	(SETQ CTEST-LINES (CTEST-READLINES STREAM SKIP-COUNT READ-COUNT))
639	(CLOSE STREAM))
640	(FORMAT T "~%Readin completed, parsing runs")
641	(SETQ CTEST-RUNS (CTEST-PARSE-RUNS CTEST-LINES))
642	(SETQ CTEST-RUNS (APPEND CTEST-RUNS NIL))
643	(FORMAT T "~%Parse completed, starting phase 1 sort. Total travel =~D"
644	(CTEST-TOTAL-TRAVEL CTEST-RUNS))
645	(SETQ CTEST-RUNS (SORT CTEST-RUNS (FUNCTION RUN-LEFT-PROBE-X-LOCN-<)))
646	(FORMAT T "~%Starting phase 2 sort. Total travel =~D"
647	(CTEST-TOTAL-TRAVEL CTEST-RUNS))
648	(SETQ CTEST-RUNS (CTEST-SORT CTEST-RUNS))
649	(FORMAT T "~%Final total travel ~D" (CTEST-TOTAL-TRAVEL CTEST-RUNS)))
650
651	(DEFUN CTEST-PROCESS-WLR (FILE &OPTIONAL (SKIP-COUNT 0) (ALREADY-IN NIL))
652	(SETQ CTEST-FILE FILE)
653	(COND ((NULL ALREADY-IN)
654	(CTEST-READIN FILE)))
655	(CTEST-TRY-TESTING SKIP-COUNT)
656	(CTEST-WRITE-BAD-RUNS "RG;LOSERS >" CTEST-BAD-RUNS 'END)
657	)
658
659	(DEFUN CTEST-WRITE-BAD-RUNS (FILE BAD PLACE)
660	(LET ((STREAM (OPEN FILE '(OUT))))
661	(FORMAT STREAM "~%PROCESSING ~A RN ~D~%" CTEST-FILE PLACE)
662	(GRIND-TOP-LEVEL BAD 80. STREAM)
663	(CLOSE STREAM)))
664
665	(DEFUN CTEST-READ-BAD-RUNS (FILE)
666	(LET ((STREAM (OPEN FILE)))
667	(READLINE STREAM)
668	(READLINE STREAM)
669	(SETQ CTEST-BAD-RUNS (READ STREAM))
670	(CLOSE STREAM)))
671
672	;RETEST BAD RUNS. NOTE THEY ARE IN TEXT FORM
673	(DEFUN CTEST-RETEST-BAD-RUNS (&OPTIONAL (BAD-RUNS CTEST-BAD-RUNS))
674	(CTEST-TRY-TESTING 0 (MAPCAR (FUNCTION CTEST-UNCONVERT-RUN)
675	(MAPCAR (FUNCTION CAR) BAD-RUNS))))
676
677	(DEFUN CTEST-FIND-RUN-ENDING (STRING-LOC &OPTIONAL (RUNS CTEST-RUNS))
678	(PROG (LOC L RN)
679	(SETQ LOC (CTEST-GETLOC STRING-LOC)
680	L RUNS
681	RN 0)
682	L (COND ((NULL L) (RETURN NIL))
683	((OR (= LOC (CAR (CADR (CAR L))))
684	(= LOC (CAR (LAST (CADR (CAR L))))))
685	(RETURN RN L)))
686	(SETQ L (CDR L) RN (1+ RN))
687	(GO L)))
688
689	(DEFUN CTEST-FIND-RUN-CONTAINING (STRING-LOC &OPTIONAL (RUNS CTEST-RUNS))
690	(PROG TOP (LOC L RN)
691	(SETQ LOC (CTEST-GETLOC STRING-LOC)
692	L RUNS
693	RN 0)
694	L (COND ((NULL L) (RETURN NIL)))
695	(DOLIST (LK (CADR (CAR L)))
696	(COND ((= LOC LK)
697	(RETURN-FROM TOP RN L))))
698	(SETQ L (CDR L) RN (1+ RN))
699	(GO L)))
700
701	(DEFUN CTEST-FIND-RUN (RUN-NAME &OPTIONAL (RUNS CTEST-RUNS))
702	(PROG (L RN)
703	(SETQ RN 0 L RUNS)
704	L (COND ((NULL L) (RETURN NIL))
705	((EQUAL RUN-NAME (CAAR L))
706	(RETURN RN L)))
707	(SETQ RN (1+ RN) L (CDR L))
708	(GO L)))
709
710	(defun ctest-try-testing (&optional (skip-count 0) (runs ctest-runs))
711	(prog (l rn wins losses)
712	(setq runs (nthcdr skip-count runs))
713	(setq l runs rn skip-count wins 0 losses nil)
714	l (cond ((null l)
715	(return wins losses)))
716	(let ((run (car l)))
717	(cond ((> (length (cadr run)) 1)
718	(cond ((test-wire (car run) (car (cadr run)) (car (last (cadr run))))
719	(setq wins (1+ wins))
720	(tv:beep))
721	(t (setq losses (cons run losses))
722	(SETQ CTEST-BAD-RUNS (CONS (CTEST-TEST-SEGMENTS RUN)
723	CTEST-BAD-RUNS))
724	(CTEST-WRITE-BAD-RUNS "RG; CTEST PLACE" CTEST-BAD-RUNS RN))))))
725	(setq l (cdr l))
726	(setq rn (1+ rn))
727	(go l)))
728
729	(DEFUN CTEST-TEST-SEGMENTS (RUN)
730	(PROG (LOC-LIST ANS SEG-NO)
731	(SETQ LOC-LIST (CADR RUN) SEG-NO 0)
732	L (COND ((NULL (CDR LOC-LIST))
733	(RETURN (LIST (CTEST-CONVERT-RUN RUN) ANS)))
734	((TEST-WIRE (LIST (CAR RUN) (SETQ SEG-NO (1+ SEG-NO)))
735	(CAR LOC-LIST)
736	(CADR LOC-LIST))
737	(TV:BEEP))
738	(T (SETQ ANS (CONS (LIST (CTEST-LOC (CAR LOC-LIST))
739	(CTEST-LOC (CADR LOC-LIST)))
740	ANS))))
741	(SETQ LOC-LIST (CDR LOC-LIST))
742	(GO L)))
743
744	(DEFUN RUN-LEFT-PROBE-X-LOCN-< (R1 R2 &AUX R1X1 R1Y1 R1X2 R1Y2 R2X1 R2Y1 R2X2 R2Y2)
745	(MULTIPLE-VALUE (R1Y1 R1X1) (CTEST-MAPLOC (CAR (CADR R1))))
746	(MULTIPLE-VALUE (R1Y2 R1X2) (CTEST-MAPLOC (CAR (LAST (CADR R1)))))
747	(COND ((< R1X1 R1X2) ;left probe takes wire with greater X
748	(SETQ R1X1 (PROG1 R1X2 (SETQ R1X2 R1X1)))
749	(SETQ R1Y1 (PROG1 R1Y2 (SETQ R1Y2 R1Y1)))))
750	(MULTIPLE-VALUE (R2Y1 R2X1) (CTEST-MAPLOC (CAR (CADR R2))))
751	(MULTIPLE-VALUE (R2Y2 R2X2) (CTEST-MAPLOC (CAR (LAST (CADR R2)))))
752	(COND ((< R2X1 R2X2) ;left probe takes wire with greater X
753	(SETQ R2X1 (PROG1 R2X2 (SETQ R2X2 R2X1)))
754	(SETQ R2Y1 (PROG1 R2Y2 (SETQ R2Y2 R2Y1)))))
755	(< R1X1 R2X1))
756
757	(DEFUN RUN-LEFT-PROBE-Y-LOCN-< (R1 R2 &AUX R1X1 R1Y1 R1X2 R1Y2 R2X1 R2Y1 R2X2 R2Y2)
758	(MULTIPLE-VALUE (R1Y1 R1X1) (CTEST-MAPLOC (CAR (CADR R1))))
759	(MULTIPLE-VALUE (R1Y2 R1X2) (CTEST-MAPLOC (CAR (LAST (CADR R1)))))
760	(COND ((< R1X1 R1X2) ;left probe takes wire with greater X
761	(SETQ R1X1 (PROG1 R1X2 (SETQ R1X2 R1X1)))
762	(SETQ R1Y1 (PROG1 R1Y2 (SETQ R1Y2 R1Y1)))))
763	(MULTIPLE-VALUE (R2Y1 R2X1) (CTEST-MAPLOC (CAR (CADR R2))))
764	(MULTIPLE-VALUE (R2Y2 R2X2) (CTEST-MAPLOC (CAR (LAST (CADR R2)))))
765	(COND ((< R2X1 R2X2) ;left probe takes wire with greater X
766	(SETQ R2X1 (PROG1 R2X2 (SETQ R2X2 R2X1)))
767	(SETQ R2Y1 (PROG1 R2Y2 (SETQ R2Y2 R2Y1)))))
768	(< R1Y1 R2Y1))
769
770	(DEFUN CTEST-TOTAL-TRAVEL (&OPTIONAL (RUNS CTEST-RUNS) (SEGMENTS 10000000))
771	(PROG (X1 X2 Y1 Y2 CR ANS P RX1 RY1 RX2 RY2 DIST)
772	(SETQ ANS 0 P RUNS)
773	(COND ((NULL P) (RETURN ANS)))
774	(SETQ CR (CAR P))
775	(MULTIPLE-VALUE (Y1 X1) (CTEST-MAPLOC (CAR (CADR CR))))
776	(MULTIPLE-VALUE (Y2 X2) (CTEST-MAPLOC (CAR (LAST (CADR CR)))))
777	(COND ((< X1 X2) ;left probe takes wire with greater X
778	(SETQ X1 (PROG1 X2 (SETQ X2 X1)))
779	(SETQ Y1 (PROG1 Y2 (SETQ Y2 Y1)))))
780	(SETQ P (CDR P))
781	L (COND ((OR (< (SETQ SEGMENTS (1- SEGMENTS)) 0)
782	(NULL P))
783	(RETURN ANS)))
784	(SETQ CR (CAR P))
785	(MULTIPLE-VALUE (RY1 RX1) (CTEST-MAPLOC (CAR (CADR CR))))
786	(MULTIPLE-VALUE (RY2 RX2) (CTEST-MAPLOC (CAR (LAST (CADR CR)))))
787	(COND ((< RX1 RX2)
788	(SETQ RX1 (PROG1 RX2 (SETQ RX2 RX1)))
789	(SETQ RY1 (PROG1 RY2 (SETQ RY2 RY1)))))
790	(SETQ DIST (+ (ABS (- RX1 X1)) (ABS (- RY1 Y1))
791	(ABS (- RX2 X2)) (ABS (- RY2 Y2))))
792	(SETQ X1 RX1 Y1 RY1 X2 RX2 Y2 RY2)
793	(SETQ ANS (+ ANS DIST))
794	(SETQ P (CDR P))
795	(GO L)))
796
797	(DEFUN CTEST-SEGMENT-TRAVEL (R1 R2)
798	(PROG (X1 X2 Y1 Y2 RX1 RY1 RX2 RY2)
799	(MULTIPLE-VALUE (Y1 X1) (CTEST-MAPLOC (CAR (CADR R1))))
800	(MULTIPLE-VALUE (Y2 X2) (CTEST-MAPLOC (CAR (LAST (CADR R1)))))
801	(COND ((< X1 X2) ;left probe takes wire with greater X
802	(SETQ X1 (PROG1 X2 (SETQ X2 X1)))
803	(SETQ Y1 (PROG1 Y2 (SETQ Y2 Y1)))))
804	(MULTIPLE-VALUE (RY1 RX1) (CTEST-MAPLOC (CAR (CADR R2))))
805	(MULTIPLE-VALUE (RY2 RX2) (CTEST-MAPLOC (CAR (LAST (CADR R2)))))
806	(COND ((< RX1 RX2)
807	(SETQ RX1 (PROG1 RX2 (SETQ RX2 RX1)))
808	(SETQ RY1 (PROG1 RY2 (SETQ RY2 RY1)))))
809	(RETURN (+ (ABS (- RX1 X1)) (ABS (- RY1 Y1))
810	(ABS (- RX2 X2)) (ABS (- RY2 Y2))))))
811
812	(DEFUN CTEST-N-OPTIMIZE (N &OPTIONAL (RUNS CTEST-RUNS))
813	(PROG (LP L)
814	(SETQ LP (VALUE-CELL-LOCATION 'RUNS) L (LENGTH RUNS))
815	L (COND ((NULL (CDR LP)) (RETURN RUNS)))
816	(RPLACD LP (COND ((<= L N)
817	(CTEST-PERMUTE (CDR LP)))
818	(T
819	(NCONC (CTEST-PERMUTE (FIRSTN N (CDR LP)))
820	(NTHCDR N (CDR LP))))))
821	(SETQ LP (CDR LP) L (1- L))
822	(GO L)
823	))
824
825	(DEFUN CTEST-DIF (RL1 RL2)
826	(PROG (C)
827	(SETQ C 0)
828	L (COND ((OR (NULL RL1) (NULL RL2)
829	(NOT (EQUAL (CAR RL1) (CAR RL2))))
830	(RETURN C)))
831	(SETQ C (1+ C) RL1 (CDR RL1) RL2 (CDR RL2))
832	(GO L)))
833
834	;FIRST FROB IS STARTING POINT, LAST ENDING POINT, SO ACTUAL PERMUTATION IS
835	; ON N-2 FROBS.
836	(DEFUN CTEST-PERMUTE (SEG)
837	(PROG (BSF BSF-DIST P1 P2 DIST P2-DIST TRY TRY-RESULT TRY-DIST)
838	(COND ((NULL (CDR SEG)) (RETURN SEG 0))
839	((NULL (CDDR SEG)) (RETURN SEG (CTEST-SEGMENT-TRAVEL (CAR SEG) (CADR SEG))))
840	((NULL (CDDDR SEG)) (RETURN SEG (+ (CTEST-SEGMENT-TRAVEL (CAR SEG)
841	(CADR SEG))
842	(CTEST-SEGMENT-TRAVEL (CADR SEG)
843	(CADDR SEG))))))
844	(SETQ P1 (CAR SEG) SEG (CDR SEG))
845	(DOTIMES (C (1- (LENGTH SEG)))
846	(SETQ P2 (NTH C SEG))
847	(SETQ P2-DIST (CTEST-SEGMENT-TRAVEL P1 P2))
848	(COND ((OR (NULL BSF-DIST)
849	(< P2-DIST BSF-DIST))
850	(MULTIPLE-VALUE (TRY-RESULT TRY-DIST)
851	(CTEST-PERMUTE (SETQ TRY (CONS P2 (BUTNTH C SEG)))))
852	(SETQ DIST (+ TRY-DIST P2-DIST))
853	(COND ((OR (NULL BSF-DIST)
854	(< DIST BSF-DIST))
855	(SETQ BSF TRY-RESULT BSF-DIST DIST))))))
856	(RETURN (CONS P1 BSF) BSF-DIST)))
857
858	;RANDOMIZE, LEAVING FIRST AND LAST THE SAME.
859	(DEFUN CTEST-RANDOMIZE (RUNS &AUX N C FIRST LAST MIDDLE)
860	(SETQ FIRST (CAR RUNS) LAST (CAR (LAST RUNS)) MIDDLE (BUTLAST (CDR RUNS)))
861	(SETQ N (LENGTH MIDDLE))
862	(DOTIMES (X N)
863	(SETQ C (RANDOM N))
864	(SETQ MIDDLE (CONS (NTH C MIDDLE) (BUTNTH C MIDDLE))))
865	(NCONC (LIST FIRST) MIDDLE (LIST LAST)))
866
867	(DEFUN BUTNTH (N LST)
868	(NCONC (FIRSTN N LST) (NTHCDR (1+ N) LST)))
869
870	;CHOOSE A WIRE AT RANDOM (THE FIRST ONE ACTUALLY). THEN FIND THE WIRE THAT
871	; CAN BE TESTED WITH THE LEAST PROBE MOVEMENT, ETC.
872	(DEFUN CTEST-SORT (RUNS)
873	(PROG (ANS P CR X1 Y1 X2 Y2 OR RX1 RY1 RX2 RY2 DIST PP LPP BSF BSF-LPP BSF-DIST TEM
874	WC)
875	(SETQ ANS (APPEND RUNS NIL))
876	(SETQ P ANS) ;FIRST ELEM P POINTS AT CONSIDERED SORTED. REST NOT.
877	L0 (COND ((NULL P)
878	(RETURN ANS)))
879	(SETQ CR (CAR P))
880	(MULTIPLE-VALUE (Y1 X1) (CTEST-MAPLOC (CAR (CADR CR))))
881	(MULTIPLE-VALUE (Y2 X2) (CTEST-MAPLOC (CAR (LAST (CADR CR)))))
882	(COND ((< X1 X2) ;left probe takes wire with greater X
883	(SETQ X1 (PROG1 X2 (SETQ X2 X1)))
884	(SETQ Y1 (PROG1 Y2 (SETQ Y2 Y1)))))
885	(SETQ LPP P PP (CDR P) BSF NIL BSF-LPP NIL)
886	(SETQ WC 0)
887	L (COND ((NULL PP)
888	(GO GOBBLE)))
889	(SETQ OR (CAR PP))
890	(MULTIPLE-VALUE (RY1 RX1) (CTEST-MAPLOC (CAR (CADR OR))))
891	(MULTIPLE-VALUE (RY2 RX2) (CTEST-MAPLOC (CAR (LAST (CADR OR)))))
892	(COND ((< RX1 RX2)
893	(SETQ RX1 (PROG1 RX2 (SETQ RX2 RX1)))
894	(SETQ RY1 (PROG1 RY2 (SETQ RY2 RY1)))))
895	(SETQ DIST (+ (ABS (- RX1 X1)) (ABS (- RY1 Y1))
896	(ABS (- RX2 X2)) (ABS (- RY2 Y2))))
897	(COND ((OR (NULL BSF)
898	(< DIST BSF-DIST))
899	(SETQ BSF OR BSF-LPP LPP BSF-DIST DIST)))
900	(COND ((AND BSF (OR (> (SETQ WC (1+ WC)) 50.)
901	(> (ABS (- RX1 X1))
902	BSF-DIST))) ;CANT FIND A BETTER ONE
903	(GO GOBBLE)))
904	(SETQ LPP PP PP (CDR PP))
905	(GO L)
906	GOBBLE (COND (BSF-LPP
907	(SETQ TEM (CDR BSF-LPP)) ;SAVE PNTR TO THIS GUY
908	(RPLACD BSF-LPP (CDDR BSF-LPP)) ;SPLICE HIM OUT
909	(RPLACD TEM (CDR P)) ;UNSORTED TAIL
910	(COND ((EQ P TEM) (BREAK FOO T)))
911	(RPLACD P TEM))) ;ADD TO SORTED PART
912	(SETQ P (CDR P))
913	(GO L0)
914	))
915
916
917	(DEFUN CTEST-READLINES (STREAM &OPTIONAL (SKIP-COUNT 0) (READ-COUNT 100000))
918	(PROG (P V TEM)
919	(DOTIMES (C SKIP-COUNT) ;FLUSH THOSE
920	(COND ((EQ (SETQ TEM (READLINE STREAM 'EOF)) 'EOF)
921	(RETURN NIL)))
922	(RETURN-ARRAY TEM))
923	(SETQ P (VALUE-CELL-LOCATION 'V))
924	L (COND ((OR (< (SETQ READ-COUNT (1- READ-COUNT)) 0)
925	(EQ (SETQ TEM (READLINE STREAM 'EOF)) 'EOF))
926	(RETURN V)))
927	(RPLACD P (SETQ P (LIST TEM)))
928	(GO L)))
929
930	(DEFUN CTEST-UNCONVERT-RUN (RUN)
931	(LIST (CAR RUN) (MAPCAR (FUNCTION CTEST-GETLOC) (CADR RUN))))
932
933	(DEFUN CTEST-CONVERT-RUN (RUN)
934	(LIST (CAR RUN) (MAPCAR (FUNCTION CTEST-LOC) (CADR RUN))))
935
936	(DEFUN CTEST-PRINT-RUNS (&OPTIONAL (RUNS CTEST-RUNS))
937	(DOLIST (RUN RUNS)
938	(PRINT (CTEST-CONVERT-RUN RUN))))
939
940	(DEFUN CTEST-PARSE-RUNS (LINES)
941	(PROG (PTR RUN-NAME TYPE SYM LOC CURRENT-RUN RUNS RUNP)
942	(SETQ PTR LINES
943	RUNP (VALUE-CELL-LOCATION 'RUNS))
944	L0 (IF (NULL PTR) (FERROR NIL "unable to find runs part of wlr file"))
945	(MULTIPLE-VALUE (TYPE SYM LOC) (CTEST-LINE-TYPE (CAR PTR)))
946	(SETQ PTR (CDR PTR))
947	(IF (NEQ TYPE 'PAGE-HEADER) (GO L0))
948	(IF (NOT (STRING-EQUAL (CAR PTR) "SIGNAL NAME" 0 0 11. 11.))
949	(GO L0))
950	L (COND ((NULL PTR) (RETURN RUNS)))
951	(MULTIPLE-VALUE (TYPE SYM LOC) (CTEST-LINE-TYPE (CAR PTR)))
952	(COND ((EQ TYPE 'RUN-HEADER)
953	(SETQ RUN-NAME SYM)
954	(SETQ CURRENT-RUN (NCONC CURRENT-RUN (LIST LOC))))
955	((EQ TYPE 'RUN-NAME)
956	(SETQ RUN-NAME SYM))
957	((EQ TYPE 'RUN-ITEM)
958	(SETQ CURRENT-RUN (NCONC CURRENT-RUN (LIST LOC))))
959	((EQ TYPE 'BLANK)
960	(COND (CURRENT-RUN
961	(RPLACD RUNP (SETQ RUNP (LIST (LIST RUN-NAME CURRENT-RUN))))))
962	(SETQ CURRENT-RUN NIL)))
963	(SETQ PTR (CDR PTR))
964	(GO L)))
965	;Returns line type:
966	; RUN-HEADER starts with signal name, followed by pin number
967	; RUN-NAME starts with signal name, then nothing else at all.
968	; Wirelister puts this out when signal name is too long.
969	; RUN-ITEM blank first field, followed by pin number
970	; RANDOM non-null, but unable to make sense out of it
971	; BLANK (completely blank, or starts with 2 tabs)
972
973	(DEFUN CTEST-LINE-TYPE (LINE)
974	(PROG (LEN CH SYM IDX LOC)
975	(SETQ IDX 0)
976	(COND ((OR (ZEROP (SETQ LEN (ARRAY-ACTIVE-LENGTH LINE)))
977	(AND (> LEN 1)
978	(= (AR-1 LINE 0) #\TAB)
979	(= (AR-1 LINE 1) #\TAB)))
980	(RETURN 'BLANK) )
981	((= (SETQ CH (AR-1 LINE IDX)) #\FORM)
982	(RETURN 'PAGE-HEADER))
983	((AND (< CH 128.)
984	(NOT (= CH #\SPACE)))
985	(MULTIPLE-VALUE (SYM IDX)
986	(CTEST-GETSYL LINE IDX '(#\TAB))) ;SPACE CAN BE PART OF SIG NAME
987	(COND ((OR (= IDX LEN)
988	(AND (< (+ IDX 4) LEN) ;"NC" IS FOLLOWED BY A BUNCH OF TABS!
989	(= (AR-1 LINE IDX) #\TAB)
990	(= (AR-1 LINE (1+ IDX)) #\TAB)
991	(= (AR-1 LINE (+ 2 IDX)) #\TAB)
992	(= (AR-1 LINE (+ 3 IDX)) #\TAB)))
993	(RETURN 'RUN-NAME SYM NIL)))))
994	(COND ((AND (= (AR-1 LINE IDX) #\TAB)
995	(SETQ LOC (CTEST-GETLOC LINE (1+ IDX))))
996	(RETURN (COND (SYM 'RUN-HEADER)
997	(T 'RUN-ITEM))
998	SYM
999	LOC)))
1000	(RETURN 'RANDOM)
1001	))
1002
1003	(DEFUN CTEST-GETSYL (STRING IDX &OPTIONAL (TERMS '(#\SPACE #\TAB)))
1004	(PROG (CH LIM FIN)
1005	(SETQ LIM (ARRAY-ACTIVE-LENGTH STRING))
1006	L0 (COND ((NOT (< IDX LIM))
1007	(RETURN NIL IDX))
1008	((MEMQ (SETQ CH (AR-1 STRING IDX)) TERMS)
1009	(SETQ IDX (1+ IDX))
1010	(GO L0)))
1011	(SETQ FIN (1+ IDX))
1012	L1 (COND ((OR (NOT (< FIN LIM))
1013	(MEMQ (SETQ CH (AR-1 STRING FIN)) TERMS))
1014	(RETURN (NSUBSTRING STRING IDX FIN) FIN)))
1015	(SETQ FIN (1+ FIN))
1016	(GO L1)))
1017
1018	(ctest-conn-and-socket-init)
1019	(lg684-init)

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format