;-*-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)
))