;-*-Mode:LISP; BASE: 8; readtable: ZL-*- ;;; ;;; (c) Copyright 1984 - Lisp Machine, Inc. ;;; (DEFCONST 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 (declare (args a-t) (values a-t)) (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) ;GET DIRECTLY HERE FROM DISPATCH CAR-PRE-DISPATCH-DIRECT. (POPJ-AFTER-NEXT DISPATCH TRANSPORT MD) ((M-T) Q-TYPED-POINTER MD) ;; Here for taking CAR of a symbol. QCARSY ((vma) m-zero) (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. ;; NOTE: you cannot call trap unless VMA contains a reasonable pointer. Clobber it first. QCARNM (DISPATCH-XCT-NEXT M-CAR-NUM-MODE CAR-NUM-DISPATCH) ((vma) m-zero) (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) ((C-PDL-BUFFER-POINTER) DPB C-PDL-BUFFER-POINTER Q-TYPED-POINTER (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL))) ((ARG-CALL MMCALL) (I-ARG 1)) ;Call, 1 arg. Value comes back in M-T. (POPJ) ;; Like QCDR but takes sequence breaks. QCDR-SB(declare (args a-t) (values a-t)) (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) QCDR4-SB (declare (args a-t) (values a-t)) ;get directly here from -direct dispatch (CHECK-PAGE-READ-SEQUENCE-BREAK-saving-vma-in-m-t-if-sequence-break) (DISPATCH TRANSPORT-CDR MD) ;Check for invz, don't really transport. (DISPATCH Q-CDR-CODE MD CDR-CDR-DISPATCH-MASK-VMA-ON-CDR-NEXT) (ERROR-TABLE BAD-CDR-CODE VMA) ;; Drops thru in case of CDR-NEXT. (POPJ-AFTER-NEXT (M-T) Q-TYPED-POINTER VMA) ((M-T) ADD M-T (A-CONSTANT 1)) ;Same data type as arg. (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 (declare (args a-t) (values a-t)) (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) QCDR4 (CHECK-PAGE-READ) ;COME DIRECTLY HERE FROM CDR-PRE-DISPATCH-DIRECT. QCDR-SB-1 (DISPATCH TRANSPORT-CDR MD) ;Check for invz, don't really transport. (DISPATCH Q-CDR-CODE MD CDR-CDR-DISPATCH-MASK-VMA-ON-CDR-NEXT) (ERROR-TABLE BAD-CDR-CODE VMA) ;; Drops thru in case of CDR-NEXT. (POPJ-AFTER-NEXT (M-T) Q-TYPED-POINTER VMA) ((M-T) ADD M-T (A-CONSTANT 1)) ;Same data type as arg. QCDRSY ((vma) m-zero) (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-XCT-NEXT M-CDR-NUM-MODE CDR-NUM-DISPATCH) ((vma) m-zero) (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) POP-THEN-XFALSE (POPJ-AFTER-NEXT (M-T) A-V-NIL) ((M-GARBAGE) PDL-POP) ;; 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 (declare (args a-t) (values a-a a-t)) (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-list)) carcdr-not-list) ((VMA-START-READ) M-T) (CHECK-PAGE-READ-SEQUENCE-BREAK-saving-vma-in-m-t-if-sequence-break) (DISPATCH TRANSPORT MD) ;;better do a full CDR if the CAR was forwarded. --Mats C. (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)) ;note well: the argument tested by the dispatch which gets here must be exactly the ; same as that which winds up in M-T. In particular, it must be masked to Q-TYPED-POINTER. ; This may mean you cant load M-T on the XCT-NEXT cycle of the dispatch and instead have ; to do it before the dispatch, taking an extra cycle. However, that is still better than ; masking the VMA here, which would always take at least one extra cycle. carcdr-direct ;reached directly from carcdr-direct dispatch if list. (declare (args a-t) (values a-a a-t)) (CHECK-PAGE-READ-SEQUENCE-BREAK-saving-vma-in-m-t-if-sequence-break) (DISPATCH TRANSPORT MD) ;;better do a full CDR if the CAR was forwarded. --Mats C. (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 (CALL-XCT-NEXT QCAR) ((PDL-PUSH) M-T) ((M-A) M-T) (JUMP-XCT-NEXT QCDR) ((M-T) PDL-POP) ;;; Take car into M-A and cdr into M-T at same time. CARCDR-NO-SB (declare (args a-t) (values a-a a-t)) (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-list)) carcdr-not-list) ((VMA-START-READ) M-T) (CHECK-PAGE-READ) (DISPATCH TRANSPORT MD) ;;better do a full CDR if the CAR was forwarded. --Mats C. (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 UNRECONCILED-TRAP) ;UNRECONCILED (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 (p-bit n-bit trap) ;rplacd-forward (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)) (END-DISPATCH) #-LAMBDA (begin-comment) (START-DISPATCH 5 0) ;DISPATCH ON DATA TYPE BEFORE TAKING CAR, AND ACTUALLY START MEM REFERENCE ;IF APPROPRIATE. DESIGNED FOR USE WITH DISPATCH-WRITE-VMA-XCT-NEXT. ;ALWAYS DOES XCT-NEXT, EVEN IF ERROR, SINCE THAT IS CONSIDERED TO HAPPEN "BEFORE" THE CAR. CAR-PRE-DISPATCH-DIRECT (P-BIT TRAP) ;TRAP (P-BIT TRAP) ;NULL (P-BIT UNRECONCILED-TRAP) ;UNRECONCILED (P-BIT QCARSY) ;SYMBOL (P-BIT TRAP) ;SYMBOL-HEADER (P-BIT QCARNM) ;FIX (P-BIT QCARNM) ;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 (P-BIT DISPATCH-START-MEM-READ-BIT QCAR4) ;LOCATIVE (P-BIT DISPATCH-START-MEM-READ-BIT QCAR4) ;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 (P-BIT QCARCDR-INSTANCE) ;INSTANCE (send message) (P-BIT TRAP) ;INSTANCE-HEADER (P-BIT TRAP) ;ENTITY (eventually send message?) (P-BIT TRAP) ;STACK-CLOSURE (P-BIT TRAP) ;SELF-REF-POINTER (P-BIT QCARNM) ;CHARACTER (p-bit trap) ;rplacd-forward (REPEAT NQZUSD (P-BIT TRAP)) (END-DISPATCH) (START-DISPATCH 5 0) ;DISPATCH ON DATA TYPE BEFORE TAKING CARCDR, AND ACTUALLY START MEM REFERENCE ;IF APPROPRIATE. DESIGNED FOR USE WITH DISPATCH-WRITE-VMA-XCT-NEXT. ;ALWAYS DOES XCT-NEXT, EVEN IF ERROR, SINCE THAT IS CONSIDERED TO HAPPEN "BEFORE" THE CAR. ;goes to CARCDR not list in any case if its not a list. No immediate arg is necessary ;since it does not go directly to the message sender. CARCDR-DISPATCH-DIRECT (P-BIT CARCDR-NOT-LIST) ;TRAP (P-BIT CARCDR-NOT-LIST) ;NULL (P-BIT CARCDR-NOT-LIST) ;UNRECONCILED (P-BIT CARCDR-NOT-LIST) ;SYMBOL (P-BIT CARCDR-NOT-LIST) ;SYMBOL-HEADER (P-BIT CARCDR-NOT-LIST) ;FIX (P-BIT CARCDR-NOT-LIST) ;EXTENDED NUMBER (P-BIT CARCDR-NOT-LIST) ;HEADER (P-BIT CARCDR-NOT-LIST) ;GC-FORWARD (P-BIT CARCDR-NOT-LIST) ;EXTERNAL-VALUE-CELL-POINTER (P-BIT CARCDR-NOT-LIST) ;ONE-Q-FORWARD (P-BIT CARCDR-NOT-LIST) ;HEADER-FORWARD (P-BIT CARCDR-NOT-LIST) ;BODY-FORWARD (P-BIT CARCDR-NOT-LIST) ;LOCATIVE (P-BIT DISPATCH-START-MEM-READ-BIT CARCDR-DIRECT) ;LIST (P-BIT CARCDR-NOT-LIST) ;U CODE ENTRY (P-BIT CARCDR-NOT-LIST) ;FEF (P-BIT CARCDR-NOT-LIST) ;ARRAY-POINTER (P-BIT CARCDR-NOT-LIST) ;ARRAY-HEADER (P-BIT CARCDR-NOT-LIST) ;STACK-GROUP (P-BIT CARCDR-NOT-LIST) ;CLOSURE (P-BIT CARCDR-NOT-LIST) ;SMALL-FLONUM (P-BIT CARCDR-NOT-LIST) ;SELECT-METHOD (P-BIT CARCDR-NOT-LIST) ;INSTANCE (send message) (P-BIT CARCDR-NOT-LIST) ;INSTANCE-HEADER (P-BIT CARCDR-NOT-LIST) ;ENTITY (eventually send message?) (P-BIT CARCDR-NOT-LIST) ;STACK-CLOSURE (P-BIT CARCDR-NOT-LIST) ;SELF-REF-POINTER (P-BIT CARCDR-NOT-LIST) ;CHARACTER (p-bit carcdr-not-list) ;rplacd-forward (REPEAT NQZUSD (P-BIT CARCDR-NOT-LIST)) (END-DISPATCH) #-LAMBDA (end-comment) (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 UNRECONCILED-TRAP) ;UNRECONCILED (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 (p-bit n-bit trap) ;rplacd-forward (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)) (END-DISPATCH) #-LAMBDA (begin-comment) (START-DISPATCH 5 0) ;DISPATCH ON DATA TYPE BEFORE TAKING CDR, AND ACTUALLY START MEM REFERENCE ;IF APPROPRIATE. DESIGNED FOR USE WHICH DISPATCH-WRITE-VMA-XCT-NEXT. ;ALWAYS DOES XCT-NEXT, EVEN IF ERROR, SINCE THAT IS CONSIDERED TO HAPPEN "BEFORE" THE CDR. CDR-PRE-DISPATCH-DIRECT (P-BIT TRAP) ;TRAP (P-BIT TRAP) ;NULL (P-BIT UNRECONCILED-TRAP) ;UNRECONCILED (P-BIT QCDRSY) ;SYMBOL (P-BIT TRAP) ;SYMBOL-HEADER (P-BIT QCDRNM) ;FIX (P-BIT QCDRNM) ;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 (P-BIT DISPATCH-START-MEM-READ-BIT QCAR4) ;LOCATIVE. NOTE CAR!! (P-BIT DISPATCH-START-MEM-READ-BIT QCDR4) ;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 (P-BIT QCARCDR-INSTANCE) ;INSTANCE (send message) (P-BIT TRAP) ;INSTANCE-HEADER (P-BIT TRAP) ;ENTITY (eventually send message?) (P-BIT TRAP) ;STACK-CLOSURE (P-BIT TRAP) ;SELF-REF-POINTER (P-BIT QCDRNM) ;CHARACTER (p-bit trap) ;rplacd-forward (REPEAT NQZUSD (P-BIT TRAP)) (END-DISPATCH) (START-DISPATCH 5 0) ;DISPATCH ON DATA TYPE BEFORE TAKING CDR, AND ACTUALLY START MEM REFERENCE ;IF APPROPRIATE. DESIGNED FOR USE WHICH DISPATCH-WRITE-VMA-XCT-NEXT. ;ALWAYS DOES XCT-NEXT, EVEN IF ERROR, SINCE THAT IS CONSIDERED TO HAPPEN "BEFORE" THE CDR. ;this one allows sequence breaks. CDR-PRE-DISPATCH-SB-DIRECT (P-BIT TRAP) ;TRAP (P-BIT TRAP) ;NULL (P-BIT UNRECONCILED-TRAP) ;UNRECONCILED (P-BIT QCDRSY) ;SYMBOL (P-BIT TRAP) ;SYMBOL-HEADER (P-BIT QCDRNM) ;FIX (P-BIT QCDRNM) ;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 (P-BIT DISPATCH-START-MEM-READ-BIT QCAR4) ;LOCATIVE. NOTE CAR!! (P-BIT DISPATCH-START-MEM-READ-BIT QCDR4-SB) ;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 (P-BIT QCARCDR-INSTANCE) ;INSTANCE (send message) (P-BIT TRAP) ;INSTANCE-HEADER (P-BIT TRAP) ;ENTITY (eventually send message?) (P-BIT TRAP) ;STACK-CLOSURE (P-BIT TRAP) ;SELF-REF-POINTER (P-BIT QCDRNM) ;CHARACTER (P-BIT TRAP) ;rplacd-forward (REPEAT NQZUSD (P-BIT TRAP)) (END-DISPATCH) #-LAMBDA (end-comment) (LOCALITY D-MEM) #+cdr-next-is-0 (begin-comment) (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) #+cdr-next-is-0 (end-comment) #-cdr-next-is-0 (begin-comment) (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 (R-BIT) ;CDR NEXT (P-BIT INHIBIT-XCT-NEXT-BIT TRAP) ;CDR NOT (INHIBIT-XCT-NEXT-BIT CDR-FULL-NODE) ;FULL-NODE (INHIBIT-XCT-NEXT-BIT CDR-IS-NIL) ;CDR NIL (END-DISPATCH) #-cdr-next-is-0 (end-comment) #+cdr-next-is-0 (begin-comment) (START-DISPATCH 2 0) ;MAYBE DOES XCT-NEXT ;DISPATCH ON CDR-CODE WHEN TAKING CDR ;use this one if the cdr-code of the VMA is not known to be 0. ; instead of popj on CDR-NEXT, drop thru. This could be flushed if we ; had OUTPUT-SELECTOR-MASK-30. ;POPJ-XCT-NEXT IF CDR-NEXT (PROBABLY MOST FREQUENT CASE) CDR-CDR-DISPATCH-MASK-VMA-ON-CDR-NEXT (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 (P-BIT R-BIT) ;CDR NEXT (END-DISPATCH) #+cdr-next-is-0 (end-comment) #-cdr-next-is-0 (begin-comment) (START-DISPATCH 2 0) ;MAYBE DOES XCT-NEXT ;DISPATCH ON CDR-CODE WHEN TAKING CDR ;use this one if the cdr-code of the VMA is not known to be 0. ; instead of popj on CDR-NEXT, drop thru. This could be flushed if we ; had OUTPUT-SELECTOR-MASK-30. ;POPJ-XCT-NEXT IF CDR-NEXT (PROBABLY MOST FREQUENT CASE) CDR-CDR-DISPATCH-MASK-VMA-ON-CDR-NEXT (P-BIT R-BIT) ;CDR NEXT (P-BIT INHIBIT-XCT-NEXT-BIT TRAP) ;CDR NOT (INHIBIT-XCT-NEXT-BIT CDR-FULL-NODE) ;FULL-NODE (INHIBIT-XCT-NEXT-BIT CDR-IS-NIL) ;CDR NIL (END-DISPATCH) #-cdr-next-is-0 (end-comment) (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) ;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) ;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 (open-qcdr m-t) QMADD (open-qcdr m-t) QMAD (open-qcdr m-t) (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 (open-qcar m-t) QMAAA (open-qcar m-t) QMAA (open-qcar m-t) (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 (open-qcdr m-t) QMDDD (open-qcdr m-t) QMDD (open-qcdr m-t) (JUMP QCDR) (ERROR-TABLE DEFAULT-ARG-LOCATIONS CAAADR M-A) XCAAADR (MISC-INST-ENTRY CAAADR) (open-qcdr-xct-next pdl-top) ((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 (open-qcdr m-t) (JUMP QMAAA) (ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDDAR M-A) XCDDDAR (MISC-INST-ENTRY CDDDAR) (open-qcar-xct-next pdl-top) ((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 (open-qcar m-t) (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 (open-qcdr m-t) QMAAD (open-qcdr m-t) (JUMP QMAA) (ERROR-TABLE DEFAULT-ARG-LOCATIONS CAADAR M-A) XCAADAR (MISC-INST-ENTRY CAADAR) (open-qcar-xct-next pdl-top) ((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 (open-qcar m-t) (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 (open-qcar m-t) QMDDA (open-qcar m-t) (JUMP QMDD) (ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDADR M-A) XCDDADR (MISC-INST-ENTRY CDDADR) (open-qcdr-xct-next pdl-top) ((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 (open-qcdr m-t) (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 (open-qcar m-t) QMADA (open-qcar m-t) (JUMP QMAD) (ERROR-TABLE DEFAULT-ARG-LOCATIONS CADADR M-A) XCADADR (MISC-INST-ENTRY CADADR) (open-qcdr-xct-next pdl-top) ((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 (open-qcdr m-t) (JUMP QMADA) (ERROR-TABLE DEFAULT-ARG-LOCATIONS CADDAR M-A) XCADDAR (MISC-INST-ENTRY CADDAR) (open-qcar-xct-next pdl-top) ((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 (open-qcar m-t) (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 (open-qcar m-t) QMDAD (open-qcdr m-t) (JUMP QMDA) (ERROR-TABLE DEFAULT-ARG-LOCATIONS CDADDR M-A) XCDADDR (MISC-INST-ENTRY CDADDR) (open-qcdr-xct-next pdl-top) ((M-T) Q-TYPED-POINTER PDL-TOP) (ERROR-TABLE ARG-POPPED 0 PP) (open-qcdr-xct-next m-t) ((M-A) Q-TYPED-POINTER PDL-POP) (JUMP QMDA) QMDADD (open-qcdr m-t) (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 (open-qcar m-t) QMDAA (open-qcar m-t) QMDA (open-qcar m-t) (JUMP QCDR) (ERROR-TABLE DEFAULT-ARG-LOCATIONS CDAADR M-A) XCDAADR (MISC-INST-ENTRY CDAADR) (open-qcdr-xct-next pdl-top) ((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 (open-qcdr m-t) (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) (open-qcar-xct-next pdl-top) ((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) (open-qcdr-xct-next pdl-top) ((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) (open-qcar-xct-next pdl-top) ((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) (open-qcdr-xct-next pdl-top) ((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)) (jump-data-type-equal c-pdl-buffer-index (a-constant (byte-value q-data-type 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)) (jump-data-type-equal c-pdl-buffer-index (a-constant (byte-value q-data-type 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 (JUMP-XCT-NEXT XNTHCDR-0) ((M-T) Q-TYPED-POINTER PDL-POP) ;List (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) (open-qcdr-sb m-t) (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) ;#+CADR (CALL-XCT-NEXT CARCDR) ;#+CADR ((M-T) Q-TYPED-POINTER PDL-POP) ((M-T) Q-TYPED-POINTER PDL-POP) #+exp (open-carcdr m-t) #+LAMBDA(DISPATCH-XCT-NEXT DISPATCH-WRITE-VMA Q-DATA-TYPE M-T CARCDR-DISPATCH-DIRECT) #+LAMBDA(NO-OP) (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 (JUMP-XCT-NEXT QCAR) (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type 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 (JUMP-XCT-NEXT QCDR-SB) (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type 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 (???) (GC-WRITE-TEST) (popj-after-next) ((m-t) q-typed-pointer 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 (???) (GC-WRITE-TEST) (popj-after-next) ((m-t) q-typed-pointer 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) dpb M-A q-typed-pointer (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL))) ;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) q-typed-pointer 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-CDR-NEXT) ;CDR NEXT (P-BIT INHIBIT-XCT-NEXT-BIT TRAP) ;CDR NOT (RPLACD-FULL-NODE) ;FULL NODE (RPLACD-NEXT-NIL) ;CDR NIL (END-DISPATCH) (LOCALITY I-MEM) rplacd-full-node ((vma-start-read) add vma (a-constant 1)) ;Get word to smash. (check-page-read) (dispatch transport-write md) ;Chase invisibles. ((md-start-write) selective-deposit md q-all-but-typed-pointer a-t) (check-page-write) (gc-write-test) rplacd-exit (popj-after-next (m-t) q-typed-pointer m-a) (no-op) rplacd-next-nil (jump-equal m-t a-v-nil rplacd-exit) ;RPLACD with nil and cdr already nil, no-op. ;; Fall through. rplacd-cdr-next ((pdl-push) m-a) ;Save for return value. ((pdl-push) vma) ;Address of cell to be forwarded. ;; This used to cons in the same area as the forwarded cell, but I think it's OK ;; just to do it in the background area, and it's a lot faster. KHS 850601. ((pdl-push) m-i) ;CAR of new cell. ((pdl-push) m-t) ;CDR of new cell. (call-xct-next qcons) ((m-s) dpb m-zero q-all-but-typed-pointer a-background-cons-area) ;; Forward original CAR with magic forwarding pointer. It is important that ;; this pointer have CDR-ERROR on it (see structure-info). ((md) dpb m-t q-pointer (a-constant (plus (byte-value q-data-type dtp-rplacd-forward) (byte-value q-cdr-code cdr-error)))) ((vma-start-write) pdl-pop) (check-page-write) (gc-write-test) (popj-after-next (m-t) q-typed-pointer pdl-pop) (no-op) ;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 UNRECONCILED-TRAP) ;UNRECONCILED (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 (p-bit trap) ;rplacd-forward (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 UNRECONCILED-TRAP) ;UNRECONCILED (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 (p-bit trap) ;rplacd-forward (REPEAT NQZUSD (P-BIT TRAP)) (END-DISPATCH) (LOCALITY I-MEM) ;;; EQUAL XEQUALP (MISC-INST-ENTRY EQUALP) ((M-T) Q-TYPED-POINTER PDL-POP) ((M-B) Q-TYPED-POINTER PDL-POP) XEQUALP-0 (JUMP-EQUAL M-T A-B XTRUE) (CALL XEQUALP-1) ;Handle numeric case. ;Else different types means unequal. (jump-data-type-not-equal m-t a-b xfalse) (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type 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) XEQUALP-COMMON (jump-data-type-equal m-t (a-constant (byte-value q-data-type dtp-array-pointer)) xequalp-array) (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-list)) 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. #+lambda(JUMP-GREATER-THAN MICRO-STACK-PNTR-AND-DATA (A-CONSTANT 20._24.) XEQUALP-SLOW-RECURSE) #+exp (JUMP-GREATER-THAN MICRO-STACK-PNTR (A-CONSTANT 10.) XEQUALP-SLOW-RECURSE) ;; Otherwise, test for EQUALity of the two cars. (CALL XEQUALP-0) XEQUALP-CDR (JUMP-EQUAL M-T A-V-NIL XEQUAL-DIFFERENT-CARS) ;; If the cars match, tail-recursively check the two cdrs. (open-qcdr-sb-xct-next pdl-top) ((M-T) PDL-POP) ((M-B) M-T) (open-qcdr-sb-xct-next pdl-top) ((M-T) PDL-POP) (JUMP XEQUALP-0) XEQUALP-SLOW-RECURSE (CALL P3ZERO) ((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVC-EQUALP)) (DISPATCH TRANSPORT MD) ((PDL-PUSH) MD) ((PDL-PUSH) DPB M-T Q-TYPED-POINTER (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT))) ((PDL-PUSH) DPB M-B Q-TYPED-POINTER (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL))) ((ARG-CALL MMCALL) (I-ARG 2)) (JUMP XEQUALP-CDR) ;; If both arrays are strings, call STRING-EQUAL; ;; otherwise answer is computed by macrocode. xequalp-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) XEQUALP-ARRAY-HARD) ;; Both rank 1. XEQUALP-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))) XEQUALP-BOTH-STRINGSP-1) (JUMP-NOT-EQUAL M-3 (A-CONSTANT (EVAL (LSH ART-FAT-STRING ARRAY-TYPE-SHIFT))) XEQUALP-ARRAY-NOT-STRING) XEQUALP-BOTH-STRINGSP-1 (JUMP-EQUAL M-2 (A-CONSTANT (EVAL (LSH ART-STRING ARRAY-TYPE-SHIFT))) XEQUALP-BOTH-STRINGSP-2) (JUMP-NOT-EQUAL M-2 (A-CONSTANT (EVAL (LSH ART-FAT-STRING ARRAY-TYPE-SHIFT))) XEQUALP-ARRAY-NOT-STRING) ;; Both strings and rank 1. XEQUALP-BOTH-STRINGSP-2 ;Call STRING-EQUAL, which will check for arrays having same size and same elements. ((PDL-PUSH) A-ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON) ((A-ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON) A-V-NIL) ((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))) (CALL-XCT-NEXT XSTRING-EQUAL);uses pdl pass-around ((PDL-PUSH) A-V-NIL) (POPJ-AFTER-NEXT (A-ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON) PDL-POP) (NO-OP) XEQUALP-ARRAY-NOT-STRING XEQUALP-ARRAY-HARD ;ALWAYS CALL MACROCODE, NO NEED TO DETECT ART-1B CASE. (CALL P3ZERO) ((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVC-EQUALP-ARRAY)) (DISPATCH TRANSPORT MD) ((PDL-PUSH) MD) ((PDL-PUSH) DPB M-T Q-TYPED-POINTER (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT))) ((PDL-PUSH) DPB M-B Q-TYPED-POINTER (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL))) ((ARG-CALL MMCALL) (I-ARG 2)) (POPJ) ;;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) XEQUAL (MISC-INST-ENTRY EQUAL) ((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) ;False if args are different data types. (jump-data-type-not-equal m-t a-b xfalse) (jump-data-type-equal m-t (a-constant (byte-value q-data-type dtp-extended-number)) xequal-xnum) (jump-data-type-equal m-t (a-constant (byte-value q-data-type dtp-array-pointer)) xequal-array) (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-list)) 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. #+lambda(JUMP-GREATER-THAN MICRO-STACK-PNTR-AND-DATA (A-CONSTANT 20._24.) XEQUAL-SLOW-RECURSE) #+exp (JUMP-GREATER-THAN MICRO-STACK-PNTR (A-CONSTANT 10.) 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. (open-qcdr-sb-xct-next pdl-top) ((M-T) PDL-POP) ((M-B) M-T) (open-qcdr-sb-xct-next pdl-top) ((M-T) PDL-POP) (JUMP XEQUAL-0) XEQUAL-DIFFERENT-CARS ;also used for XEQUALP (POPJ-AFTER-NEXT (PDL-BUFFER-POINTER) SUB PDL-BUFFER-POINTER (A-CONSTANT 2)) (NO-OP) XEQUAL-SLOW-RECURSE (CALL P3ZERO) ((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVC-EQUAL)) (DISPATCH TRANSPORT MD) ((PDL-PUSH) MD) ((PDL-PUSH) DPB M-T Q-TYPED-POINTER (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT))) ((PDL-PUSH) DPB M-B Q-TYPED-POINTER (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL))) ((ARG-CALL MMCALL) (I-ARG 2)) (JUMP XEQUAL-CDR) ;; Read headers of both args to EQUAL or EQUALP ;; 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 EQL (not =) to compare the numbers. ;; (equal #c(3 -4.0) #c(3 -4)) ==> false ;; not to mention that rational and floats wont mix in complex Lisp Machine ;; numbers. ((PDL-PUSH) M-B) (DISPATCH-XCT-NEXT Q-DATA-TYPE M-B D-NUMARG1) ((M-A) (A-CONSTANT ARITH-2ARG-EQL)) ;; 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) XFALSE) ;only strings or bit-vectors to have a chance ;; 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) 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))) (CALL-XCT-NEXT XSTRING-EQUAL) ;uses pdl pass-around ((PDL-PUSH) A-V-NIL) (POPJ-AFTER-NEXT (A-ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON) PDL-POP) (no-op) XEQUAL-ARRAY-NOT-STRING (JUMP-NOT-EQUAL M-3 (A-CONSTANT (EVAL (LSH ART-1B ARRAY-TYPE-SHIFT))) XFALSE) (JUMP-NOT-EQUAL M-2 (A-CONSTANT (EVAL (LSH ART-1B ARRAY-TYPE-SHIFT))) XFALSE) (JUMP XEQUALP-ARRAY-HARD) ;BOTH BITVEC, OK TO COMPARE WITH EQUALP MACROCODE. ;(%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)) ;(%BLT-BOOLE ALU from-address to-address n-words increment) ; if from-address and/or to-address are DTP-ARRAY-POINTER, the data origin of the array ; is substituted, otherwise, from-address and to-address are raw addresses. ;Increment is usually 1, less often -1 for backwards blt. ;Value is a fixnum between 0 and 3. Bit 0 is set if IOR of all data is 0, ; BIT 1 is set if AND of all data is -1. XBLT-BOOLE (MISC-INST-ENTRY %BLT-BOOLE) ((M-R) Q-POINTER PDL-POP) ;increment ((M-C) Q-POINTER PDL-POP) ;n-words (call-data-type-equal pdl-top (a-constant (byte-value q-data-type dtp-array-pointer)) address-array-data) ;replaces array pointer on stack with its data origin. ;clobbers M-A, M-B, M-D, M-E, M-S ((M-2) Q-POINTER PDL-POP) ;to address (call-data-type-equal pdl-top (a-constant (byte-value q-data-type dtp-array-pointer)) address-array-data) ((M-1) Q-POINTER PDL-POP) ;from address ((A-ALUF) DPB PDL-POP OAL-ALUF A-ZERO) ((M-2) SUB M-2 A-R) ((M-1) SUB M-1 A-R) ((M-3) SETZ) ;GETS IOR OF ALL DATA ((M-4) SETO) ;GETS AND OF ALL DATA XBLT-BOOLE-1 (JUMP-EQUAL M-C (A-CONSTANT 0) XBLT-BOOLE-2) ((VMA-START-READ M-1) ADD M-1 A-R) (CHECK-PAGE-READ) ((M-J) MD) ;should to moved to untyped when possible. **** ((VMA-START-READ M-2) ADD M-2 A-R) (CHECK-PAGE-READ) ((OA-REG-LOW) A-ALUF) ((WRITE-MEMORY-DATA-START-WRITE) SETZ MD A-J) (CHECK-PAGE-WRITE) ((M-3) IOR MD A-3) ((M-4) AND MD A-4) (JUMP-XCT-NEXT XBLT-BOOLE-1) ((M-C) SUB M-C (A-CONSTANT 1)) XBLT-BOOLE-2 ((m-j) setz) ;flush garbage. ((M-T) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) (JUMP-NOT-EQUAL M-3 A-ZERO XBLT-BOOLE-3) ((M-T) IOR M-T (A-CONSTANT 1)) ;IOR of all data is 0. XBLT-BOOLE-3 (POPJ-AFTER-NEXT POPJ-NOT-EQUAL M-4 (A-CONSTANT -1)) ((M-T) IOR M-T (A-CONSTANT 2)) ;AND of all data is -1. ADDRESS-ARRAY-DATA ;REPLACE AN ARRAY POINTER ON TOP OF STACK WITH ITS DATA ORIGIN. #+exp ((vma) pdl-top) (DISPATCH-XCT-NEXT #+lambda DISPATCH-WRITE-VMA Q-DATA-TYPE PDL-TOP ARRAY-HEADER-SETUP-DISPATCH) ((m-a) seta a-minus-one c-pdl-buffer-pointer-pop) (popj-after-next (pdl-push) dpb m-array-origin q-pointer (a-constant (byte-value q-data-type dtp-fix))) (no-op) 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 (jump-data-type-equal m-t (a-constant (byte-value q-data-type dtp-fix)) xtrue) ((M-4) (A-CONSTANT (EVAL %HEADER-TYPE-BIGNUM))) XFXFLP ;false unless extended number of type in M-4 (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type 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 (jump-data-type-equal m-t (a-constant (byte-value q-data-type dtp-small-flonum)) xtrue) (JUMP-XCT-NEXT XFXFLP) ((M-4) (A-CONSTANT (EVAL %HEADER-TYPE-FLONUM))) XRATIONALP (MISC-INST-ENTRY RATIONALP) ((M-T) Q-TYPED-POINTER PDL-POP) (JUMP-DATA-TYPE-EQUAL M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) XTRUE) (JUMP-DATA-TYPE-NOT-EQUAL M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTENDED-NUMBER)) XFALSE) ((VMA-START-READ) M-T) (CHECK-PAGE-READ) (DISPATCH TRANSPORT-HEADER MD) ((M-TEM) (LISP-BYTE %%HEADER-TYPE-FIELD) MD) (JUMP-EQUAL M-TEM (A-CONSTANT (EVAL %HEADER-TYPE-BIGNUM)) XTRUE) (JUMP-EQUAL M-TEM (A-CONSTANT (EVAL %HEADER-TYPE-RATIONAL)) XTRUE) (JUMP XFALSE) 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 (JUMP-XCT-NEXT XFXFLP) ((M-T) Q-TYPED-POINTER PDL-POP) 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 (m-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 ;; Pointer from PDL has already been transported, or is a fixnum virtual address. ((VMA-START-READ) PDL-POP) (CHECK-PAGE-READ) ((MD-START-WRITE) SELECTIVE-DEPOSIT MD Q-ALL-BUT-TYPED-POINTER A-T) (CHECK-PAGE-WRITE) (GC-WRITE-TEST) (popj) (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 ((m-TEM2) SUB (M-CONSTANT 40) A-E) ;COMPENSATE FOR SHIFTER LOSSAGE #+exp ((m-tem3) add m-j (a-constant 1)) (POPJ-AFTER-NEXT (OA-REG-LOW) DPB #+lambda M-J #+exp m-tem3 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) ((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP) (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 ((m-TEM2) SUB (M-CONSTANT 40) A-E) ;Compensate for shifter lossage #+exp ((m-tem3) add m-j (a-constant 1)) (POPJ-AFTER-NEXT (OA-REG-LOW) DPB #+lambda M-J #+exp m-tem3 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.)) #+lambda((OA-REG-HIGH) BIGNUM-HEADER-SIGN M-C) ;Byte off top of bignum, return sign bits #+exp ((m-t) bignum-header-sign m-c) #+exp ((oa-reg-high) dpb m-t oah-m-src a-zero) ((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 #+exp ((m-tem3) add m-j (a-constant 1)) ((OA-REG-LOW) DPB #+lambda M-J #+exp m-tem3 OAL-BYTL-1 A-ZERO) ((M-1) BYTE-INST MD A-ZERO) ;Get bits from second word ;Put those bits above the previous bits. ((OA-REG-LOW) DPB #+lambda M-J #+exp m-tem3 OAL-BYTL-1 A-4) ((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 #+exp ((m-tem3) add m-k (a-constant 1)) (POPJ-AFTER-NEXT (OA-REG-LOW) DPB #+lambda M-K #+exp m-tem3 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 #+exp ((m-tem3) add m-e (a-constant 1)) ((OA-REG-LOW) DPB #+lambda M-E #+exp m-tem3 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. ((m-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 #+lambda M-TEM #+exp m-4 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 #+exp ((m-tem3) add m-tem (a-constant 1)) (POPJ-AFTER-NEXT (OA-REG-LOW) DPB #+lambda M-TEM #+exp m-tem3 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 #+exp ((m-tem3) add m-tem (a-constant 1)) ((OA-REG-LOW) DPB #+lambda M-TEM #+exp m-tem3 OAL-BYTL-1 A-E) ((M-2) DPB M-1 A-2) ;DO THE DPB ((m-TEM2) M-A-1 (M-CONSTANT 40) A-TEM) ;SHIFT OVER TO USE UP WHATS BEEN DPB'ED #+exp ((m-tem3) add m-k (a-constant 1)) (POPJ-AFTER-NEXT ;FACT BYTE SIZE IS +1 DOESNT HURT, (OA-REG-LOW) DPB #+lambda M-K #+exp m-tem3 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) ;if DPBing into character, return character DTP. (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)) ((m-TEM1) (BYTE-FIELD 6 6) PDL-POP) ;GET NUMBER OF PLACES OVER #+exp ((m-tem3) add m-k (a-constant 1)) ((OA-REG-LOW) DPB #+lambda M-K #+exp m-tem3 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-ZR) Q-DATA-TYPE PDL-TOP) ;save data type for xdpb1 (character or not). (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. ((M-1) OUTPUT-SELECTOR-EXTEND-25 C-PDL-BUFFER-POINTER-POP) ;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 #+exp ((m-tem3) add m-j (a-constant 1)) ((OA-REG-LOW) DPB #+lambda M-J #+exp m-tem3 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-ZR (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 #+exp ((m-tem3) add m-j (a-constant 1)) ((OA-REG-LOW) DPB #+lambda M-J #+exp m-tem3 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 ((m-TEM2) (BYTE-FIELD 6 6) PDL-POP) ;GET NUMBER OF PLACES OVER #+exp ((m-tem3) add m-j (a-constant 1)) (POPJ-AFTER-NEXT ;NO "SHIFTER LOSSAGE" ON SELECTIVE-DEPOSIT (OA-REG-LOW) DPB #+lambda M-J #+exp m-tem3 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) ((m-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) ((m-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)) ((m-TEM1) (BYTE-FIELD 6 6) PDL-POP) ;GET NUMBER OF PLACES OVER #+exp ((m-tem3) add m-k (a-constant 1)) (POPJ-AFTER-NEXT (OA-REG-LOW) DPB #+lambda M-K #+exp m-tem3 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) xps-tag-and-pointer ;This can be used to gronk ONE-Q-FORWARDs, etc. (misc-inst-entry %p-store-data-type-and-pointer) ((m-a) q-typed-pointer pdl-pop) ;ARG3, value for pointer field (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP) ;ARG2, data type Q-DATA-TYPE PDL-TOP TRAP-UNLESS-FIXNUM) ((m-t) q-typed-pointer pdl-pop) ((vma-start-read) pdl-pop) ;arg1, where to store. (check-page-read) (dispatch transport-cdr md) ;read CDR-CODE from newspace. ((m-tem) md) ((m-tem) dpb m-a q-pointer a-tem) ((md-start-write) dpb m-t q-data-type a-tem) (check-page-write) (gc-write-test) (popj) ;return data-type, which is safe. XPDAT (MISC-INST-ENTRY %P-POINTER) ((M-1) (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-1) ((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-1) (A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST Q-DATA-TYPE)))) XPCDRC (MISC-INST-ENTRY %P-CDR-CODE) (JUMP-XCT-NEXT XPDAT1) ((M-1) (A-CONSTANT (OA-LOW-CONTEXT (BYTE-INST Q-CDR-CODE)))) XSPDTP (MISC-INST-ENTRY %P-STORE-DATA-TYPE) ((M-1) (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) ((m-TEM2) MD) ((OA-REG-LOW) M-1) ((MD-START-WRITE) DPB M-T A-TEM2) (CHECK-PAGE-WRITE) (GC-WRITE-TEST) (popj) XSPDAT (MISC-INST-ENTRY %P-STORE-POINTER) (JUMP-XCT-NEXT XSPDTP1) ((M-1) (A-CONSTANT (OA-LOW-CONTEXT (DPB Q-POINTER)))) XSPCDR (MISC-INST-ENTRY %P-STORE-CDR-CODE) (JUMP-XCT-NEXT XSPDTP1) ((M-1) (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 ((M-T) Q-POINTER MD (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE))) (POPJ-EQUAL MD A-1) ;REPEAT IF E.G. SNAPPED OUT HDR-FWD (jump xpcal1) 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))) xpless (misc-inst-entry %pointer-lessp) ((m-1) q-pointer pdl-pop) ((m-2) q-pointer pdl-pop) (jump-less-than m-2 a-1 xtrue) (jump xfalse) xpgreater (misc-inst-entry %pointer-greaterp) ((m-1) q-pointer pdl-pop) ((m-2) q-pointer pdl-pop) (jump-greater-than m-2 a-1 xtrue) (jump xfalse) 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) (GC-WRITE-TEST) (popj) ;%MAKE-POINTER-OFFSET returns a pointer whose pointer ; is (+ (%POINTER ) ) and whose data type is . No data ; type checks. XMOP (MISC-INST-ENTRY %MAKE-POINTER-OFFSET) ;Can this make pointers to oldspace? ;Well, if it is indexing into a structure, it can't because the original structure ;must be in newspace. If it is indexing into a cdr-coded list (questionable code) ;I think it will work because the list is transported all at once. ((M-T) Q-TYPED-POINTER PDL-POP) ((M-T) ADD PDL-POP A-T) (popj-after-next (M-T) DPB Q-DATA-TYPE PDL-POP A-T) ((m-t) q-typed-pointer m-t) ;avoid garbage in cdr-code. 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. ((M-D) Q-TYPED-POINTER PDL-POP) ;Arg2, property name. ((M-T) Q-TYPED-POINTER PDL-POP) ;Arg1, symbol or plist. (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-instance)) xget2) ((ARG-CALL INSTANCE-INVOKE-1) (I-ARG INSTANCE-INVOKE-GET)) ((PDL-PUSH) DPB M-D Q-TYPED-POINTER (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT))) ((PDL-PUSH) DPB M-E Q-TYPED-POINTER (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL))) ((ARG-CALL MMCALL) (I-ARG 3)) ;Call, 2 args. Value comes back in M-T. (POPJ) ;(ERROR-TABLE DEFAULT-ARG-LOCATIONS GET M-B M-D) ;XGET (MISC-INST-ENTRY INTERNAL-GET-2) ; ((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. ; ((M-E) A-V-NIL) XGET2 ;; The following instruction can popj out of XGET. ((ARG-CALL-XCT-NEXT PLGET) (I-ARG INSTANCE-INVOKE-GET)) ((M-B) M-T) ;Save copy of arg in M-B. XGET1 (JUMP-EQUAL M-T A-V-NIL XGET-NOT-FOUND) XGET1A (open-carcdr m-t) ;; If the car matches desired property, ;; return the car of the following link (now in M-T). (JUMP-EQUAL M-A A-D QCAR) (open-qcdr m-t) (JUMP-NOT-EQUAL M-T A-V-NIL XGET1A) XGET-NOT-FOUND (POPJ-AFTER-NEXT (M-T) M-E) (NO-OP) xget (misc-inst-entry internal-get-2) ((m-d) q-typed-pointer c-pdl-buffer-pointer-pop) (call-xct-next xget-property-list) ((m-t) q-typed-pointer c-pdl-buffer-pointer-pop) (popj-equal m-t a-v-nil) xget0 #+lambda(dispatch-xct-next dispatch-write-vma q-data-type m-t carcdr-dispatch-direct) #+exp (open-carcdr-xct-next m-t) (no-op) (jump-equal m-a a-d qcar) #+lambda(dispatch-xct-next dispatch-write-vma (i-arg instance-invoke-cdr) q-data-type m-t cdr-pre-dispatch-direct) #+exp (open-qcdr-xct-next m-t) (no-op) (jump-xct-next xget0) (popj-equal m-t a-v-nil) xget-property-list (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-symbol)) xget-property-list-hard) ((vma-start-read) add m-t (a-constant 3)) (check-page-read) (popj-after-next dispatch transport md) ((m-t) q-typed-pointer md) xget-property-list-hard (jump-data-type-equal m-t (a-constant (byte-value q-data-type dtp-list)) qcdr) (jump-data-type-equal m-t (a-constant (byte-value q-data-type dtp-locative)) qcdr) (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-instance)) xfalse) ((arg-jump-xct-next instance-invoke) (i-arg instance-invoke-get)) ((m-a) m-d) ;(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-2) ((PDL-INDEX M-2) SUB M-2 A-PDL-BUFFER-VIRTUAL-ADDRESS) (JUMP-NOT-EQUAL PDL-INDEX M-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 XGETI2) ((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)) (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. ;; The following instruction can popj out of XGETI. ((ARG-CALL-XCT-NEXT PLGET) (I-ARG INSTANCE-INVOKE-GET-LOCATION-OR-NIL)) ((M-B) M-T) ;Save copy of arg in M-B. XGETI1 (POPJ-EQUAL M-T A-V-NIL) ;END OF PLIST REACHED XGETI1A (open-carcdr m-t) (JUMP-EQUAL M-A A-D XGETI2) (open-qcdr m-t) (JUMP-NOT-EQUAL M-T A-V-NIL XGETI1A) (POPJ) ;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) ;SUBROUTINE TO 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. PLGET (JUMP-DATA-TYPE-EQUAL M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL)) PLGET2) (JUMP-DATA-TYPE-EQUAL M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)) QCDR) ;"DISEMBODIED" PROPERTY LIST (JUMP-DATA-TYPE-EQUAL M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)) QCDR) ;"DISEMBODIED" PROPERTY LIST (JUMP-DATA-TYPE-EQUAL M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-INSTANCE)) INSTANCE-INVOKE) (JUMP XFALSE) ;GET OF RANDOM THINGS NIL IN MACLISP, SO ... 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) ;; Send a message to the instance in M-T, with argument in M-A. ;; The I-ARG controls what message we send; it is an INSTANCE-INVOKE code. ;; POPJ's twice, so exits the calling function. INSTANCE-INVOKE (CALL INSTANCE-INVOKE-1);Push frame and the instance. ((PDL-PUSH) DPB M-A Q-TYPED-POINTER (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL))) ;Push the arg. ((ARG-CALL MMCALL) (I-ARG 2)) ;Call, 2 args. Value comes back in M-T. ((M-GARBAGE) MICRO-STACK-DATA-POP) ;Flush return address in GET or GETL. (POPJ) ;***Lots of things depend on CAR and CDR to save ACs, which could get clobberred here!!!*** INSTANCE-INVOKE-1 ((M-B) DPB READ-I-ARG Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) (CALL P3ZERO) ((PDL-PUSH) 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) DPB MD Q-TYPED-POINTER (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT))) (NO-OP) (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 ;; The following instruction can popj out of XGETL. ((ARG-CALL-XCT-NEXT PLGET) (I-ARG INSTANCE-INVOKE-GETL)) ((M-T) M-B) ((M-S) M-A) XGETL1 (POPJ-EQUAL M-T A-V-NIL) ;EXHAUSTED THE PLIST XGETL1A (open-qcar-xct-next m-t) ;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 (open-qcar-xct-next m-t) ;GET NEXT PROP NAME TO TRY ((PDL-PUSH) M-T) (JUMP-EQUAL M-T A-A POP1TJ) ;GOT IT (open-qcdr-sb-xct-next pdl-top) ((M-T) PDL-POP) ;TRY NEXT PROP NAME (JUMP XGETL2) XGETL3 (open-qcdr-sb-xct-next pdl-top) ((M-T) Q-TYPED-POINTER PDL-POP) (open-qcdr m-t) (JUMP-NOT-EQUAL M-T A-V-NIL XGETL1A) (POPJ) POP1TJ (POPJ-AFTER-NEXT (M-GARBAGE) PDL-POP) ((M-T) PDL-POP) (ERROR-TABLE DEFAULT-ARG-LOCATIONS ASSQ M-B M-D) ;; Called indirectly from QLENTR -- watch out. XASSQ (MISC-INST-ENTRY ASSQ) ((M-T) Q-TYPED-POINTER PDL-POP) ;ARG2 ((M-B) Q-TYPED-POINTER PDL-POP) ;ARG1 ((M-D) M-T) XASSQ1 (POPJ-EQUAL M-T A-V-NIL) (open-carcdr m-t) ;Skip nil's in alist. (jump-equal m-a a-v-nil xassq1) ((PDL-PUSH) M-T) ;; Next link in alist is on pdl, this alist element in M-A. Take its car. (open-qcar-xct-next m-a) ((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-B XASSQ1) ((M-T) PDL-POP) (POPJ-XCT-NEXT) ((M-T) M-A) (error-table default-arg-locations assoc m-b m-d) XASSOC (MISC-INST-ENTRY ASSOC) ((M-T) Q-TYPED-POINTER PDL-POP) ;ARG2 ((M-B) Q-TYPED-POINTER PDL-POP) ;ARG1 ((m-d) m-t) (jump-data-type-equal m-b (a-constant (byte-value q-data-type dtp-symbol)) xassq1) (jump-data-type-equal m-b (a-constant (byte-value q-data-type dtp-fix)) xassq1) XASSOC1 (POPJ-EQUAL M-T A-V-NIL) (open-carcdr m-t) ;Skip nil's in alist. (jump-equal m-a a-v-nil xassoc1) ((PDL-PUSH) M-T) ;; Next link in alist is on pdl, this alist element in M-A. Take its car. (open-qcar-xct-next m-a) ((M-T) M-A) ;; Next link still on pdl, this alist element in M-A, ;; this element's key in M-T. ((pdl-push) m-a) (call-xct-next xequal-0) ((pdl-push) m-b) ((m-b) q-typed-pointer pdl-pop) ((m-a) pdl-pop) (jump-equal-xct-next m-t a-v-nil xassoc1) ((m-t) pdl-pop) (popj-xct-next) ((m-t) q-typed-pointer 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 (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-list)) popt1j) (open-qcdr-sb-xct-next m-t) ((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 (jump-data-type-equal m-t (a-constant (byte-value q-data-type dtp-list)) xlen3) (JUMP-NOT-EQUAL M-T A-V-NIL XLEN2) xlen3 ((PDL-PUSH) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) XLEN1 (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-list)) poptj) (open-qcdr-sb m-t) (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 (jump-data-type-equal-xct-next m-t (a-constant (byte-value q-data-type 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) ;; PDL has arg1, the symbol to set. (call-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-symbol)) trap) (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-J) Q-TYPED-POINTER PDL-POP) ((M-T) A-V-TRUE) (POPJ-AFTER-NEXT POPJ-EQUAL M-J A-V-NIL) ((M-T) A-V-NIL) XTNOT (JUMP-EQUAL M-T A-V-NIL XTRUE) ;MC-LINKAGE (POPJ-AFTER-NEXT (M-T) A-V-NIL) ;XFALSE (NO-OP) XATOM (MISC-INST-ENTRY ATOM) (jump-data-type-equal pdl-pop (a-constant (byte-value q-data-type dtp-list)) xfalse) (JUMP XTRUE) XGPN (MISC-INST-ENTRY GET-PNAME) (call-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-symbol)) trap) (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 ) ;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 ) 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 ) ((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 (open-qcar m-t) (call-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-symbol)) trap) (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) Q-POINTER PDL-POP) ;READ INTERNAL VALUE CELL (CALL-CONDITIONAL PG-FAULT XCLOS-PG-FAULT) ;(CHECK-PAGE-READ) ((PDL-PUSH) ADD M-T A-ZERO ALU-CARRY-IN-ONE) ;BUMP FILLING POINTER (DISPATCH TRANSPORT-NO-EVCP MD) ;; Jump if already EVCP. (JUMP-DATA-TYPE-EQUAL MD (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-EXTERNAL-VALUE-CELL-POINTER)) XCLOS3A) ((PDL-PUSH) VMA) ;SAVE POINTER TO INTERNAL VALUE CELL ((PDL-PUSH) MD) ;SAVE INTERNAL VALUE CELL CONTENTS (call-xct-next allocate-list-storage-default) ((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) (gc-write-test) ;***?? ((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) (gc-write-test) ;***?? 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 ;#+CADR (CALL-XCT-NEXT QCDR-SB) ;#+LAMBDA(DISPATCH-XCT-NEXT DISPATCH-WRITE-VMA ; (I-ARG INSTANCE-INVOKE-CDR) Q-DATA-TYPE C-PDL-BUFFER-INDEX ; CDR-PRE-DISPATCH-SB-DIRECT) (open-qcdr-sb-xct-next c-pdl-buffer-index) ((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 XCLOS-PG-FAULT (JUMP-LESS-THAN VMA (A-CONSTANT LOWEST-A-MEM-VIRTUAL-ADDRESS) PGF-R) (CALL TRAP) (ERROR-TABLE ATTEMPT-CLOSE-OVER-A-MEMORY-LOCATION) (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) ((m-TEM1) (A-CONSTANT 1)) XCL1 (call-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-symbol)) trap) (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) ((m-TEM1) (A-CONSTANT 2)) XPRPCL (MISC-INST-ENTRY PROPERTY-CELL-LOCATION) (JUMP-XCT-NEXT XCL1) ((m-TEM1) (A-CONSTANT 3)) XPACKAGE-CELL-LOCATION (MISC-INST-ENTRY PACKAGE-CELL-LOCATION) (JUMP-XCT-NEXT XCL1) ((m-TEM1) (A-CONSTANT 4)) XFCTEV (MISC-INST-ENTRY FSYMEVAL) (call-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-symbol)) trap) (error-table argtyp symbol pp t) ((VMA-START-READ) ADD PDL-POP (a-constant 2)) (CHECK-PAGE-READ) (POPJ-AFTER-NEXT DISPATCH TRANSPORT MD) ((M-T) Q-TYPED-POINTER MD) XSYMEV (MISC-INST-ENTRY SYMEVAL) (call-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-symbol)) trap) (error-table argtyp symbol pp t) ((VMA-START-READ) ADD PDL-POP (a-constant 1)) (CHECK-PAGE-READ) (POPJ-AFTER-NEXT DISPATCH TRANSPORT MD) ((M-T) Q-TYPED-POINTER MD) (ERROR-TABLE DEFAULT-ARG-LOCATIONS MEMQ M-B M-J) XMEMQ (MISC-INST-ENTRY MEMQ) ((M-T) Q-TYPED-POINTER PDL-POP) ((M-B) Q-TYPED-POINTER PDL-POP) XMEMQ2 ((M-J) M-T) ;entry from XMEMBER-EQL XMEMQ1 (POPJ-EQUAL M-T A-V-NIL) (open-carcdr-xct-next m-t) ;#+CADR (CALL-XCT-NEXT CARCDR) ;Get car in M-A, cdr in M-T. ;#+LAMBDA(DISPATCH-XCT-NEXT DISPATCH-WRITE-VMA Q-DATA-TYPE M-T CARCDR-DISPATCH-DIRECT) ((M-D) M-T) ;Save this link, as value if this elt matches. (JUMP-NOT-EQUAL M-A A-B XMEMQ1) (POPJ-XCT-NEXT) ((M-T) M-D) (error-table default-arg-locations member m-b m-j) XMEMBER (MISC-INST-ENTRY MEMBER) ((M-T) Q-TYPED-POINTER PDL-POP) ((M-B) Q-TYPED-POINTER PDL-POP) ((M-J) M-T) (jump-data-type-equal m-b (a-constant (byte-value q-data-type dtp-symbol)) xmemq1) (jump-data-type-equal m-b (a-constant (byte-value q-data-type dtp-fix)) xmemq1) XMEMBER1 (POPJ-EQUAL M-T A-V-NIL) (open-carcdr-xct-next m-t) ;#+CADR (CALL-XCT-NEXT CARCDR) ;Get car in M-A, cdr in M-T. ;#+LAMBDA(DISPATCH-XCT-NEXT DISPATCH-WRITE-VMA Q-DATA-TYPE M-T CARCDR-DISPATCH-DIRECT) ((M-D) M-T) ;Save this link, as value if this elt matches. ((PDL-PUSH) M-T) ((M-T) M-A) ((PDL-PUSH) M-D) ;VALUE IF EQUAL T. (CALL-XCT-NEXT XEQUAL-0) ((PDL-PUSH) M-B) ((M-B) Q-TYPED-POINTER PDL-POP) ((M-D) PDL-POP) (JUMP-EQUAL-XCT-NEXT M-T A-V-NIL XMEMBER1) ((M-T) PDL-POP) (POPJ-XCT-NEXT) ((M-T) Q-TYPED-POINTER 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 XMEMQ2))) (DISPATCH-XCT-NEXT Q-DATA-TYPE M-C POPJ-IF-NOT-NUMBER) ((M-B) M-C) ((M-GARBAGE) 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) (open-carcdr-xct-next m-t) ;#+CADR (CALL-XCT-NEXT CARCDR) ;#+LAMBDA(DISPATCH-XCT-NEXT DISPATCH-WRITE-VMA Q-DATA-TYPE M-T CARCDR-DISPATCH-DIRECT) ((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) (JUMP-DATA-TYPE-EQUAL PDL-TOP (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL)) XLOCATE-IN-INSTANCE-1) (CALL-DATA-TYPE-NOT-EQUAL PDL-TOP (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)) TRAP) (ERROR-TABLE ARGTYP SYMBOL-OR-LOCATIVE PP 1 XLOCATE-IN-INSTANCE) (call find-structure-header) (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) (CALL-DATA-TYPE-NOT-EQUAL PDL-TOP (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE 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-NOT-EQUAL M-T A-V-NIL XLISTP) (jump-xct-next xtrue) (pdl-pop) (MISC-INST-ENTRY LISTP) XLISTP (jump-data-type-not-equal pdl-pop (a-constant (byte-value q-data-type dtp-list)) xfalse) (JUMP XTRUE) XNLISTP (MISC-INST-ENTRY NLISTP) XNLSTP (jump-data-type-equal pdl-pop (a-constant (byte-value q-data-type dtp-list)) xfalse) (JUMP XTRUE) XSYMBOLP (MISC-INST-ENTRY SYMBOLP) XSYMP (jump-data-type-equal pdl-pop (a-constant (byte-value q-data-type dtp-symbol)) xtrue) (JUMP XFALSE) XNSYMBOLP (MISC-INST-ENTRY NSYMBOLP) XNSYMP (jump-data-type-not-equal pdl-pop (a-constant (byte-value q-data-type dtp-symbol)) xtrue) (JUMP XFALSE) XARRAYP (MISC-INST-ENTRY ARRAYP) XARRYP (jump-data-type-equal pdl-pop (a-constant (byte-value q-data-type dtp-array-pointer)) xtrue) (JUMP XFALSE) XFIXNUMP (MISC-INST-ENTRY FIXNUMP) (jump-data-type-equal pdl-pop (a-constant (byte-value q-data-type dtp-fix)) xtrue) (JUMP XFALSE) XSMALL-FLOATP (MISC-INST-ENTRY SMALL-FLOATP) (jump-data-type-equal pdl-pop (a-constant (byte-value q-data-type dtp-small-flonum)) xtrue) (JUMP XFALSE) XCHARACTERP (MISC-INST-ENTRY CHARACTERP) (jump-data-type-equal pdl-pop (a-constant (byte-value q-data-type 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) (call-data-type-not-equal pdl-top (a-constant (byte-value q-data-type dtp-symbol)) trap) (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 (jump-data-type-equal md (a-constant (byte-value q-data-type 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) (jump-data-type-equal m-t (a-constant (byte-value q-data-type 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) (popj-data-type-not-equal-xct-next m-a (a-constant (byte-value q-data-type dtp-array-pointer))) 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-xct-next decode-1d-array-force-1) ((m-array-pointer) validate-array-cache m-a) (call store-array-registers-in-accumulators) (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) ;; A symbol => return it. (popj-data-type-equal-xct-next md (a-constant (byte-value q-data-type dtp-symbol))) ((M-T) Q-TYPED-POINTER MD) ;If it's not a symbol, only a closure is a valid thing to find here. (jump-data-type-not-equal md (a-constant (byte-value q-data-type dtp-closure)) xfalse) (CALL-XCT-NEXT QCAR) ;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))) (popj-data-type-equal m-t (a-constant (byte-value q-data-type 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) (jump-data-type-equal m-a (a-constant (byte-value q-data-type dtp-array-pointer)) xtypep-structure) (jump-data-type-equal m-a (a-constant (byte-value q-data-type 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) ;#+LAMBDA(DISPATCH-XCT-NEXT DISPATCH-WRITE-VMA ; (I-ARG INSTANCE-INVOKE-CAR) Q-DATA-TYPE M-T CAR-PRE-DISPATCH-DIRECT) ;#+LAMBDA(NO-OP) ;#+CADR (CALL QCAR) (open-qcar m-t) 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) (jump-data-type-not-equal md (a-constant (byte-value q-data-type 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) ;;; mapping-function-call-out (call-xct-next carcdr) ((pdl-push) m-q) ;Save function. (call-xct-next p3zero) ;Set up micro-macro call block. ((pdl-push) m-t) ;Save remainder of list. ((pdl-push) m-q) ;Push function. ((pdl-push) dpb m-a q-typed-pointer (a-constant (byte-value q-cdr-code cdr-nil))) ;Push list element as argument. ((arg-call mmcall) (i-arg 1)) ((m-a) m-t) ;Result. (popj-after-next (m-t) pdl-pop) ;List. ((m-q) pdl-pop) ;Function. x-internal-mapc (misc-inst-entry %internal-mapc) ((m-t) q-typed-pointer pdl-pop) ;List. ((m-q) q-typed-pointer pdl-pop) ;Function. (popj-equal m-t a-v-nil) ((pdl-push) m-t) ;Save list for result. (call-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-list)) trap) (error-table argtyp list m-t 0) x-internal-mapc-loop (call mapping-function-call-out) (jump-not-equal m-t a-v-nil x-internal-mapc-loop) x-internal-mapc-finish (popj-after-next (m-t) q-typed-pointer pdl-pop) ;Restore initial list as argument. (no-op) x-internal-mapcar (misc-inst-entry %internal-mapcar) ((m-t) q-typed-pointer pdl-pop) ;List. ((m-q) q-typed-pointer pdl-pop) ;Function. (popj-equal m-t a-v-nil) (call-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-list)) trap) (error-table argtyp list m-t 0) ((m-j) m-t) ;Save argument list. (call-xct-next xlen1) ((pdl-push) (a-constant (byte-value q-data-type dtp-fix))) ((m-b) q-pointer m-t) (call-xct-next list-of-nils) ((m-s) dpb m-zero q-all-but-typed-pointer a-cnsadf) ((pdl-push m-s) dpb q-pointer m-t (a-constant (byte-value q-data-type dtp-list))) ((m-t) m-j) ;Restore argument list. ;; M-S = loc of result list (also on pdl), M-T argument list, M-Q funarg. x-internal-mapcar-loop (call-xct-next mapping-function-call-out) ((pdl-push) m-s) (jump-equal m-t a-v-nil x-internal-mapcar-finish) ((md) ldb m-a q-all-but-cdr-code (a-constant (byte-value q-cdr-code cdr-next))) ((vma-start-write m-s) pdl-pop) (check-page-write) (gc-write-test) (jump-xct-next x-internal-mapcar-loop) ((m-s) add m-s (a-constant 1)) x-internal-mapcar-finish ((md) ldb m-a q-all-but-cdr-code (a-constant (byte-value q-cdr-code cdr-nil))) ((vma-start-write) pdl-pop) (check-page-write) ((m-s) a-v-nil) ;Could contain garbage from above. (gc-write-test) ((m-t) pdl-pop) (popj) ;;;two args on stack. x-append (misc-inst-entry %internal-append-2) ((m-d) q-typed-pointer c-pdl-buffer-pointer-pop) ;2nd arg ((m-c) q-typed-pointer c-pdl-buffer-pointer-pop) ;1st arg (call-xct-next xtleng) ((m-t) m-c) ((m-b) q-pointer m-t) (jump-equal m-b a-zero return-m-d) (jump-equal m-d a-v-nil xapp1) ((m-b) m+1 m-b a-zero) ;extra for cdr-normal xapp1 ;necessary to initialize storage since taking CDR could involve sending a message, ;which would get to macrocode and allow sequence breaks, etc. (call-xct-next list-of-nils) ((m-s) dpb m-zero q-all-but-typed-pointer a-cnsadf) ((pdl-push m-s) dpb q-pointer m-t (a-constant (byte-value q-data-type dtp-list))) ((m-t) m-c) xappend-copy-list-loop (open-carcdr m-t) ((md) dpb m-a q-typed-pointer (a-constant (byte-value q-cdr-code cdr-next))) ((vma-start-write) m-s) (check-page-write) (gc-write-test) (jump-data-type-equal-xct-next m-t (a-constant (byte-value q-data-type dtp-list)) xappend-copy-list-loop) ((m-s) add m-s (a-constant 1)) (jump-equal-xct-next m-d a-v-nil xapp2) ((m-s) a-v-nil) ;Could contain garbage from above. ((md-start-write) dpb md q-typed-pointer (a-constant (byte-value q-cdr-code cdr-normal))) (check-page-write) (gc-write-test) ((md) dpb m-d q-typed-pointer (a-constant (byte-value q-cdr-code cdr-error))) ((vma-start-write) add vma (a-constant 1)) (check-page-write) (gc-write-test) ((m-t) q-typed-pointer pdl-pop) (popj) xapp2 ((md-start-write) dpb md q-typed-pointer (a-constant (byte-value q-cdr-code cdr-nil))) (check-page-write) (gc-write-test) (popj-after-next (m-t) q-typed-pointer pdl-pop) (no-op) return-m-d (popj-after-next (m-t) q-typed-pointer m-d) (no-op) x-internal-nconc (misc-inst-entry %internal-nconc-2) ((m-d) q-typed-pointer pdl-pop) ;arg2 ((m-t) q-typed-pointer pdl-pop) ;arg1 (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-list)) return-m-d) (call-xct-next xlast) ((pdl-push m-j) m-t) ;used by last. ((pdl-push) m-t) (call-xct-next xrplcd) ((pdl-push) m-d) (popj-after-next (m-t) m-j) (no-op) (begin-comment) Zwei Lossage (end-comment) (error-table restart delq) delq (misc-inst-entry %internal-delq) (trap-unless-fixnum c-pdl-buffer-pointer :argument 2 :restart delq) ((m-q) q-pointer c-pdl-buffer-pointer-pop) ;# times. ((m-s) q-typed-pointer c-pdl-buffer-pointer-pop) ;list ((m-r) q-typed-pointer c-pdl-buffer-pointer-pop) ;item to delete ((m-t) q-typed-pointer m-s) delq-0 (jump-equal m-q a-zero delq-return) (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-list)) delq-return) (open-carcdr m-t) ; (dispatch-xct-next dispatch-write-vma q-data-type m-t carcdr-dispatch-direct) ; (no-op) (jump-not-equal m-a a-r delq-1) ((m-s) q-typed-pointer m-t) (jump-xct-next delq-0) ((m-q) add m-q a-minus-one) delq-1 ((m-t) q-typed-pointer m-s) delq-2 ((m-c) q-typed-pointer m-d) delq-3 (jump-equal m-q a-zero delq-return) (jump-data-type-not-equal m-t (a-constant (byte-value q-data-type dtp-list)) delq-return) ; (dispatch-xct-next dispatch-write-vma q-data-type m-t carcdr-dispatch-direct) (open-carcdr-xct-next m-t) ((m-d) q-typed-pointer m-t) (jump-not-equal m-a a-r delq-2) (call-xct-next delq-rplacd) ((pdl-push) q-typed-pointer m-s) (jump-xct-next delq-3) ((m-s) q-typed-pointer pdl-pop) delq-return (popj-after-next (m-t) q-typed-pointer m-s) (no-op) delq-rplacd ((vma-start-read) m-c) ;GET CAR OF CONS TO BE SMASHED (need cdr codes) (check-page-read) ((m-a) q-typed-pointer m-t) ((m-q) add m-q a-minus-one) (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) ))