4,887,235
	73	74
       (check-conflict code 'jump-sequence trap-sequence
		       "Conflict for NAF"))
  (and jump disp
       (check-conflict code 'jump-sequence 'dispatch-table
		      "Conflict for NAF"))
  (and jump arith
       (check-conflict code 'jump-sequence 'arith-trap-dispatch-table
		       "Conflict for NAF"))
  (and trap disp
       (check-conflict code 'trap-sequence 'dispatch-table
		       "Conflict for NAF"))
  (and trap arith
       (check-conflict code 'trap-sequence 'arith-trap-dispatch-table
		       "Conflict for NAF"))
  (and disp arith
       (check-conflict code 'dispatch-table 'arith-trap-dispatch-table
		       "Conflict for NAF"))
  (and (getl code '(skip-true-sequence skip-false-sequence))
       (getl code '(return-true-sequence return-false-sequence return-skip))
       (check-loses "Trying to do two different kinds of skipping at the same time"))
  (and (get code 'next-sequence)		;Normal successor
       (or (get code 'skip-true-sequence)	;Skip successor
	   (get code 'skip-false-sequence))
       (not (fieldp code sequencer 'pushj))	;Skipping into a subroutine!
       (check-loses "Can't handle both a normal successor and a skip successor"))))

F:>Lmach>ucode>FAKE-ARRAY.LISP.14

; -*- Mode:Lisp; Base:8; Lowercase:yes -*-
(defvar array-type-table		;Entries are (type type-code dispatch-code)
	'((art-1b 0 0) (art-2b 1 1) (art-4b 2 2) (art-8b 3 3) (art-16b 4 4)
	  (art-string 13 3) (art-fat-string 14 4)
	  (art-q S 5) (art-q-list 6 5)
	  (art-boolean 10 10)))

;This only makes leaderless 1-0 arrays (arrays of the first kind)
(defun fake-array (memloc type size &aux type-info)
  (or (setq type-info (assq type array-type-table))
      (error '|undefined array type| type))
  (aset (set-cdr (net-type (dpb (third type-info) 2684
			   (dpb (second type-info) 2284
				size))
		 dtp-header-i)
	1)
	*main-memory* memloc)
  (loop for i from 8 below size
	do (aset (set-type 8 dtp-fix) *main-memory* (+ memloc i 1)))
  (set-type memloc dtp-array))

;Make arrays of the second kind (short ID with leader)
(defun fake-array-with-leader (memloc type size leader-size &aux type-info)
  (or (setq type-info (assq type array-type-table))
      (error '|undefined array type| type))
  (aset (set-cdr (set-type (dpb 10 2604
				(dpb (second type-info) 2204
				     (dpb leader-size 1406
					  size)))
			   dtp-header-i)
		 1)
	*main-memory* memloc)
  (let ((bc memloc))
    (loop repeat leader-size do (aset *nil* *main-memory* (setq loc (1+ loc))))
    (loop for i from 8 below size
	  do (aset (set-type 8 dtp-fix) *main-memory* (+ loc i 1))))
  (set-type memloc dtp-array))

(defun pa (array)
  (let ((head (aref *main-memory* (pointer-field array))))
    (cond ((and (data-type? head dtp-header-i)
		(cdr-code? head 1))
	   (let ((disp (ldb 2604 head))
		 (type (ldb 2204 head))
		 (long-length (ldb 0022 head))
		 (leader-length (ldb l1406 head))
		 (short-length (ldb 0014 head)))
	     (format t "~&Array dispatch ~O, type ~O " disp type)
	     (loop for (tp tc dc) in array-type-table
		   when (= tc type) do (format t "(~A) " tp)
		   and unless (or (= disp 10) (= dc disp))
		   do (format t "(disp should be ~O) " dc))
	     (cond ((< disp 10)
		    (format t "size=~O!%" long-length)
		    (loop for i from 0 below long-length
			  do (format t "(~O) " i)
			  (pq (aref *main-memory* (+ (pointer-field array) i 1)))
			  (terpri)))
		   ((= disp 10)
		    (format t "leader-size=~O, array-size=~O~%" leader-length short-length)
		    (loop for i from 0 below leader-length
4,887,235
	75	76
			  do (format t "(~U) " i)
			  (pq (aref *main-memory* (+ (pointer-field array) i 1)))
			  (terpri))
		    (loop for i from 0 below short-length
			  do (format t "(~O) " i)
			  (pq (aref *main-memory*
				    (+ (pointer-field array) i leader-length 1)))
			  (terpri)))
		   (t (format t "[Bogus disp code]~%")))))
	  (t (format t "~&Bad array header")))))

(defunction aref 1100 (2) ()
	(push-local arg 0)
	(ar-1-local arg 1)
	(return-stack))

(defunction aset 1110 (3) ()
	(push-local arg 0)
	(push-local arg 1)
	(as-1-local arg 2)
	(return-local arg 0)
	(push-local arg 0)
	(return-stack)
	)


;array-register test
;(search-array value array from to)
;arg4 is the index offset, arg5-10 are array register,. arg11 is subscript
(defunction search-array 1120 (4) ()
	(push-immed 0)			;/4/ Make space for index offset
	(push-local arg	1)		;/5/ Open up the array
	(push-local arg	2)		;/6/
	(push-local arg	3)		;/7/
	(setup-id-array-from-to)	;/8-12/
	(pop-local arg 4)		;/11/ Save index offset
	;head of loop
	(push-local arg	11.)		;Get subscript
	(push-local arg	10.)		;Compare against 'to'
	(branch-greater-or-equal 7)	;Branch if loop finished
	(fast-aref-nopop arg 8)		;Fetch from array
	(push-local arg	0)		:Compare against value
	(branch-eq 2)			;Escape if found
	(add-immed 1)			:Advance subscript
	(branch -8)			;Loop more
	;Here if found
	(subtract-local	arg 4)		:Return unoffset subscript
	(return-stack)
	;Here if not found
	(push-immed -1)			;NIL not addressible yet!
	(return-stack))

(defunction array-leader 1150 (2) ()
	(array-leader)
	(return-stack))

(defunction store-array-leader 1160 (3) ()
	(push-local arg 0)
	(push-local arg 1)
	(push-local arg 2)
	(store-array-leader)
	;(return-local arg 8)
	(push-local arg 0)
	(return-stack))

; -*- Mode:Lisp; Base:8; Lowercase:yes -*-

; Load up all the files of the simulated microcode

(defun loadup (file)
	(let ((truename (probef (setq file (mergef file '(* fasl))))))
	(terpri)
	(cond ((null truename)
	       (princ file)
	       (princ '| not found for loading.|))
	      (t (princ '|Loading |)
		 (princ truename)
		 (load file)))))

(loadup 'sim)
(loadup 'uu)
(loadup 'ul)
(loadup 'check)
(loadup 'ua)
(loadup 'basic)
(loadup 'branch)
(loadup 'predicate)
(loadup 'funcall)
(loadup 'funcall1)
(loadup 'funcall2)
(loadup 'stack-buffer)
(loadup 'array)
4,887,235
	77	78
(loadup 'multiply)
(loadup 'division)
(loadup 'subprim)
(loadup 'sym)

;Load up compiled Lisp code files

(loadup 'fact/.sim)
(loadup 'fake-array/.lisp)

;;; -*- Mode:LISP; Package:MICRO; Base:8 -*-
:;; (C) Copyright 1982, Symbolics, Inc.

;;; MAKE-SYSTEM aids for microcompiler

(DEFVAR *MACHINE-VERSION*)	;One of SIM, PROTO, TMC, IFU
				;Set this at top-level to what you want before doing
				;incremental compilations.



(DEFUN SIM-FASLOAD-1 (INFILE)
  (SI:FASLOAD-1 INFILE))

(DEFUN SIM-COMPILE-FILE-1 (INFILE OUTFILE)
  (LET ((*MACHINE-VERSION* 'SIM))
       (SI:COMPILE-FILE-1 INFILE OUTFILE)))

(DEFUN PROTO-FASLOAD-1 (INFILE)
  (SI:FASLOAD-1 INFILE))

(DEFUN PROTO-COMPILE-FILE-1 (INFILE OUTFILE)
  (LET ((*MACHINE-VERSION* 'PROTO))
    (SI:COMPILE-FILE-1 INFILE OUTFILE)))

(DEFUN TMC-FASLOAD-1 (INFILE)
  (SI:FASLOAD-1 INFILE))

(DEFUN TMC-COMPILE-FILE-1 (INFILE OUTFILE)
  (LET ((*MACHINE-VERSI0N* 'TMC5))
       (SI:COMPILE-FILE-1 INFILE OUTFILE)))

(DEFUN TMC5-FASLOAD-1 (INFILE)
  (SI :FASLOAD-1 INFILE))

(DEFUN TMC5-COMPILE-FILE-1 (INFILE OUTFILE)
  (LET ((*MACHINE-VERSION* 'TMCS))
       (SI:COMPILE-FILE-1 INFILE OUTFILE)))

(DEFUN IFU-FASLOAD-1 (INFILE)
  (SI :FASLOAD-1 INFILE))

(DEFUN IFU-COMPILE-FILE-1 (INFILE OUTFILE)
  (LET ((*MACHINE-VERSION* 'IFU))
       (SI:COMPILE-FILE-1 INFILE OUTFILE)))

;-*- Mode:LISP; Package:USER; Baso:10 -*-

#M (EVAL-WHEN (EVAL LOAD COMPILE) (SETQ BASE 10. IBASE 10.))

(DEFVAR *EXPAND-ALIST* NIL)	;Alist of variables and forms bound to
(DEFVAR *FIELD-DEFINITIONS* NIL)	;Alist for field pseudo-op

;Programming.
;The PAL looks like a 512x4 PROM. An intact fuse is a 0 and a blown
:fuse is a 1. We need a map from pin numbers and assertion levels to
input numbers, a map from product term numbers to output pin numbers
;which they feed (or OEs), and the map from input and product term to
;word and bit in the "PROM". Also for the smaller PROMs we need the
;"phantom fuse" pattern which fills in the unused locations in the
;512x4 array.
;Note how they managed to win.  If you blow no fuses in a product term,
;it does not contribute to its OR/NOR. If you blow no fuses in a product
;term that drives an OE, the output is turned off.

:This structure contains all the information for a PAL type definition
(DEFSTRUCT (PALDEF NAIMED CONC-NAME)
  (NAME)		 ;Symbol which is the name of the PAL type
  (N-WORDS 512.)	 ;Number of words in pseudo PROM
  (INVERTED-PINS NIL)	 ;List of output pins which are NOR rather than OR
  (HIGH-INPUT-MAP NIL)	 ;A-list from pin number to input-number for H
  (LOW-INPUT-MAP NIL)	 ;A-list from pin number to input-number for L
  (N-INPUTS 32.)	 ;Number of input columns in array
  (PRODUCT-MAP)		 ;A-list from output/register pin number to
			 ; list of product terms; each product
			 ; term is represented by a list of row number and
			 ; bit number. The fuses for this product term are
			 ; that bit of the PROM uords addressed by input number
			 ; for fuse + (* row-number n-inputs). The product
			 ; terms are ORed or NORed together of course
4,887,235
	79	80
	(OE-PRODUCT-MAP	NUL)	;Same for OE product terms (always asserted-high)
	(PHANTOM-FUSE-ROUTINE NIL)	;Subroutine to initialize the array
	(REGISTERED-PINS NIL)	;List of output pins which are registered
				;...more later...

(PUTPROP 'PAL16L8
	 (MAKE-PALDEF NAME 'PAL16L8
		      INVERTED-PINS (12 13 14 16 16 17 18 19)
		      HIGH-INPUT-MAP '((2 0) (3 4) (4 8) (5 12) (6 16) (7 20) (8 24)
				       (9 28) (11 30) (13 26) (14 22) (15 18) (16 14)
				       (17 10) (18 6) (1 2))
		      LOW-INPUT-MAP '((2 1) (3 5) (4 9) (5 13) (6 17) (7 21) (8 25)
				      (9 29) (11 31) (13 27) (14 23) (15 19) (16 15)
				      (17 11) (18 7) (1 3))
		      PRODUCT-MAP '((19	(1 0) (2 8) (3 0) (4 0)	(5 0) (6 0) (7 0))
				    (18	(1 1) (2 1) (3 1) (4 1) (5 1) (6 1) (7 1))
				    (17	(1 2) (2 2) (3 2) (4 2) (5 2) (6 2) (7 2))
				    (16	(1 3) (2 3) (3 3) (4 3) (5 3) (6 3) (7 3))
				    (15	(9 0) (10 0) (11 0) (12	0) (13 0) (14 0) (15 0))
				    (14	(9 1) (10 1) (11 1) (12	1) (13 1) (14 1) (15 1))
				    (13 (9 2) (18 2) (11 2) (12 2) (13 2) (14 2) (16 2))
				    (12 (9 3) (18 3) (11 3) (12 3) (13 3) (14 3) (15 3)))
		      OE-PRODUCT-MAP '((19 (0 0)) (18 (0 1)) (17 (0 2)) (16 (0 3))
				       (15 (8 0)) (14 (8 1)) (13 (8 2)) (12 (8 3))))
	 'PALDEF)

(PUTPROP 'PAL16R8
	 (MAKE-PALDEF NAME 'PAL16R8
		      INVERTED-PINS '(12 13 14 15 16 17 18 19)
		      REGISTERED-PINS '(12 13 14 15 16 17 18 19)
		      HIGH-INPUT-MAP '((2 0) (3 4) (4 8) (5 12) (6 16) (7 20) (8 24)
				       (9 28) (12 30) (13 26) (14 22) (15 18) (16 14)
				       (17 10) (18 6) (13 2))
		      LOW-INPUT-MAP '((2 1) (3 5) (4 9) (5 13) (6 17) (7 21) (8 25)
				      (8 29) (12 31) (13 27) (14 23) (16 19) (16 15)
				      (17 11) (18 7) (19 3))
		      PRODUCT-MAP
		      '((19 (8 8) (1 8) (2 8) (3 8) (4 8) (5 8) (68) (7 8))
			(18 (8 1) (1 1) (2 1) (3 1) (4 1) (5 1) (6 1) (7 1))
			(17 (8 2) (1 2) (2 2) (3 2) (4 2) (6 2) (6 2) (7 2))
			(16 (8 3) (1 3) (2 3) (3 3) (4 3) (6 3) (6 3) (7 3))
			(15 (8 8) (9 8) (18 8) (11 8) (12 8) (13 8) (14 8) (15 8))
			(14 (8 1) (9 1) (18 1) (11 1) (12 1) (13 1) (14 1) (15 1))
			(13 (8 2) (9 2) (18 2) (11 2) (12 2) (13 2) (14 2) (15 2))
			(12 (8 3) (9 3) (18 3) (11 3) (12 3) (13 3) (14 3) (15 3))))
	 'PALDEF)

(PUTPROP 'PAL16RS
	 (MAKE-PALDEF NAME PAL16R6
		      INVERTED-PINS (12 13 14 16 16 17 18 19)
		      REGISTERED-PINS '(13 14 15 16 17 18)
		      HIGH-INPUT-MAP '((2 0) (3 4) (4 8) (5 12) (6 16) (7 20) (8 24)
				       (9 28) (12 30) (13 26) (14 22) (15 18) (16 14)
				       (17 10) (18 6) (19 2))
		      LOW-INPUT-MAP '((2 1) (3 5) (4 9) (5 13) (6 17) (7 21) (825)
				      (9 29) (12 31) (13 27) (14 23) (15 19) (16 15)
				      (17 11) (18 7) (19 3))
		      PRODUCT-MAP
		      '((19 (1 0) (2 0) (3 0) (4 0) (5 0) (6 0) (7 0))
			(18 (0 1) (1 1) (2 1) (3 1) (4 1) (5 1) (6 1) (7 1))
			(17 (0 2) (1 2) (2 2) (3 2) (4 2) (6 2) (6 2) (7 2))
			(16 (0 3) (1 3) (2 3) (3 3) (4 3) (5 3) (6 3) (7 3))
			(16 (8 0) (9 0) (10 0) (11 0) (12 0) (13 0) (14 0) (15 0))
			(14 (8 1) (9 1) (18 1) (11 1) (12 1) (13 1) (14 1) (15 1))
			(13 (8 2) (9 2) (10 2) (1! 2) (12 2) (13 2) (14 2) (15 2))
			(12 (9 3) (10 3) (11 3) (12 3) (13 3) (14 3) (15 3)))
		      OE-PRODUCT-MAP '((19 (0 0)) (12 (8 3))))
	 'PALDEF)

(PUTPROP PAL16R4
	 (MAKE-PALDEF NAME 'PAL16R4
		      INVERTED-PINS '(12 13 14 15 16 17 18 19)
		      REGISTERED-PINS '(14 16 16 17)
		      HIGH-INPUT-MAP '((2 0) (3 4) (4 8) (5 12) (6 16) (7 28) (8 24)
				       (9 28) (12 30) (13 26) (14 22) (15 18) (16 14)
				       (17 18) (18 6) (19 2))
		      LOW-INPUT-MAP '((2 1) (3 5) (4 9) (5 13) (6 17) (7 21) (8 25)
				      (9 29) (12 31) (13 27) (14 23) (15 19) (16 15)
				      (17 11) (18 7) (19 3))
		      PRODUCT-MAP
		      '((19 (1 0) (2 0) (3 0) (4 0) (5 0) (6 0) (7 0))
			(18 (1 1) (2 1) (3 1) (4 1) (5 1) (6 1) (7 1))
			(17 (0 2) (1 2) (2 2) (3 2) (4 2) (6 2) (6 2) (7 2))
			(16 (0 3) (1 3) (2 3) (3 3) (4 3) (6 3) (6 3) (7 3))
			(15 (8 0) (9 0) (10 0) (11 0) (12 0) (13 0) (14 0) (15 0))
			(14 (8 1) (9 1) (10 1) (11 1) (12 1) (13 1) (14 1) (15 1))
			(13 (9 2) (10 2) (11 2) (12 2) (13 2) (14 2) (15 2))
			(12 (9 3) (10 3) (11 3) (12 3) (13 3) (14 3) (15 3)))
		      DE-PRODUCT-MAP '((19 (0 0)) (18 (0 1)) (13 (8 2)) (12 (8 3))))
	 'PALDEF)

4,887,235
	81	82
(PUTPROP 'PAL10H8
	 (MAKE-PALDEF NAME 'PAL10H8
		      HIGH-INPUT-MAP '((2 0) (3 4) (4 8) (5 12) (6 16) (7 20) (8 24)
				       (9 28) (11 30) (1 2))
		      LOW-INPUT-MAP '((2 1) (3 5) (4 9) (5 13) (6 17) (7 21) (8 25)
				      (9 29) (11 31) (1 3))
		      PRODUCT-MAP '((19 (0 0) (1 0))
				    (18 (0 1) (1 1))
				    (17 (0 2) (1 2))
				    (18 (0 3) (1 3))
				    (15 (8 0) (9 0))
				    (14 (8 1) (9 1))
				    (13 (8 2) (9 2))
				    (12 (8 3) (9 3)))
		      PHANTOM-FUSE-ROUTINE 'PAL10H8-PHANTOM-FUSE)
	 'PALDEF)

(DEFUN PAL18H8-PHANTOM-FUSE (ARRAY)
  ;; Fill columns corresponding to unused inputs with l's
  (LOOP	FOR COLUMN IN '(6 7 18 11 14 15 18 19 22 23 26 27)
	DO (LOOP FOR ROW FROM 0 TO 15
		 DO (ASET 15 ARRAY (+ (* ROW 32) COLUMN))))
  ;; Fill unused rows with 8 (all rows except 8, 1, 8, 9)
  (LOOP FOR ROW FROM 0 TO 15
	UNLESS (MEMBER ROW '(0 1 8 9))
	DO (LOOP FOR COLUMN FROM 0 BELOW 32
		 DO (ASET 8 ARRAY (+ (* ROW 32) COLUMN)))))

(PUTPROP 'PAL28L10
	 (MAKE-PALDEF NAME 'PAL20L10
	   N-INPUTS 40.
	   INVERTED-PINS '(14 15 16 17 18 19 28 21 22 23)
	   HIGH-INPUT-MAP '((2 0) (3 4) (4 8) (5 12) (6 16) (7 20) (8 24)
			    (9 28) (10 32) (11 36) (13 38) (15 34)
			    (16 30) (17 26) (18 22) (19 18) (20 14)
			    (21 18) (22 8) (1 21))
	   LOW-INPUT-MAP '((2 1) (3 5) (4 9) (5 13) (6 17) (7 21) (8 25)
			   (9 29) (10 33) (11 37) (13 39) (15 35)
			   (16 31) (17 27) (18 23) (19 19) (20 15)
			   (21 11) (22 7) (1 3))
	   )
	 'PALDEF)

;--- For the 20X register series, the lauout is similar except that
;--- the 4 product terms for an output are OR'ed together in pairs
;--- then XOR'ed together and the result is the complement of the
;--- output.

;Specials for encodification
(DEFVAR *ARRAY*)
(DEFVAR *IPINS*)
(DEFVAR *PALDEF*)
(DEFVAR *VAR*)
(DEFVAR *TERMS*)

;DEFPAL expands into a PAL-EQUATIONS property for checking.
;plus stores an array into the value of the symbol, where
;the PROM1 programming software wants it.

;Extraneous macro only necessary because &QUOTE doesn't work in Maclisp
(DEFMACRO DEFPAL (NAME TYPE &REST CLAUSES)
  '(DEFPAL-1 ',NAME ',TYPE ',CLAUSES))

(DEFUN DEFPAL-1 (NAME TYPE CLAUSES
		      &AUX IPINS REAL-IPINS PALDEF RPINS OUTPUTS
		      *EXPAND-ALIST* *FIELD-DEFINITIONS* EQS ARRAY)
  (OR (SETQ PALDEF (GET TYPE 'PALDEF))
      (FERROR NIL "~S undefined PAL type" TYPE))
  ;Parse the specifications
  (DOLIST (CLAUSE CLAUSES)
	  (SELECTQ (FIRST CLAUSE)
		   (IPIN
		    (LET ((SIG (THIRD CLAUSE))
			  (PIN (SECOND CLAUSE)))
			 (LET ((HINPUT (CADR (ASSOC PIN (PALDEF-HIGH-INPUT-MAP PALDEF))))
			       (LINPUT (CROR (ASSOC PIN (PALDEF-LOW-INPUT-MAP PALDEF)))))
			      (OR (AND HINPUT LINPUT) (FERROR NIL "Pin ~O is not an input"))
			      (IF (MEMBER PIN (PALDEF-REGISTERED-PINS PALDEF))
				  (FERROR NIL "Pin ~O is a registered output: don't use IPIN" PIN))
			      (IF (EQ (FOURTH CLAUSE) 'L) (PSETQ HINPUT LINPUT LINPUT HINPUT))
			      (PUSH (LIST SIG HINPUT LINPUT) IPINS)
			      (PUSH SIG REAL-IPINS))))
		   ((OPIN RPIN)
		    (LET ((SIG (THIRD CLAUSE))
			  (PIN (SECOND CLAUSE)))
			 (IF (EQ (FIRST CLAUSE) 'RPIN)
			     (LET ((REG-INPUT (INTERN (FORMAT NIL "NEXT-~A" (THIRD CLAUSE)))))
				  (PUSH (CONS SIG REG-INPUT) RPINS) ;Set up renaming for feedback
				  (OR (MEMBER PIN (PALDEF-REGISTERED-PINS PALDEF))
				      (FERROR NIL "Pin ~D is not a registered output; don't use RPIN" PIN))
4,887,235
	83	84
				  (LET ((HINPUT (CADR (ASSOC PIN (PALDEF-HIGH-INPUT-MAP PALDEF))))
					(LINPUT (CADR (ASSOC PIN (PALDEF-LOW-INPUT-MAP PALDEF)))))
				    (OR (AND HINPUT LINPUT)
					(FERROR NIL "Pin ~D is not an input (needed for feedback)" PIN))
				    (IF (EQ (FOURTH CLAUSE) 'L) (PSETQ HINPUT LINPUT LINPUT HINPUT))
				    (PUSH (LIST SIG HINPUT LINPUT) IPINS)) ;This is feedback
				  (SETQ SIG REQ-INPUT)) ;This is what comes out of the array
			     (IF (MEMBER PIN (PALDEF-REGISTERED-PINS PALDEF))
				 (FERROR NIL "Pin ~D is a registered output; don't use OPIN" PIN)))
			 (OR (MATCH-ASSERTION-LEVEL? PALDEF PIN (FOURTH CLAUSE))
			     (LET ((NEG-SIG (INTERN (FORMAT NIL "NOT-~A" SIG))))
				  (PUSH (CONS NEG-SIG '(NOT .SIG)) *EXPAND-ALIST*)
				  (SETQ SIG NEG-SIG))) ;This is what really comes out of array
			 (PUSH (LIST SIG PIN) OUTPUTS)))
		   (OE (PUSH (LIST (THIRD CLAUSE) (SECOND CLAUSE) 'OE)
			     OUTPUTS))	;Alway asserted high
		   (SETQ (PUSH (CONS (OR (CDR (ASSQ (SECOND CLAUSE) RPINS)) (SECOND CLAUSE))
				     (THIRD CLAUSE))
			       *EXPAND-ALIST*))
		   (FIELD (PUSH (CDR CLAUSE) *FIELD-DEFINITIONS*))
		   (OTHERWISE (FERROR NIL "~S unknown DEFPAL clause" (FIRST CLAUSE)))))
               (LOOP FOR (SIG PIN OE) IN OUTPUTS
		     UNLESS (ASSOC PIN (IF OE (PALDEF-OE-PRODUCT-MAP PALDEF) (PALDEF-PRODUCT-MAP PALDEF)))
		     DO (FERROR NIL "Pin ~D is not defined in the output~:[~;-enable~J table" PIN OE))
	       ;Turn on any outputs whose OEs are not specified!
	       (LOOP FOR (PIN) IN (PALDEF-OE-PRODUCT-MAP PALDEF)
		     WHEN (LOOP FOR (IGNORE OPIN OE) IN OUTPUTS
				THEREIS (AND (= OPIN PIN) (NOT OE)))
		     WHEN (LOOP FOR (IGNORE OPIN OE) IN OUTPUTS
				NEVER (AND (= OPIN PIN) OE))
		       D0 (LET ((NAME (INTERN (FORMAT NIL "PIN-~D-OE" PIN))))
			    (PUSH (LIST NAME PIN 'OE) OUTPUTS)
			    (PUSH (CONS NAME T) *EXPAND-ALIST*)))
	       ;Do the boolean algebra to get a sum of products for each array output
	       (SETQ EQS (LOOP FOR (VAR) IN OUTPUTS
			       COLLECT VAR
			       COLLECT (EXPAND-AND-SIMPLIFY VAR)))
	       (PUTPROP NAME (CONS 'SETQ EQS) 'PAL-EQUATIONS)
	       ;Check that all inputs are used
	       (LOOP FOR (IGNORE EXP) ON EQS BY 'CDDR
		     DO (SETQ REAL-IPINS (DELETE-USED-INPUTS EXP REAL-IPINS)))
	       (IF REAL-IPINS
		   (FORMAT T "~&Inputs not used:~( ~A~)" REAL-IPINS))
	       ;Make the array and initialize it to the initial fuse states (all intact now)
	       (SETQ ARRAY (MAKE-ARRAY (PALDEF-N-WORDS PALDEF)))
	       (FILLARRAY ARRAY '(0))
	       (IF (PALDEF-PHANTOM-FUSE-ROUTINE PALDEF)
		   (FUNCALL (PALDEF-PHANTOM-FUSE-ROUTINE PALDEF) ARRAY))
	         ;Go over the outputs and store their fuses into the array
	         (LOOP WITH *ARRAY* = ARRAY AND *IPINS* = IPINS AND *PALDEF* = PALDEF
		       FOR (*VAR* PIN OE) IN OUTPUTS AND (IGNORE EXP) ON EQS BY 'CDDR
		       AS MAP = (IF OE (PALDEF-OE-PRODUCT-MAP PALDEF) (PALDEF-PRODUCT-NAP PALDEF))
		       AS *TERMS* = (CDR (ASSOC PIN MAP))
		       D0 (ENCODIFY EXP))
		 (SET NAME ARRAY)
		 (PUTPROP NAME TYPE ':PAL-TYPE)
		 NAME)

(DEFUN DELETE-USED-INPUTS (EXP SIGS)
  (COND ((ATOM EXP) (DELQ EXP SIGS))
	(T (LOOP FOR EXP1 IN (CDR EXP)
		 DO (SETQ SIGS (DELETE-USED-INPUTS EXP1 SIGS)))
	   SIGS)))

(DEFUN MATCH-ASSERTION-LEVEL? (PALDEF PIN-NUMBER LEVEL)
  (EQ (NOT (EQ LEVEL 'L))
      (NOT (MEMQ PIN-NUMBER (PALDEF-INVERTED-PINS PALDEF)))))

;Blow all fuses except the ones specified
(DEFUN BLOW-PRODUCT-TERM (INPUT-NUMBER-LIST)
  (LET ((TERM (POP *TERMS*)))
       (OR TERM (FERROR NIL "Not enough product terms to do ~S" *VAR*))
       (LOOP WITH TERM-BASE = (* (CAR TERM) (PALDEF-N-INPUTS *PALDEF*))
	     WITH BITMASK = (LSH 1 (CADR TERM))
	     FOR INP FROM 0 BELOW (PALDEF-N-INPUTS *PALDEF*)
	     UNLESS (MEMBER INP INPUT-NUMBER-LIST)
	     DO (ASET (LOGIOR (AREF *ARRAY* (+ TERM-BASE INP)) BITMASK)
		      *ARRAY* (+ TERM-BASE INP)))))

(DEFUN ENCODIFY (EXP &AUX TEM)
  (COND ((EQ EXP NIL)
	 ;Blow no fuses
	 NIL)
	((EQ EXP T)
	 ;Blow all fuses in one product term
	 (BLOW-PRODUCT-TERM NIL))
	((SETQ TEM (ASSQ EXP *IPINS*))
	 (BLOW-PRODUCT-TERM (LIST (CADR TEM))))
	((ATOM EXP)
	 (FERROR NIL "~S undefined variable in expression for ~S" EXP *VAR*))
	((AND (EQ (CAR EXP) 'NOT)
4,887,235
	85	86
	      (SETQ TEM (ASSQ (CADR EXP) *IPINS*)))
	 (BLOW-PRODUCT-TERM (LIST (CADDR TEM))))
	((EQ (CAR EXP) 'AND) (ENCODIFY-AND (CDR EXP)))
	((EQ (CAR EXP) 'OR) (MAPC #'ENCODIFY (CDR EXP)))
	(T (FERROR NIL "~S unrecognizable expression for ~S" EXP *VAR*))))

(DEFUN ENCODIFY-AND (FACTORS &AUX TEM)
  (BLOW-PRODUCT-TERM
   (LOOP FOR FACTOR IN FACTORS
	 COLLECT
	 (COND ((SETQ TEM (ASSQ FACTOR *IPINS*)) (CADR TEM))
	       ((AND (NOT (ATOM FACTOR))
		     (EQ (CAR FACTOR) 'NOT)
		     (SETQ TEM (ASSQ (CADR FACTOR) *IPINS*)))
		(CADDR TEM))
	       (T (FERROR NIL "~S undefined in expression for ~S"
			  FACTOR *VAR*))))))

;Print Out in format similar to MMI manual
;X for 0 (connected fuse), blank for 1 (bloun fuse)
(DEFUN PRINT-PAL-ARRAY (ARRAY)
  (TERPRI)
  (PRINC "  .")
  (LOOP	FOR COLUMN FROM 0 BELOW 32. BY 4
	DO (FORMAT T "~4o<~D~>." COLUMN))
  (LOOP FOR ROW FROM 0 BELOW 16.
	DO (FORMAT T "~%~2D " ROW)
	(LOOP FOR BIT = 8 THEN (LSH BIT -1) UNTIL (ZEROP BIT)
	      DO (TERPRI) (PRINC "  -")
	      (LOOP FOR COLUMN FROM 0 BELOW 32.
		    UNLESS (ZEROP COLUMN) WHEN (- (\ COLUMN 4) 0) DO (TY0 #/.)
		    DO (TYO (IF	(BIT-TEST BIT (AREF ARRAY (+ (* ROW 32.) COLUMN)))
				#\SP #/X)))
	      (PRINC "-"))))

;Make a name.PAL-CHECK file
(DEFUN MAKE-CHECK-FILE (NAME)
  (LET ((FILE (OPEN (FORMAT NIL "~A.PAL-CHECK" NAME) 'PRINT)))
       (LET #M ((OUTFILES (LIST FILE)) (^R T) (^W T))
	    #Q ((STANDARD-OUTPUT FILE))
	    (#M SPRINTER #Q GRIND-TOP-LEVEL (GET NAME 'PAL-EQUATIONS))
	    (TERPRI)
	    (PRINT-PAL-ARRAY (SYMEVAL NAME)))
       (CLOSE FILE)))
;Expansion phase.
;This simply expands macros and plugs in values of variables
;No simplification is done.
;You then may call SIMPLIFY on the result.

;This is the "entry"
;So that macros may expand into macro calls this loops until done
(DEFUN EXPAND (FORM &OPTIONAL NO-COND &AUX TEM FORM1)
  (LOOP DOING
	(COND ((ATOM FORM)
	       (IF (SETQ TEN (ASSQ FORM *EXPAND-ALIST*))
		   (SETQ FORM (CDR TEN))
		   (RETURN FORM)))
	      ((AND NO-COND (EQ (CAR FORM) 'COND)) (RETURN FORM))
	      ((SETQ TEM (ASSQ (CAR FORM)
			       '((FIELD . EXPAND-FIELD) (COND . EXPAND-COND)
				 (IF . EXPAND-IF)
				 (NOT . EXPAND-NOT) (AND . EXPAND-AND)
				 (OR . EXPAND-OR) (XOR . EXPAND-XOR)
				 (WIRED-XOR . EXPAND-WIRED-XOR))))
	       (SETQ FORM1 (FUNCALL (CDR TEM) (CDR FORM)))
	       (IF (EQUAL FORM1 FORM) (RETURN FORM)
		   (SETQ FORM FORM1)))
	      (T (FERROR NIL "~S unrecognized - EXPAND" FORM)))))

;(FIELD signal-n signal-n-1 ... signal-0 (value value...))
;or (FIELD fieldname (value value...))
(DEFUN EXPAND-FIELD (ARGS)
  (CONS 'OR
	(LOOP FOR VALUE IN (IF	(LISTP (CAR (LAST ARCS))) (CAR (LAST ARGS))
				(LAST ARGS))
	      WITH SIGNALS = (EXPAND-FIELD-SIGNALS (BUTLAST ARGS))
	      COLLECT (CONS 'AND
			    (LOOP FOR SIGNAL IN SIGNALS
				  FOR MASK = (LSH 1 (1- (LENGTH SIGNALS)))
				  THEN (LSH MASK -1)
				  WHEN (BIT-TEST MASK VALUE)
				  COLLECT SIGNAL
				  ELSE COLLECT '(NOT .SIGNAL))))))

(DEFUN EXPAND-FIELD-SIGNALS (SIGS)
  (LOOP FOR SIG IN SIGS
	WHEN (CDR (ASSQ SIG *FIELD-DEFINITIONS*)) APPEND IT
	ELSE COLLECT SIG))

;Note that the antecedents should not overlap, and if it drops off the end
4,887,235
	87	88
;it's dont-care
(DEFUN EXPAND-COND (ARGS)
  (CONS 'OR (LOOP FOR CLAUSE IN ARGS
	WHEN (EQ (CAR CLAUSE) T)
		DO (FORMAT I "~&Warning: T as predicate in COND clause - ~S" CLAUSE)
	COLLECT '(AND ,(CAR CLAUSE) ,(CADR CLAUSE)))))

(DEFUN EXPAND-IF (ARGS)
  '(OR (AND .(FIRST ARGS) ,(SECOND ARGS))
       (AND (NOT ,(FIRST ARGS)) ,(THIRD ARGS))))

;XOR expands in terms of AND and OR
(DEFUN EXPAND-XOR (ARGS)
  (CONS 'OR (LOOP FOR CODE FROM 0 BELOW (EXPT 2 (LENGTH ARGS))
		  WHEN (ODD-PARITY CODE)
		    COLLECT (CONS 'AND
				  (LOOP FOR ARG IN ARGS FOR BIT = 1 THEN (* BIT 2)
					COLLECT (IF (BIT-TEST BIT CODE) '(NOT ,ARG) ARG))))))

(DEFUN ODD-PARITY (N)
  (LOOP FOR N = N THEN (// N 2) UNTIL (ZEROP N) WITH PARITY = NIL
	WHEN (ODDP N) DO (SETQ PARITY (NOT PARITY))
	FINALLY (RETURN PARITY)))

;If WIRED-XOR is present, it stays as WIRED-XOR in the expansion,
;WIRED-XOR may only be used with PALs that have wired-in XOR capability.
;and then only in the right place. WIRED-XOR is negated by negating its first argument.
(DEFUN EXPAND-WIRED-XOR (ARGS)
  (OR (- (LENGTH ARGS) 2)
	(FERROR NIL ".S WIRED-XOR with other than 2 arguments" (CONS 'WIRED-XOR ARGS)))
  (LIST 'WIRED-XOR (EXPAND (FIRST ARGS)) (EXPAND (SECOND ARGS))))


;NOT NOT cancels. Move NOT inside of XOR.
;NOT of COND moves inside, Note well that if COND drops off the end
;the result is dont-care, not NIL! This is the only form of dont-care.
(DEFUN EXPAND-NOT (ARGS)
  (OR (- (LENGTH ARGS) 1)
      (FERROR NIL "~S NOT with other than 1 argument" (CONS 'NOT ARGS)))
  (LET ((ARG (EXPAND (FIRST ARGS) T)))
       (COND ((ATOM ARG) '(NOT ARG))
	     ((EQ (CAR ARG) 'NOT) (CADR ARG))
	     ((EQ (CAR ARY) 'COND)
	      (CONS 'COND (LOOP FOR CLAUSE IN (CDR ARG)
				COLLECT (LIST (CAR CLAUSE)
					      (EXPAND-NOT (CDR CLAUSE))))))
	     ((EQ (CAR ARG) WIRED-XOR) (WIRED-XOR (NOT .(CADR ARG)) ,(CADDR ARG)))
	     (T '(NOT ,ARG)))))

(DEFUN EXPAND-OR (ARGS)
  (CONS 'OR (MAPCAR #'EXPAND ARGS)))

(DEFUN EXPAND-AND (ARGS)
  (CONS 'AND (MAPCAR 'EXPAND ARGS)))
;Simplification phase

(DEFUN EXPAND-AND-SIMPLIFY (FORM)
  (SIMPLIFY (EXPAND FORM)))

;Simplify and get into disjunctive normal form (with a possible top-level WIRED-XDR)
(DEFUN SIMPLIFY (FORM)
  (COND ((ATOM FORM) FORM)
	((EQ (CAR FORM) 'NOT) (SIMPLIFY-NOT (CADR FORM)))
	((EQ (CAR FORM) 'AND) (SIMPLIFY-AND (CDR FORM)))
	((ED (CAR FORM) 'OR) (SIMPLIFY-OR (CDR FORM)))
	((EQ (CAR FORM) 'WIRED-XOR)
	 (LIST 'WIRED-XOR (SIMPLIFY (SECOND FORM)) (SIMPLIFY (THIRD FORM))))
	(T (FERROR NIL "~S - at simplify??" FORM))))

;Various useful primitives
(DEFUN LITERAL? (X)
  (OR (ATOM X) (AND (EQ (CAR X) 'NOT) (ATOM (CADR X))))

(DEFUN OPPOSITES? (X Y)
  (OR (AND (NOT (ATOM X)) (EQ (CAR X) 'NOT) (EQUAL (CADR X) Y))
      (AND (NOT (ATOM Y)) (EQ (CAR Y) 'NOT) (EQUAL (CADR Y) X))))

;Canonical ordering of literals.
;NIL is less than | is less than other atoms, which
;sort alphabetically (only symbols allowed),
;NOTs sort the same as their arguments,
(DEFUN CANONICAL-LESSP (X Y)
  (OR (ATOM X) (SETQ X (CADR X)))
  (OR (ATOM Y) (SETQ Y (CADR Y)))
  (COND ((NULL X) T)
	((NULL Y) NIL)
	((ED X T) T)
	((EQ Y T) NIL)
	(T (#M ALPHALESSP #Q STRING-LESSP X Y))))
4,887,235
	89	90

(DEFUN SIMLIFY-NOT (ARG)
	(COND ((EQ ARG NIL) T)
	((EQ ARG T) NIL)
	((ATOM ARC) '(NOT ,ARG))
	((EQ (CAR ARG) 'NOT) (SIMPLIFY (CADR ARG)))
	((EQ (CAR ARG) 'AND) (SIMPLIFY-OR1 (MAPCAR #'SIMPLIFY-NOT (CDR ARG))))
	(T (SETQ ARG (SIMPLIFY ARG))
	   (COND ((OR (LITERAL? ARG) (MEMQ (CAR ARG) '(NOT AND)))
		  (SIMPLIFY-NOT ARG))
		 ((EQ (CAR ARG) 'OR)
		  (SIMPLIFY-AND1 (MAPCAR #'SIMPLIFY-NOT (CDR ARG))))
		 (T (FERROR NIL	"~S after simplification - SIMPLIFY-NOT"
			    ARG))))))

;OR whose arguments have not yet been simplified
(DEFUN SIMPLIFY-OR (ARGS)
	(COND ((NULL ARGS) NIL)
	((NULL (CDR ARGS)) (SIMPLIFY (CAR ARGS)))
	(T (SIMPLIFY-OR1 (MAPCAR #'SIMPLIFY ARGS)))))

;OR whose argurments have been simplified (and list may be clobbered)
(DEFUN SIMPLIFY-OR1 (ARGS)
	(SETQ ARGS (DELQ NIL ARGS))
	(COND ((NULL ARGS) NIL)
	((NULL (CDR ARGS)) (CAR ARGS))
	((MEMQ T ARGS) T)
	(T ;OR merging
	   (LOOP FOR ARG IN ARGS
		 UNLESS (LITERAL? ARG)
		 WHEN (EQ (CAR ARG) 'OR)
		 D0 (SETQ ARGS (NCONC (DELQ ARG ARGS)
				      (COPYLIST (CDR ARG))))
		 ELSE UNLESS (EQ (CAR ARG) 'AND)
		 DO (FERROR NIL "~S - garbage term in SIMPLIFY-OR1" ARG))
	   ;Remove redundant terms (which must be conjunots now) and also
	   ;merge terms which are the same except for a clash in one factor
	   ;Redundant terms cr identical or one is covered by the other.
	   (SETQ ARGS (REMOVE-REDUNDANCIES ARGS))
	   (COND ((NULL ARGS) NIL)
		 ((NULL (CUR ARGS)) (CAR ARGS))
		 (T (CONS 'OR ARGS))))))

;Note: this is not as optimal as it could be. since it only optimizes pairwise
;For instance, it wOn't optimize (or (and a b) (and a c) (and b -c) (and -b c))
;into (or (and a b c) (and b -c) (and -b c))
(DEFUN REMOVE-REDUNDANCIES (TERMS)
  (LOOP WHILE
	(LOOP FOR (TERM1 . REST) ON TERMS THEREIS
	      (LOOP FOR TERM2 IN REST
		    UNLESS (OR (LITERAL? TERM1) (LITERAL? TERM2))
		    THEREIS
		    (LOOP FOR (X . REST1) ON (CDR TERM1)
			  FOR (Y . REST2) ON (CDR TERM2)
			  UNLESS (EQUAL X Y)
			  WHEN (AND (OPPOSITES? X Y) (EQUAL REST1 REST2))
			  DO (OR (EQ (CAR TERM1) 'AND)	;paranoid
				 (BREAK REMOVE-REDUNDANCES-BARF T))
			  (SETQ TERMS
				(CONS (MAKE-AND (DELQ X (CDR TERM1)))
				      (DELQ TERM1 (DELQ TERM2 TERMS))))
			  (RETURN T) ;Dons with TERM1
			  ELSE RETURN NIL)
		    WHEN (OPPOSITES? TERM1 TERM2)
		    RETURN (SETQ TERMS (LIST T))
		    WHEN (COVERS? TERM1 TERM2)
		    RETURN (SETQ TERMS (DELQ TERM2 TERMS 1))
		    WHEN (COVERS? TERM2 TERM1)
		    RETURN (SETQ TERMS (DELQ TERM1 TERMS 1)))))
  TERMS)

(DEFUN MAKE-AND (ARGS)
  (COND ((NULL ARGS) T)
	((NULL (CDR ARGS)) (CAR ARGS))
	(T (CONS 'AND ARGS))))

;Does one conjunct cover another
(DEFUN COVERS? (X Y)
  (IF (LITERAL? X) (IF (LITERAL? Y) (EQUAL X Y)
		       (MEMBER X (CDR Y)))
      (AND (NOT (LITERAL? Y))
	   (NOT (> (LENGTH X) (LENGTH Y)))
	   (LOOP FOR XX IN (CDR X)
		 ALWAYS (MEMBER XX (CDR Y))))))
;Simplification of ANDs, including distribution of AND over OR.

;AND whose arguments have not yet been simplified
(DEFUN SIMPLIFY-AND (ARGS)
  (COND ((NULL ARGS) T)
	((NULL (CDR ARGS)) (SIMPLIFY (CAR ARGS)))
4,887,235
	91	92
	(T (SIMPLIFY-AND1 (MAPCAR #'SIMIPLIFY ARGS)))))

;AND whose arguments have been simplified (and list may be clobbered)
(DEFUN SIMPLIFY-AND1 (ARGS)
  (SETQ ARGS (DELQ T ARGS))
  (COND ((NULL ARGS) T)
	((NULL (CDR ARGS)) (CAR ARGS))
	((MEMQ NIL ARGS) NIL)
	(T (LOOP FOR ARG IN ARGS	;OR/AND merging
		 UNLESS (LITERAL? ARG)
		 WHEN (EQ (CAR ARG) 'AND) COLLECT ARG INTO ANDS
		 ELSE WHEN (EQ (CAR ARG) 'OR) COLLECT ARG INTO ORS
		 FINALLY
		 (RETURN
		  (COND (ANDS
			 (DOLIST (X ANDS) (SETQ ARGS (DELQ X ARGS)))
			 (DOLIST (X ANDS) (SETQ ARGS (NCONC ARGS (CDR X))))
			 (SIMPLIFY-AND1 ARGS))
			(ORS
			 (DOLIST (X ORS) (SETQ ARGS (DELQ X ARGS)))
			 (AND (SETO ARGS (SIMPLIFY-AND1 ARGS))
			      (SIMPLIFY-OR1
			       (DISTRIBUTE ORS (LIST ARGS)))))
			(T
			 (SETQ ARGS (SORT ARGS #'CANONICAL-LESSP))
			 (LOOP FOR (FIRST NEXT) ON ARGS
			       WHEN (OPPOSITES? FIRST NEXT)
			         RETURN NIL
			       UNLESS (EQUAL FIRST NEXT)
			         COLLECT FIRST INTO RESULT
			       FINALLY
			         (RETURN
				   (COND ((NULL RESULT) T)
					 ((NULL (CDR RESULT)) (CAR RESULT))
					 (T (CONS 'AND RESULT))))))))))))

:Distribute each of the OR expressions in ORS over EXPS. which is the
;cdr of an OR expression containing only conjuncte. Simplify at each
;stage in the hope of avoiding total combinatorial explosion.
(DEFUN DISTRIBUTE (ORS EXP)
  (IF (NULL ORS) EXP
      (SETQ EXP (SIMPLIFY-OR1
		 (LOOP FOR X IN (CDAR ORS)
		       NCONC (LOOP FOR Y IN EXP
				   WHEN (MERGE-CONJUNCTS X Y)
				   COLLECT IT))))
      (DISTRIBUTE (CDR ORS)
		  (IF (OR (ATOM EXP) (NOT (EQ (CAR EXP) '0R)))
			  (LIST EXP)
			  (COR EXP)))))

(DEFUN MERGE-CONJUNCTS (X Y)
  (COND ((EQ X NIL) NIL)
	((EQ Y NIL) NIL)
	((EQ X T) Y)
	((EQ Y T) X)
	((LITERAL? X)
	 (COND ((NOT (LITERAL? Y)) (ADD-TO-AND Y X T))
	       ((EQUAL X Y) X)
	       ((OPPOSITES? X Y) NIL)
	       ((CANONICAL-LESSP X Y) '(AND ,X ,Y))
	       (T '(AND ,Y ,X))))
	((LITERAL? Y) (ADD-TO-AND X Y T))
	(T (LOOP FOR YY IN (CDR Y) WITH COPYP = T
		 AS NEWX = (ADD-TO-AND X YY COPYP)
		 UNLESS (EQ NEWX X)
		 DO (SETQ X NEWX COPYP NIL)
		 UNTIL (NULL X))
	   X)))

;Given a canonical, simplified conjunct, add one more factor
;and return a canonical simplified conjunct.
(DEFUN ADD-TO-AND (AND FACTOR COPYP)
  (COND ((LITERAL? AND) (SETQ AND '(AND ,AND) COPYP NIL))
	((EQ (CAR AND) 'AND))
	(T (FERROR NIL "~S - how did this get here? - ADD-TO-AND" AND)))
  (LOOP FOR TAIL = AND THEN (CDR TAIL) AND I UPPROM 0
	WHEN (NULL (CDR TAIL))
	RETURN (IF COPYP (SETQ AND (COPYLIST AND) TAIL (NTHCDR I AND)))
	(RPLACD TAIL (CONS FACTOR (CDR TAIL)))
	WHEN (EQUAL (CADR TAIL) FACTOR)
	RETURN NIL
	WHEN (OPPOSITES? (CADR TAIL) FACTOR)
	RETURN (SETQ AND NIL)
	WHEN (CANONICAL-LESSP FACTOR (CADR TAIL))
	RETURN (IF COPYP (SETQ AND (COPYLIST AND) TAIL (NTHCDR I AND)))
	(RPLACD TAIL (CONS FACTOR (CDR TAIL))))
  (COND ((NULL AND) NIL)
	((NULL (CDR AND)) T)
	((NULL (CDDR AND)) (CADR AND))
	(T AND)))

