
;-*-Mode:Midas-*-

(SETQ UC-FCTNS '(
;;; CAR AND CDR

;; XCAR and XCDR are the misc instructions.

;; QCAR and QCDR are for use as subroutines;
;; they take arg in M-T and return value in M-T.
;; QCDR-SB is like QCDR but allows sequence breaks;
;; use it in preference to QCDR except when you cannot
;; tell whether a sequence break is safe.

;; QMA and QMD are old names for QCAR and QCDR.
;; They are used only by the microcompiler.

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAR M-T)

XCAR   (MISC-INST-ENTRY M-CAR)
	((M-T) Q-TYPED-POINTER PDL-POP)
QMA
   (ERROR-TABLE RESTART CAR)
QCAR	(DISPATCH (I-ARG INSTANCE-INVOKE-CAR) Q-DATA-TYPE M-T CAR-PRE-DISPATCH)
	;; I-ARG is in case go to QCARCDR-INSTANCE.
   (ERROR-TABLE ARGTYP CONS M-T T CAR CAR)
;; Drop through for CAR of a CONS.
QCAR3	((VMA-START-READ) M-T)
QCAR4	(CHECK-PAGE-READ)  
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT MD)
       ((M-T) Q-TYPED-POINTER MD)

;; Here for taking CAR of a symbol.
QCARSY	(DISPATCH-XCT-NEXT M-CAR-SYM-MODE CAR-SYM-DISPATCH)
       ((M-T) Q-TYPED-POINTER M-T)
   (ERROR-TABLE ARGTYP CONS M-T T CAR CAR)
	(POPJ-EQUAL M-T A-V-NIL)
	(CALL TRAP)
   (ERROR-TABLE ARGTYP CONS M-T T CAR CAR)

;; Here for taking CAR of a number.
QCARNM	(DISPATCH M-CAR-NUM-MODE CAR-NUM-DISPATCH)
   (ERROR-TABLE ARGTYP CONS M-T T CAR CAR)

;; Here for CAR or CDR of an instance.  Send a message to it.
;; I-ARG already set up to say what operation we do.
QCARCDR-INSTANCE
	(CALL INSTANCE-INVOKE-1)
	((ARG-CALL MMCALL) (I-ARG 1))	;Call, 1 arg.  Value comes back in M-T.
	(POPJ)

;; Like QCDR but takes sequence breaks.
QCDR-SB
	(DISPATCH (I-ARG INSTANCE-INVOKE-CDR) Q-DATA-TYPE M-T CDR-PRE-DISPATCH)
	;; I-ARG is in case go to QCARCDR-INSTANCE.
   (ERROR-TABLE ARGTYP CONS M-T T CDR CDR)
;; Drop through for CDR of a CONS.
	((VMA-START-READ) M-T)
	(CHECK-PAGE-READ-SEQUENCE-BREAK)
	(JUMP QCDR-SB-1)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDR M-T)

XCDR   (MISC-INST-ENTRY M-CDR)
	((M-T) Q-TYPED-POINTER PDL-POP)
QMD   
   (ERROR-TABLE RESTART CDR)
QCDR	(DISPATCH (I-ARG INSTANCE-INVOKE-CDR) Q-DATA-TYPE M-T CDR-PRE-DISPATCH)
	;; I-ARG is in case go to QCARCDR-INSTANCE.
   (ERROR-TABLE ARGTYP CONS M-T T CDR CDR)
;; Drop through for CDR of a CONS.
QCDR3	((VMA-START-READ) M-T)
	(CHECK-PAGE-READ)  
QCDR-SB-1
	(DISPATCH TRANSPORT-CDR MD)	;Check for invz, don't really transport.
	(DISPATCH Q-CDR-CODE MD CDR-CDR-DISPATCH)
   (ERROR-TABLE BAD-CDR-CODE VMA)
;; Does POPJ-XCT-NEXT to do this insn for case of CDR-NEXT.
       ((M-T) ADD VMA (A-CONSTANT 1))	;Same data type as arg.

QCDRSY	(DISPATCH-XCT-NEXT M-CDR-SYM-MODE CDR-SYM-DISPATCH)
       ((M-T) Q-TYPED-POINTER M-T)
   (ERROR-TABLE ARGTYP CONS M-T T CDR CDR)
	(POPJ-EQUAL M-T A-V-NIL)
	(CALL TRAP)
   (ERROR-TABLE ARGTYP CONS M-T T CDR CDR)

QCDRNM	(DISPATCH M-CDR-NUM-MODE CDR-NUM-DISPATCH)
   (ERROR-TABLE ARGTYP CONS M-T T CDR CDR)

CDR-FULL-NODE 
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-READ)  
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT MD) ;CHECK FOR INVISIBLE, GC
       ((M-T) Q-TYPED-POINTER MD)

CDR-IS-NIL 
   (MISC-INST-ENTRY FALSE)
XFALSE 	(POPJ-AFTER-NEXT (M-T) A-V-NIL)
       (NO-OP)

;; CDR of SYMBOL, in the mode where that gets the plist.
QCDPRP	((M-T) Q-TYPED-POINTER M-T)
	(JUMP-EQUAL M-T A-V-NIL XFALSE)		;CDR of NIL is still NIL,
 	((M-T) ADD (A-CONSTANT 3) M-T)
	(JUMP-XCT-NEXT QCDR)
       ((M-T) DPB M-T Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
 
;; Take car into M-A and cdr into M-T at same time.
;; By default, allow sequence breaks.
CARCDR	(DISPATCH Q-DATA-TYPE M-T SKIP-IF-LIST)
	 (JUMP CARCDR-NOT-LIST)
	((VMA-START-READ) M-T)
	(CHECK-PAGE-READ-SEQUENCE-BREAK)
	(DISPATCH TRANSPORT MD)
	(JUMP-NOT-EQUAL-XCT-NEXT VMA A-T QCDR3)
       ((M-A) Q-TYPED-POINTER MD)
	(DISPATCH Q-CDR-CODE MD CDR-CDR-DISPATCH)
   (ERROR-TABLE BAD-CDR-CODE VMA)
;; Does POPJ-XCT-NEXT to do this insn for case of CDR-NEXT.
       ((M-T) ADD VMA (A-CONSTANT 1))

CARCDR-NOT-LIST
	((PDL-PUSH) M-T)
	(CALL QCAR)
	((M-A) M-T)
	((M-T) PDL-POP)
	(JUMP QCDR)

;;; Take car into M-A and cdr into M-T at same time.
CARCDR-NO-SB
	(DISPATCH Q-DATA-TYPE M-T SKIP-IF-LIST)
	 (JUMP CARCDR-NOT-LIST)
	((VMA-START-READ) M-T)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT MD)
	(JUMP-NOT-EQUAL-XCT-NEXT VMA A-T QCDR3)
       ((M-A) Q-TYPED-POINTER MD)
	(DISPATCH Q-CDR-CODE MD CDR-CDR-DISPATCH)
   (ERROR-TABLE BAD-CDR-CODE VMA)
;; Does POPJ-XCT-NEXT to do this insn for case of CDR-NEXT.
       ((M-T) ADD VMA (A-CONSTANT 1))

(LOCALITY D-MEM)
(START-DISPATCH 5 0)
;DISPATCH ON DATA TYPE BEFORE TAKING CAR
;IF DROPS THROUGH, NORMAL LIST-TYPE CAR
CAR-PRE-DISPATCH 
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;TRAP
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;NULL
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;FREE
	(INHIBIT-XCT-NEXT-BIT QCARSY)		;SYMBOL
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SYMBOL-HEADER
	(INHIBIT-XCT-NEXT-BIT QCARNM)		;FIX
	(INHIBIT-XCT-NEXT-BIT QCARNM)		;EXTENDED NUMBER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;GC-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ONE-Q-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;HEADER-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;BODY-FORWARD
	(P-BIT R-BIT)				;LOCATIVE
	(P-BIT R-BIT)				;LIST
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;U CODE ENTRY
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-GROUP
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;CLOSURE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SMALL-FLONUM 
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SELECT-METHOD
	(INHIBIT-XCT-NEXT-BIT QCARCDR-INSTANCE)	;INSTANCE (send message)
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ENTITY (eventually send message?)
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-CLOSURE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SELF-REF-POINTER
	(INHIBIT-XCT-NEXT-BIT QCARNM)		;CHARACTER
 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT TRAP))
(END-DISPATCH)

(START-DISPATCH 5 0)
;DISPATCH ON INPUT DATA TYPE WHEN TAKING CDR
;DROP THROUGH IF NORMAL LIST-TYPE CDR
CDR-PRE-DISPATCH
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;TRAP
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;NULL
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;FREE
	(INHIBIT-XCT-NEXT-BIT QCDRSY)		;SYMBOL
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SYMBOL-HEADER
	(INHIBIT-XCT-NEXT-BIT QCDRNM)		;FIX
	(INHIBIT-XCT-NEXT-BIT QCDRNM)		;EXTENDED NUMBER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;GC-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ONE-Q-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;HEADER-FORWARD
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;BODY-FORWARD
	(INHIBIT-XCT-NEXT-BIT QCAR3)		;LOCATIVE.  NOTE CAR!!
	(P-BIT R-BIT)				;LIST
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;U CODE ENTRY
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;FEF
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-POINTER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ARRAY-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-GROUP
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;CLOSURE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SMALL-FLONUM 
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SELECT-METHOD
	(INHIBIT-XCT-NEXT-BIT QCARCDR-INSTANCE)	;INSTANCE (send message)
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;INSTANCE-HEADER
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;ENTITY (eventually send message?)
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;STACK-CLOSURE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;SELF-REF-POINTER
	(INHIBIT-XCT-NEXT-BIT QCDRNM)		;CHARACTER
 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT TRAP))
(END-DISPATCH)
(LOCALITY I-MEM)

(LOCALITY D-MEM)
(START-DISPATCH 2 0)	;MAYBE DOES XCT-NEXT
;DISPATCH ON CDR-CODE WHEN TAKING CDR
;POPJ-XCT-NEXT IF CDR-NEXT (PROBABLY MOST FREQUENT CASE)
CDR-CDR-DISPATCH 
	(INHIBIT-XCT-NEXT-BIT CDR-FULL-NODE)	;FULL-NODE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;CDR NOT
	(INHIBIT-XCT-NEXT-BIT CDR-IS-NIL)	;CDR NIL
	(R-BIT)					;CDR NEXT
(END-DISPATCH)

(START-DISPATCH 2 0)
;DISPATCH ON M-CAR-SYM-MODE WHEN TAKING CAR OF SYM
CAR-SYM-DISPATCH 
	(P-BIT TRAP)	;ERROR
	(P-BIT R-BIT)	;ERROR EXCEPT (CAR NIL) = NIL
	(XFALSE)	;NIL
	(P-BIT TRAP)	;UNUSED
(END-DISPATCH)

(START-DISPATCH 2 INHIBIT-XCT-NEXT-BIT)
;DISPATCH ON M-CAR-NUM-MODE WHEN TAKING CAR OF NUM
CAR-NUM-DISPATCH
	(P-BIT TRAP)	;ERROR
	(XFALSE)	;NIL
	(P-BIT TRAP)	;"WHATEVER IT IS"
	(P-BIT TRAP)	;ERROR
(END-DISPATCH)

(START-DISPATCH 2 0)
;DISPATCH ON M-CDR-SYM-MODE WHEN TAKING CDR OF SYM
CDR-SYM-DISPATCH
	(P-BIT TRAP)	;ERROR
	(P-BIT R-BIT)	;ERROR EXCEPT (CDR NIL) = NIL
	(R-BIT)		;NIL -> NIL
	(QCDPRP)	;PROPERTY LIST
(END-DISPATCH)

(START-DISPATCH 2 INHIBIT-XCT-NEXT-BIT)
;DISPATCH ON M-CDR-NUM-MODE WHEN TAKING CDR OF NUM
CDR-NUM-DISPATCH 
	(P-BIT TRAP)	;ERROR
	(XFALSE)	;NIL
	(P-BIT TRAP)	;"WHATEVER IT IS"
	(P-BIT TRAP)
(END-DISPATCH)
(LOCALITY I-MEM)

;; Multiple CAR/CDR functions.

;; XCAAR, etc. pop arg off stack and return value in M-T.
;; They generally clobber M-A to save the original argument for errors.

;; QCDDR, like QCAR and QCDR, is for use as a subroutine from the microcode.
;; It takes arg in M-T and returns value in M-T.
;; If any other multiple car/cdr function is needed as a subroutine,
;; create a QC...R entry point name for it.

;; QMAA, QMDD, etc. are obsolete names for QCAAR, QCDDR, etc.,
;; still used by the microcompiler.  Eventually this series of names
;; should go away and the QCAAR series used for both purposes.
;; Meanwhile, QMAA ... should not be referred to except from this page.
;; and the following page.

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADDDR M-A)

XCADDDR (MISC-INST-ENTRY CADDDR)
	((M-A) Q-TYPED-POINTER PDL-TOP)
	((M-T) Q-TYPED-POINTER PDL-POP)
QMADDD 	(CALL QCDR)
QMADD 	(CALL QCDR)
QMAD 	(CALL QCDR)
	(JUMP QCAR)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAAAAR M-A)

XCAAAAR	(MISC-INST-ENTRY CAAAAR)
	((M-T) Q-TYPED-POINTER PDL-POP)
	((M-A) M-T)
QMAAAA 	(CALL QCAR)
QMAAA  	(CALL QCAR)
QMAA   	(CALL QCAR)
	(JUMP QCAR)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDDDR M-A)

XCDDDDR (MISC-INST-ENTRY CDDDDR)
	((M-A) Q-TYPED-POINTER PDL-TOP)
	((M-T) Q-TYPED-POINTER PDL-POP)
QMDDDD 	(CALL QCDR)
QMDDD 	(CALL QCDR)
QMDD 	(CALL QCDR)
	(JUMP QCDR)

QCDDR	(JUMP-XCT-NEXT QCDR)
       (CALL QCDR)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAAADR M-A)

XCAAADR (MISC-INST-ENTRY CAAADR)
 	(CALL-XCT-NEXT QCDR)
       ((M-T) Q-TYPED-POINTER PDL-TOP)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QMAAA)
       ((M-A) Q-TYPED-POINTER PDL-POP)

QMAAAD 	(CALL QCDR)
	(JUMP QMAAA)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDDAR M-A)

XCDDDAR (MISC-INST-ENTRY CDDDAR)
 	(CALL-XCT-NEXT QCAR)
       ((M-T) Q-TYPED-POINTER PDL-TOP)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QMDDD)
       ((M-A) Q-TYPED-POINTER PDL-POP)

QMDDDA 	(CALL QCAR)
	(JUMP QMDDD)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAADDR M-A)

XCAADDR (MISC-INST-ENTRY CAADDR)
	((M-T) Q-TYPED-POINTER PDL-POP)
	((M-A) M-T)
QMAADD 	(CALL QCDR)
QMAAD  	(CALL QCDR)
	(JUMP QMAA)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAADAR M-A)

XCAADAR (MISC-INST-ENTRY CAADAR)
 	(CALL-XCT-NEXT QCAR)
       ((M-T) Q-TYPED-POINTER PDL-TOP)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QMAAD)
       ((M-A) Q-TYPED-POINTER PDL-POP)

QMAADA 	(CALL QCAR)
	(JUMP QMAAD)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDAAR M-A)

XCDDAAR (MISC-INST-ENTRY CDDAAR)
	((M-T) Q-TYPED-POINTER PDL-POP)
	((M-A) M-T)
QMDDAA 	(CALL QCAR)
QMDDA  	(CALL QCAR)
	(JUMP QMDD)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDADR M-A)

XCDDADR (MISC-INST-ENTRY CDDADR)	
 	(CALL-XCT-NEXT QCDR)
       ((M-T) Q-TYPED-POINTER PDL-TOP)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QMDDA)
       ((M-A) Q-TYPED-POINTER PDL-POP)

QMDDAD 	(CALL QCDR)
	(JUMP QMDDA)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADAAR M-A)

XCADAAR (MISC-INST-ENTRY CADAAR)
	((M-T) Q-TYPED-POINTER PDL-POP)
	((M-A) M-T)
QMADAA 	(CALL QCAR)
QMADA  	(CALL QCAR)
	(JUMP QMAD)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADADR M-A)

XCADADR (MISC-INST-ENTRY CADADR)
 	(CALL-XCT-NEXT QCDR)
       ((M-T) Q-TYPED-POINTER PDL-TOP)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QMADA)
       ((M-A) Q-TYPED-POINTER PDL-POP)

QMADAD 	(CALL QCDR)
	(JUMP QMADA)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADDAR M-A)

XCADDAR (MISC-INST-ENTRY CADDAR)
 	(CALL-XCT-NEXT QCAR)
       ((M-T) Q-TYPED-POINTER PDL-TOP)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QMADD)
       ((M-A) Q-TYPED-POINTER PDL-POP)

QMADDA 	(CALL QCAR)
	(JUMP QMADD)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDADAR M-A)

XCDADAR (MISC-INST-ENTRY CDADAR)
	((M-T) Q-TYPED-POINTER PDL-POP)
	((M-A) M-T)
QMDADA 	(CALL QCAR)
QMDAD  	(CALL QCDR)
	(JUMP QMDA)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDADDR M-A)

XCDADDR (MISC-INST-ENTRY CDADDR)
 	(CALL-XCT-NEXT QCDR)
       ((M-T) Q-TYPED-POINTER PDL-TOP)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(CALL-XCT-NEXT QCDR)
       ((M-A) Q-TYPED-POINTER PDL-POP)
	(JUMP QMDA)

QMDADD 	(CALL QCDR)
	(JUMP QMDAD)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDAAAR M-A)

XCDAAAR (MISC-INST-ENTRY CDAAAR)
	((M-T) Q-TYPED-POINTER PDL-POP)
	((M-A) M-T)
QMDAAA 	(CALL QCAR)
QMDAA  	(CALL QCAR)
QMDA   	(CALL QCAR)
	(JUMP QCDR)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDAADR M-A)

XCDAADR (MISC-INST-ENTRY CDAADR)
 	(CALL-XCT-NEXT QCDR)
       ((M-T) Q-TYPED-POINTER PDL-TOP)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QMDAA)
       ((M-A) Q-TYPED-POINTER PDL-POP)

QMDAAD 	(CALL QCDR)
	(JUMP QMDAA)


;For CAAAR ... CDDDR, the arg is in M-A whenever an error occurs.

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAAAR M-A)

XCAAAR (MISC-INST-ENTRY CAAAR)
	((M-T) Q-TYPED-POINTER PDL-POP)
	(JUMP-XCT-NEXT QMAAA)
       ((M-A) M-T)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAADR M-A)

XCAADR (MISC-INST-ENTRY CAADR)
	((M-T) Q-TYPED-POINTER PDL-POP)
	(JUMP-XCT-NEXT QMAAD)
       ((M-A) M-T)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADAR M-A)

XCADAR (MISC-INST-ENTRY CADAR)
	((M-T) Q-TYPED-POINTER PDL-POP)
	(JUMP-XCT-NEXT QMADA)
       ((M-A) M-T)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADDR M-A)

XCADDR (MISC-INST-ENTRY CADDR)
	((M-T) Q-TYPED-POINTER PDL-POP)
	(JUMP-XCT-NEXT QMADD)
       ((M-A) M-T)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDAAR M-A)

XCDAAR (MISC-INST-ENTRY CDAAR)
	((M-T) Q-TYPED-POINTER PDL-POP)
	(JUMP-XCT-NEXT QMDAA)
       ((M-A) M-T)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDADR M-A)

XCDADR (MISC-INST-ENTRY CDADR)
	((M-T) Q-TYPED-POINTER PDL-POP)
	(JUMP-XCT-NEXT QMDAD)
       ((M-A) M-T)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDAR M-A)

XCDDAR (MISC-INST-ENTRY CDDAR)
	((M-T) Q-TYPED-POINTER PDL-POP)
	(JUMP-XCT-NEXT QMDDA)
       ((M-A) M-T)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDDR M-A)

XCDDDR (MISC-INST-ENTRY CDDDR)
	((M-T) Q-TYPED-POINTER PDL-POP)
	(JUMP-XCT-NEXT QMDDD)
       ((M-A) M-T)

;For CAAR ... CDDR, the arg is in M-A unless an ARG-POPPED says it is elsewhere.

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAAR M-A)

XCAAR  (MISC-INST-ENTRY M-CAAR)
	(CALL-XCT-NEXT QCAR)
       ((M-T) Q-TYPED-POINTER PDL-TOP)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QCAR)
       ((M-A) Q-TYPED-POINTER PDL-POP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADR M-A)

XCADR  (MISC-INST-ENTRY M-CADR)
	(CALL-XCT-NEXT QCDR)
       ((M-T) Q-TYPED-POINTER PDL-TOP)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QCAR)
       ((M-A) Q-TYPED-POINTER PDL-POP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDAR M-A)

XCDAR  (MISC-INST-ENTRY M-CDAR)
	(CALL-XCT-NEXT QCAR)
       ((M-T) Q-TYPED-POINTER PDL-TOP)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QCDR)
       ((M-A) Q-TYPED-POINTER PDL-POP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDR M-A)

XCDDR  (MISC-INST-ENTRY M-CDDR)
	(CALL-XCT-NEXT QCDR)
       ((M-T) Q-TYPED-POINTER PDL-TOP)
    (ERROR-TABLE ARG-POPPED 0 PP)
	(JUMP-XCT-NEXT QCDR)
       ((M-A) Q-TYPED-POINTER PDL-POP)

XSETELT (MISC-INST-ENTRY SETELT)
	((PDL-INDEX) SUB PDL-POINTER (A-CONSTANT 2))
	((M-1) Q-DATA-TYPE C-PDL-BUFFER-INDEX)
	(JUMP-EQUAL M-1 (A-CONSTANT (EVAL DTP-ARRAY-POINTER)) XSET-AR-1)
	(CALL-XCT-NEXT XNTHCDR-REVERSE)
       ((M-D) Q-TYPED-POINTER PDL-POP)
	((M-S) M-T)
	((M-T) M-D)
	(JUMP-XCT-NEXT XSETCAR1)
       ((M-A) M-T)

XELT (MISC-INST-ENTRY ELT)
	((PDL-INDEX) SUB PDL-POINTER (A-CONSTANT 1))
	((M-1) Q-DATA-TYPE C-PDL-BUFFER-INDEX)
	(JUMP-EQUAL M-1 (A-CONSTANT (EVAL DTP-ARRAY-POINTER)) Xcommon-lisp-AR-1)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QCAR)))
XNTHCDR-REVERSE
		(ERROR-TABLE RESTART XNTHCDR0)
	(DISPATCH Q-DATA-TYPE PDL-TOP TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP 0 XNTHCDR0)
	(CALL-IF-BIT-SET-XCT-NEXT BOXED-SIGN-BIT PDL-TOP TRAP)
       ((M-B) Q-TYPED-POINTER PDL-TOP)
	    (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP 0 XNTHCDR0)
	((M-1) Q-POINTER PDL-POP)		;Count
	((M-T) Q-TYPED-POINTER PDL-POP)	;List
	(JUMP XNTHCDR-0)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS NTH PP M-T)
(ERROR-TABLE DEFAULT-ARG-LOCATIONS NTHCDR PP M-T)

;Drops in
XNTH (MISC-INST-ENTRY NTH)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QCAR)))
	;drops in
XNTHCDR (MISC-INST-ENTRY NTHCDR)
	((M-T) Q-TYPED-POINTER PDL-POP)	;List
		(ERROR-TABLE RESTART XNTHCDR0)
	(DISPATCH Q-DATA-TYPE PDL-TOP TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP 0 XNTHCDR0)
	(CALL-IF-BIT-SET-XCT-NEXT BOXED-SIGN-BIT PDL-TOP TRAP)
       ((M-B) Q-TYPED-POINTER PDL-TOP)
	    (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP 0 XNTHCDR0)
	((M-1) Q-POINTER PDL-POP)		;Count
XNTHCDR-0
	(POPJ-EQUAL-XCT-NEXT M-1 A-ZERO)
       ((M-A) M-T)
XNTHCDR-1
	(POPJ-EQUAL M-T A-V-NIL)
	(CALL M-T A-V-NIL QCDR-SB)
	    (ERROR-TABLE CALLS-SUB NTHCDR)
	    (ERROR-TABLE ARG-POPPED 0 M-B M-A)
	(JUMP-GREATER-THAN-XCT-NEXT M-1 (A-CONSTANT 1) XNTHCDR-1)
       ((M-1) SUB M-1 (A-CONSTANT 1))
	(POPJ)

;; Leave the CDR on the stack and return the CAR.

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CARCDR M-T)

XCARCDR (MISC-INST-ENTRY CARCDR)
	(CALL-XCT-NEXT CARCDR)
       ((M-T) Q-TYPED-POINTER PDL-POP)
	(POPJ-AFTER-NEXT
	 (PDL-PUSH) M-T)
       ((M-T) M-A)

;; "Safe" forms of CAR, CDR etc.
;; These treat any non-list as NIL, and never get an error
;; if the arg is a valid Lisp object.

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADR-SAFE M-T)

XCADR-SAFE (MISC-INST-ENTRY CADR-SAFE)
	(CALL-XCT-NEXT CDR-SAFE)
;; DROPS THRU with XCT-NEXT!

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAR-SAFE M-T)

;; DROPS THRU with XCT-NEXT!
XCAR-SAFE (MISC-INST-ENTRY CAR-SAFE)
	((M-T) Q-TYPED-POINTER PDL-POP)
CAR-SAFE
	((M-1) Q-DATA-TYPE M-T)
	(JUMP-XCT-NEXT QCAR)
       (JUMP-NOT-EQUAL M-1 (A-CONSTANT (EVAL DTP-LIST)) XFALSE)


(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDR-SAFE M-T)

XCDDR-SAFE (MISC-INST-ENTRY CDDR-SAFE)
	(CALL-XCT-NEXT CDR-SAFE)
;; DROPS THRU with XCT-NEXT!

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDR-SAFE M-T)

;; DROPS THRU with XCT-NEXT!
XCDR-SAFE (MISC-INST-ENTRY CDR-SAFE)
	((M-T) Q-TYPED-POINTER PDL-POP)
CDR-SAFE
	((M-1) Q-DATA-TYPE M-T)
	(JUMP-XCT-NEXT QCDR-SB)
       (JUMP-NOT-EQUAL M-1 (A-CONSTANT (EVAL DTP-LIST)) XFALSE)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDDDR-SAFE M-T)

XCDDDDR-SAFE (MISC-INST-ENTRY CDDDDR-SAFE)
	(CALL XCDDR-SAFE)
	(CALL CDR-SAFE)
	(JUMP CDR-SAFE)


(ERROR-TABLE DEFAULT-ARG-LOCATIONS NTH-SAFE PP M-T)
(ERROR-TABLE DEFAULT-ARG-LOCATIONS NTHCDR-SAFE PP M-T)

;Drops in
XNTH-SAFE (MISC-INST-ENTRY NTH-SAFE)
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC CAR-SAFE)))
	;drops in
XNTHCDR-SAFE (MISC-INST-ENTRY NTHCDR-SAFE)
	((M-T) Q-TYPED-POINTER PDL-POP)	;List
		(ERROR-TABLE RESTART XNTHCDR-SAFE-0)
	(DISPATCH Q-DATA-TYPE PDL-TOP TRAP-UNLESS-FIXNUM)
	    (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP 0 XNTHCDR-SAFE-0)
	(CALL-IF-BIT-SET-XCT-NEXT BOXED-SIGN-BIT PDL-TOP TRAP)
       ((M-B) Q-TYPED-POINTER PDL-TOP)
	    (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP 0 XNTHCDR-SAFE-0)
	((M-1) Q-POINTER PDL-POP)		;Count
	(POPJ-EQUAL-XCT-NEXT M-1 A-ZERO)
       ((M-A) M-T)
XNTHCDR-SAFE-1
	(POPJ-EQUAL M-T A-V-NIL)
	(CALL CDR-SAFE)
	    (ERROR-TABLE CALLS-SUB NTHCDR-SAFE)
	    (ERROR-TABLE ARG-POPPED 0 M-B M-A)
	(JUMP-GREATER-THAN-XCT-NEXT M-1 (A-CONSTANT 1) XNTHCDR-SAFE-1)
       ((M-1) SUB M-1 (A-CONSTANT 1))
	(POPJ)

;;; RPLACA AND RPLACD

  (ERROR-TABLE DEFAULT-ARG-LOCATIONS RPLACA M-S M-T)
  (MISC-INST-ENTRY RPLACA)
XRPLCA	((M-T) Q-TYPED-POINTER PDL-POP)
	((M-S) Q-TYPED-POINTER PDL-POP)
QRAR1	((M-A) M-S)
;; M-A has the value we should return; differs for RPLACA vs SETCAR.
   (ERROR-TABLE RESTART RPLACA)
XSETCAR1
	(DISPATCH (I-ARG INSTANCE-INVOKE-SET-CAR) Q-DATA-TYPE M-S QRACDT)
   (ERROR-TABLE ARGTYP CONS M-S 0 RPLACA)

QRAR4	((VMA-START-READ) M-S)			;FETCH WORD TO BE SMASHED
	(CHECK-PAGE-READ)			;NO INT, CALLED BY MVR
	(DISPATCH TRANSPORT-WRITE MD)	;CHASE INVISIBLES
	((MD-START-WRITE) SELECTIVE-DEPOSIT
		MD Q-ALL-BUT-TYPED-POINTER A-T)	;STORE M-T INTO Q-TYPED-PNTR
	(CHECK-PAGE-WRITE)			;NO SEQ BRK, CALLED BY MVR (???)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       ((M-T) M-A)

;No longer used for RPLACA, but some random places still call it.
QRAR3	((VMA-START-READ) M-S)			;FETCH WORD TO BE SMASHED
	(CHECK-PAGE-READ)			;NO INT, CALLED BY MVR
	(DISPATCH TRANSPORT-WRITE MD)	;CHASE INVISIBLES
	((MD-START-WRITE) SELECTIVE-DEPOSIT
		MD Q-ALL-BUT-TYPED-POINTER A-T)	;STORE M-T INTO Q-TYPED-PNTR
	(CHECK-PAGE-WRITE)			;NO SEQ BRK, CALLED BY MVR (???)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       ((M-T) M-S)

;; Here for SETCAR or SETCDR of an instance.  Send a message to it.
;; I-ARG already set up to indicate which operation.
XSETCARCDR-INSTANCE
	((PDL-PUSH) M-A)
	((M-A) M-T)
	((M-T) M-S)		;M-S is what has the instance.  Put in M-T.
	(CALL INSTANCE-INVOKE-1)
	((PDL-PUSH) M-A)	;Pass desired car or cdr as arg.
	((ARG-CALL MMCALL) (I-ARG 2))	;Call, 2 arg.  Value comes back in M-T.
	(POPJ-AFTER-NEXT)
       ((M-T) PDL-POP)		;Ignore that value, return what we are supposed to return.

  (ERROR-TABLE DEFAULT-ARG-LOCATIONS RPLACD M-S M-T)
  (MISC-INST-ENTRY RPLACD)
;MUSTN'T CLOBBER M-C OR M-R BECAUSE CALLED BY MULTIPLE-VALUE-LIST
;NOW CLOBBERS M-S, M-T, M-I, M-A
XRPLCD	((M-T) Q-TYPED-POINTER PDL-POP)
	((M-S) Q-TYPED-POINTER PDL-POP)
QRDR1	((M-A) M-S)
;; M-A has the value we should return; differs for RPLACD vs SETCDR.
   (ERROR-TABLE RESTART RPLACD)
XSETCDR1
	(DISPATCH (I-ARG INSTANCE-INVOKE-SET-CDR) Q-DATA-TYPE M-S QRDCDT)
   (ERROR-TABLE ARGTYP CONS M-S 0 RPLACD)

QRDRSY	(DISPATCH M-CDR-SYM-MODE RPLACD-SYM-DISPATCH)
   (ERROR-TABLE ARGTYP CONS M-S 0 RPLACD)

(LOCALITY D-MEM)
(START-DISPATCH 2 INHIBIT-XCT-NEXT-BIT)
;DISPATCH ON DOING RPLACD OF SYM
RPLACD-SYM-DISPATCH
	(P-BIT TRAP)	;ERROR
	(P-BIT TRAP)	;ERROR
	(P-BIT TRAP)	;ERROR
	(QRDPRP)	;SMASH PROP LIST
(END-DISPATCH)
(LOCALITY I-MEM)

QRDPRP 	((M-S) ADD (A-CONSTANT 3) M-S)		;RPLACD ING SYMBOL (IN P-LIST MODE)
	(JUMP-XCT-NEXT XSETCDR1)
       ((M-S) DPB M-S Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))

QRDR3	((VMA-START-READ) M-S)			;GET CAR OF CONS TO BE SMASHED
	(CHECK-PAGE-READ)			;NO SEQ BRK, CDR CODE IN HAND, ALSO MVR
	(DISPATCH TRANSPORT-CDR MD) ;CHASE INVISIBLE, NO NEED TO TRANSPORT
	(DISPATCH-XCT-NEXT Q-CDR-CODE MD RPLACD-CDR-DISPATCH)
   (ERROR-TABLE BAD-CDR-CODE VMA)
       ((M-I) MD)

(LOCALITY D-MEM)
(START-DISPATCH 2 0)	;DOES XCT-NEXT
;DISPATCH ON CDR-CODE WHEN DOING RPLACD
RPLACD-CDR-DISPATCH
	(RPLACD-FULL-NODE)	;FULL NODE
	(P-BIT INHIBIT-XCT-NEXT-BIT TRAP)	;CDR NOT
	(RPLACD-NEXT-NIL)	;CDR NIL
	(RPLACD-CDR-NEXT)	;CDR NEXT
(END-DISPATCH)
(LOCALITY I-MEM)

RPLACD-FULL-NODE
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))	;GET WORD TO SMASH
	(CHECK-PAGE-READ)			;NO SEQ BRK, WORD IN HAND, ALSO MVR
	(DISPATCH TRANSPORT-WRITE MD)	;CHASE INVISIBLES
	((MD-START-WRITE) SELECTIVE-DEPOSIT	;STORE M-T INTO Q-TYPED-PNTR
		MD Q-ALL-BUT-TYPED-POINTER A-T)
	(CHECK-PAGE-WRITE)			;NO SEQ BRK, CALLED BY MVR (???)
QRDR2	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       ((M-T) M-A)

RPLACD-NEXT-NIL 
	(JUMP-EQUAL M-T A-V-NIL QRDR2)		;RPLACD WITH NIL AND CDR ALREADY NIL, NO-OP
RPLACD-CDR-NEXT 
;THIS CODE CAN SEQUENCE BREAK!!! BEWARE!!!
	((PDL-PUSH) M-A)		;SAVE THIS SO WE CAN RETURN IT
	((PDL-PUSH) VMA)		;ADDR OF CELL TO BE FORWARDED
	((MD) VMA)					;ADDRESS THE MAP
	(DISPATCH L2-MAP-STATUS-CODE D-GET-MAP-BITS) ;Ensure validity of meta bits
	((M-TEM) L2-MAP-REPRESENTATION-TYPE)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL %REGION-REPRESENTATION-TYPE-LIST)) TRAP)
    (ERROR-TABLE RPLACD-WRONG-REPRESENTATION-TYPE M-S)
    (ERROR-TABLE ARG-POPPED 0 (PP 1) M-T)
	((PDL-PUSH) M-I)		;CAR OF NEW CELL
	((PDL-PUSH) M-T)		;CDR OF NEW CELL
	(CALL-XCT-NEXT XARN)				;IN WHAT AREA WAS THE CONS?
       ((PDL-PUSH) Q-POINTER MD)	;MD HAS ORIGINAL VMA
	(CALL-XCT-NEXT QCONS)
       ((M-S) Q-TYPED-POINTER M-T)			;PASS ON THE AREA NUMBER
	((MD) DPB M-T Q-POINTER		;CLOBBER ORIGINAL "CAR"
			(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-HEADER-FORWARD)))
	((VMA-START-WRITE) PDL-POP)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       ((M-T) Q-TYPED-POINTER PDL-POP) ;RETURN THE ORIGINAL FIRST ARG

;Same as RPLACD but returns second argument (the value stored).
XSETCDR (MISC-INST-ENTRY SETCDR)
	((M-T) Q-TYPED-POINTER PDL-POP)
	((M-S) Q-TYPED-POINTER PDL-POP)
	(JUMP-XCT-NEXT XSETCDR1)
       ((M-A) M-T)		;Save the arg where QRDR1 will return it.

;Same as RPLACA but returns second argument (the value stored).
XSETCAR (MISC-INST-ENTRY SETCAR)
	((M-T) Q-TYPED-POINTER PDL-POP)
	((M-S) Q-TYPED-POINTER PDL-POP)
	(JUMP-XCT-NEXT XSETCAR1)
       ((M-A) M-T)		;Save the arg where QRAR1 will return it.

(LOCALITY D-MEM)
(START-DISPATCH 5 INHIBIT-XCT-NEXT-BIT)
;DISP ON DATA TYPE OF POINTER-TO-SMASH-CONTENTS-OF WHEN DOING RPLACA
QRACDT	(P-BIT TRAP)	;TRAP
	(P-BIT TRAP)	;NULL
	(P-BIT TRAP)	;FREE
	(P-BIT TRAP)	;SYMBOL
	(P-BIT TRAP)	;SYMBOL-HEADER
	(P-BIT TRAP)	;FIX
	(P-BIT TRAP)	;EXTENDED NUMBER
	(P-BIT TRAP)	;HEADER
	(P-BIT TRAP)	;GC-FORWARD
	(P-BIT TRAP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT TRAP)	;ONE-Q-FORWARD
	(P-BIT TRAP)	;HEADER-FORWARD
	(P-BIT TRAP)	;BODY-FORWARD
	(QRAR4)		;LOCATIVE
	(QRAR4)		;LIST
	(P-BIT TRAP)	;U CODE ENTRY
	(P-BIT TRAP)	;FEF
	(P-BIT TRAP)	;ARRAY-POINTER
	(P-BIT TRAP)	;ARRAY-HEADER
	(P-BIT TRAP)	;STACK-GROUP
	(P-BIT TRAP)	;CLOSURE
	(P-BIT TRAP)	;SMALL-FLONUM 
	(P-BIT TRAP)	;SELECT-METHOD
	(XSETCARCDR-INSTANCE)	;INSTANCE
	(P-BIT TRAP)	;INSTANCE-HEADER
	(P-BIT TRAP)	;ENTITY
	(P-BIT TRAP)	;STACK-CLOSURE
	(P-BIT TRAP)	;SELF-REF-POINTER
	(P-BIT TRAP)	;CHARACTER
 (REPEAT NQZUSD (P-BIT TRAP))
(END-DISPATCH)

(START-DISPATCH 5 INHIBIT-XCT-NEXT-BIT)
;DISPATCH ON DATA TYPE OF POINTER-TO-SMASH-CONTENTS-OF WHEN DOING RPLACD
QRDCDT	(P-BIT TRAP)	;TRAP
	(P-BIT TRAP)	;NULL
	(P-BIT TRAP)	;FREE
	(QRDRSY)	;SYMBOL
	(P-BIT TRAP)	;SYMBOL-HEADER
	(P-BIT TRAP)	;FIX
	(P-BIT TRAP)	;EXTENDED NUMBER
	(P-BIT TRAP)	;HEADER
	(P-BIT TRAP)	;GC-FORWARD
	(P-BIT TRAP)	;EXTERNAL-VALUE-CELL-POINTER
	(P-BIT TRAP)	;ONE-Q-FORWARD
	(P-BIT TRAP)	;HEADER-FORWARD
	(P-BIT TRAP)	;BODY-FORWARD
	(QRAR4)		;LOCATIVE. NOTE CAR!!
	(QRDR3)		;LIST
	(P-BIT TRAP)	;U CODE ENTRY
	(P-BIT TRAP)	;FEF
	(P-BIT TRAP)	;ARRAY-POINTER
	(P-BIT TRAP)	;ARRAY-HEADER
	(P-BIT TRAP)	;STACK-GROUP
	(P-BIT TRAP)	;CLOSURE
	(P-BIT TRAP)	;SMALL-FLONUM 
	(P-BIT TRAP)	;SELECT-METHOD
	(XSETCARCDR-INSTANCE)	;INSTANCE
	(P-BIT TRAP)	;INSTANCE-HEADER
	(P-BIT TRAP)	;ENTITY
	(P-BIT TRAP)	;STACK-CLOSURE
	(P-BIT TRAP)	;SELF-REF-POINTER
	(P-BIT TRAP)	;CHARACTER
 (REPEAT NQZUSD (P-BIT TRAP))
(END-DISPATCH)
(LOCALITY I-MEM)

;;; EQUAL

XEQUALP	(MISC-INST-ENTRY EQUALP)
	(JUMP-XCT-NEXT X-EQUAL-EQUALP)
       ((M-C) A-V-NIL)

XEQUAL	(MISC-INST-ENTRY EQUAL)
	((M-C) A-V-TRUE)

;; EQUAL and  EQUALP.
;; M-C has NIL for EQUALP, T for EQUAL.
X-EQUAL-EQUALP
	((M-T) Q-TYPED-POINTER PDL-POP)
	((M-B) Q-TYPED-POINTER PDL-POP)
;; Args in M-B, M-T.
XEQUAL-0
	(JUMP-EQUAL M-T A-B XTRUE)
	((M-1) Q-DATA-TYPE M-T)
	(JUMP-EQUAL-XCT-NEXT M-C A-V-NIL XEQUALP-0)
       ((M-2) Q-DATA-TYPE M-B)
;; For EQUAL only here.  False if args are different data types.
	(JUMP-NOT-EQUAL M-1 A-2 XFALSE)
	(JUMP-EQUAL M-1 (A-CONSTANT (EVAL DTP-EXTENDED-NUMBER)) XEQUAL-XNUM)
;; EQUALP branches back in here.
;; Args are same type, and not numbers.
XEQUALP-COMMON
	(JUMP-EQUAL M-1 (A-CONSTANT (EVAL DTP-ARRAY-POINTER)) XEQUAL-ARRAY)
	(DISPATCH Q-DATA-TYPE M-T SKIP-IF-NO-ATOM)
	(JUMP XFALSE)

	;; Now we are a list	
	((PDL-PUSH) M-T)
	(CALL-XCT-NEXT QCAR3)
       ((PDL-PUSH) M-B)
	((M-B) M-T)
	(CALL-XCT-NEXT QCAR3)
       ((M-T) PDL-TOP)
	;; If the micro stack is filling up, make new stack frame.
	(JUMP-GREATER-THAN MICRO-STACK-PNTR-AND-DATA (A-CONSTANT 10._24.)
			   XEQUAL-SLOW-RECURSE)
	;; Otherwise, test for EQUALity of the two cars.
	(CALL XEQUAL-0)

XEQUAL-CDR
	(JUMP-EQUAL M-T A-V-NIL XEQUAL-DIFFERENT-CARS)
	;; If the cars match, tail-recursively check the two cdrs.
	(CALL-XCT-NEXT QCDR-SB)
       ((M-T) PDL-POP)
	((M-B) M-T)
	(CALL-XCT-NEXT QCDR-SB)
       ((M-T) PDL-POP)
	(JUMP XEQUAL-0)

XEQUAL-DIFFERENT-CARS
	(POPJ-AFTER-NEXT (PDL-BUFFER-POINTER) SUB PDL-BUFFER-POINTER (A-CONSTANT 2))
       (NO-OP)

XEQUAL-SLOW-RECURSE
	(CALL P3ZERO)
	(JUMP-EQUAL M-C A-V-NIL XEQUALP-SLOW-RECURSE)
	(JUMP-XCT-NEXT XEQUAL-SLOW-RECURSE-1)
       ((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVC-EQUAL))

XEQUALP-SLOW-RECURSE
	((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVC-EQUALP))
XEQUAL-SLOW-RECURSE-1
	(DISPATCH TRANSPORT MD)
	((PDL-PUSH) MD)
	((PDL-PUSH) M-T)
	((PDL-PUSH) M-B)
	((ARG-CALL MMCALL) (I-ARG 2))
	(JUMP XEQUAL-CDR)

;; Read headers of both args to EQUAL.
;; Header from M-T goes in M-1.
;; Header from M-B goes in MD.
XEQUAL-READ-HEADERS
	((VMA-START-READ) M-T)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER MD)
	((M-1) MD)
	((VMA-START-READ) M-B)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER MD)
	(POPJ)

;; Here for EQUAL of two extended numbers.
;; Compare their header types first.
XEQUAL-XNUM
	(CALL XEQUAL-READ-HEADERS)
	((M-1) (LISP-BYTE %%HEADER-TYPE-FIELD) M-1)
	((M-2) (LISP-BYTE %%HEADER-TYPE-FIELD) MD)
	(JUMP-NOT-EQUAL M-1 A-2 XFALSE)
;; Header type fields match; use = to compare the numbers.
	((PDL-PUSH) M-B)
	(DISPATCH-XCT-NEXT Q-DATA-TYPE M-B D-NUMARG1)
       ((M-A) (A-CONSTANT ARITH-2ARG-EQUAL))
;; Will not fall through, since numbers are not fixnums.

;; If both arrays are strings, call STRING-EQUAL;
;; otherwise answer is NIL for EQUAL, or computed by macrocode for EQUALP.
XEQUAL-ARRAY
	(CALL XEQUAL-READ-HEADERS)
	((M-3) (LISP-BYTE %%ARRAY-NUMBER-DIMENSIONS) M-1)
	((M-2) (LISP-BYTE %%ARRAY-NUMBER-DIMENSIONS) MD)
	(JUMP-NOT-EQUAL M-3 A-2 XFALSE)	;Not same rank.
	(JUMP-NOT-EQUAL M-3 (A-CONSTANT 1) XEQUAL-ARRAY-HARD)
;; Both rank 1.
XEQUAL-STRING-1
	((M-3) (LISP-BYTE %%ARRAY-TYPE-FIELD) M-1)
	((M-2) (LISP-BYTE %%ARRAY-TYPE-FIELD) MD)
	(JUMP-EQUAL M-3 (A-CONSTANT (EVAL (LSH ART-STRING ARRAY-TYPE-SHIFT))) 
		    XEQUAL-BOTH-STRINGSP-1)
	(JUMP-NOT-EQUAL M-3 (A-CONSTANT (EVAL (LSH ART-FAT-STRING ARRAY-TYPE-SHIFT)))
		        XEQUAL-ARRAY-NOT-STRING)
XEQUAL-BOTH-STRINGSP-1
	(JUMP-EQUAL M-2 (A-CONSTANT (EVAL (LSH ART-STRING ARRAY-TYPE-SHIFT)))
		    XEQUAL-BOTH-STRINGSP-2)
	(JUMP-NOT-EQUAL M-2 (A-CONSTANT (EVAL (LSH ART-FAT-STRING ARRAY-TYPE-SHIFT)))
		        XEQUAL-ARRAY-NOT-STRING)
;; Both strings and rank 1.
XEQUAL-BOTH-STRINGSP-2
;Call STRING-EQUAL, which will check for arrays having same size and same elements.
	((PDL-PUSH) M-C)
	(JUMP-EQUAL-XCT-NEXT M-C A-V-NIL XEQUAL-BOTH-STRINGSP-3)
	((PDL-PUSH) A-ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON)
	((A-ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON) A-V-TRUE)
XEQUAL-BOTH-STRINGSP-3
	((PDL-PUSH) A-T)
	((PDL-PUSH) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) )
	((PDL-PUSH) A-B)
	((PDL-PUSH) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	((PDL-PUSH) A-V-NIL)
	(CALL XSTRING-EQUAL)			;No XCT-NEXT here
	(POPJ-AFTER-NEXT
	 (A-ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON) PDL-POP)
       ((M-C) PDL-POP)

XEQUAL-ARRAY-NOT-STRING
	(JUMP-NOT-EQUAL M-3 (A-CONSTANT (EVAL (LSH ART-1B ARRAY-TYPE-SHIFT)))
			XEQUAL-ARRAY-HARD)
	(JUMP-EQUAL M-2 (A-CONSTANT (EVAL (LSH ART-1B ARRAY-TYPE-SHIFT)))
		    XEQUAL-ARRAY-BOTH-BITVEC)
;; Arrays not strings or not rank 1.
XEQUAL-ARRAY-HARD
	(JUMP-NOT-EQUAL M-C A-V-NIL XFALSE)
XEQUAL-ARRAY-BOTH-BITVEC
	(CALL P3ZERO)
       ((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVC-EQUALP-ARRAY))
	(DISPATCH TRANSPORT MD)
	((PDL-PUSH) MD)
	((PDL-PUSH) M-T)
	((PDL-PUSH) M-B)
	((ARG-CALL MMCALL) (I-ARG 2))
	(POPJ)

;; These are only for EQUALP

;; Here when all we know is that objects are not EQ.
XEQUALP-0
	(CALL XEQUALP-1)	;Handle numeric case.
	(JUMP-NOT-EQUAL M-1 A-2 XFALSE)	;Else different types means unequal.
	(JUMP-NOT-EQUAL M-1 (A-CONSTANT (EVAL DTP-CHARACTER)) XEQUALP-COMMON)
;Both args are character objects.  Compare, ignoring bucky bits, font and case.
	((PDL-PUSH) M-B)
	((PDL-PUSH) M-T)
	(JUMP XCHAR-EQUAL)

;;Numbers are EQUALP if =
XEQUALP-1
	(DISPATCH-XCT-NEXT Q-DATA-TYPE M-T POPJ-IF-NOT-NUMBER)
       ((M-A) (A-CONSTANT ARITH-2ARG-EQUAL))
	(DISPATCH-XCT-NEXT Q-DATA-TYPE M-B POPJ-IF-NOT-NUMBER)
       ((NO-OP))
	((PDL-PUSH) M-B)
	(JUMP-XCT-NEXT QMEQL)
       ((M-GARBAGE) MICRO-STACK-DATA-POP)

;(%BLT from-address to-address n-words increment)
;Increment is usually 1, less often -1 for backwards blt.
XBLT (MISC-INST-ENTRY %BLT)
	((M-D) Q-POINTER PDL-POP)
	((M-C) Q-POINTER PDL-POP)
	((M-2) Q-POINTER PDL-POP)
	((M-1) Q-POINTER PDL-POP)
	((M-2) SUB M-2 A-D)
	((M-1) SUB M-1 A-D)
XBLT1	(JUMP-EQUAL M-C (A-CONSTANT 0) XFALSE)
	((VMA-START-READ M-1) ADD M-1 A-D)
	(CHECK-PAGE-READ)
	((VMA-START-WRITE M-2) ADD M-2 A-D)
	(CHECK-PAGE-WRITE)
	(JUMP-XCT-NEXT XBLT1)
       ((M-C) SUB M-C (A-CONSTANT 1))

XBLT-TYPED (MISC-INST-ENTRY %BLT-TYPED)
	((M-D) Q-POINTER PDL-POP)
	((M-C) Q-POINTER PDL-POP)
	((M-2) Q-POINTER PDL-POP)
	((M-1) Q-POINTER PDL-POP)
	((M-2) SUB M-2 A-D)
	((M-1) SUB M-1 A-D)
XBLT-TYPED-1
	(JUMP-EQUAL M-C (A-CONSTANT 0) XFALSE)
	((VMA-START-READ M-1) ADD M-1 A-D)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-SCAV MD)
	((VMA-START-WRITE M-2) ADD M-2 A-D)
	(CHECK-PAGE-WRITE)
	(GC-WRITE-TEST)
	(JUMP-XCT-NEXT XBLT-TYPED-1)
       ((M-C) SUB M-C (A-CONSTANT 1))

XNUMBP (MISC-INST-ENTRY NUMBERP)
	((M-T) Q-TYPED-POINTER PDL-POP)
XTNUMB	(DISPATCH-XCT-NEXT Q-DATA-TYPE M-T POPJ-IF-NOT-NUMBER)	;MC-LINKAGE
       ((M-T) A-V-NIL)
	(JUMP XTRUE)

XFIXP (MISC-INST-ENTRY INTEGERP)
	((M-T) Q-TYPED-POINTER PDL-POP)
XTFIXP	((M-TEM) Q-DATA-TYPE M-T)
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-FIX)) XTRUE)
	((M-4) (A-CONSTANT (EVAL %HEADER-TYPE-BIGNUM)))
XFXFLP	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-EXTENDED-NUMBER)) XFALSE)
	((VMA-START-READ) M-T)
	(CHECK-PAGE-READ)
	((M-T) A-V-TRUE)
	(DISPATCH TRANSPORT-HEADER MD)
	(POPJ-AFTER-NEXT (M-TEM) (LISP-BYTE %%HEADER-TYPE-FIELD) MD)
       (CALL-NOT-EQUAL M-TEM A-4 XFALSE)

XFLTP (MISC-INST-ENTRY FLOATP)
	((M-T) Q-TYPED-POINTER PDL-POP)
XTFLTP	((M-TEM) Q-DATA-TYPE M-T)
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-SMALL-FLONUM)) XTRUE)
	(JUMP-XCT-NEXT XFXFLP)
       ((M-4) (A-CONSTANT (EVAL %HEADER-TYPE-FLONUM)))

XRATIONALP (MISC-INST-ENTRY RATIONALP)
	(CALL XFIXP)
	(POPJ-NOT-EQUAL M-T A-V-NIL)
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL %HEADER-TYPE-RATIONAL)) XTRUE)
	(POPJ)

XRATIOP (MISC-INST-ENTRY RATIOP)
	(JUMP-XCT-NEXT XRATIOP1)
       ((M-4) (A-CONSTANT (EVAL %HEADER-TYPE-RATIONAL)))

XCOMPLEXP (MISC-INST-ENTRY COMPLEXP)
	((M-4) (A-CONSTANT (EVAL %HEADER-TYPE-COMPLEX)))
XRATIOP1
	((M-T) Q-TYPED-POINTER PDL-POP)
	(JUMP-XCT-NEXT XFXFLP)
       ((M-TEM) Q-DATA-TYPE M-T)

XDATTP (MISC-INST-ENTRY %DATA-TYPE)
	(POPJ-AFTER-NEXT 
	 (M-T)  PDL-POP 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))
		Q-DATA-TYPE)
       (NO-OP)

XDAT   (MISC-INST-ENTRY %POINTER)
	(POPJ-AFTER-NEXT 
	 (M-T)  PDL-POP 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))
		Q-POINTER)
       (NO-OP)

XSDATP (MISC-INST-ENTRY %MAKE-POINTER)
	(POPJ-AFTER-NEXT
	 (A-TEM1) Q-TYPED-POINTER PDL-POP)    ;ARG2, THE POINTER
       ((M-T) DPB PDL-POP Q-DATA-TYPE A-TEM1) ;ARG1, THE DATA TYPE
	
XSTND (MISC-INST-ENTRY %P-STORE-CONTENTS)
	((M-T) Q-TYPED-POINTER PDL-POP) ;NEED IN M-T FOR RETURNED VALUE
	((VMA-START-READ) PDL-POP)
	(CHECK-PAGE-READ)
	((MD-START-WRITE)
	    SELECTIVE-DEPOSIT MD Q-ALL-BUT-TYPED-POINTER A-T)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       (NO-OP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-LDB-OFFSET PP M-C M-B)

XOPLDB(MISC-INST-ENTRY %P-LDB-OFFSET)
	(JUMP-XCT-NEXT XOPLD1)			;JOIN XLDB, BUT FIRST
       (CALL XOMR0)				;REFERENCE THE LOCATION

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %LOGLDB PP M-1)

XLLDB (MISC-INST-ENTRY %LOGLDB)			;LDB FOR FIXNUMS
	(JUMP-XCT-NEXT XLLDB1)
       ((M-1) Q-POINTER PDL-POP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-LDB PP VMA)

;%P-LDB treats target Q just as 32 bits.  Data type is not interpreted.
XPLDB (MISC-INST-ENTRY %P-LDB)
	((VMA-START-READ) Q-TYPED-POINTER PDL-POP)
	(CHECK-PAGE-READ)			;VMA MAY POINT AT UNBOXED DATA.
XOPLD1  ((M-1) MD)		;VMA MAY BE LEFT POINTING AT UNBOXED DATA..
XLLDB1	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP) ;ARG1, BYTE POINTER.  MUST BE FIXNUM.
			Q-DATA-TYPE PDL-TOP TRAP-UNLESS-FIXNUM)
  (ERROR-TABLE ARGTYP FIXNUM PP 0)
	((M-K) (BYTE-FIELD 6 0) PDL-TOP)    ;GET NUMBER OF BITS
	(JUMP-EQUAL M-K A-ZERO XLDB-ZERO)  ;WANT 0 BITS, RETURN 0
					   ; (THIS IS A FAIRLY RANDOM THING TO CHECK FOR
					   ; BUT IF WE DIDNT, IT WOULD CAUSE LOSSAGE)
	(CALL-GREATER-THAN M-K (A-CONSTANT Q-POINTER-WIDTH) TRAP)
    (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0)
	((M-J) SUB M-K (A-CONSTANT 1))	   ;BYTE LENGTH MINUS ONE FIELD
	((M-E) (BYTE-FIELD 6 6) PDL-POP) ;GET NUMBER OF PLACES OVER
	((A-TEM2) SUB (M-CONSTANT 40) A-E)	  ;COMPENSATE FOR SHIFTER LOSSAGE
	(POPJ-AFTER-NEXT 
	 (OA-REG-LOW) DPB M-J A-TEM2 OAL-BYTL-1)
       ((M-T) BYTE-INST 
		M-1 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

;LDB can only extract from fixnums and bignums.  The target is considered to
; have infinite sign extension.  LDB "should" always return a positive number.
; This issue currently doesn't arise, since LDB is implemented only for
; positive-fixnum-sized bytes, i.e. a maximum of 23. bits wide.  Note the
; presence of %LOGLDB, which will load a 24-bit byte of a fixnum and return
; it as a possibly-negative fixnum.
XLDB  (MISC-INST-ENTRY LDB) (ERROR-TABLE RESTART XLDB)
	(DISPATCH Q-DATA-TYPE PDL-TOP D-NUMARG)  ;Only the second operand is
	    (ERROR-TABLE ARGTYP NUMBER PP 1 XLDB)   ;processed via NUMARG.  Thus LDB is
	    (ERROR-TABLE ARG-POPPED 0 PP PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-LDB))	    ;considered to be a one operand op.
		(ERROR-TABLE RESTART XLDB0)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)	;Arg1, byte pointer.  Must be fixnum.
			Q-DATA-TYPE PDL-TOP TRAP-UNLESS-FIXNUM)
            (ERROR-TABLE ARGTYP FIXNUM PP 0 XLDB0)
	    (ERROR-TABLE ARG-POPPED 0 PP (FIXPACK M-1))
;Fixnum case.  Data to LDB out of (arg2) sign extended in M-1.
	((M-K) (BYTE-FIELD 6 0) PDL-TOP)    ;Get number of bits
	(JUMP-EQUAL M-K A-ZERO XLDB-ZERO)  ;Want 0 bits, return 0
					   ; (This is a fairly random thing to check for
					   ; but if we didnt, it would cause lossage)
	(CALL-GREATER-THAN M-K (A-CONSTANT (DIFFERENCE Q-POINTER-WIDTH 1)) TRAP)
    (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0 XLDB0)
    (ERROR-TABLE ARG-POPPED 0 PP (FIXPACK M-1))
	((M-J) SUB M-K (A-CONSTANT 1))	   ;Byte length minus one field
	((M-E) (BYTE-FIELD (DIFFERENCE Q-POINTER-WIDTH (PLUS 1 6)) 6)
		 PDL-POP) ;Get number of places over
	((M-2) SUB (M-CONSTANT 40) A-K)	   ;Maximum M-rotate to keep byte within a word
XLDB3	(JUMP-GREATER-THAN M-E A-2 XLDB2)  ;Jump if left edge of byte off end of word
	((A-TEM2) SUB (M-CONSTANT 40) A-E) ;Compensate for shifter lossage
	(POPJ-AFTER-NEXT 
	 (OA-REG-LOW) DPB M-J OAL-BYTL-1 A-TEM2)
       ((M-T) BYTE-INST M-1
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))  

;Get here if left edge of byte is off 32. bit word.  Arithmetic shift right until it fits.
XLDB2	((M-1) LDB (BYTE-FIELD 31. 1) M-1 A-1)
	(JUMP-XCT-NEXT XLDB3)
       ((M-E) SUB M-E (A-CONSTANT 1))

BIGNUM-LDB	;M-Q has bignum, M-C has bignum header, M-I has length of bignum.
		(ERROR-TABLE RESTART BIGNUM-LDB)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)	;Arg1, byte pointer.  Must be fixnum.
			Q-DATA-TYPE PDL-TOP TRAP-UNLESS-FIXNUM)
            (ERROR-TABLE ARGTYP FIXNUM PP 0 BIGNUM-LDB)
	    (ERROR-TABLE ARG-POPPED 0 PP M-Q)
	((M-K) (BYTE-FIELD 6 0) PDL-TOP)    ;Get number of bits
	(CALL-GREATER-THAN M-K (A-CONSTANT (DIFFERENCE Q-POINTER-WIDTH 1)) TRAP)
	    (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0 BIGNUM-LDB)
	    (ERROR-TABLE ARG-POPPED 0 PP M-Q)
	((M-E) (BYTE-FIELD (DIFFERENCE Q-POINTER-WIDTH (PLUS 1 6)) 6)
			 PDL-TOP)  ;Number of places over
	((M-D) (A-CONSTANT 1))			;Offset within bignum
BIGLDB2	(JUMP-LESS-THAN M-E (A-CONSTANT 31.) BIGLDB1)  ;Found word desired byte starts in
	((M-D) ADD M-D (A-CONSTANT 1))
	(JUMP-LESS-OR-EQUAL-XCT-NEXT M-D A-I BIGLDB2)
       ((M-E) SUB M-E (A-CONSTANT 31.))
	((OA-REG-HIGH) BIGNUM-HEADER-SIGN M-C)	;Byte off top of bignum, return sign bits
	((M-T) M-ZERO)
	(JUMP PDL-POP BIGLDB6)	;Truncate byte and return (also flush arg)

BIGLDB1	((VMA-START-READ) ADD M-Q A-D)	;Fetch word of bignum
	(CHECK-PAGE-READ)
	((M-ZR) (A-CONSTANT 31.))	;31. useful bits in bignum word.
	(CALL-XCT-NEXT I-LDB)		;Get at least some of the right stuff into M-2
       ((M-1) MD)
	((M-T) Q-POINTER M-2 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) ;Force result into fixnum
	(JUMP-EQUAL M-4 A-K BIGLDB3)   ;and return it if that is entire byte
	(JUMP-EQUAL M-D A-I BIGLDB3)   ;Also return if that was last word of bignum
	((VMA-START-READ) M+A+1 M-Q A-D)	;Get next word of bignum
	(CHECK-PAGE-READ)
	((M-J) M-A-1 M-K A-4)		;Number of bits left to go minus one
	((OA-REG-LOW) DPB M-J OAL-BYTL-1 A-ZERO)
	((M-1) BYTE-INST MD A-ZERO)  ;Get bits from second word
	((OA-REG-LOW) DPB M-J OAL-BYTL-1 A-4)   ;Put those bits above the previous bits.
	((M-T) DPB M-1 A-T)
BIGLDB3	(POPJ-IF-BIT-CLEAR-XCT-NEXT BIGNUM-HEADER-SIGN M-C)	;Done if bignum was positive
       ((M-E) (BYTE-FIELD (DIFFERENCE Q-POINTER-WIDTH (PLUS 1 6)) 6)	;Retrieve byte pos, flush arg from pdl
			 PDL-POP)
	;; Bignum was negative.  Take complement of the byte value retrieved.
	;; This is a 1's or 2's complement depending on whether all bits to the
	;; right are zero.  M-K still has the byte size.
	((M-T) XOR M-T (A-CONSTANT -1))	;1's complement the byte and some extra bits to left
	((VMA) M-Q)			;Scan the bignum for zeros, until start of the byte
BIGLDB4	(JUMP-LESS-OR-EQUAL M-E A-ZERO BIGLDB7)
	((VMA-START-READ) ADD VMA (A-CONSTANT 1))
	(CHECK-PAGE-READ)
	(JUMP-LESS-THAN M-E (A-CONSTANT 31.) BIGLDB5)
	(JUMP-EQUAL-XCT-NEXT MD A-ZERO BIGLDB4)
       ((M-E) SUB M-E (A-CONSTANT 31.))
BIGLDB6	((M-K) SUB M-K (A-CONSTANT 1))	;OK, truncate the byte value and return it
	(POPJ-AFTER-NEXT (OA-REG-LOW) DPB M-K OAL-BYTL-1 A-ZERO)
       ((M-T) (BYTE-FIELD 0 0) M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

BIGLDB5	((M-E) SUB M-E (A-CONSTANT 1))	;Check bits in last word
	((OA-REG-LOW) DPB M-E OAL-BYTL-1 A-ZERO)
	((M-TEM) (BYTE-FIELD 0 0) MD)
	(JUMP-NOT-EQUAL M-TEM A-ZERO BIGLDB6)
BIGLDB7	(JUMP-XCT-NEXT BIGLDB6)		;2's complement
       ((M-T) ADD M-T (A-CONSTANT 1))

XLSH-ZERO 
XLDB-ZERO 
	(POPJ-AFTER-NEXT 
	 (M-T) SETA (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) ;RESULT = 0
		    PDL-POP)	;DON'T FORGET TO POP ARG1
       (NO-OP)

;INTERNAL LDB.  TAKES DATA IN M-1, BITS IN M-K, PLACES OVER IN M-E.
; SIZE OF DATA IN M-1 IN M-ZR (MAX 32.).
; RETURNS BYTE IN M-2.  M-4 GETS NUMBER OF BITS OF M-2 THAT ACTUALLY 
; CONTAIN DESIRED BYTE, IE, SAME AS M-K IF ENTIRE BYTE WAS WITHIN M-ZR BITS,
; OTHERWISE ONE LESS FOR EACH BIT BYTE EXTENDED BEYOND M-ZR BITS, OR ZERO IF
; BYTE WAS ENTIRELY TO THE LEFT OF M-ZR BITS.  REST OF M-2 IS ZERO.
I-LDB	((M-2) ADD M-K A-E)
	(JUMP-GREATER-THAN M-2 A-ZR I-LDB0)	;LEFT EDGE OF BYTE OFF TOP
	((M-4) M-K)				;ENTIRE BYTE WILL FIT.
I-LDB2	(POPJ-EQUAL-XCT-NEXT M-4 A-ZERO)
       ((M-2) A-ZERO)				;RETURN 0 FOR 0 LENGTH BYTE.
	((A-TEM2) SUB (M-CONSTANT 40) A-E)
	((M-TEM) SUB M-4 (A-CONSTANT 1))	;HARDWARE BYTE LENGTH IS REAL VALUE -1.
	(POPJ-AFTER-NEXT
	 (OA-REG-LOW) DPB M-TEM OAL-BYTL-1 A-TEM2)
       ((M-2) BYTE-INST M-1 A-ZERO)

I-LDB0	((M-2) SUB M-2 A-ZR)			;NUMBER OF BITS OFF TOP
	(JUMP-LESS-THAN-XCT-NEXT M-E A-ZR I-LDB2) ;JUMP IF ANY BITS OF BYTE IN THIS WORD
       ((M-4) SUB M-K A-2)			;REDUCE SIZE OF BYTE TO AS MUCH AS WILL FIT
	(POPJ-AFTER-NEXT (M-4) A-ZERO)		;BYTE NOT IN THIS WORD, RETURN 0 BITS
       ((M-2) A-ZERO)

;INTERNAL DPB. TAKES DATA TO DEPOSIT IN M-1, DATA TO DEPOSIT INTO IN M-2,
; SIZE OF M-2 (MAX 32.) IN M-ZR.  BITS IN M-K, PLACES OVER IN M-E.
; RESULT IN M-2.  M-K REDUCED BY BITS THAT WERE DEPOSITED (IE WILL BE ZERO IF
; ENTIRE BYTE FIT).  IF BYTE DID NOT COMPLETELY FIT, M-1 IS SHIFTED RIGHT BY
; AMOUNT THAT DID FIT.  SMASHES M-4, TEMPS
I-DPB	(POPJ-EQUAL M-K A-ZERO)
	((M-4) ADD M-K A-E)
	(JUMP-GREATER-THAN-XCT-NEXT M-4 A-ZR I-DPB0)	;JUMP IF LEFT EDGE OF BYTE OFF TOP
       ((M-TEM) SUB M-K (A-CONSTANT 1))
	((M-K) A-ZERO)				;NONE LEFT TO DO, WHOLE BYTE IN THIS WORD
	(POPJ-AFTER-NEXT 
	 (OA-REG-LOW) DPB M-TEM OAL-BYTL-1 A-E)
       ((M-2) DPB M-1 A-2)

I-DPB0	(POPJ-GREATER-OR-EQUAL M-E A-ZR)	;RETURN IF ENTIRE BYTE OFF TO LEFT
	((M-K) SUB M-4 A-ZR)			;M-K GETS NUMBER OF BITS LEFT OVER
	((M-TEM) SUB M-TEM A-K)			;REDUCE SIZE OF BYTE
	((OA-REG-LOW) DPB M-TEM OAL-BYTL-1 A-E)
	((M-2) DPB M-1 A-2)			;DO THE DPB
	((A-TEM2) M-A-1 (M-CONSTANT 40) A-TEM)	;SHIFT OVER TO USE UP WHATS BEEN DPB'ED
	(POPJ-AFTER-NEXT 			;FACT BYTE SIZE IS +1 DOESNT HURT,
	 (OA-REG-LOW) DPB M-K OAL-BYTL-1 A-TEM2)	; SINCE M-1 WASN'T 32 BITS
       ((M-1) BYTE-INST M-1 A-ZERO)		;RIGHT ADJUST BITS IN M-1 FOR NEXT TIME.

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-DPB-OFFSET PP PP M-C M-B)

XOPDPB(MISC-INST-ENTRY %P-DPB-OFFSET)
	(JUMP-XCT-NEXT XOPDP1)			;JOIN XDPB, BUT FIRST
       (CALL XOMR0)				;REFERENCE THE DATA AND SET VMA

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %LOGDPB M-1 (+ (LSH M-E 6) M-K) M-2)

XLDPB (MISC-INST-ENTRY %LOGDPB)    ;DPB FOR FIXNUMS ONLY, CAN STORE INTO SIGN BIT
	((M-2) Q-TYPED-POINTER PDL-POP)
	((M-K) (BYTE-FIELD 6 0) PDL-TOP)
	((M-E) (BYTE-FIELD 6 6) PDL-POP)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
			Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM PP 0)
	((M-1) PDL-POP)
	(CALL-XCT-NEXT I-DPB)	  ;SEMI-RANDOM TO USE THIS ROUTINE, BUT SPEED DOESNT
       ((M-ZR) (A-CONSTANT Q-POINTER-WIDTH))  ; MATTER AND IT SAVES A UINST OR TWO.
	(POPJ-AFTER-NEXT 
	  (M-T) M-2)
       (NO-OP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-DPB PP PP VMA)

XPDPB (MISC-INST-ENTRY %P-DPB)
	((VMA-START-READ) PDL-POP)
	(CHECK-PAGE-READ)	;VMA MAY POINT TO UNBOXED DATA
XOPDP1  ((M-1) MD)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)		 ;ARG2, BYTE POINTER
			Q-DATA-TYPE PDL-TOP TRAP-UNLESS-FIXNUM)
   (ERROR-TABLE ARGTYP FIXNUM PP 1)
	((M-K) (BYTE-FIELD 6 0) PDL-TOP) ;GET NUMBER OF BITS
	(JUMP-EQUAL M-K A-ZERO XDPB-ZERO)
	((M-K) SUB M-K (A-CONSTANT 1))
	((A-TEM1) (BYTE-FIELD 6 6) PDL-POP) ;GET NUMBER OF PLACES OVER
	((OA-REG-LOW) DPB M-K A-TEM1 OAL-BYTL-1)
	((MD-START-WRITE)	;VMA CAN BE LEFT POINTING AT UNBOXED DATA
		DPB PDL-POP A-1)
	(CHECK-PAGE-WRITE)
	(JUMP XFALSE)
       
; DPB never changes the sign of quantity DPB'ed into, it extends
; the sign arbitrarily far to the left past the byte.
XDPB (MISC-INST-ENTRY DPB) (ERROR-TABLE RESTART XDPB)
	((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 2))	;ADDRESS ARG1
	(DISPATCH Q-DATA-TYPE C-PDL-BUFFER-INDEX TRAP-UNLESS-FIXNUM)	;MAKE SURE NOT BIGNUM
    (ERROR-TABLE ARGTYP FIXNUM (PP -2) 0 XDPB)
    (ERROR-TABLE ARG-POPPED 0 PP PP PP)
	((M-TEM) Q-DATA-TYPE PDL-TOP)
	(DISPATCH Q-DATA-TYPE PDL-TOP D-NUMARG) ;ONLY THE THIRD OPERAND IS 
	    (ERROR-TABLE ARGTYP NUMBER PP T XDPB)  ;PROCESSED VIA NUMARG. THUS DPB IS A
	    (ERROR-TABLE ARG-POPPED 0 PP PP PP)
       ((M-A) (A-CONSTANT ARITH-1ARG-DPB))	   ;ONE OPERAND OP.
;FIXNUM CASE.  DATA TO DPB INTO (ARG3) SIGN EXTENDED IN M-1.
		(ERROR-TABLE RESTART XDPB0)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)		 ;ARG2, BYTE POINTER
			Q-DATA-TYPE PDL-TOP TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM PP 1 XDPB0)
    (ERROR-TABLE ARG-POPPED 0 PP PP M-1)
	((M-K) (BYTE-FIELD 6 0) PDL-TOP) ;GET NUMBER OF BITS
	(JUMP-EQUAL M-K A-ZERO XDPB-ZERO)
	(CALL-GREATER-THAN M-K (A-CONSTANT (DIFFERENCE Q-POINTER-WIDTH 1)) TRAP)
    (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0 XDPB0)
    (ERROR-TABLE ARG-POPPED 0 PP PP M-1)
	((M-E) (BYTE-FIELD (DIFFERENCE Q-POINTER-WIDTH (PLUS 1 6)) 6)
			PDL-POP) ;GET NUMBER OF PLACES OVER
ASHDPB	((M-2) ADD M-K A-E)			;M-2 maximum number of bits in result
	(JUMP-GREATER-THAN M-2 (A-CONSTANT 32.) XDPB2A)	;Multi-word => use bignum code 
	(JUMP-LESS-THAN-XCT-NEXT M-1 A-ZERO ASHDPB-NEG)
       ((M-J) SUB M-K (A-CONSTANT 1))		;Single-word => use hardware DPB
	((OA-REG-LOW) DPB M-J OAL-BYTL-1 A-E)
	((M-1) DPB PDL-POP A-1)
	(JUMP-GREATER-OR-EQUAL M-1 A-ZERO XDPB1) ;Result in M-1 if sign didn't change
	((M-C) A-ZERO)				;Else it's a 2-word bignum
	(JUMP-XCT-NEXT OVERFLOW-BIGNUM-CREATE)
       ((M-2) A-ZERO)

;; Here if DPB into fixnum or character fits in pointer field.
;; Return a character if the arg was a character.
XDPB1	(JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-CHARACTER)) RETURN-M-1)
	(POPJ-XCT-NEXT)
       ((M-T) DPB M-1 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-CHARACTER)))

ASHDPB-NEG					;Single-word DPB into negative number
	((OA-REG-LOW) DPB M-J OAL-BYTL-1 A-E)
	((M-1) DPB PDL-POP A-1)
	(JUMP-LESS-THAN M-1 A-ZERO XDPB1)	;Result in M-1 if sign didn't change
	((M-1) SUB M-ZERO A-1)			;Else it's a 2-word bignum
	(JUMP-NOT-EQUAL-XCT-NEXT M-1 A-ZERO OVERFLOW-BIGNUM-CREATE-NEGATIVE)
       ((M-2) A-ZERO)
	(JUMP-XCT-NEXT OVERFLOW-BIGNUM-CREATE-NEGATIVE)
       ((M-2) (A-CONSTANT 1))

;Get here on DPB ing into fixnum at position beyond 31. bits.  Fake up bignum
; and fall into bignum case.  Hair is that it avoids creating a
; garbage bignum just to copy out of.
XDPB2A	(CALL-LESS-THAN-XCT-NEXT M-1 A-ZERO XDPB-BM)   ;MAGNITUDIFY M-1 AND SAVE SIGN
       ((M-C) A-ZERO)		    ;IN BIGNUM-HEADER-SIGN POSITION.
ASHDPB1	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC BIGDPB3)))
ASHDPB2	((M-J) DPB M-E (BYTE-FIELD (DIFFERENCE Q-POINTER-WIDTH (PLUS 1 6)) 6) A-K)
	((PDL-PUSH) DPB M-J Q-POINTER 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))  ;PUSH ARG2 BACK
	((M-D) DPB M-1 Q-POINTER    ;SUBROUTINE SMASHES M-1
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))  ;THIS IS NOW ALWAYS A POSITIVE
	(CALL-XCT-NEXT DPB-BIGNUM-SETUP)			; NUMBER EVEN IF IT IS SETZ
       ((M-I) A-ZERO)	;INDICATE SPECIAL CASE TO BIGNUM-COPY-EXPAND. HEADER SIGN IN M-C.
	((MD) Q-POINTER M-D)
	((VMA-START-WRITE) ADD M-T (A-CONSTANT 1))  ;STORE AWAY SAVED PIECE, CREATING
	(CHECK-PAGE-WRITE)			    ;BIGNUM TO SMASH
;Smashable bignum in M-T, header in M-C.  Length in M-I has been smashed.
BIGDPB0	((M-I) BIGNUM-HEADER-LENGTH M-C)	;NEW LENGTH
	((M-K) (BYTE-FIELD 6 0) PDL-TOP)  ;NUMBER-OF-BITS
	(CALL-GREATER-THAN M-K (A-CONSTANT (DIFFERENCE Q-POINTER-WIDTH 1)) TRAP)
	    (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0)
	    (ERROR-TABLE ARG-POPPED PP PP M-T)
	(CALL-IF-BIT-SET BIGNUM-HEADER-SIGN M-C BIGNEG)	;GET 2'S COMPLEMENT REPRESENTATION
	((M-E) (BYTE-FIELD (DIFFERENCE Q-POINTER-WIDTH (PLUS 1 6)) 6)
		PDL-POP)  ;NUMBER OF PLACES OVER
	((M-1) Q-POINTER PDL-POP)	;DATA TO DEPOSIT.
	((M-D) (A-CONSTANT 1))		;OFFSET WITHIN BIGNUM
BIGDPB2	(JUMP-LESS-THAN M-E (A-CONSTANT 31.) BIGDPB1)
	((M-D) ADD M-D (A-CONSTANT 1))		;BYTE DOES NOT START IN THIS WORD
	(JUMP-LESS-OR-EQUAL-XCT-NEXT M-D A-I BIGDPB2)
       ((M-E) SUB M-E (A-CONSTANT 31.))
	(CALL TRAP)
	   (ERROR-TABLE BIGNUM-NOT-BIG-ENOUGH-DPB)	;SHOULDN'T HAPPEN

BIGDPB1	((VMA-START-READ) ADD M-T A-D)	  ;FETCH WORD OF BIGNUM
	(CHECK-PAGE-READ)
	((M-ZR) (A-CONSTANT 31.))
	(CALL-XCT-NEXT I-DPB)		;DEPOSIT IN SOME
       ((M-2) MD)
	((MD-START-WRITE) M-2)		;WRITE THAT WORD BACK.
	(CHECK-PAGE-WRITE)
	(POPJ-EQUAL M-K A-ZERO)			;NO BITS LEFT TO DEPOSIT
	((VMA-START-READ) ADD M-T A-D ALU-CARRY-IN-ONE)
	(CHECK-PAGE-READ)
	((M-E) A-ZERO)
	(CALL-XCT-NEXT I-DPB)		;DEPOSIT THE REST OF THE BITS.
       ((M-2) MD)
	(POPJ-AFTER-NEXT (MD-START-WRITE) M-2)
       (CHECK-PAGE-WRITE)

XDPB-BM	(POPJ-AFTER-NEXT   ;MAKING NEGATIVE NUMBER.  MAGNITUDIFY AND SET BIGNUM SIGN BIT.
	 (M-1) SUB M-ZERO A-1)
       ((M-C) DPB M-MINUS-ONE BIGNUM-HEADER-SIGN A-ZERO)

;Bignum in M-T, length in M-I.  Take 2's complement of it.  Bashes M-3, M-4
BIGNEG	((M-3) (A-CONSTANT 1))		;Offset into bignum
	((M-4) (A-CONSTANT 0))		;0 if borrow, -1 if no borrow
BIGNEG1	((VMA-START-READ) ADD M-T A-3)
	(CHECK-PAGE-READ)
	((M-3) ADD M-3 (A-CONSTANT 1))
	((M-TEM) MD)
	(JUMP-EQUAL-XCT-NEXT MD A-ZERO BIGNEG2)
       ((M-TEM) SUB M-4 A-TEM)
	((M-4) (A-CONSTANT -1))		;No more borrow
BIGNEG2	((MD-START-WRITE) (BYTE-FIELD 31. 0) M-TEM)	;Make sure high bit stays clear
	(CHECK-PAGE-WRITE)
	(JUMP-LESS-OR-EQUAL M-3 A-I BIGNEG1)
	(POPJ)

BIGNUM-DPB  ;bignum in M-Q, header in M-C, length in M-I.
	(CALL DPB-BIGNUM-SETUP)
	(CALL BIGDPB0)
BIGDPB3	(CALL-IF-BIT-SET BIGNUM-HEADER-SIGN M-C BIGNEG)	;If was negated, put in sign-magn form
	(JUMP BIGNUM-DPB-CLEANUP)	;bignum in M-T, header in M-C, length in M-I.

XDPB-ZERO
	((M-T) DPB M-1 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
	(POPJ-AFTER-NEXT 			;RESULT IS ARG3
	    (M-GARBAGE) PDL-POP)
       ((M-GARBAGE) PDL-POP)	;AND POP OTHER TWO ARGS

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-MASK-FIELD-OFFSET PP M-C M-B)

XOPMF (MISC-INST-ENTRY %P-MASK-FIELD-OFFSET)
	(JUMP-XCT-NEXT XOPMF1)			;JOIN XMF, BUT FIRST
       (CALL XOMR0)				;REFERENCE THE LOCATION

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-MASK-FIELD PP VMA)

XPMF  (MISC-INST-ENTRY %P-MASK-FIELD)
	((VMA-START-READ) Q-TYPED-POINTER PDL-POP)
	(CHECK-PAGE-READ)
XOPMF1	(JUMP-XCT-NEXT XPFM1)
       ((M-1) MD)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS MASK-FIELD PP M-1)

XMF   (MISC-INST-ENTRY MASK-FIELD)	;LIKE LDB BUT DATA IN ORIGINAL POSITION IN Q
	((M-1) Q-TYPED-POINTER PDL-POP)	;DATA TO EXTRACT
XPFM1	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP) ;ARG1, BYTE POINTER.  MUST BE FIXNUM.
			Q-DATA-TYPE PDL-TOP TRAP-UNLESS-FIXNUM)
  (ERROR-TABLE ARGTYP FIXNUM PP 0)
	((M-K) (BYTE-FIELD 6 0) PDL-TOP)    ;GET NUMBER OF BITS
	(JUMP-EQUAL M-K A-ZERO XLDB-ZERO)  ;WANT 0 BITS, RETURN 0
					   ; (THIS IS A FAIRLY RANDOM THING TO CHECK FOR
					   ; BUT IF WE DIDNT, IT WOULD CAUSE LOSSAGE)
	((M-J) SUB M-K (A-CONSTANT 1))	   ;BECAUSE BITS IN LDB IS +1
	((A-TEM2) (BYTE-FIELD 6 6) PDL-POP) ;GET NUMBER OF PLACES OVER
	(POPJ-AFTER-NEXT 		   ;NO "SHIFTER LOSSAGE" ON SELECTIVE-DEPOSIT
	 (OA-REG-LOW) DPB M-J A-TEM2 OAL-BYTL-1)
       ((M-T) SELECTIVE-DEPOSIT 
		M-1 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-DEPOSIT-FIELD-OFFSET PP PP M-C M-B)

XOPDF(MISC-INST-ENTRY %P-DEPOSIT-FIELD-OFFSET)
	(JUMP-XCT-NEXT XOPDF1)			;JOIN XDF, BUT FIRST
       (CALL XOMR0)				;REFERENCE THE LOCATION AND SET VMA

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-DEPOSIT-FIELD PP PP VMA)

XPDF (MISC-INST-ENTRY %P-DEPOSIT-FIELD)
	((VMA-START-READ) Q-TYPED-POINTER PDL-POP)
	(CHECK-PAGE-READ)
XOPDF1	(CALL-XCT-NEXT XPDF1)
       ((A-TEM3) MD)
	((MD-START-WRITE) M-T)
	(CHECK-PAGE-WRITE)
	(JUMP XFALSE)

;This can return untyped data.  It also doesn't work on bignums.
;Fortunately no one has ever called it.
XDF  (MISC-INST-ENTRY DEPOSIT-FIELD)
	((A-TEM3) Q-TYPED-POINTER PDL-POP) ;ARG3, DATA TO STORE IN
XPDF1	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)		 ;ARG2, BYTE POINTER
			Q-DATA-TYPE PDL-TOP TRAP-UNLESS-FIXNUM)
  (ERROR-TABLE ARGTYP FIXNUM PP 1)
	((M-K) (BYTE-FIELD 6 0) PDL-TOP) ;GET NUMBER OF BITS
	(JUMP-EQUAL M-K A-ZERO XDPB-ZERO)
	((M-K) SUB M-K (A-CONSTANT 1))
	((A-TEM1) (BYTE-FIELD 6 6) PDL-POP) ;GET NUMBER OF PLACES OVER
	(POPJ-AFTER-NEXT 
	 (OA-REG-LOW) DPB M-K A-TEM1 OAL-BYTL-1)
       ((M-T) SELECTIVE-DEPOSIT PDL-POP A-TEM3)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-STORE-TAG-AND-POINTER PP M-A)

XCMBS (MISC-INST-ENTRY %P-STORE-TAG-AND-POINTER)
	((M-A) Q-TYPED-POINTER PDL-POP) ;ARG3, VALUE FOR POINTER FIELD
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)	      ;ARG3 ANY TYPE, MISCBITS MUST BE FIXNUM
			Q-DATA-TYPE PDL-TOP TRAP-UNLESS-FIXNUM)
    (ERROR-TABLE ARGTYP FIXNUM PP 2)
	((MD) DPB PDL-POP ;ARG2, VALUE FOR TYPE, ETC.
		Q-ALL-BUT-POINTER A-A)
	((VMA-START-WRITE) PDL-POP) ;ARG1, WHERE TO STORE
	(CHECK-PAGE-WRITE)
	(GC-WRITE-TEST)
	(JUMP XFALSE)

XPDAT (MISC-INST-ENTRY %P-POINTER)
	((M-K) (A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST Q-POINTER))))
XPDAT1  ((VMA-START-READ) PDL-POP)
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT
	 (OA-REG-LOW) M-K)
       ((M-T) BYTE-INST MD (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))

XPDATP (MISC-INST-ENTRY %P-DATA-TYPE)
	(JUMP-XCT-NEXT XPDAT1)
       ((M-K) (A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST Q-DATA-TYPE))))

XPCDRC (MISC-INST-ENTRY %P-CDR-CODE)
	(JUMP-XCT-NEXT XPDAT1)
       ((M-K) (A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST Q-CDR-CODE))))

XSPDTP (MISC-INST-ENTRY %P-STORE-DATA-TYPE)
	((M-K) (A-CONSTANT (OA-LOW-CONTEXT (DPB Q-DATA-TYPE))))
XSPDTP1 ((M-T) Q-TYPED-POINTER PDL-POP)	;DATA TO DPB IN (ALSO RETURN AS VALUE)
	((VMA-START-READ) Q-TYPED-POINTER PDL-POP)
	(CHECK-PAGE-READ)
	((A-TEM2) MD)
	((OA-REG-LOW) M-K)
	((MD-START-WRITE) DPB M-T A-TEM2)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       (NO-OP)

XSPDAT (MISC-INST-ENTRY %P-STORE-POINTER)
	(JUMP-XCT-NEXT XSPDTP1)
       ((M-K) (A-CONSTANT (OA-LOW-CONTEXT (DPB Q-POINTER))))

XSPCDR (MISC-INST-ENTRY %P-STORE-CDR-CODE)
	(JUMP-XCT-NEXT XSPDTP1)
       ((M-K) (A-CONSTANT (OA-LOW-CONTEXT (DPB Q-CDR-CODE))))

;Provides a way to pick up the pointer-field of an external-value-cell
;pointer or a dtp-null pointer, or any invisible pointer,
;converting it into a locative and transporting it if it points to old-space.
XPCAL (MISC-INST-ENTRY %P-CONTENTS-AS-LOCATIVE)
	((VMA-START-READ) Q-TYPED-POINTER PDL-POP)	;GET SPECD LOCATION
	(CHECK-PAGE-READ)
XPCAL1	(CALL-XCT-NEXT TRANS-OLD0)			;TRANSPORT OLDSPACE POINTER, BUT
       ((M-1) MD)					; DON'T CHASE INVISIBLE POINTERS
	(POPJ-AFTER-NEXT (M-T) Q-POINTER MD 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
       (CALL-NOT-EQUAL MD A-1 XPCAL1)			;REPEAT IF E.G. SNAPPED OUT HDR-FWD

XPCALO (MISC-INST-ENTRY %P-CONTENTS-AS-LOCATIVE-OFFSET)
	(JUMP-XCT-NEXT XPCAL1)
       (CALL XOMR0)					;GET SPECD LOCATION
	
XPDIF (MISC-INST-ENTRY %POINTER-DIFFERENCE)
	((M-T) Q-POINTER PDL-POP)
	(POPJ-AFTER-NEXT
	  (M-T) SUB PDL-POP A-T)
       ((M-T) DPB M-T Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))


XOMR (MISC-INST-ENTRY %P-CONTENTS-OFFSET)
	(CALL XOMR0)				;READ THE SPECIFIED LOCATION
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT MD)
       ((M-T) Q-TYPED-POINTER MD)	;RETURN ITS CONTENTS

XOMR0	((M-B) PDL-POP)	;GET THE OFFSET
	((VMA-START-READ M-C) PDL-POP)	;READ THE HEADER WORD
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER MD)	;FOLLOW FORWARDING PTR
	(POPJ-AFTER-NEXT
	 (VMA-START-READ) ADD VMA A-B)		;NOW REFERENCE THE SPECIFIED LOCATION
       (CHECK-PAGE-READ)			;VMA COULD BE POINTING INTO UNFORWARDED DATA

XOMS  (MISC-INST-ENTRY %P-STORE-CONTENTS-OFFSET)
	(CALL XOMR0)				;READ THE SPECIFIED LOCATION, SET VMA
	((M-T) Q-TYPED-POINTER PDL-POP)
	((MD-START-WRITE) SELECTIVE-DEPOSIT MD 
		Q-ALL-BUT-TYPED-POINTER A-T)
	(CHECK-PAGE-WRITE)
	(POPJ-AFTER-NEXT GC-WRITE-TEST)
       (NO-OP)

;%MAKE-POINTER-OFFSET <new data type> <pointer> <offset> returns a pointer whose pointer
;   is (+ (%POINTER <pointer>) <offset>) and whose data type is <new data type>.  No data
;   type checks.
XMOP (MISC-INST-ENTRY %MAKE-POINTER-OFFSET)
	((M-T) Q-TYPED-POINTER PDL-POP)
	(POPJ-AFTER-NEXT
		(M-T) ADD PDL-POP A-T)
       ((M-T) DPB Q-DATA-TYPE PDL-POP A-T)


XSFP (MISC-INST-ENTRY %STACK-FRAME-POINTER)
	(CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
       ((M-K) M-AP)
	(POPJ-AFTER-NEXT (M-T) M-K)
       (NO-OP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS INTERNAL-GET-3 M-B M-D M-E)

XINTERNAL-GET-3 (MISC-INST-ENTRY INTERNAL-GET-3)
	((M-E) Q-TYPED-POINTER PDL-POP)	     ;Arg3, default value.
	(JUMP XGET3)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS GET M-B M-D)

XGET (MISC-INST-ENTRY INTERNAL-GET-2)
	((M-E) A-V-NIL)
XGET3
	((M-D) Q-TYPED-POINTER PDL-POP) ;Arg2, property name.
	((M-T) Q-TYPED-POINTER PDL-POP) ;Arg1, symbol or plist.
	((M-A) M-D)		;Arg must go here as well, for INSTANCE-INVOKE.
XGET2	(CALL-XCT-NEXT PLGET)
       ((M-B) M-T)		;Save copy of arg in M-B.
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 36) M-T XGET-INSTANCE)
XGET1	(JUMP-EQUAL M-T A-V-NIL XGET-NOT-FOUND)
	(CALL CARCDR)
;; If the car matches desired property,
;; return the car of the following link (now in M-T).
	(JUMP-EQUAL M-A A-D QCAR)
	(JUMP-XCT-NEXT XGET1)
       (CALL QCDR)

XGET-NOT-FOUND
	(POPJ-AFTER-NEXT (M-T) M-E)
       (NO-OP)

XGET-INSTANCE
	((ARG-CALL INSTANCE-INVOKE-1) (I-ARG INSTANCE-INVOKE-GET))
	((PDL-PUSH) M-D Q-TYPED-POINTER (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
	((PDL-PUSH) M-E Q-TYPED-POINTER (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	((ARG-CALL MMCALL) (I-ARG 3))	;Call, :GET plus 2 args.  Value comes back in M-T.
	(POPJ)

;(DEFUN GET-LEXICAL-VALUE-CELL (X Y) (GET-LOCATION-OR-NIL (LOCF X) Y))
;except it runs much faster when X is a list that lives inside the pdl buffer.
XGETLV (MISC-INST-ENTRY GET-LEXICAL-VALUE-CELL)
	((M-D) Q-TYPED-POINTER PDL-POP) ;Arg2, cell locative to search for.
	((M-T) Q-TYPED-POINTER PDL-POP) ;Arg1, plist contents.
	((M-2) Q-POINTER M-T)
	((PDL-INDEX M-2) SUB M-2 A-PDL-BUFFER-VIRTUAL-ADDRESS)
	(JUMP-NOT-EQUAL PDL-INDEX A-2 XGETI1)
	((PDL-INDEX) ADD PDL-INDEX A-PDL-BUFFER-HEAD)
XGETLV1	((M-A) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)
	(JUMP-EQUAL M-A A-D XGETLV2)
	((M-1) Q-CDR-CODE C-PDL-BUFFER-INDEX)
	(JUMP-EQUAL M-1 (A-CONSTANT (EVAL CDR-NIL)) XFALSE)
	((PDL-INDEX) ADD PDL-INDEX (A-CONSTANT 1))
	(JUMP-XCT-NEXT XGETLV1)
       ((M-T) ADD M-T (A-CONSTANT 1))

;Convert address of next link (whose car is the property value) into a locative.
XGETLV2	(POPJ-AFTER-NEXT (M-T) ADD M-T (A-CONSTANT 1))
       ((M-T) DPB M-T Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))

(ERROR-TABLE DEFAULT-ARG-LOCATIONS GET-LOCATION-OR-NIL M-B M-D)

XGETI (MISC-INST-ENTRY GET-LOCATION-OR-NIL)
	((M-D) Q-TYPED-POINTER PDL-POP) ;Arg2, property name.
	((M-T) Q-TYPED-POINTER PDL-POP) ;Arg1, symbol or plist.
	((M-A) M-D)		;Arg must go here as well, for INSTANCE-INVOKE.
	(CALL-XCT-NEXT PLGET)
       ((M-B) M-T)		;Save copy of arg in M-B.
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 36) M-T XGETI-INSTANCE)
XGETI1	(POPJ-EQUAL M-T A-V-NIL)		;END OF PLIST REACHED
	(CALL CARCDR)
	(JUMP-EQUAL M-A A-D XGETI2)
	(JUMP-XCT-NEXT XGETI1)
       (CALL QCDR)

;Convert address of next link (whose car is the property value) into a locative.
XGETI2 (POPJ-AFTER-NEXT (M-T) DPB M-T Q-POINTER
	    (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
       (NO-OP)

XGETI-INSTANCE
	((ARG-CALL INSTANCE-INVOKE-1) (I-ARG INSTANCE-INVOKE-GET-LOCATION-OR-NIL))
	((PDL-PUSH) M-D Q-TYPED-POINTER (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	((ARG-CALL MMCALL) (I-ARG 2))	;Call, kwd plus 1 args  Value comes back in M-T.
	(POPJ)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS GETL M-B M-S)

XGETL (MISC-INST-ENTRY GETL)
	((M-A) Q-TYPED-POINTER PDL-POP)	;ARG2, LIST OF PROPERTIES
	((M-B) Q-TYPED-POINTER PDL-POP)	;ARG1, THING TO GET FROM
	(CALL-XCT-NEXT PLGET)
       ((M-T) M-B)
	(JUMP-IF-BIT-SET (BYTE-FIELD 1 36) M-T XGETL-INSTANCE)
	((M-S) M-A)
XGETL1	(POPJ-EQUAL M-T A-V-NIL)		;EXHAUSTED THE PLIST
	(CALL-XCT-NEXT QCAR)			;GET NEXT INDICATOR
       ((PDL-PUSH) M-T)	;SAVE CURRENT PLIST NODE
	((M-A) Q-TYPED-POINTER M-T)		;SAVE INDICATOR.
	((M-T) Q-TYPED-POINTER M-S)		;GET LIST OF PROPERTY NAMES
XGETL2	(JUMP-EQUAL M-T A-V-NIL XGETL3)		;NO MATCH THIS ONE
	(CALL-XCT-NEXT QCAR)			;GET NEXT PROP NAME TO TRY
       ((PDL-PUSH) M-T)
	(JUMP-EQUAL M-T A-A POP1TJ)		;GOT IT
	(CALL-XCT-NEXT QCDR-SB)
       ((M-T) PDL-POP)		;TRY NEXT PROP NAME
	(JUMP XGETL2)

XGETL3	(CALL-XCT-NEXT QCDR-SB)
       ((M-T) Q-TYPED-POINTER PDL-POP)
	(JUMP-XCT-NEXT XGETL1)       
       (CALL QCDR)				;TRY NEXT PROPERTY

XGETL-INSTANCE
	((ARG-CALL INSTANCE-INVOKE-1) (I-ARG INSTANCE-INVOKE-GETL))
	((PDL-PUSH) M-D Q-TYPED-POINTER (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	((ARG-CALL MMCALL) (I-ARG 2))	;Call, kwd plus 1 args  Value comes back in M-T.
	(POPJ)

;Pick up the plist of the object in M-T, returning it in M-T.
;Returns NIL if a random type, for maclisp compatibility.  Unfortunately
;not useful for plist-changing things, but those aren't currently in microcode anyway.
;If the argument is an instance or named structure,
;returns in M-T a copy of M-B, with both cdr-code bits nonzero.
;(In normal practice, M-B is another copy of the argument.)
;Preserves M-A, M-B, M-D, M-E.
PLGET	((M-ZR) Q-DATA-TYPE M-T)
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-SYMBOL)) PLGET2)
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-LIST)) QCDR) ;"DISEMBODIED" PROPERTY LIST
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-LOCATIVE)) QCDR) ;"DISEMBODIED" PROPERTY LIST
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-INSTANCE)) PLGET1)
			;GET OF RANDOM THINGS NIL IN MACLISP, SO ...
	(JUMP-NOT-EQUAL M-ZR (A-CONSTANT (EVAL DTP-ARRAY-POINTER)) XFALSE)
			;If it's an array, is it a named structure?
	((PDL-PUSH) M-A)
	((PDL-PUSH) M-E)
	((PDL-PUSH) M-D)
	((PDL-PUSH) M-B)
	((PDL-PUSH) M-T)
	(CALL XNAMED-STRUCTURE-P)
	((M-B) PDL-POP)
	((M-D) PDL-POP)
	((M-E) PDL-POP)
	((M-A) PDL-POP)
	(POPJ-EQUAL M-T A-V-NIL)	;Not named structure => return NIL.
PLGET1	(POPJ-XCT-NEXT)
       ((M-T) DPB Q-CDR-CODE M-MINUS-ONE A-B)

PLGET2	((VMA-START-READ) ADD M-T		;ARG1, SYMBOL TO GET FROM
		      (A-CONSTANT 3))		;GET PLIST CELL OF ARG1
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT MD)
       ((M-T) Q-TYPED-POINTER MD)

;; Push a call block to the function in M-T,
;; and a first argument found in the instance invoke vector indexed by the I-ARG.
INSTANCE-INVOKE-1
	((M-B) DPB READ-I-ARG Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
	(CALL P3ZERO)
	((PDL-PUSH) Q-TYPED-POINTER M-T) ;First push the instance -- that's what we call.
	((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVC-INSTANCE-INVOKE-VECTOR))
	(DISPATCH TRANSPORT MD)
	((VMA-START-READ) ADD MD (A-CONSTANT 1))
	(CHECK-PAGE-READ)	;Get the value of INSTANCE-INVOKE-VECTOR.
	(DISPATCH TRANSPORT MD)
	((VMA-START-READ) M+A+1 MD A-B)
	(CHECK-PAGE-READ)	;Get the operation keyword out of the vector.
	(DISPATCH TRANSPORT MD)
	(POPJ-AFTER-NEXT (PDL-PUSH) Q-TYPED-POINTER MD
			 (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
       (NO-OP)

POP1TJ	(POPJ-AFTER-NEXT
	  (M-GARBAGE) PDL-POP)
       ((M-T) PDL-POP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS ASSQ M-D M-B)

;; Called indirectly from QLENTR -- watch out.
XASSQ (MISC-INST-ENTRY ASSQ)
	((M-T) Q-TYPED-POINTER PDL-POP)	;ARG2
	((M-D) Q-TYPED-POINTER PDL-POP)	;ARG1
	((M-B) M-T)
XASSQ1	(POPJ-EQUAL M-T A-V-NIL)
	(CALL CARCDR)
	((PDL-PUSH) M-T)
;; Next link in alist is on pdl, this alist element in M-A.  Take its car.
	(CALL-XCT-NEXT QCAR)
       ((M-T) M-A)
;; Next link still on pdl, this alist element in M-A,
;; this element's key in M-T.
	(JUMP-NOT-EQUAL-XCT-NEXT M-T A-D XASSQ1)
       ((M-T) PDL-POP)
	(POPJ-XCT-NEXT)
       ((M-T) M-A)

POPTJ	(POPJ-AFTER-NEXT
	  (M-T) Q-TYPED-POINTER PDL-POP)
       (NO-OP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS LAST (PP -1))

XLAST (MISC-INST-ENTRY LAST)
	((M-T PDL-PUSH) Q-TYPED-POINTER PDL-TOP)
XLAST1	(DISPATCH Q-DATA-TYPE M-T SKIP-IF-LIST)
	 (JUMP POPT1J)
	(CALL-XCT-NEXT QCDR-SB)
       ((PDL-TOP) M-T)
	(JUMP XLAST1)

POPT1J	(POPJ-AFTER-NEXT
	  (M-T) PDL-POP)
	(PDL-POP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS LENGTH M-A)

XLENGT (MISC-INST-ENTRY LENGTH)
   (ERROR-TABLE RESTART LENGTH)
	((M-T) Q-TYPED-POINTER PDL-POP)
	((M-A) M-T)
XTLENG	(DISPATCH Q-DATA-TYPE M-T SKIP-IF-LIST)		;MC-LINKAGE
	 (JUMP-NOT-EQUAL M-T A-V-NIL XLEN2)
	((PDL-PUSH) 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
XLEN1	(DISPATCH Q-DATA-TYPE M-T SKIP-IF-LIST)
	 (JUMP POPTJ)
	(CALL QCDR-SB)
	(JUMP-XCT-NEXT XLEN1)
       ((PDL-TOP) ADD PDL-TOP (A-CONSTANT 1))

;Arg is not a list of any sort.  If it's an array, return the active length.
XLEN2	((M-1) Q-DATA-TYPE M-T)
	(JUMP-EQUAL-XCT-NEXT M-1 (A-CONSTANT (EVAL DTP-ARRAY-POINTER)) XAAIXL)
       ((PDL-PUSH) M-T)
	(CALL TRAP)
   (ERROR-TABLE ARGTYP LIST PP T LENGTH)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS SET M-S M-T)

XSET (MISC-INST-ENTRY SET)
	((M-T) Q-TYPED-POINTER PDL-POP);ARG2, NEW VALUE & RESULT
		(ERROR-TABLE RESTART XSET)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)		;ARG1, THE SYMBOL TO SET
			Q-DATA-TYPE PDL-TOP TRAP-UNLESS-SYM)
   (ERROR-TABLE ARGTYP SYMBOL PP 0 XSET)
   (ERROR-TABLE ARG-POPPED 0 PP M-T)
	((M-S) Q-TYPED-POINTER PDL-POP)
	((VMA-START-READ) ADD M-S (A-CONSTANT 1))	;ACCESS V.C.
	(CHECK-PAGE-READ)				;READ VALUE CELL FIRST
	(JUMP-NOT-EQUAL M-S A-V-NIL XSET2)		;Merge with STOCYC.
	(CALL TRAP)					;Don't clobber NIL!
   (ERROR-TABLE ARGTYP NON-NIL M-S 0)

XNOT (MISC-INST-ENTRY NOT)
	((M-T) Q-TYPED-POINTER PDL-POP)
	(JUMP-EQUAL M-T A-V-NIL XTRUE)
	(JUMP XFALSE)

XATOM (MISC-INST-ENTRY ATOM)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
			Q-DATA-TYPE PDL-POP SKIP-IF-ATOM)
	(JUMP XFALSE)
	(JUMP XTRUE)

XGPN  (MISC-INST-ENTRY GET-PNAME)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
		  Q-DATA-TYPE PDL-TOP TRAP-UNLESS-SYM)
   (ERROR-TABLE ARGTYP SYMBOL PP T)
   (ERROR-TABLE ARG-POPPED 0 PP)
	((VMA-START-READ) Q-TYPED-POINTER PDL-POP)
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT MD)
       ((M-T) DPB MD Q-POINTER
		 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-ARRAY-POINTER)))

   (MISC-INST-ENTRY %BINDING-INSTANCES)    ;(%BINDING-INSTANCES <LIST-OF-SYMBOLS>)
  ;SIMILAR TO CLOSURE, BUT TAKES NO FUNCTION.  VALUE RETURNNED IS LIST OF
  ;LOCATIVES WHICH ARE ALTERNATELY INTERNAL AND EXTERNAL VALUE CELL POINTERS.
XBINS   ((M-T) Q-TYPED-POINTER PDL-TOP)
	(JUMP-EQUAL M-T A-V-NIL POPTJ)
	(CALL XTLENG)
	((M-B) ADD M-T A-T)			;TWO CELLS FOR EACH VAR
	((M-B) Q-POINTER M-B)
	(CALL-XCT-NEXT LIST-OF-NILS)		;ALLOCATE CLOSURE OUT OF LIST SPACE
       ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF)  ;LIST OF NILS SETS UP CDR CODES
	((M-T PDL-PUSH) Q-POINTER M-T 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))  ;VALUE TO RETURN, EVENTUALLY
	(JUMP-XCT-NEXT XBINS1)
       ((PDL-PUSH) M-T)	;FILLING POINTER.

   (MISC-INST-ENTRY CLOSURE)	;(CLOSURE <CLOSURE-LIST> <FCTN>)
XCLOS	((M-J) Q-TYPED-POINTER PDL-POP)   ;FCTN
	(CALL-XCT-NEXT XTLENG)
       ((M-T) Q-TYPED-POINTER PDL-TOP)
	((M-B) ADD M-T A-T ALU-CARRY-IN-ONE)	;TWO CELLS FOR EACH VAR PLUS ONE FOR FCTN
	((M-B) Q-POINTER M-B)
	(CALL-XCT-NEXT LIST-OF-NILS)		;ALLOCATE CLOSURE OUT OF LIST SPACE
       ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF)  ;LIST OF NILS SETS UP CDR CODES
	((PDL-PUSH)	;EVENTUAL VALUE
		Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-CLOSURE)))
	((M-S) Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
	(CALL-XCT-NEXT QRAR1)			;(RPLACA <CLOSURE-BLOCK> <FCTN>)
       ((M-T) M-J)				;FCTN
	((PDL-PUSH) ADD M-T A-ZERO ALU-CARRY-IN-ONE)	;STEP FILLING POINTER
XBINS1	((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 2))
	((M-T) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)
;0(IP) - POINTER TO BINDING INSTANCE BLOCK BEING FILLED IN
;-1(IP)- VALUE TO RETURN EVENTUALLY.
;-2(IP)- LIST OF VARS TO CLOSE OVER.
XCLOS4	(JUMP-EQUAL M-T A-V-NIL XCLOSX)		;LIST OF SYMS TO CLOSE IN M-T
	(CALL QCAR)
	(DISPATCH Q-DATA-TYPE M-T TRAP-UNLESS-SYM)
   (ERROR-TABLE ARGTYP SYMBOL M-T NIL)
	((M-S) PDL-POP)	;FILLING POINTER  (IN POSITION FOR RPLACA)
	((M-T) DPB M-T Q-POINTER 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
	(CALL-XCT-NEXT QRAR1)
       ((M-T PDL-PUSH) ADD M-T A-ZERO ALU-CARRY-IN-ONE)
					;POINTER TO INTERNAL VALUE CELL
					;M-T GETS LOCATION FILLED.
	((VMA-START-READ) PDL-POP)	;READ INTERNAL VALUE CELL
	(CHECK-PAGE-READ)
	((PDL-PUSH) ADD M-T A-ZERO ALU-CARRY-IN-ONE) ;BUMP FILLING POINTER
	(DISPATCH TRANSPORT-NO-EVCP MD)
	((M-1) Q-DATA-TYPE MD)
	(JUMP-EQUAL M-1 (A-CONSTANT (EVAL DTP-EXTERNAL-VALUE-CELL-POINTER)) 
			XCLOS3A)	;XFER ON EXTERNAL VALUE CELL ALREADY EXISTS
	((PDL-PUSH) VMA)	;SAVE POINTER TO INTERNAL VALUE CELL
	((PDL-PUSH) MD)	;SAVE INTERNAL VALUE CELL CONTENTS
	(CALL-XCT-NEXT LCONS-D)			;ALLOCATE EXT VAL CELL IN LIST SPACE
       ((M-B) (A-CONSTANT 1))
	((VMA M-T) Q-POINTER M-T		;ADDRESS OF NEW EXTERNAL V-C
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTERNAL-VALUE-CELL-POINTER)))
	((MD-START-WRITE)
		DPB PDL-TOP Q-TYPED-POINTER  ;V-C CONTENTS
		(A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
	(CHECK-PAGE-WRITE)
	((MD) SELECTIVE-DEPOSIT PDL-POP 
		Q-ALL-BUT-TYPED-POINTER A-T)
	((VMA-START-WRITE) PDL-POP)	;WRITE INTO INTERNAL V-C
	(CHECK-PAGE-WRITE)
XCLOS3	((M-T) DPB M-T Q-POINTER       ;TO AVOID PROFUSION OF RANDOM D.T.S.  AVOIDS LOSSAGE
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE))) ;WITH CAR IN QCLS1
					;QCLS1 CHANGES BACK TO DTP-EXT-V-C EVENTUALLY
	(CALL-XCT-NEXT QRAR1)				;FORWARDING PNTR IN M-T
       ((M-S) PDL-POP)			;GET BACK FILL POINTER
	((PDL-PUSH) ADD M-T A-ZERO ALU-CARRY-IN-ONE)   ;BUMP FILL POINTER
	((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 2))	;BUMP VARS POINTER
	(CALL-XCT-NEXT QCDR-SB)
       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)
		;PDL-BUFFER-INDEX NOT SAVED ACROSS SEQUENCE BREAKS
	((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 2))
	(JUMP-XCT-NEXT XCLOS4)
       ((C-PDL-BUFFER-INDEX) M-T)

XCLOS3A	(JUMP-XCT-NEXT XCLOS3)
       ((M-T) MD)		;POINTER TO EXTERNAL V-C

XCLOSX	((M-GARBAGE) PDL-POP)	;FLUSH FILLING POINTER
	(POPJ-AFTER-NEXT 
	 (M-T) Q-TYPED-POINTER PDL-POP)
       ((M-GARBAGE) PDL-POP)	;FLUSH CLOSURE-LIST


      (MISC-INST-ENTRY %EXTERNAL-VALUE-CELL)
XEVC	(CALL XVCL)		;Returns address of IVC.  Does not follow EVCPs.
	((VMA-START-READ) M-T)
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT-IVC MD) ;GC
       ((M-T) DPB VMA Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))

XVCL  (MISC-INST-ENTRY VALUE-CELL-LOCATION)
	((A-TEM1) (A-CONSTANT 1))
XCL1	(DISPATCH Q-DATA-TYPE PDL-TOP TRAP-UNLESS-SYM)
   (ERROR-TABLE ARGTYP SYMBOL PP T)
   (ERROR-TABLE ARG-POPPED 0 PP)
	(POPJ-AFTER-NEXT 
	 (M-T) DPB Q-POINTER PDL-POP 
		(A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
       ((M-T) ADD M-T A-TEM1)

XFCL  (MISC-INST-ENTRY FUNCTION-CELL-LOCATION)
	(JUMP-XCT-NEXT XCL1)
       ((A-TEM1) (A-CONSTANT 2))

XPRPCL (MISC-INST-ENTRY PROPERTY-CELL-LOCATION)
	(JUMP-XCT-NEXT XCL1)
       ((A-TEM1) (A-CONSTANT 3))

XPACKAGE-CELL-LOCATION (MISC-INST-ENTRY PACKAGE-CELL-LOCATION)
	(JUMP-XCT-NEXT XCL1)
       ((A-TEM1) (A-CONSTANT 4))

XFCTEV (MISC-INST-ENTRY FSYMEVAL)
	(JUMP-XCT-NEXT XSYME2)
       ((M-1) (A-CONSTANT 2))

XSYMEV (MISC-INST-ENTRY SYMEVAL)
	((M-1) (A-CONSTANT 1))
XSYME2		(ERROR-TABLE RESTART XSYME2)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
	 	  Q-DATA-TYPE PDL-TOP TRAP-UNLESS-SYM)
   (ERROR-TABLE ARGTYP SYMBOL PP T XSYME2)
   (ERROR-TABLE ARG-POPPED 0 PP)
	((VMA-START-READ) ADD PDL-POP A-1)
	(CHECK-PAGE-READ)
	(POPJ-AFTER-NEXT DISPATCH TRANSPORT MD) ;GC, FOLLOW INVZ
       ((M-T) Q-TYPED-POINTER MD)

POP-THEN-XFALSE
	(JUMP-XCT-NEXT XFALSE)
       ((M-GARBAGE) PDL-POP)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS MEMQ M-C M-B)

XMEMQ (MISC-INST-ENTRY MEMQ)
	((M-T) Q-TYPED-POINTER PDL-POP)
	((M-C) Q-TYPED-POINTER PDL-POP)
	((M-B) M-T)
XMEMQ1	(POPJ-EQUAL M-T A-V-NIL)
	(CALL-XCT-NEXT CARCDR)	;Get car in M-A, cdr in M-T.
       ((M-D) M-T)		;Save this link, as value if this elt matches.
	(JUMP-NOT-EQUAL M-A A-C XMEMQ1)
	(POPJ-XCT-NEXT)
       ((M-T) M-D)

(ERROR-TABLE DEFAULT-ARG-LOCATIONS MEMBER-EQL M-C M-B)

XMEMBER-EQL (MISC-INST-ENTRY MEMBER-EQL)
	((M-T) Q-TYPED-POINTER PDL-POP)
	((M-C) Q-TYPED-POINTER PDL-POP)
;; Do it using MEMQ if 1st arg is not a number.
	((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC XMEMQ1)))
	(DISPATCH-XCT-NEXT Q-DATA-TYPE M-C POPJ-IF-NOT-NUMBER)
       ((M-B) M-T)
	(MICRO-STACK-DATA-POP)
XMEMBER-EQL-1
	(POPJ-EQUAL M-T A-V-NIL)
	(CALL-XCT-NEXT CARCDR)	;Get car in M-A, cdr in M-T.
       ((PDL-PUSH) M-T)		;Save this link, as value if this elt matches.
	((PDL-PUSH) M-T)	;Save the following link.
	((PDL-PUSH) M-A)	;First arg to EQL.
	((M-T) M-C)		;Second arg.
	(CALL XEQL1)
	(JUMP-NOT-EQUAL M-T A-V-NIL XMEMBER-EQL-2)  ;Jump if they are EQL.
	((M-T) PDL-POP)		;Else continue with next link,
	(JUMP-XCT-NEXT XMEMBER-EQL-1)
       (PDL-POP)		;discard this link whose car did not match.

XMEMBER-EQL-2
	(POPJ-XCT-NEXT PDL-POP)	;Discard next link,
       ((M-T) PDL-POP)		;return this link whose car matched.

(ERROR-TABLE DEFAULT-ARG-LOCATIONS FIND-POSITION-IN-LIST M-D M-C)

XFPIL (MISC-INST-ENTRY FIND-POSITION-IN-LIST)
	((M-T) Q-TYPED-POINTER PDL-POP)
	((M-C) M-T)
	((M-D) Q-TYPED-POINTER PDL-POP)
	((M-B) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
XFPIL1	(POPJ-EQUAL M-T A-V-NIL)
	(CALL-XCT-NEXT CARCDR)
       ((M-B) ADD M-B (A-CONSTANT 1))
	(JUMP-NOT-EQUAL M-A A-D XFPIL1)
	(POPJ-XCT-NEXT)
       ((M-T) SUB M-B (A-CONSTANT 1))

XLOCATE-IN-INSTANCE (MISC-INST-ENTRY LOCATE-IN-INSTANCE)
    (ERROR-TABLE RESTART XLOCATE-IN-INSTANCE)
	((M-TEM) Q-DATA-TYPE PDL-TOP)
	(JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-SYMBOL)) XLOCATE-IN-INSTANCE-1)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-LOCATIVE)) TRAP)
    (ERROR-TABLE ARGTYP SYMBOL-OR-LOCATIVE PP 1 XLOCATE-IN-INSTANCE)
	(CALL XFSH)
	(JUMP-XCT-NEXT XLOCATE-IN-INSTANCE-2)
       ((M-C) M-T)

XLOCATE-IN-INSTANCE-1
	((M-C) LDB Q-TYPED-POINTER PDL-POP)
;Decode the first arg.
XLOCATE-IN-INSTANCE-2
    (ERROR-TABLE RESTART XLOCATE-IN-INSTANCE-2)
	((M-TEM) Q-DATA-TYPE PDL-TOP)
	(CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-INSTANCE)) TRAP)
    (ERROR-TABLE ARGTYP INSTANCE PP 1 XLOCATE-IN-INSTANCE-2)
    (ERROR-TABLE ARG-POPPED M-C)
	((M-A VMA-START-READ) Q-TYPED-POINTER PDL-POP)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER MD)
	((VMA-START-READ) ADD MD (A-CONSTANT (EVAL %INSTANCE-DESCRIPTOR-ALL-INSTANCE-VARIABLES)))
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT MD)
	((VMA M-D) MD)
;; M-A holds the instance.
;; M-D holds the list of all instance variables.
;; VMA is a tail of that list.
;; M-C is the symbol we want.
XLOCATE-IN-INSTANCE-LOOP
	((VMA-START-READ) VMA)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT MD)
	((M-TEM) Q-TYPED-POINTER MD)
	(JUMP-EQUAL M-TEM A-C XLOCATE-IN-INSTANCE-FOUND)
	((M-TEM) Q-CDR-CODE MD)
	(JUMP-EQUAL-XCT-NEXT M-TEM (A-CONSTANT (EVAL CDR-NEXT)) XLOCATE-IN-INSTANCE-LOOP)
       ((VMA) ADD VMA (A-CONSTANT 1))
;; Variable is not found.
	(CALL TRAP)
    (ERROR-TABLE INSTANCE-LACKS-INSTANCE-VARIABLE M-C M-A)

XLOCATE-IN-INSTANCE-FOUND
	((M-1) SUB VMA A-D)
	((M-T) M+A+1 M-A A-1)
	(POPJ-XCT-NEXT)
       ((M-T) DPB M-T Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))

   (MISC-INST-ENTRY COMMON-LISP-LISTP)
XCOMMON-LISP-LISTP
	(JUMP-EQUAL M-T A-V-NIL XTRUE)
   (MISC-INST-ENTRY LISTP)
XLISTP	(DISPATCH Q-DATA-TYPE PDL-POP SKIP-IF-LIST)
	(JUMP XFALSE)
	(JUMP XTRUE)

XNLISTP   (MISC-INST-ENTRY NLISTP)
XNLSTP	(DISPATCH Q-DATA-TYPE PDL-POP SKIP-IF-ATOM)
	(JUMP XFALSE)
	(JUMP XTRUE)

XSYMBOLP   (MISC-INST-ENTRY SYMBOLP)
XSYMP	((M-ZR) Q-DATA-TYPE PDL-POP)
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-SYMBOL)) XTRUE)
	(JUMP XFALSE)

XNSYMBOLP   (MISC-INST-ENTRY NSYMBOLP)
XNSYMP	((M-ZR) Q-DATA-TYPE PDL-POP)
	(JUMP-NOT-EQUAL M-ZR (A-CONSTANT (EVAL DTP-SYMBOL)) XTRUE)
	(JUMP XFALSE)

XARRAYP   (MISC-INST-ENTRY ARRAYP)
XARRYP	((M-ZR) Q-DATA-TYPE PDL-POP)
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-ARRAY-POINTER)) XTRUE)
	(JUMP XFALSE)

XFIXNUMP (MISC-INST-ENTRY FIXNUMP)
	((M-ZR) Q-DATA-TYPE PDL-POP)
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-FIX)) XTRUE)
	(JUMP XFALSE)
   
XSMALL-FLOATP (MISC-INST-ENTRY SMALL-FLOATP)
	((M-ZR) Q-DATA-TYPE PDL-POP)
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-SMALL-FLONUM)) XTRUE)
	(JUMP XFALSE)

XCHARACTERP (MISC-INST-ENTRY CHARACTERP)
	((M-ZR) Q-DATA-TYPE PDL-POP)
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-CHARACTER)) XTRUE)
	(JUMP XFALSE)

   (MISC-INST-ENTRY FBOUNDP)
XFCTNP	(JUMP-XCT-NEXT XBOUNP1)
       ((M-1) (A-CONSTANT 2))

   (MISC-INST-ENTRY BOUNDP)
XBOUNP	((M-1) (A-CONSTANT 1))
XBOUNP1	(ERROR-TABLE RESTART XBOUNP1)
	(DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
			Q-DATA-TYPE PDL-TOP TRAP-UNLESS-SYM)
   (ERROR-TABLE ARGTYP SYMBOL PP 0 XBOUNP1)
   (ERROR-TABLE ARG-POPPED 0 PP)
	((VMA-START-READ) ADD PDL-POP A-1)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-IVC MD)	;NOT USING CONTENTS, DON'T BARF IF NULL
	((M-ZR) Q-DATA-TYPE MD)		;AND DON'T TRANSPORT
	(JUMP-EQUAL M-ZR (A-CONSTANT (EVAL DTP-NULL)) XFALSE)
	(JUMP XTRUE)

XENDP (MISC-INST-ENTRY ENDP)
	((M-T) Q-TYPED-POINTER PDL-POP)
    (ERROR-TABLE RESTART XENDP)
	(JUMP-EQUAL M-T A-V-NIL XTRUE)
	((M-1) Q-DATA-TYPE M-T)
	(JUMP-EQUAL M-T (A-CONSTANT (EVAL DTP-LIST)) XFALSE)
	(CALL TRAP)
    (ERROR-TABLE ARGTYP LIST M-T 0 XENDP)
    (ERROR-TABLE ARG-POPPED M-T)

XNAMED-STRUCTURE-P (MISC-INST-ENTRY NAMED-STRUCTURE-P)
	((M-A) Q-TYPED-POINTER PDL-POP)
	((M-ZR) Q-DATA-TYPE M-A)
	(POPJ-NOT-EQUAL-XCT-NEXT M-ZR (A-CONSTANT (EVAL DTP-ARRAY-POINTER)))  ;NIL unles array
XNAMED-STRUCTURE-P-0
       ((M-T) A-V-NIL)
	((VMA-START-READ) M-A)	;Fetch array header.
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER MD)
	(POPJ-IF-BIT-CLEAR (LISP-BYTE %%ARRAY-NAMED-STRUCTURE-FLAG) MD)  ;Not named str!
	(JUMP-IF-BIT-CLEAR (LISP-BYTE %%ARRAY-LEADER-BIT) MD XNAMED-STRUCTURE-P-1)
	((VMA-START-READ) SUB VMA (A-CONSTANT 1))  ;Array has leader; fetch leader length.
	(CHECK-PAGE-READ)
	((M-1) Q-POINTER MD)
	(POPJ-LESS-OR-EQUAL M-1 (A-CONSTANT 1))	;Ldr length = 1 => no structure type.
	((VMA-START-READ) SUB VMA (A-CONSTANT 2))	;Yes => fetch leader elt. 1.
	(JUMP XNAMED-STRUCTURE-P-CHECK-CLOSURE)

XNAMED-STRUCTURE-P-1		;Array has no leader.  Fetch element 0.
	((M-Q) M-MINUS-ONE)	;Prevent any subscript-oob error.
	(CALL ARRAY-DECODE-1-FORCE-A-Q)
	(JUMP-EQUAL M-S A-ZERO XFALSE)  ;Now check the subscript, but don't err, just ret NIL.
	((VMA-START-READ) M-E)	;It checks; get the first element of the array.
;Here we have the contents of the appropriate array slot or leader slot.
XNAMED-STRUCTURE-P-CHECK-CLOSURE
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT MD)
	((M-ZR) Q-DATA-TYPE MD)
	(POPJ-EQUAL-XCT-NEXT M-ZR (A-CONSTANT (EVAL DTP-SYMBOL)))	;A symbol => return it
       ((M-T) Q-TYPED-POINTER MD)
;If it's not a symbol, only a closure is a valid thing to find here.
	(JUMP-NOT-EQUAL M-ZR (A-CONSTANT (EVAL DTP-CLOSURE)) XFALSE)
;Get the function closed over.  It should be a symbol.  Return it if so, else NIL.
	((M-T) DPB M-T Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
	(CALL QCAR)
	((M-ZR) Q-DATA-TYPE M-T)
	(POPJ-EQUAL M-ZR (A-CONSTANT (EVAL DTP-SYMBOL)))
	(JUMP XFALSE)

XTYPEP-STRUCTURE-OR-FLAVOR (MISC-INST-ENTRY TYPEP-STRUCTURE-OR-FLAVOR)
	((M-I) Q-TYPED-POINTER PDL-POP)
	((M-A) Q-TYPED-POINTER PDL-POP)
	((M-1) Q-DATA-TYPE M-A)
	(JUMP-EQUAL M-1 (A-CONSTANT (EVAL DTP-ARRAY-POINTER)) XTYPEP-STRUCTURE)
	(JUMP-EQUAL M-1 (A-CONSTANT (EVAL DTP-INSTANCE)) XTYPEP-FLAVOR)
	(JUMP XFALSE)

XTYPEP-STRUCTURE
	(CALL XNAMED-STRUCTURE-P-0)	
XTYPEP-STRUCTURE-1
	(JUMP-EQUAL M-T A-I XTRUE)
;; Not exact match of types.  See if the actual type INCLUDEs some other type.
;; (and (setq d (get xname 'defstruct-description))
;;	(defstruct-description-named-p d)
;;	(setq xname (car (defstruct-description-include d))))
;; (unless xname (return nil))
	((PDL-PUSH) M-A)
	((PDL-PUSH) M-I)
	((PDL-PUSH) M-T)
	((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVC-DEFSTRUCT-DESCRIPTION))
	(DISPATCH TRANSPORT MD)
	((PDL-PUSH) MD)
	(CALL XGET)
	(JUMP-EQUAL M-T A-V-NIL XTYPEP-STRUCTURE-2)
;; Ref the DEFSTRUCT-DESCRIPTION-INCLUDE slot.
	((PDL-PUSH) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX) 13)))
	((PDL-PUSH) M-T)
	(CALL XNTH)
	(CALL QCAR)
XTYPEP-STRUCTURE-2
	((M-I) PDL-POP)
	((M-A) PDL-POP)
;; If object's type doesn't INCLUDE another, return NIL.
	(POPJ-EQUAL M-T A-V-NIL)
;; The type does INLUDE another--is that other the one we are looking for?
	(JUMP XTYPEP-STRUCTURE-1)

XTYPEP-FLAVOR
	((VMA-START-READ) M-A)
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT-HEADER MD)
	((M-B) DPB MD Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-ARRAY-POINTER)))
;; M-B has the flavor structure for the flavor of this instance.
	((VMA-START-READ) ADD M-B (A-CONSTANT (EVAL %INSTANCE-DESCRIPTOR-DEPENDS-ON-ALL)))
	(CHECK-PAGE-READ)
	(DISPATCH TRANSPORT MD)
	((M-1) Q-DATA-TYPE MD)
	(JUMP-NOT-EQUAL M-1 (A-CONSTANT (EVAL DTP-LIST)) XFALSE)
	((PDL-PUSH) M-I)
	((PDL-PUSH) Q-TYPED-POINTER MD)
	(CALL XMEMQ)
	(JUMP-NOT-EQUAL M-T A-V-NIL XTRUE)
	(POPJ)

))
