Changeset 274


Ignore:
Timestamp:
08/18/11 17:38:53 (3 years ago)
Author:
rjs
Message:

Update from System 78.

Location:
trunk/lisp/lcadr
Files:
9 deleted
14 edited

Legend:

Unmodified
Added
Removed
  • trunk/lisp/lcadr/cadldb.lisp

    r203 r274  
    1717                                      (LDB (+ (LOGAND PPSS 7700) 27) WORD)))
    1818                                (T (LDB PPSS WORD))))
     19
  • trunk/lisp/lcadr/ccdisk.lisp

    r204 r274  
    2323                  %PHT-DUMMY-VIRTUAL-ADDRESS
    2424                  MICRO-CODE-SYMBOL-AREA-START MICRO-CODE-SYMBOL-AREA-END
    25                   PHT-ADDR SIZE-OF-PAGE-TABLE
     25                  PHT-ADDR
    2626                  INITIAL-LOD-NAME N-PARTITIONS
    2727                  N-HEADS N-CYLINDERS N-BLOCKS-PER-TRACK
     
    123123    (PRINC '|ECC ERROR BIT POSITION |)
    124124    (PRIN1 (LOGLDB 0020 (PHYS-MEM-READ (+ CC-DISK-ADDRESS 3))))
    125     (PRINT 'SAVED-COMMAND)
     125    (PRINT 'LAST-CC-COMMAND)
    126126    (CC-TYPE-OUT CC-DISK-LAST-CMD CC-DISK-CMD-DESC T T)
    127127    (PRINT 'DISK-ADDRESS)
     
    129129    (PRINT 'MEMORY-ADDRESS)
    130130    (PRIN1 (LOGLDB 0026 (PHYS-MEM-READ (+ CC-DISK-ADDRESS 1))))
    131     (PRINT 'SAVED-COMMAND-LIST-POINTER)
     131    (PRINT 'LAST-CC-COMMAND-LIST-POINTER)
    132132    (PRIN1 CC-DISK-LAST-CLP)
    133133    (PRINT 'COMMAND-LIST)
     
    202202                                 "Strobe Early" "Strobe Late"
    203203                                 "Servo Reverse -- Strobe Early"  ;NO COMMAS INSIDE STRINGS
    204                                  "Servo Reverse -- Strobe Late"   : IN MACLISP
     204                                 "Servo Reverse -- Strobe Late"   ; IN MACLISP
    205205                                 "Servo Forward -- Strobe Early"
    206206                                 "Servo Forward -- Strobe Late")
     
    300300
    301301;returns t if wins
     302; if DISK-BLOCK-NUM a list, its (track head sector).
    302303(DEFUN CC-DISK-XFER (FCN DISK-BLOCK-NUM CORE-PAGE-NUM N-BLOCKS)
    303   (PROG (TRACK HEAD SECTOR DUSH ERRCNT STATUS)
     304  (PROG (TRACK HEAD SECTOR DUSH ERRCNT STATUS
     305         FINAL-DUSH FINAL-ADDRESS FINAL-SECTOR FINAL-HEAD FINAL-TRACK)
    304306     (DECLARE (FIXNUM TRACK HEAD SECTOR DUSH ERRCNT STATUS))
    305307     (COND ((NOT CC-DISK-TYPE)(CC-DISK-INIT)))
    306308     (SETQ ERRCNT CC-DISK-RETRY-COUNT)
    307      (SETQ TRACK (// DISK-BLOCK-NUM BLOCKS-PER-CYLINDER))
    308      (SETQ SECTOR (\ DISK-BLOCK-NUM BLOCKS-PER-CYLINDER))
    309      (SETQ HEAD (// SECTOR BLOCKS-PER-TRACK)
    310            SECTOR (\ SECTOR BLOCKS-PER-TRACK))
     309     (COND ((NUMBERP DISK-BLOCK-NUM)
     310            (SETQ TRACK (// DISK-BLOCK-NUM BLOCKS-PER-CYLINDER))
     311            (SETQ SECTOR (\ DISK-BLOCK-NUM BLOCKS-PER-CYLINDER))
     312            (SETQ HEAD (// SECTOR BLOCKS-PER-TRACK)
     313                  SECTOR (\ SECTOR BLOCKS-PER-TRACK))
     314            (SETQ FINAL-ADDRESS (+ DISK-BLOCK-NUM (1- N-BLOCKS))
     315                  FINAL-TRACK (// FINAL-ADDRESS BLOCKS-PER-CYLINDER)
     316                  FINAL-SECTOR (\ FINAL-ADDRESS BLOCKS-PER-CYLINDER)
     317                  FINAL-HEAD (// FINAL-SECTOR BLOCKS-PER-TRACK)
     318                  FINAL-SECTOR (\ FINAL-SECTOR BLOCKS-PER-TRACK)))
     319           (T (SETQ TRACK (CAR DISK-BLOCK-NUM)
     320                    HEAD (CADR DISK-BLOCK-NUM)
     321                    SECTOR (CADDR DISK-BLOCK-NUM))))               
    311322     (SETQ DUSH (+ (CC-SHIFT TRACK 16.) (LSH HEAD 8) SECTOR))
    312323     (AND (> N-BLOCKS 366) ;We only want to use 1 page for the command list
     
    329340       (AND (ZEROP (LOGAND 1 (SETQ STATUS (PHYS-MEM-READ CC-DISK-ADDRESS))))
    330341            (GO WAIT))))
     342     (SETQ FINAL-DUSH (PHYS-MEM-READ (+ CC-DISK-ADDRESS 2)))
    331343     (COND ((NOT (ZEROP (LOGAND STATUS 47777560)))
    332344                ; ERROR BITS: INTERNAL PARITY, NXM, MEM PAR, HEADER COMPARE,
     
    339351            (PRINT 'RETRYING)
    340352            (TERPRI)
     353            ;(BREAK CC-DISK-ERROR T)
     354            (GO LP))
     355           ((AND (NUMBERP FINAL-TRACK)
     356                 (OR (NOT (= FINAL-TRACK (LDB 2014 FINAL-DUSH)))
     357                     (NOT (= FINAL-HEAD (LDB 1010 FINAL-DUSH)))
     358                     (NOT (= FINAL-SECTOR (LDB 0010 FINAL-DUSH)))))
     359            (FORMAT T "~%Final disk address incorrect, is ~D,~D,~D; should be ~D,~D,~D"
     360                    (LDB 2014 FINAL-DUSH) (LDB 1010 FINAL-DUSH) (LDB 0010 FINAL-DUSH)
     361                    FINAL-TRACK FINAL-HEAD FINAL-SECTOR)
     362            (BREAK 'CC-FINAL-DISK-ADDRESS-ERROR T)
    341363            (GO LP)))
    342364     (RETURN T)         ;won
     
    346368; MAINLY GOOD FOR RETRYING TRANSFERS THAT LOSE, ETC.
    347369(DEFUN CC-DISK-XFER-TRACK-HEAD-SECTOR (FCN TRACK HEAD SECTOR CORE-PAGE-NUM N-BLOCKS)
    348   (DECLARE (FIXNUM TRACK HEAD SECTOR DUSH ERRCNT STATUS))
    349   (PROG (DUSH ERRCNT STATUS)
    350      (SETQ ERRCNT CC-DISK-RETRY-COUNT)
    351      (SETQ DUSH (+ (CC-SHIFT TRACK 16.) (LSH HEAD 8) SECTOR))
    352      (AND (> N-BLOCKS 366) ;We only want to use 1 page for the command list
    353           (ERROR N-BLOCKS 'TOO-MANY-BLOCKS-FOR-CMD-LIST 'FAIL-ACT))
    354  LP  ;;Set up the command list, starting at location 12, a bit of a kludge
    355      (DO ((I 12 (1+ I))
    356           (A CORE-PAGE-NUM (1+ A))
    357           (N N-BLOCKS (1- N)))
    358          ((= N 0))
    359        (PHYS-MEM-WRITE I (+ (CC-SHIFT A 8) (COND ((= N 1) 0) (T 1)))))
    360      (LET ((CTALK-BARF-AT-WRITE-ERRORS NIL))  ;THESE MIGHT NOT READ BACK EXACTLY THE SAME...
    361       (PROG NIL
    362        (PHYS-MEM-WRITE (+ CC-DISK-ADDRESS 0) FCN) ;Store command, does reset
    363        (PHYS-MEM-WRITE (+ CC-DISK-ADDRESS 1) 12)  ;Store CLP
    364        (SETQ CC-DISK-LAST-CMD FCN CC-DISK-LAST-CLP 12)
    365        (PHYS-MEM-WRITE (+ CC-DISK-ADDRESS 2) DUSH)  ;Store disk address
    366        (PHYS-MEM-WRITE (+ CC-DISK-ADDRESS 3) 0)   ;Start transfer
    367   WAIT ;;This loop awaits completion
    368        #M (SLEEP-JIFFIES 2)
    369        #Q (PROCESS-SLEEP 2)
    370        (AND (ZEROP (LOGAND 1 (SETQ STATUS (PHYS-MEM-READ CC-DISK-ADDRESS))))
    371             (GO WAIT))))
    372      (COND ((NOT (ZEROP (LOGAND STATUS 47777560)))
    373                 ; ERROR BITS: INTERNAL PARITY, NXM, MEM PAR, HEADER COMPARE,
    374                 ; HEADER ECC, ECC HARD, ECC SOFT, OVERRUN, TRANSFER ABORTED,
    375                 ; START-BLOCK ERR, TIMEOUT, SEEK ERR, OFF LINE, OFF CYL, FAULT,
    376                 ;    NO SEL, MUL SEL
    377             (CC-DISK-ANALYZE)
    378             (AND (ZEROP (SETQ ERRCNT (1- ERRCNT)))
    379                  (RETURN NIL))
    380             (PRINT 'RETRYING)
    381             (TERPRI)
    382             (GO LP)))
    383      ))
     370  (CC-DISK-XFER FCN (LIST TRACK HEAD SECTOR) CORE-PAGE-NUM N-BLOCKS))
    384371
    385372
     
    536523    (CC-DISK-READ-IN-CORE 'PAGE)))
    537524
    538 (DEFUN CC-CHECK-PAGE-HASH-TABLE-ACCESSIBILITY NIL
     525(DEFUN CC-CHECK-PAGE-HASH-TABLE-ACCESSIBILITY ()
    539526  (DO ((TABLE-ADR PHT-ADDR (+ TABLE-ADR 2))
    540527       (HASH-ADR)
    541528       (PHT1)
    542        (COUNT (LSH SIZE-OF-PAGE-TABLE -1) (1- COUNT))
     529       (COUNT (LSH (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-SIZE))) -1)
     530              (1- COUNT))
    543531       (NUMBER-ERRORS 0))
    544532      ((= COUNT 0) NUMBER-ERRORS)
  • trunk/lisp/lcadr/chploc.lisp

    r203 r274  
    1 ;;; -*- LISP; PACKAGE:CADR -*-
     1;;; -*- MODE:LISP; PACKAGE:CADR -*-
    22
    33;; This stuff is to help locating errors relative to IC chips.
     
    55(DEFUN (PCHECK CC-COLON-CMD) (IGNORE)
    66  (LET ((QUAN (CC-REGISTER-EXAMINE CC-LAST-OPEN-REGISTER)))
    7     (FORMAT T "~%=~O" QUAN)
    87    (SELECTQ (CC-FIND-REG-ADR-RANGE CC-LAST-OPEN-REGISTER)
    9       (C (LET ((P0 (PARITY (LDB (BITS 12.  0.) QUAN)))
     8      (C (SETQ QUAN (CC-READ-C-MEM-WITH-PARITY (- CC-LAST-OPEN-REGISTER RACMO)))
     9         (FORMAT T "~%=~O  -> " QUAN)
     10         (CC-PRINT-BITS QUAN)
     11         (LET ((P0 (PARITY (LDB (BITS 12.  0.) QUAN)))
    1012               (P1 (PARITY (LDB (BITS 12. 12.) QUAN)))
    1113               (P2 (PARITY (LDB (BITS 12. 24.) QUAN)))
  • trunk/lisp/lcadr/diags.lisp

    r206 r274  
    120120  (PRINT 'CC-TEST-ARITH-COND-JUMP)
    121121  (CC-TEST-ARITH-COND-JUMP)
     122  (PRINT 'CC-GROSS-DATA-TESTS)
     123  (CC-GROSS-DATA-TESTS ALL-MEMORIES)
    122124  (PRINT 'CC-ADDRESS-TEST-A-MEM)
    123125  (CC-ADDRESS-TEST-A-MEM)
     
    130132
    131133;Test each 4K separately since they have separate address drivers
    132 (DEFUN CC-FAST-ADDRESS-TEST-C-MEM-BANKS (&OPTIONAL (NBANKS 3))
     134(DEFUN CC-FAST-ADDRESS-TEST-C-MEM-BANKS (&OPTIONAL (NBANKS 4))
    133135  (FORMAT T "CC-FAST-ADDRESS-TEST-C-MEM-BANKS~%")
    134136  (DOTIMES (BANK NBANKS)
    135137    (CC-FAST-ADDRESS-TEST
    136138      (FORMAT NIL "CMEM-BANK ~A" BANK) (+ RACMO (* BANK 10000)) 48. 12.)))
    137 
    138139
    139140
     
    678679    (AND (= (CC-READ-PC) 3)                     ;NORMAL HALT, DONE
    679680         (RETURN (NREVERSE ERRORS)))
    680     (SETQ ADDRESS (1+ (#Q ASH #M LSH (CC-READ-M-MEM CONS-M-SRC-LC) -6))  ;NEXT ADDRESS TO DO
     681    (SETQ ADDRESS (1+ (logand 7777
     682                              (#Q ASH #M LSH (CC-READ-M-MEM CONS-M-SRC-LC)
     683                               -6)))  ;NEXT ADDRESS TO DO
    681684          LOC (1- ADDRESS)
    682685          GOOD (CC-READ-M-MEM CONS-M-SRC-MD)
     
    797800       (ONES (SUB1 (EXPT 2 N-DATA-BITS)))
    798801       (ZEROS 0)
    799        (HIADR (+ REGADR (COND ((EQ MEM-NAME 'C-MEM) 30000)   ;CROCK
    800                               (T (EXPT 2 N-ADDRESS-BITS)))))
     802       (HIADR (+ REGADR (EXPT 2 N-ADDRESS-BITS)))
    801803       (ERRORS 0))
    802804      ((= N 0))
     
    10961098;; the MROT field.  Doesn't currently test whether automatic fetching.
    10971099;; Does test LC incrementing.  Eventually that should be tested.
     1100;; Should test LC -> VMA data path.
    10981101(DEFUN CC-TEST-LC-AFFECTS-SHIFT ()
    10991102  (CC-WRITE-A-MEM 1 0)
     
    12261229            (PRIN1 VAL))
    12271230           (T (SETQ OK-CNT (1+ OK-CNT))))))
    1228   (cc-execute (w-c-mem 0)
     1231  (cc-write-d-mem 0 (dpb 1 cons-disp-p-bit (dpb 1 cons-disp-n-bit 0)))
     1232  (do ((cnt 0 (1+ cnt))
     1233       (adr 0 (lsh 1 cnt)))
     1234      ((= adr 20000))
     1235    (cc-execute (w-c-mem adr)
    12291236              cons-ir-op cons-op-dispatch
    12301237              cons-ir-disp-lpc 1
    12311238              cons-ir-disp-bytl 0
    12321239              cons-ir-disp-addr 0)
    1233   (cc-write-d-mem 0 (dpb 1 cons-disp-p-bit (dpb 1 cons-disp-n-bit 0)))
    1234   (cc-save-micro-stack)
    1235   (setq cc-saved-micro-stack-ptr 0)
    1236   (as-1 -1 cc-micro-stack 0)
    1237   (as-1 -1 cc-micro-stack 1)
    1238   (cc-restore-micro-stack)
    1239   (cc-write-pc 0)
    1240   (cc-noop-clock)       ;dispatch inst to IR
    1241   (cc-clock)            ;execute it
    1242   (cc-noop-clock)       ;write spc
    1243   (cc-save-micro-stack)
    1244   (cond ((not (= cc-saved-micro-stack-ptr 1))
    1245          (format t "~%Dispatch push failed to advance USP ~s" cc-saved-micro-stack-ptr)))
    1246   (cond ((not (= (setq tem (ar-1 cc-micro-stack 1)) 0))
    1247          (format t "~%Dispatch push own address at 0 pushed ~s instead" tem)))
     1240    (cc-save-micro-stack)
     1241    (setq cc-saved-micro-stack-ptr 0)
     1242    (as-1 -1 cc-micro-stack 0)
     1243    (as-1 -1 cc-micro-stack 1)
     1244    (cc-restore-micro-stack)
     1245    (cc-write-pc adr)
     1246    (cc-noop-clock)     ;dispatch inst to IR
     1247    (cc-clock)          ;execute it
     1248    (cc-noop-clock)     ;write spc
     1249    (cc-save-micro-stack)
     1250    (cond ((not (= cc-saved-micro-stack-ptr 1))
     1251           (format t "~%Dispatch push failed to advance USP ~s" cc-saved-micro-stack-ptr)))
     1252    (cond ((not (= (setq tem (ar-1 cc-micro-stack 1)) adr))
     1253           (format t "~%Dispatch push own address at adr ~s pushed ~s instead" adr tem)))
     1254    (cc-execute (w-c-mem adr)
     1255              cons-ir-op cons-op-dispatch
     1256              cons-ir-disp-bytl 0
     1257              cons-ir-disp-addr 0)
     1258    (cc-save-micro-stack)
     1259    (setq cc-saved-micro-stack-ptr 0)
     1260    (as-1 -1 cc-micro-stack 0)
     1261    (as-1 -1 cc-micro-stack 1)
     1262    (cc-restore-micro-stack)
     1263    (cc-write-pc adr)
     1264    (cc-noop-clock)     ;dispatch inst to IR
     1265    (cc-clock)          ;execute it
     1266    (cc-noop-clock)     ;write spc
     1267    (cc-save-micro-stack)
     1268    (cond ((not (= cc-saved-micro-stack-ptr 1))
     1269           (format t "~%Dispatch push failed to advance USP ~s" cc-saved-micro-stack-ptr)))
     1270    (cond ((not (= (setq tem (ar-1 cc-micro-stack 1)) (1+ adr)))
     1271           (format t "~%Dispatch next address at adr ~s pushed ~s instead" adr tem))))
    12481272)
    12491273
     
    14881512
    14891513
    1490 (DEFUN CC-MEM-FILL (FROM TO &OPTIONAL (WORD 0) (FUNCTION (FUNCTION (LAMBDA (X) (1+ X)))))
     1514(DEFUN CC-MEM-FILL (FROM TO &OPTIONAL (WORD 0) (FUNCTION (FUNCTION 1+)))
    14911515  (DO ((ADR FROM (1+ ADR))
    14921516       (WORD WORD (FUNCALL FUNCTION WORD)))
     
    14941518      (PHYS-MEM-WRITE ADR WORD)))
    14951519
    1496 (DEFUN CC-MEM-FILL-CHECK (FROM TO &OPTIONAL (WORD 0)
    1497                                             (FUNCTION (FUNCTION (LAMBDA (X) (1+ X)))))
     1520(DEFUN CC-MEM-FILL-CHECK (FROM TO &OPTIONAL (WORD 0) (FUNCTION (FUNCTION 1+)))
    14981521  (DO ((ADR FROM (1+ ADR))
    14991522       (MEM-WORD 0)
     
    15491572  `(LDB 1612 ,VMA))
    15501573
    1551 (DEFUN CC-PARITY-SWEEP-INFO (PHYS-ADR-LIST &OPTIONAL (PRINT-AREA-SYMBOL T))
     1574(DEFUN CC-PARITY-SWEEP-INFO (PHYS-ADR-LIST
     1575                             &OPTIONAL FIX-SINGLE-BIT-ERRORS (PRINT-AREA-SYMBOL T))
    15521576  (DO ((L PHYS-ADR-LIST (CDR L))
    15531577       (PHYS-ADR) (VIRT-ADR) (AREA-NUMBER) (AREA-SYMBOL) (CORE) (DISK))
     
    15631587            (SETQ CORE (QF-MEM-READ VIRT-ADR))
    15641588            (SETQ DISK (QF-MEM-READ-DISK-COPY VIRT-ADR)))
    1565     (CC-PRINT-BITS (LOGXOR CORE DISK)))
    1566 )
     1589    (CC-PRINT-BITS (LOGXOR CORE DISK))
     1590    (IF (AND FIX-SINGLE-BIT-ERRORS
     1591             T  ;(SINGLE-BIT-P (LOGXOR CORE DISK))
     1592             )
     1593        (PROGN (FORMAT T "~%Fixing locn ~o to ~o" phys-adr disk)
     1594               (PHYS-MEM-WRITE PHYS-ADR DISK)))))
    15671595
    15681596(DEFUN CC-PARITY-SWEEP (&OPTIONAL (NUMBER-OF-MEMORIES 2)
     
    17011729  (process-sleep 60.)
    17021730  (spy-write spy-clk 10)        ;Clear RUN, but leave DEBUG set
     1731  (spy-write spy-mode 0)        ;Dont leave that random speed in there.  The cc-read-m-mem
     1732                                ; may cause randomness if you do.
    17031733  (let ((low (%unibus-read 764120))  ;Hardware synchronizes if you read this one first
    17041734        (high (%unibus-read 764122)))
     
    21852215 )
    21862216
     2217(defun display-registers-for-debug-divide-test ()
     2218  (cond ((boundp display-registers-for-debug-divide-test-flag)
     2219         (format T "~%A-MEM 1001 dividend  ~A    " (cc-read-a-mem 1001))
     2220         (format T "A-MEM 1002 divisor   ~A~%" (cc-read-a-mem 1002))
     2221         (format T "A-MEM 1003 rem       ~A    " (cc-read-a-mem 1003))
     2222         (format T "M-MEM 1    count     ~A" (cc-read-m-mem 1))
     2223         (format T "~%M-1                  ~A    " (cc-read-m-mem #o22))
     2224         (format T "A-2                  ~A" (cc-read-A-mem #o23))
     2225         (format T "~%Output Bus           ~A" (cc-read-obus)))))
     2226
     2227;(setq  display-registers-for-debug-divide-test-flag T)
    21872228
    21882229;first arg of NIL says use values in machine.
    21892230(DEFUN CC-DIVIDE-TEST-LOOP (&OPTIONAL (DIVIDEND (RANDOM 37777777))
    21902231                            (DIVISOR (RANDOM 37777777)))
    2191   (LET ((REM (\ DIVIDEND DIVISOR)))
     2232  (LET ((REM (IF DIVIDEND (\ DIVIDEND DIVISOR))))
    21922233    (CC-WRITE-M-MEM 1 0)                        ;error count
    21932234    (IF (NUMBERP DIVIDEND)
     
    22002241)
    22012242
     2243(DEFUN CC-DIVIDE-SAVE-STATE NIL
     2244  (LIST (CC-READ-A-MEM 1001) (CC-READ-A-MEM 1002) (CC-READ-A-MEM 1003)))
     2245
     2246(DEFUN CC-DIVIDE-RESTORE-STATE (STATE)
     2247  (CC-WRITE-A-MEM 1001 (CAR STATE))
     2248  (CC-WRITE-A-MEM 1002 (CADR STATE))
     2249  (CC-WRITE-A-MEM 1003 (CADDR STATE)))
     2250 
     2251(DEFUN CC-DIVIDE-COMPARE-STATE (STATE &AUX TEM)
     2252  (IF (NOT (= (SETQ TEM (CC-READ-A-MEM 1001)) (CAR STATE)))
     2253      (FORMAT T "~%1001 CLOBBERED FROM ~S TO ~S" TEM (CAR STATE)))
     2254  (IF (NOT (= (SETQ TEM (CC-READ-A-MEM 1002)) (CADR STATE)))
     2255      (FORMAT T "~%1002 CLOBBERED FROM ~S TO ~S" TEM (CADR STATE)))
     2256  (IF (NOT (= (SETQ TEM (CC-READ-A-MEM 1003)) (CADDR STATE)))
     2257      (FORMAT T "~%1003 CLOBBERED FROM ~S TO ~S" TEM (CADDR STATE))))
     2258
     2259(comment
    22022260(DEFUN CC-DIVIDE-TEST-LOOP-STATE NIL
    2203   (LIST (CC-READ-A-MEM 1001) (CC-READ-A-MEM 1002)))
    2204 
    2205 (DEFUN CC-DIVIDE-RESTORE-STATE (S)
     2261  (LIST (CC-READ-A-MEM 1001) (CC-READ-A-MEM 1002))) )
     2262
     2263(DEFUN CC-DIVIDE-RESTORE-STATE-AND-DIAGNOSE (S)
    22062264  (DBG-RESET)
    22072265  (CC-RESET-MACH)
     
    22332291              (IF (SETQ TEM (ASSQ PC HIST))
    22342292                  (IF (NOT (= (CDR TEM) OBUS))
    2235                       (PROGN (FORMAT T "~%Multiple values observed at PC ~S, ~S ~S "
     2293                      (COMMENT (PROGN (FORMAT T "~%Multiple values observed at PC ~S, ~S ~S "
    22362294                                     PC OBUS (CDR TEM))
    2237                              (CC-PRINT-BITS (LOGXOR OBUS (CDR TEM)))))
     2295                             (CC-PRINT-BITS (LOGXOR OBUS (CDR TEM))))))
    22382296                  (SETQ HIST (CONS (CONS PC OBUS) HIST))))
    22392297          (SPY-WRITE SPY-CLK 1))        ;continue
     
    22642322  ))
    22652323
     2324;THIS DOESNT SEEM TO WORK JUST YET.
     2325(DEFUN CC-PDL-BUFFER-PUSH-POP-CHECK ()
     2326  (DBG-RESET)
     2327  (CC-RESET-MACH)
     2328  (CC-EXECUTE (W-C-MEM 100)
     2329      CONS-IR-FUNC-DEST CONS-FUNC-DEST-PDL-BUFFER-PUSH)
     2330  (CC-EXECUTE (W-C-MEM 101)
     2331      CONS-IR-M-SRC CONS-M-SRC-C-PDL-BUFFER-POINTER-POP)
     2332  (CC-EXECUTE (W-C-MEM 102)
     2333      CONS-IR-OP CONS-OP-JUMP
     2334      CONS-IR-JUMP-ADDR 100
     2335      CONS-IR-JUMP-COND CONS-JUMP-COND-UNC
     2336      CONS-IR-N 1)
     2337  (LET ((PP 1777) PC RPP INCR IR)
     2338    (CC-WRITE-PDL-BUFFER-POINTER PP)
     2339    (CC-SET-SPEED 2)
     2340    (CC-COLON-START 100)
     2341    (DOTIMES (C 1000)
     2342      (CC-STOP-MACH)
     2343      (SETQ PC (CC-READ-PC)
     2344            IR (CC-READ-IR)
     2345            RPP (CC-READ-PDL-BUFFER-POINTER))
     2346      (SETQ INCR (CDR (ASSQ PC '((100 . 0) (101 . 1) (102 . 0) (103 . 0)))))
     2347      (IF (NULL INCR)
     2348          (FORMAT T "~%PC was random ~S" PC)
     2349          (IF (NOT (= (LOGAND 1777 (+ PP INCR)) RPP))
     2350              (FORMAT T "~%PP WRONG, WAS ~S SHOULD BE ~S" RPP (LOGAND 1777 (+ PP INCR)))))
     2351      (CC-WRITE-IR IR)
     2352      (CC-WRITE-PC PC)
     2353      (CC-CLOCK)
     2354      (SPY-WRITE SPY-CLK 1))   ;CONTINUE
     2355    ))
     2356
     2357
     2358(DEFVAR KEY-BITS
     2359        '((#/4 11)
     2360          (#\PLUS-MINUS 21)
     2361          (#\NETWORK 42)
     2362          (#\MACRO 100)
     2363          (#/C 164)))
     2364
     2365(DEFVAR *TEST-LOCAL-KEYBOARD* NIL)
     2366(DEFUN KEYBOARD-DBG-READ (ADR)
     2367  (IF *TEST-LOCAL-KEYBOARD* (%UNIBUS-READ ADR) (DBG-READ ADR)))
     2368
     2369(DEFUN KEYBOARD-DBG-WRITE (ADR DATA)
     2370  (IF *TEST-LOCAL-KEYBOARD* (%UNIBUS-WRITE ADR DATA) (DBG-WRITE ADR DATA)))
     2371
     2372(DEFUN TEST-IO-KEYBOARD ()
     2373  (KEYBOARD-DBG-READ 764100)                            ;Clear out keyboard
     2374  (IF (LDB-TEST 0501 (KEYBOARD-DBG-READ 764112))
     2375      (FORMAT T "~&Keyboard ready did not clear when read"))
     2376  (DOLIST (L KEY-BITS)
     2377    (APPLY 'TEST-KEY L))
     2378  )
     2379
     2380(DEFUN TEST-KEY (KEY VALUE)
     2381  (FORMAT T "~&Hold down the ~:C key on the debugee and then type space on this keyboard."
     2382          KEY)
     2383  (FUNCALL STANDARD-INPUT ':TYI)
     2384  (LET ((READ-KEY (KEYBOARD-DBG-READ 764100)))
     2385    (IF ( READ-KEY VALUE)
     2386        (FORMAT T "Keyboard should have been ~O and was ~O" VALUE READ-KEY))))
     2387
     2388(DEFUN CC-TEST-IO-BOARD (&OPTIONAL (*TEST-LOCAL-KEYBOARD* *TEST-LOCAL-KEYBOARD*))
     2389  (FORMAT T "~&Testing Time of day clock")
     2390  (CHECK-ANDS-AND-OR 764120 16. 1000. "Time of day")
     2391  ;; Enable remote mouse
     2392  (KEYBOARD-DBG-WRITE 764112 1)
     2393  (FORMAT T
     2394          "~&Testing mouse Y direction, roll mouse upwards for a while
     2395and then type space")
     2396  (CHECK-ANDS-AND-OR 764104 12. NIL "Mouse Y position")
     2397  (FORMAT T
     2398          "~&Testing mouse X direction, roll mouse sideways for a while
     2399and then type space")
     2400  (CHECK-ANDS-AND-OR 764106 12. NIL "Mouse X position")
     2401  (FORMAT T "~&Testing console beeper, should be beeping")
     2402  (LOOP DO (KEYBOARD-DBG-READ 764110) UNTIL (FUNCALL STANDARD-INPUT ':TYI-NO-HANG))
     2403  (FORMAT T "~&Testing Chaosnet interface")
     2404  (LET ((CHAOS:CHATST-USE-DEBUG (NOT *TEST-LOCAL-KEYBOARD*)))
     2405    (CHAOS:CHATST)))
     2406
     2407(DEFUN CHECK-ANDS-AND-OR (ADDR BITS ITERATION NAME)
     2408  (LET* ((MASK (1- (^ 2 BITS)))
     2409         (AND MASK)
     2410         (OR 0))
     2411    (DO ((I 0 (1+ I))
     2412         (RES))
     2413        ((IF (NULL ITERATION)
     2414             (FUNCALL STANDARD-INPUT ':TYI-NO-HANG)
     2415             (
     2416 I ITERATION)))
     2417      (SETQ RES (LOGAND MASK (KEYBOARD-DBG-READ ADDR))
     2418            OR (LOGIOR OR RES)
     2419            AND (LOGAND AND RES)))
     2420    (IF (OR ( AND 0) ( OR MASK))
     2421        (FORMAT T "~&Bits in the ~A register not changing.~% LOGAND=~O LOGIOR=~O"
     2422                NAME AND OR))))
     2423
     2424(DEFCONST *SERIAL-IO-TESTS*
     2425          '(((:BAUD 1200.) (:PARITY :ODD)
     2426             (:NUMBER-OF-DATA-BITS 7) (:NUMBER-OF-STOP-BITS 2))
     2427            ((:BAUD 9600.) (:PARITY :EVEN)
     2428             (:NUMBER-OF-DATA-BITS 8) (:NUMBER-OF-STOP-BITS 1))))
     2429
     2430(DEFUN TEST-SERIAL-IO ()
     2431  (LET ((STREAM NIL))
     2432    (UNWIND-PROTECT
     2433      (PROGN
     2434        (SETQ STREAM (SI:MAKE-SERIAL-STREAM
     2435                       ':NUMBER-OF-STOP-BITS 1
     2436                       ':PARITY ':ODD))
     2437        (DOLIST (PROP '(:CHECK-PARITY-ERRORS :CHECK-OVER-RUN-ERRORS :CHECK-FRAMING-ERRORS))
     2438          (FUNCALL STREAM ':PUT PROP T))
     2439        (FORMAT T "~&Testing serial I/O using /"remote loop back/" in the UART.")
     2440        (UNWIND-PROTECT
     2441          (PROGN
     2442            (FUNCALL STREAM ':PUT ':LOCAL-LOOP-BACK T)
     2443            (TEST-SERIAL-IO-SERIES STREAM *SERIAL-IO-TESTS*))
     2444          (FUNCALL STREAM ':PUT ':LOCAL-LOOP-BACK NIL))
     2445        (FORMAT T "~2&Attach a loop-back plug; type N if you don't want to do this test,
     2446or any other character to run the test.")
     2447        (LET ((CHAR (FUNCALL STANDARD-INPUT ':TYI)))
     2448          (COND ((NOT (CHAR-EQUAL #/N CHAR))
     2449                 (FORMAT T "~&Testing extra EIA-RS-232 bits.")
     2450                 (TEST-SERIAL-IO-EIA-RS-232-BITS STREAM)
     2451                 (TEST-SERIAL-IO-SERIES STREAM *SERIAL-IO-TESTS*)))))
     2452      (CLOSE STREAM))))
     2453
     2454(DEFVAR *SERIAL-IO-ERROR-COUNT*)
     2455(DEFCONST *SERIAL-IO-ERROR-LIMIT* 5)
     2456
     2457(DEFUN TEST-SERIAL-IO-SERIES (STREAM SERIES)
     2458  (DOLIST (TEST SERIES)
     2459    (LET ((BASE 10.)
     2460          (FIRST T)
     2461          (*SERIAL-IO-ERROR-COUNT* 0))
     2462      (FORMAT T "~&")
     2463      (DOLIST (CLAUSE TEST)
     2464        (LET ((NAME (FIRST CLAUSE))
     2465              (VALUE (SECOND CLAUSE)))
     2466          (IF (NOT FIRST)
     2467              (FORMAT T "; "))
     2468          (SETQ FIRST NIL)
     2469          (FORMAT T "~S = ~S" NAME VALUE)
     2470          (FUNCALL STREAM ':PUT NAME VALUE)))
     2471      (TEST-SERIAL-IO-CHARS STREAM))))
     2472
     2473(DEFCONST *SERIAL-IO-TIMEOUT* 60.)
     2474
     2475(DEFUN TEST-SERIAL-IO-CHARS (STREAM)
     2476  (DOTIMES (SENT-CHAR (^ 2 (FUNCALL STREAM ':GET ':NUMBER-OF-DATA-BITS)))
     2477    (FUNCALL STREAM ':TYO SENT-CHAR)
     2478    (COND ((PROCESS-WAIT-WITH-TIMEOUT "Serial In" *SERIAL-IO-TIMEOUT* STREAM ':LISTEN)
     2479           (LET ((GOT-CHAR (FUNCALL STREAM ':TYI)))
     2480             (COND ((NOT (= SENT-CHAR GOT-CHAR))
     2481                    (FORMAT T "~&Error: sent ~O and got back ~O (both octal)~%"
     2482                            SENT-CHAR GOT-CHAR)
     2483                    (INCF *SERIAL-IO-ERROR-COUNT*)
     2484                    (COND ((< *SERIAL-IO-ERROR-COUNT* *SERIAL-IO-ERROR-LIMIT*)
     2485                           (FORMAT T "~&Status of serial I//O line:~%")
     2486                           (SI:SERIAL-STATUS)))))))
     2487           (T
     2488             (FORMAT T "~&Error: timed out waiting for character ~O (octal)~%"
     2489                     SENT-CHAR)))))
     2490
     2491;;; Unfortunately, you can't read back clear-to-send (the LM-2 Serial I/O
     2492;;; documentation is wishful thinking).
     2493(DEFUN TEST-SERIAL-IO-EIA-RS-232-BITS (STREAM)
     2494  (LOOP FOR SET IN '(:DATA-TERMINAL-READY :DATA-TERMINAL-READY)
     2495        FOR GET IN '(:DATA-SET-READY      :CARRIER-DETECT)
     2496        DO
     2497        (FUNCALL STREAM ':PUT SET NIL)
     2498        (IF (NOT (NULL (FUNCALL STREAM ':GET GET)))
     2499            (FORMAT T "~&Error: Sent zero on ~S and got one on ~S.~%" SET GET))
     2500        (FUNCALL STREAM ':PUT SET T)
     2501        (IF (NULL (FUNCALL STREAM ':GET GET))
     2502            (FORMAT T "~&Error: Sent one on ~S and got zero on ~S.~%" SET GET)))
     2503  ;; Fix world.
     2504  (FUNCALL STREAM ':PUT ':REQUEST-TO-SEND T)
     2505  (FUNCALL STREAM ':PUT ':DATA-TERMINAL-READY T))
  • trunk/lisp/lcadr/dmon.lisp

    r204 r274  
    33
    44(DEFVAR CC-MAIN-MEMORY-SIZE NIL)
    5   (ADD-INITIALIZATION "clear target machine core size"
    6                       '(SETQ CC-MAIN-MEMORY-SIZE NIL))
    7 
    8 (DEFUN CC-RUN-MTEST (&OPTIONAL ALREADY-LOADED RANGE (MAP-OFFSET 0) &AUX PC CHAR)
     5(ADD-INITIALIZATION "clear target machine core size"
     6                    '(SETQ CC-MAIN-MEMORY-SIZE NIL)
     7                    '(:BEFORE-COLD))
     8
     9(DEFUN CC-RUN-MTEST-AUTO (&OPTIONAL ALREADY-LOADED RANGE (MAP-OFFSET 0))
     10  (CC-RUN-MTEST ALREADY-LOADED RANGE MAP-OFFSET T))
     11
     12;if AUTO-P is non-nil, errors will be proceeded from.  ADRIOR, ADRAND, DATAIOR, DATAAND
     13; will be updated if prgm can figure out how to do it.
     14(DEFUN CC-RUN-MTEST (&OPTIONAL ALREADY-LOADED RANGE (MAP-OFFSET 0) AUTO-P
     15                     &AUX PC SYMBOLIC-PC CHAR
     16                     ERRORS OTHER-ERRORS ADRAND ADRIOR DATAAND DATAIOR)
    917       (COND ((AND (NULL CC-MAIN-MEMORY-SIZE)
    1018                   (NULL RANGE))
     
    1220       (COND ((NULL ALREADY-LOADED)
    1321              (CC-ZERO-ENTIRE-MACHINE)
    14               (CC-UCODE-LOADER NIL "AI:LISPM1;MEMD ULOAD" NIL)))
     22              (CC-UCODE-LOADER NIL "SYS: UBIN; MEMD ULOAD >" NIL)))
    1523       (COND ((ZEROP MAP-OFFSET) (CC-FAST-LOAD-STRAIGHT-MAP))
    1624             (T (CC-LOAD-STRAIGHT-MAP MAP-OFFSET)))
     
    2331         (CC-RESET-MACH)                                   ; ERROR STOPS.
    2432         (DO TEST 0 (1+ TEST) (= TEST 10)
     33             (SETQ ERRORS 0 OTHER-ERRORS 0
     34                   ADRAND 77777777 ADRIOR 0 DATAAND 37777777777 DATAIOR 0)
    2535             (SETQ CC-UPDATE-DISPLAY-FLAG T)
    2636             (CC-SYMBOLIC-DEPOSIT-REGISTER 'M-TEST TEST)
    2737             (CC-REGISTER-DEPOSIT RASA (CC-SYMBOLIC-CMEM-ADR  'MEMORY-DATA-TEST))
    28             (CC-REGISTER-DEPOSIT RAGO 0)
     38        CONT (CC-REGISTER-DEPOSIT RAGO 0)
    2939          L  (COND ((SETQ CHAR (KBD-TYI-NO-HANG))
    3040                    (GO X1))
     
    3747                    (GO E)))
    3848          X  (CC-REGISTER-DEPOSIT RASTOP 0)
    39              (COND ((NOT (= (SETQ PC (CC-REGISTER-EXAMINE RAPC))
    40                             (CC-SYMBOLIC-CMEM-ADR 'MEMORY-TEST-OK)))
    41                     (FORMAT T "~%Test ~D halted at ~S (= ~O) "
    42                             TEST
    43                             (CC-FIND-CLOSEST-SYM (+ RACMO PC))
    44                             PC))
     49             (COND ((NOT (OR (= (SETQ PC (CC-REGISTER-EXAMINE RAPC))
     50                                (CC-SYMBOLIC-CMEM-ADR 'MEMORY-TEST-OK))
     51                             (> ERRORS 100.)))   ;give up after 100. errors.
     52                    (SETQ SYMBOLIC-PC (CC-FIND-CLOSEST-SYM (+ RACMO PC)))
     53                    (IF (NULL AUTO-P)
     54                        (FORMAT T "~%Test ~D halted at ~S (= ~O) " TEST SYMBOLIC-PC PC)
     55                        (SETQ ERRORS (1+ ERRORS))
     56                        (LET* ((CORRECT-DATA
     57                                (CC-SYMBOLIC-EXAMINE-REGISTER 'A-CURRENT-MEMORY-DATA))
     58                               (WRONG-BITS (LOGXOR CC-SAVED-MD CORRECT-DATA)))
     59                          (IF (NOT (MEMBER SYMBOLIC-PC '( ERROR-WRONG-DATA
     60                                                          (ERROR-WRONG-DATA 2)
     61                                                          (MEMORY-CHECK 2))))
     62                              (PROGN (SETQ OTHER-ERRORS (1+ OTHER-ERRORS))
     63                                     (FORMAT T "~%unexpected stop!!")
     64                                     (CC))
     65                              (SETQ ADRAND (LOGAND ADRAND CC-SAVED-VMA)
     66                                    ADRIOR (LOGIOR ADRIOR CC-SAVED-VMA)
     67                                    DATAAND (LOGAND WRONG-BITS DATAAND)
     68                                    DATAIOR (LOGIOR WRONG-BITS DATAIOR))))
     69                        (GO CONT)))
     70                   ((NOT (ZEROP ERRORS))
     71                    (FORMAT T "~%Test ~D, ~D errors, ADRAND ~S, ADRIOR ~S,
     72DATAAND ~S, DATAIOR ~S, other errors ~D"
     73                            TEST ERRORS ADRAND ADRIOR DATAAND DATAIOR OTHER-ERRORS)
     74                    (FORMAT T "~%DATAIOR bits ")
     75                    (CC-PRINT-BITS DATAIOR))
    4576                   (T (FORMAT T "~%Test ~D OK" TEST)))
    4677           E  )))
     
    83114        (LOGAND 377 (PHYS-MEM-READ (+ TV-ADR 1))))
    84115
     116(DEFUN CC-TV-READ-SYNC-ENB-RAM (ADR &OPTIONAL (TV-ADR 17377760))
     117        (PHYS-MEM-WRITE (+ TV-ADR 3) 200)       ;Enable SYNC RAM
     118        (PHYS-MEM-WRITE (+ TV-ADR 2) ADR)       ;Set pointer
     119        (LOGAND 377 (PHYS-MEM-READ (+ TV-ADR 1))))
     120
     121;;; This clobbers vertical spacing in order to guarantee access to RAM not PROM.
    85122(DEFUN CC-TV-WRITE-SYNC (ADR DATA &OPTIONAL (TV-ADR 17377760))
     123        (PHYS-MEM-WRITE (+ TV-ADR 3) 200)       ;Enable SYNC RAM
    86124        (PHYS-MEM-WRITE (+ TV-ADR 2) ADR)       ;Set pointer
    87125        (PHYS-MEM-WRITE (+ TV-ADR 1) DATA))
     
    125163  (CC-TV-START-SYNC 0 1 0 TV-ADR))
    126164
     165(defun cc-tv-setup-loop ()
     166  (do ()
     167      (())
     168    (cc-tv-setup-cpt)))
    127169
    128170(DEFUN CC-TV-CPT-CHECK-SYNC (&OPTIONAL (SYNC-PROG SI:CPT-SYNC2) (TV-ADR 17377760))
     
    171213                                (CC-WRONG-BITS-LIST GOOD2 BAD3 8)))))))
    172214
    173 (defun cc-tv-sync-write-loop (&optional (adr 0) (data -1))
    174   (do () (())
    175     (cc-tv-write-sync adr data)))
     215(DEFUN CC-TV-SYNC-WRITE-LOOP (&OPTIONAL (ADR 0) (DATA -1))
     216  (DO () ((KBD-TYI-NO-HANG))
     217    (CC-TV-WRITE-SYNC ADR DATA)))
    176218
    177219(DEFUN CC-TV-SYNC-READ-LOOP (&OPTIONAL (ADR 0))
    178   (DO () (())
     220  (DO () ((KBD-TYI-NO-HANG))
    179221    (CC-TV-READ-SYNC ADR)))
     222
     223(DEFUN CC-TV-SYNC-READ-LOOP-ENB-RAM (&OPTIONAL (ADR 0))
     224  (DO () ((KBD-TYI-NO-HANG))
     225    (CC-TV-READ-SYNC-ENB-RAM ADR)))
     226
    180227
    181228(DEFUN CC-TEST-TV-MEMORY (&OPTIONAL ALREADY-LOADED)
     
    211258                                 32.
    212259                                 14.)))
     260
     261;FAST-ADDRESS-TEST FOR THE TV ONLY DOES TWO 16K BANKS.  ONE BANK IS ODD ADDRESSES, THE
     262;OTHER EVEN.  A COUPLE OF THE VARIABLES HAVE DIFFERENT NAMES AND SOME HAVE BEEN
     263;REPLACED BY CONSTANTS BUT OTHERWISE THIS IS COPIED FROM THE FAST ADDRESS TEST BELOW.
     264(DEFUN CC-FAST-ADDRESS-TEST-TV-MEM ()
     265 (DOTIMES (BANK 2)
     266  (FORMAT T "~%~[even ~;odd ~]bank " BANK)
     267    (DO ((N 4 (1- N))
     268         (PHASE 0 (1+ PHASE))
     269         (ONES 37777777777)
     270         (ADR-MASK 37776)
     271         (ZEROS 0)
     272         (BASE-ADDRESS (+ 17000000 BANK)))
     273        ((= N 0))                                       
     274     (DO ((BITNO 0 (1+ BITNO))
     275         (GOOD1 (COND ((EVENP PHASE) ZEROS) (T ONES)))
     276         (GOOD2 (COND ((EVENP PHASE) ONES) (T ZEROS)))
     277         (BAD1)
     278         (BAD2)
     279         (BAD3)
     280         (LOCATION-ONE)
     281         (LOCATION-TWO)
     282         (CC-SUSPECT-BIT-LIST))
     283        ((= BITNO 13.))
     284      (SETQ LOCATION-ONE (+ BASE-ADDRESS (COND ((< PHASE 2)
     285                                                (LSH 2 BITNO))
     286                                               (T (LOGXOR ADR-MASK (LSH 2 BITNO))))))
     287      (SETQ LOCATION-TWO (COND ((< PHASE 2) BASE-ADDRESS)
     288                            (T (+ BASE-ADDRESS ADR-MASK))))
     289      (PHYS-MEM-WRITE LOCATION-ONE GOOD2)
     290      (COND ((NOT (EQUAL (SETQ BAD2 (PHYS-MEM-READ LOCATION-ONE)) GOOD2))
     291             (PRINC " loc ") (PRIN1 LOCATION-ONE)
     292             (CC-PRINT-BIT-LIST " fails in data bits "
     293                                (CC-WRONG-BITS-LIST GOOD2 BAD2 32.))))
     294      (PHYS-MEM-WRITE LOCATION-TWO GOOD1)
     295      (COND ((NOT (EQUAL (SETQ BAD1 (PHYS-MEM-READ LOCATION-TWO)) GOOD1))
     296             (PRINC " loc ") (PRIN1 LOCATION-TWO)
     297             (CC-PRINT-BIT-LIST " fails in data bits "
     298                                (CC-WRONG-BITS-LIST GOOD1 BAD1 32.))))
     299      (COND ((NOT (EQUAL (SETQ BAD3 (PHYS-MEM-READ LOCATION-ONE)) GOOD2))
     300             (PRINC " address bit ") (PRIN1-DECIMAL (1+ BITNO))
     301             (CC-PRINT-BIT-LIST (COND ((EVENP PHASE)
     302                                       " fails storing 1's then 0 in data bits ")
     303                                      (T " fails storing 0 then 1's in data bits "))
     304                                (CC-WRONG-BITS-LIST GOOD2 BAD3 32.))))))))
     305
    213306
    214307
     
    256349                                (CC-WRONG-BITS-LIST GOOD2 BAD3 N-DATA-BITS)))))))
    257350
    258 ;; Fill main memory. Stop via statistics counter.
     351
     352
     353;; Fillmain memory. Stop via statistics counter.
    259354;; VMA gets loaded with starting address minus one.
    260355;; MD has data.
  • trunk/lisp/lcadr/lcadmc.lisp

    r204 r274  
    132132   CONS-IR-STAT-BIT 5601
    133133   CONS-IR-SPARE-BIT 5701
     134   CONS-IR-PARITY-BIT 6001    ;Not normally read but returnned by CC-READ-C-MEM-WITH-PARITY.
    134135   CONS-IR-A-SRC 4012
    135136   CONS-IR-M-SRC 3206
  • trunk/lisp/lcadr/lcadrd.lisp

    r205 r274  
    342342                      (FORMAT T "~%AND ~O IOR ~O" AND IOR))))))))
    343343
    344 (DEFUN CC-READ-M-MEM-AND-CHECK-PARITY (ADR)
     344(DEFUN CC-READ-M-MEM-AND-CHECK-PARITY (ADR &AUX DATA ERROR-P)
    345345  (CC-EXECUTE CONS-IR-M-SRC ADR ;PUT IT ONTO THE OBUS
    346346              CONS-IR-ALUF CONS-ALU-SETM
    347347              CONS-IR-OB CONS-OB-ALU)
    348   (PROG1 (CC-READ-OBUS)
    349          (CC-NOOP-CLOCK)
    350          (COND ((NOT (ZEROP (LOGLDB 101 (SPY-READ SPY-FLAG-1))))
    351                 (FORMAT T "~%BAD M-MEM PARITY, ADR ~S" ADR)))))
     348  (SETQ DATA (CC-READ-OBUS))
     349  (CC-NOOP-CLOCK)
     350  (COND ((SETQ ERROR-P (NOT (ZEROP (LOGLDB 101 (SPY-READ SPY-FLAG-1)))))
     351         (FORMAT T "~%BAD M-MEM PARITY, ADR ~S" ADR)))
     352  (PROG NIL (RETURN DATA ERROR-P)))
    352353
    353354(DEFUN CC-SWEEP-M-MEM NIL
     
    415416  (CC-READ-IR))                 ;RETURN CONTENTS
    416417
     418(DEFUN CC-READ-C-MEM-WITH-PARITY (ADR)
     419  (LET ((TEM (CC-READ-C-MEM ADR)))
     420    (DPB (LDB 0501 (SPY-READ SPY-FLAG-2))
     421         CONS-IR-PARITY-BIT
     422         TEM)))
     423
    417424;USED FOR SAVING & RESTORING
    418425;OTHERWISE MICRO-DIAGNOSTICS WHICH RUN IN FOREIGN MACHINE BASH EACH OTHER
     
    495502  T)
    496503
     504(DEFUN CC-WRITE-LC (VAL)
     505  (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-LC VAL))
     506
     507(DEFUN CC-READ-LC ()
     508  (CC-READ-M-MEM CONS-M-SRC-LC))
     509
    497510(DEFUN CC-WRITE-FUNC-DEST (ADR VAL)
    498511  (CC-WRITE-MD VAL)
     
    537550              CONS-IR-FUNC-DEST CONS-FUNC-DEST-PDL-BUFFER-INDEX))
    538551
     552(DEFUN CC-READ-PDL-BUFFER-POINTER ()
     553  (CC-READ-M-MEM CONS-M-SRC-PDL-BUFFER-POINTER))
     554
     555(DEFUN CC-WRITE-PDL-BUFFER-POINTER (VAL)
     556  (CC-WRITE-MD VAL)
     557  (CC-EXECUTE (WRITE)
     558              CONS-IR-M-SRC CONS-M-SRC-MD
     559              CONS-IR-ALUF CONS-ALU-SETM
     560              CONS-IR-OB CONS-OB-ALU
     561              CONS-IR-FUNC-DEST CONS-FUNC-DEST-PDL-BUFFER-POINTER)
     562  VAL)
     563
    539564;READ THE PDL BUFFER
    540565(DEFUN CC-READ-PDL-BUFFER (ADR)
     
    557582              CONS-IR-OB CONS-OB-ALU
    558583              CONS-IR-FUNC-DEST CONS-FUNC-DEST-C-PI))
     584
     585(DEFUN CC-SCAN-P-MEM-FOR-BAD-PARITY (&OPTIONAL (PRINT-RUNNING-LOGAND-AND-LOGIOR NIL))
     586  (DO ((ADR 0 (1+ ADR))
     587       (AND 7777777777777777)
     588       (IOR 0)
     589       (ERRS 0))
     590      ((= ADR 2000)
     591       (COND ((NOT (ZEROP ERRS))
     592              (FORMAT T "~%AND ~O IOR ~O" AND IOR))))
     593    (MULTIPLE-VALUE-BIND (DATA ERROR-P)
     594        (CC-READ-P-MEM-AND-CHECK-PARITY ADR)
     595      (COND (ERROR-P
     596              (SETQ AND (LOGAND AND DATA) IOR (LOGIOR IOR DATA))
     597              (SETQ ERRS (1+ ERRS))
     598              (COND (PRINT-RUNNING-LOGAND-AND-LOGIOR
     599                      (FORMAT T "~%AND ~O IOR ~O" AND IOR))))))))
     600
     601(DEFUN CC-READ-P-MEM-AND-CHECK-PARITY (ADR &AUX DATA ERROR-P)
     602  (OR CC-PDL-BUFFER-INDEX-CHANGED-FLAG
     603      (CC-SAVE-PDL-BUFFER-INDEX))                       ;SAVE PDL INDEX IF NECESSARY
     604  (CC-WRITE-PDL-BUFFER-INDEX ADR)                       ;ADDRESS THE PDL
     605  (CC-EXECUTE CONS-IR-M-SRC CONS-M-SRC-C-PDL-BUFFER-INDEX       ;READ IT OUT
     606              CONS-IR-ALUF CONS-ALU-SETM
     607              CONS-IR-OB CONS-OB-ALU)
     608  (SETQ DATA (CC-READ-OBUS))
     609  (CC-NOOP-CLOCK)
     610  (COND ((SETQ ERROR-P (NOT (ZEROP (LOGLDB 201 (SPY-READ SPY-FLAG-1)))))
     611         (FORMAT T "~%BAD P-MEM PARITY, ADR ~S" ADR)))
     612  (PROG NIL (RETURN DATA ERROR-P)))
     613
    559614
    560615
     
    811866                        T))))))
    812867
    813 (DEFUN CC-SWEEP-LEVEL-1-MAP (&AUX (ADR-AND 7777) (ADR-IOR 0) (DATA-AND 37) (DATA-IOR 0)
    814                                   DAT LOSEP (LOSES 0))
     868(DEFUN CC-SCAN-LEVEL-1-MAP-FOR-BAD-PARITY (&AUX (ADR-AND 7777) (ADR-IOR 0)
     869                                           (DATA-AND 37) (DATA-IOR 0)
     870                                           DAT LOSEP (LOSES 0))
    815871  (DOTIMES (ADR 10000)
    816872    (MULTIPLE-VALUE (DAT LOSEP)
     
    864920  #Q (LET ((OBUS (CC-READ-OBUS)))
    865921        (DPB (LDB 2701 OBUS) 2701 (LDB 0027 OBUS))))
     922
     923(DEFUN CC-READ-LEVEL-2-MAP-AND-CHECK-PARITY (ADR)
     924  (CC-WRITE-MD (CC-ADDRESS-LEVEL-2-MAP ADR))    ;SET UP MD
     925  (CC-EXECUTE CONS-IR-M-SRC CONS-M-SRC-MAP      ;READ OUT MAP
     926              CONS-IR-ALUF CONS-ALU-SETM
     927              CONS-IR-OB CONS-OB-ALU)
     928  (LET ((OBUS (CC-READ-OBUS)))
     929    (PROG1 (DPB (LDB 2701 OBUS) 2701 (LDB 0027 OBUS))
     930           (PROGN (CC-NOOP-CLOCK)
     931                  (COND ((ZEROP (LOGLDB 1601 (SPY-READ SPY-FLAG-1)))
     932                         (FORMAT T "~%BAD LEVEL-2-MAP PARITY, ADR ~S" ADR)
     933                        T))))))
     934
     935(DEFUN CC-SCAN-LEVEL-2-MAP-FOR-BAD-PARITY (&AUX (ADR-AND 1777) (ADR-IOR 0)
     936                                           (DATA-AND 77777777) (DATA-IOR 0)
     937                                           DAT LOSEP (LOSES 0))
     938  (DOTIMES (ADR 2000)
     939    (MULTIPLE-VALUE (DAT LOSEP)
     940      (CC-READ-LEVEL-2-MAP-AND-CHECK-PARITY ADR))
     941    (COND (LOSEP (SETQ ADR-AND (LOGAND ADR-AND ADR)
     942                       ADR-IOR (LOGIOR ADR-IOR ADR)
     943                       DATA-AND (LOGAND DATA-AND DAT)
     944                       DATA-IOR (LOGIOR DATA-IOR DAT)
     945                       LOSES (1+ LOSES)))))
     946  (COND ((NOT (ZEROP LOSES))
     947         (FORMAT T "~%~D loses: ADRAND=~O, ADRIOR=~O, DATAAND=~O, DATAIOR=~O"
     948                 LOSES ADR-AND ADR-IOR DATA-AND DATA-IOR))))
     949
     950;find level 2 map entries which are non-zero but do not have access bit set.
     951(DEFUN CC-SCAN-LEVEL-2-MAP-FOR-GARBAGE  (&OPTIONAL RUNNING-PRINTOUT
     952                                         &AUX (ADR-AND 1777) (ADR-IOR 0)
     953                                           (DATA-AND 77777777) (DATA-IOR 0)
     954                                           DAT LOSEP (LOSES 0))
     955  (DOTIMES (ADR 2000)
     956    (SETQ DAT (CC-READ-LEVEL-2-MAP-AND-CHECK-PARITY ADR))
     957    (SETQ LOSEP (AND (NOT (ZEROP DAT))
     958                     (ZEROP (LOGAND DAT 1_23.))))
     959    (COND (LOSEP (SETQ ADR-AND (LOGAND ADR-AND ADR)
     960                       ADR-IOR (LOGIOR ADR-IOR ADR)
     961                       DATA-AND (LOGAND DATA-AND DAT)
     962                       DATA-IOR (LOGIOR DATA-IOR DAT)
     963                       LOSES (1+ LOSES))
     964                 (IF RUNNING-PRINTOUT (FORMAT T "~%adr ~s, data ~s" ADR DAT)))))
     965  (COND ((NOT (ZEROP LOSES))
     966         (FORMAT T "~%~D loses: ADRAND=~O, ADRIOR=~O, DATAAND=~O, DATAIOR=~O"
     967                 LOSES ADR-AND ADR-IOR DATA-AND DATA-IOR))))
     968
    866969;WRITE INTO LEVEL 2 MAP
    867970(DEFUN CC-WRITE-LEVEL-2-MAP (ADR VAL)
     
    13021405  (SETQ CC-LOW-LEVEL-FLAG (READ)))
    13031406
    1304 (SETQ PDP11-DISABLE T) ;CLEARLY
    1305 
    13061407(DEFUN CC-PRINT-ERROR-STATUS (ERR-STS)
    13071408       (COND ((EQ CC-LOW-LEVEL-FLAG 'VERY)
     
    15871688  (SETQ CC-UPDATE-DISPLAY-FLAG T)
    15881689  NIL)
     1690
  • trunk/lisp/lcadr/ldbg.lisp

    r204 r274  
    9191;;; Print the error status bits
    9292(DEFVAR SERIAL-STREAM)
     93(DEFPROP SERIAL-STREAM T SI:IO-STREAM-P)
    9394
    9495(DEFUN DBG-PRINT-STATUS ()
     
    117118  (OR (= HIGH DBG-SERIAL-HIGH-BIT)
    118119      (FORMAT 'SERIAL-STREAM "~OS" (+ (SETQ DBG-SERIAL-HIGH-BIT HIGH)
    119                                     (COND (DBG-NXM-INHIBIT 4) (T 0))))))
     120                                      (COND (DBG-NXM-INHIBIT 4) (T 0))))))
     121
     122(DEFUN SET-SERIAL-SPEED (BAUD)
     123  (LET ((BAUD-CODE (SECOND (ASSQ BAUD '((50. 0) (75. 1) (110. 2) (150. 4) (300. 5) (600. 6)
     124                                        (1200. 7) (1800. 10) (2000. 11) (2400. 12) (3600. 13)
     125                                        (4800. 14) (7200. 15) (9600. 16) (19200. 17))))))
     126    (OR BAUD-CODE (FERROR NIL "~D is illegal baud rate" BAUD))
     127    (FORMAT 'SERIAL-STREAM "~OA" BAUD-CODE)
     128    (PROCESS-SLEEP 20.)
     129    (FUNCALL SERIAL-STREAM ':CLOSE)
     130    (SETQ SERIAL-STREAM (SI:MAKE-SERIAL-STREAM ':PARITY NIL ':NUMBER-OF-DATA-BITS 8
     131                                               ':BAUD BAUD))
     132    (PROCESS-SLEEP 20.)))
    120133
    121134;;; Dummy stream for SERIAL I/O
    122 (DEFUN SERIAL-STREAM (OP &OPTIONAL ARG1)
     135(DEFUN SERIAL-STREAM (OP &OPTIONAL ARG1 ARG2 ARG3 &REST IGNORE)
    123136  ;; Don't do this at load time since it doesn't work if the machine doesn't have
    124137  ;; the serial interface hardware
     
    127140                                                 ':BAUD 300.)))
    128141  (SELECTQ OP
    129     (:WHICH-OPERATIONS '(TYI TYO))
    130     (:STRING-OUT (DOTIMES (I (STRING-LENGTH ARG1))
    131                    (FUNCALL SERIAL-STREAM ':TYO (CHARACTER-ODD-PARITY (AREF ARG1 I)))))
     142    (:WHICH-OPERATIONS '(:TYI :TYO))
     143    (:STRING-OUT (LOOP FOR I FROM (OR ARG2 0) BELOW (OR ARG3 (STRING-LENGTH ARG1)) DO
     144                       (FUNCALL SERIAL-STREAM ':TYO (CHARACTER-ODD-PARITY (AREF ARG1 I)))))
    132145    (:TYI (DO ((CHAR (FUNCALL SERIAL-STREAM ':TYI) (FUNCALL SERIAL-STREAM ':TYI)))
    133146              (NIL)
     
    235248  (DBG-WRITE (+ 766140 (* 2 LOC)) VAL))
    236249
     250(DEFUN READ-UNIBUS-MAP (LOC)
     251  (%UNIBUS-READ (+ 766140 (* 2 LOC))))
     252
     253(DEFUN WRITE-UNIBUS-MAP (LOC VAL)
     254  (%UNIBUS-WRITE (+ 766140 (* 2 LOC)) VAL))
     255
     256;This run as warm initialization.  In the PDP11 slave case, it
     257; assures there will be no collision with PDP11 memory.
     258(DEFUN DBG-CLEAR-UNIBUS-MAP () "clear debugee's unibus map"
     259  (DOTIMES (L 16.)
     260    (DBG-WRITE-UNIBUS-MAP L 0)))
     261
     262;(ADD-INITIALIZATION "clear unibus map" '(CLEAR-UNIBUS-MAP) '(:SYSTEM))
     263;CLEAR-UNIBUS-MAP called from SI:LISP-REINITIALIZE.  Do it very early to
     264; avoid screwwing ETHERNET code.
     265(DEFUN CLEAR-UNIBUS-MAP ()  "clear this machine's unibus map"
     266  (DOTIMES (L 16.)
     267    (WRITE-UNIBUS-MAP L 0)))
     268
    237269;; Returns unibus location mapped into specified xbus location
    238270(DEFUN DBG-SETUP-UNIBUS-MAP (LOC XBUS-LOC)
    239271  (DBG-WRITE-UNIBUS-MAP LOC (+ 140000 (LDB 1016 XBUS-LOC)))
     272  (+ 140000 (* LOC 2000) (* 4 (LOGAND 377 XBUS-LOC))))
     273
     274(DEFUN SETUP-UNIBUS-MAP (LOC XBUS-LOC)
     275  (WRITE-UNIBUS-MAP LOC (+ 140000 (LDB 1016 XBUS-LOC)))
    240276  (+ 140000 (* LOC 2000) (* 4 (LOGAND 377 XBUS-LOC))))
    241277
  • trunk/lisp/lcadr/lqfmac.lisp

    r204 r274  
    2121(DEFMACRO QF-DATA-TYPE (Q) `(LDB 3005 ,Q))
    2222
    23 (DEFMACRO QF-POINTER (Q) `(LET ((**FOO** ,Q))
    24                                (LOGIOR (LSH (LDB 1414 **FOO**) 14) (LDB 0014 **FOO**))))
     23(DEFMACRO QF-POINTER (Q) `(LOGAND 77777777 ,Q)) ;Can't use LDB, byte too wide
    2524
    2625(DEFMACRO QF-CDR-CODE (Q) `(LDB 3602 ,Q))
  • trunk/lisp/lcadr/packed.lisp

    r204 r274  
    612612(DEFUN CC-SET-CURRENT-MICROLOAD (PART)
    613613  (COND ((NUMBERP PART) (SETQ PART (IMPLODE (APPEND '(M C R) (LIST (+ PART 60)))))))
    614   (OR (MEMQ PART '(MCR1 MCR2))
    615       (ERROR '|Partition name should be MCR1 or MCR2| PART))
     614  (OR (STRING-EQUAL PART "MCR" 0 0 3)
     615      (ERROR '|Partition name should be MCRn| PART))
    616616  (READ-LABEL)
    617617  (SETQ INITIAL-MCR-NAME PART)
     
    620620(DEFUN CC-SET-CURRENT-BAND (PART)
    621621  (COND ((NUMBERP PART) (SETQ PART (IMPLODE (APPEND '(L O D) (LIST (+ PART 60)))))))
    622   (OR (MEMQ PART '(LOD1 LOD2 LOD3 LOD4 LOD5 LOD6 LOD7))
     622  (OR (STRING-EQUAL PART "LOD" 0 0 3)
    623623      (ERROR '|Partition name should be among LOD1...LOD7| PART))
    624624  (READ-LABEL)
    625625  (SETQ INITIAL-LOD-NAME PART)
    626626  (WRITE-LABEL))
     627
     628;;; Only works on the real machine.
     629(DEFUN CC-PRINT-DISK-LABEL ()  ;This is what I always think it is named. -- DLW
     630  (PRINT-DISK-LABEL "CC"))
  • trunk/lisp/lcadr/praid.lisp

    r204 r274  
    1 ;;-*- mode: lispm; package: cadr -*-
     1;;-*- mode: lisp; package: cadr -*-
    22
    33;Production check out aids.  These are mostly for freshly constructed machines
     
    6161
    6262
    63 
     63;-DB NEEDS UB   BUSINT D01-8
     64;BUS REQ        BUSINT D05-6
     65;NPR            BUSINT D10-6
     66;DB UB MASTER   BUSINT D04-12
     67;SELECT DEBUG   BUSINT E07-8
    6468;SPY WRITE L    BUSINT J08-10
    6569;-DBWRITE       5F03(6)  SPY0   5AJ1-10  MBCPIN
     
    128132
    129133(DEFUN P-MD-SHIFTING-LOOP (&OPTIONAL (N 0))
    130   (DO () (()) (CC-WRITE-MD-SHIFTING N)))
     134  (DO () (()) (CC-WRITE-MD-SHIFTING N)))        ;
    131135
    132136(DEFUN CC-TEST-VMA (&OPTIONAL (N 0) (M -1))
     
    174178  (DO () (()) (CC-READ-A-MEM ADR)))
    175179
     180
     181(DEFUN P-PDL-BUFFER-WR-LOOP (&OPTIONAL (ADR 0) (VAL1 0) (VAL2 -1))
     182  (DO () (())
     183    (CC-WRITE-PDL-BUFFER ADR VAL1)
     184    (CC-READ-PDL-BUFFER ADR)
     185    (CC-WRITE-PDL-BUFFER ADR VAL2)
     186    (CC-READ-PDL-BUFFER VAL2)))
     187
     188
    176189(defun p-m-rw-a-pass (n &optional (adr 0))
    177190  (CC-WRITE-MD n)               ;PUT VALUE INTO THE MRD REGISTER
     
    193206(DEFUN P-C-MEM-R-LOOP (&OPTIONAL (ADR 0))
    194207  (DO () (()) (CC-READ-C-MEM ADR)))
     208
     209(DEFUN P-C-MEM-WR-LOOP (&OPTIONAL (ADR 0) (VAL1 0) (VAL2 -1))
     210  (DO () (())
     211    (CC-WRITE-C-MEM ADR VAL1)
     212    (CC-READ-C-MEM ADR)
     213    (CC-WRITE-C-MEM ADR VAL2)
     214    (CC-READ-C-MEM ADR)))
     215
     216(defun p-lc-wr-loop (&optional (n1 0) (n2 -1))
     217  (do () (())
     218    (cc-write-lc n1)
     219    (cc-read-lc)
     220    (cc-write-lc n2)
     221    (cc-read-lc)))
    195222
    196223(DEFUN P-LC-LOOP (&OPTIONAL (N 0))
     
    279306      (())
    280307    (DBG-WRITE ADR DATA)))
     308
     309
     310  ;;
     311  ;;  Functions for debugging disk controllers
     312  ;;
     313
     314
     315
     316
     317  ;; Part 6 - Write and read block 1 of the disk.  Use a floating 1's and 0's
     318  ;;          pattern, and then an address pattern, and check for Xbus data path
     319  ;;          and addressing failures.
     320  ;; This doesn't check high-order address bits
     321(DEFUN DLOOP ()
     322  (DO () (())
     323  (DO I 0 (1+ I) (= I 40)       ;Loc 0-37 get floating 1's
     324    (PHYS-MEM-WRITE I (#M LSH #Q ASH 1 I)))
     325  (DO I 0 (1+ I) (= I 40)       ;Loc 40-77 get floating 0's
     326    (PHYS-MEM-WRITE (+ 40 I) (- (#M LSH #Q ASH 1 32.) (#M LSH #Q ASH 1 I))))
     327  (DO I 100 (1+ I) (= I 400)    ;Loc 100-377 get address pattern
     328    (PHYS-MEM-WRITE I (+ (LSH (LOGXOR 377 I) 8) I)))
     329 ; (PRINT 'WRITE)
     330  (DC-EXEC DC-WRITE 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS)
     331;  (LET ((MA (DC-READ-MA)))
     332;    #M (DECLARE (FIXNUM MA))
     333;    (COND ((NOT (= MA 377))
     334;          (TERPRI) (PRINC '|MA wrong on write of pattern, correct=377, actual=|)
     335;          (PRIN1 MA))))
     336  (DO I 0 (1+ I) (= I 400)      ;Clear buffer
     337    (PHYS-MEM-WRITE I 0))
     338 ; (PRINT 'READ)
     339  (DC-EXEC DC-READ 0 0 1 CCW-LOC 0 DC-ALL-ERROR-BITS)
     340;  (LET ((MA (DC-READ-MA)))
     341;    #M (DECLARE (FIXNUM MA))
     342;    (COND ((NOT (= MA 377))
     343;          (TERPRI) (PRINC '|MA wrong on read of pattern, correct=377, actual=|)
     344;          (PRIN1 MA) (TERPRI))))               
     345  ;; Check pattern read back into core, see if it's correct
     346;  (LET ((DCHECK-AND 37777777777) (DCHECK-IOR 0)  ;Accumulate error bits here
     347;       (DCHECK-ADR-AND 377) (DCHECK-ADR-IOR 0))
     348;    (DO I 0 (1+ I) (= I 40)    ;Loc 0-37 get floating 1's
     349;      (DCHECK-COMPARE I (#M LSH #Q ASH 1 I)))
     350;    (DO I 0 (1+ I) (= I 40)    ;Loc 40-77 get floating 0's
     351;      (DCHECK-COMPARE (+ 40 I) (- (#M LSH #Q ASH 1 32.) (#M LSH #Q ASH 1 I))))
     352;    (DO I 100 (1+ I) (= I 400) ;Loc 100-377 get address pattern
     353;      (DCHECK-COMPARE I (+ (#M LSH #Q ASH (LOGXOR 377 I) 8) I)))
     354;    (DCHECK-PM '|Data bits dropped during write to or read from disk: |
     355;              (LOGXOR 37777777777 DCHECK-IOR))
     356;    (DCHECK-PM '|Data bits picked during write to or read from disk: |
     357;              DCHECK-AND)
     358;    (DCHECK-PM '|Address bits 0 with bad data during write to or read from disk: |
     359;              (LOGXOR 377 DCHECK-ADR-AND))
     360;    (DCHECK-PM '|Address bits 1 with bad data during write to or read from disk: |
     361;              DCHECK-ADR-IOR))
     362  ));; Maybe there should be a test-loop for the above?
  • trunk/lisp/lcadr/qf.lisp

    r204 r274  
    99;LEVELS -2 MEANS IN PDL BUFFER.
    1010
    11 (DECLARE (FIXNUM ADR VADR PADR HASH LEN HASH1 DATA I J K M N Q MUM PHT-ADR SIZE-OF-PAGE-TABLE))
     11(DECLARE (FIXNUM ADR VADR PADR HASH LEN HASH1 DATA I J K M N Q MUM PHT-ADR))
    1212(DECLARE (SETQ RUN-IN-MACLISP-SWITCH T))        ;Inhibit some error messages
    1313
     
    6262;                 QF-VIRTUAL-ADDR-KNOWN-PHT1 QF-VIRTUAL-ADDR-KNOWN-PHT2
    6363                  QF-AREA-ORIGIN-CACHE QF-PAGE-PARTITION-CACHE QF-FINDCORE-TRACE-SWITCH
     64                  QF-PHT-CACHE  ;NIL or list of microcode version and PHT-LIMIT and PHT-MASK
    6465                  QF-SWAP-IN-LOOP-CHECK QF-PAGE-HASH-TABLE-EXTRA-CHECKING-FLAG))
    6566(SETQ QF-PAGE-HASH-TABLE-EXTRA-CHECKING-FLAG NIL
     
    7071  (COND (EVERYTHINGP
    7172         (SETQ QF-AREA-ORIGIN-CACHE NIL)
    72          (REMPROP 'QF-HASH-RELOAD-POINTER 'QF-HASH-RELOAD-POINTER)
    7373         (ALLREMPROP 'REAL-MACHINE-ATOM-HEADER-POINTER)
    7474         (ALLREMPROP 'REAL-MACHINE-PACKAGE-POINTER)))
     75   (SETQ QF-PHT-CACHE NIL)
    7576   (SETQ QF-PAGE-PARTITION-CACHE NIL)
    7677)
    7778
    78 (DECLARE (SPECIAL PHT-ADDR SIZE-OF-PAGE-TABLE))
     79(DECLARE (SPECIAL PHT-ADDR))
    7980(SETQ PHT-ADDR (* 5 400))
    8081
     
    104105
    105106(DEFUN QF-PAGE-HASH-TABLE-LOOKUP (ADR)  ;RETURNS -1 OR PHYSICAL MEM ADR OF PHT1 WD
    106  (SETQ ADR (QF-POINTER ADR))            ; OF HASH-TBL ENTRY FOR ADR
    107  (DO ((PHT-MASK (- SIZE-OF-PAGE-TABLE 2))
    108       (HASH (LOGXOR (LOGLDB 1612 ADR) (LOGAND 777774 (LOGLDB 0622 ADR))) (+ HASH 2))
    109       (PHT1)
    110       (COUNT (LSH SIZE-OF-PAGE-TABLE -1) (1- COUNT)))
    111      ((= COUNT 0) -1)     ;INACESSIBLE (SHOULD NEVER HAPPEN, BUT AT LEAST DONT GET
    112                           ; INTO INFINITE LOOP IF HASH TABLE GETS OVER-FULL)
    113    (DECLARE (FIXNUM PHT-MASK HASH PHT1 PHT2 COUNT))
    114    (SETQ HASH (LOGAND HASH PHT-MASK))
    115    (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH)))
    116    (COND ((= 0 (LOGAND 100 PHT1))       ;NO VALID BIT
    117             (RETURN -1))                ;NOT FOUND
    118          ((= 0 (LOGAND 77777400 (LOGXOR ADR PHT1)))  ;ADDRESS MATCH
    119             (RETURN (+ PHT-ADDR HASH))))))      ;FOUND IT
     107  (SETQ ADR (QF-POINTER ADR))           ; OF HASH-TBL ENTRY FOR ADR
     108  (OR QF-PHT-CACHE (QF-REFILL-PHT-CACHE))
     109  (LET ((PHT-SIZE (CADR QF-PHT-CACHE)))
     110    (DECLARE (FIXNUM PHT-SIZE))
     111    (DO ((HASH (QF-COMPUTE-PAGE-HASH ADR) (+ HASH 2))
     112         (PHT1)
     113         (COUNT (LSH PHT-SIZE -1) (1- COUNT)))
     114        ((= COUNT 0) -1)     ;INACESSIBLE (SHOULD NEVER HAPPEN, BUT AT LEAST DONT GET
     115                             ; INTO INFINITE LOOP IF HASH TABLE GETS OVER-FULL)
     116      (DECLARE (FIXNUM HASH PHT1 PHT2 COUNT))
     117      (AND (>= HASH PHT-SIZE) (SETQ HASH (- HASH PHT-SIZE)))
     118      (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH)))
     119      (COND ((= 0 (LOGAND 100 PHT1))    ;NO VALID BIT
     120               (RETURN -1))             ;NOT FOUND
     121            ((= 0 (LOGAND 77777400 (LOGXOR ADR PHT1)))  ;ADDRESS MATCH
     122               (RETURN (+ PHT-ADDR HASH)))))))  ;FOUND IT
    120123
    121124;Linearly scan page hash table looking for info on given phys-adr.
     
    124127       (HASH-LOCN 0 (+ HASH-LOCN 2))
    125128       (PHT1) (PHT2)
    126        (COUNT (LSH SIZE-OF-PAGE-TABLE -1) (1- COUNT)))
     129       (COUNT (LSH (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-SIZE))) -1)
     130              (1- COUNT)))
    127131      ((= COUNT 0) NIL)
    128132    (COND ((AND (BIT-TEST 100 (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH-LOCN))))
     
    137141        (DECLARE (FIXNUM LEAD-POINTER LEAD-POINTER-HASH-ADR LEAD-POINTER-VIRT-ADR
    138142                         LIM PHT1 PHT2 MOVED-POINTER PPDP))
    139         (SETQ LIM (+ PHT-ADDR SIZE-OF-PAGE-TABLE -2))           ;POINTS TO LAST VALID ENTRY
     143        (SETQ LIM (+ PHT-ADDR
     144                     (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-SIZE)))
     145                     -2))               ;POINTS TO LAST VALID ENTRY
    140146   L1   (PHYS-MEM-WRITE HOLE-POINTER (QF-MAKE-Q 0 DTP-FIX))     ;FLUSH GUY FROM TABLE
    141147        (SETQ LEAD-POINTER HOLE-POINTER)
     
    174180))
    175181
     182(DEFUN QF-REFILL-PHT-CACHE ()
     183 (LET ((PHT-SIZE (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-SIZE)))))
     184   (DECLARE (FIXNUM PHT-SIZE))
     185   (LET ((PHT-MASK (- (LSH 1 (HAULONG (- PHT-SIZE 2))) 2)))
     186     (DECLARE (FIXNUM PHT-MASK))
     187     (SETQ QF-PHT-CACHE (LIST (QF-POINTER (CC-SYMBOLIC-EXAMINE-REGISTER 'A-VERSION))
     188                              PHT-SIZE
     189                              PHT-MASK)))))
     190
    176191(DEFUN QF-COMPUTE-PAGE-HASH (ADR)
    177     (LOGAND (- SIZE-OF-PAGE-TABLE 2)
    178             (LOGXOR (LOGLDB 1612 ADR) (LOGAND 777774 (LOGLDB 0622 ADR)))))
     192  (OR QF-PHT-CACHE (QF-REFILL-PHT-CACHE))
     193  (LET ((PHT-SIZE (CADR QF-PHT-CACHE)) (PHT-MASK (CADDR QF-PHT-CACHE)))
     194   (DECLARE (FIXNUM PHT-SIZE PHT-MASK))
     195   (LET ((HASH (LOGAND (LOGXOR (LOGLDB 1612 ADR)
     196                               (IF (> (CAR QF-PHT-CACHE) 703.)  ;New microcode
     197                                   (LOGAND 777760 (LOGLDB 0424 ADR))
     198                                   (LOGAND 777774 (LOGLDB 0622 ADR))))
     199                       PHT-MASK)))
     200     (DECLARE (FIXNUM HASH))
     201     (AND (>= HASH PHT-SIZE) (SETQ HASH (- HASH PHT-SIZE)))
     202     HASH)))
    179203
    180204(DEFUN QF-VIRTUAL-MEM-MAP (ADR WRITE-CYCLE)
    181205 (SETQ ADR (QF-POINTER ADR))            ;FLUSH DATA TYPE ETC.
    182  (DO ((PHT-MASK (- SIZE-OF-PAGE-TABLE 2))
    183       (HASH (LOGXOR (LOGLDB 1612 ADR) (LOGAND 777774 (LOGLDB 0622 ADR))) (+ HASH 2))
    184       (PHT1)
    185       (PHT2)
    186       (TEM)(STS)
    187       (COUNT (LSH SIZE-OF-PAGE-TABLE -1) (1- COUNT)))
    188      ((= COUNT 0) -1)                                   ;INACCESSIBLE
    189      (DECLARE (FIXNUM PHT-MASK HASH PHT1 PHT2 COUNT TEM STS))
    190      (SETQ HASH (LOGAND HASH PHT-MASK))
    191      (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH)))
    192      (COND ((= 0 (LOGAND 100 PHT1))                     ;NO VALID BIT
    193             (RETURN -1))                                ;INACCESSIBLE
    194            ((= 0 (LOGAND 77777400 (LOGXOR ADR PHT1)))   ;ADDRESS MATCH
    195             (SETQ STS (LOGAND 7 PHT1))                  ;ISOLATE SWAP STATUS CODE
    196             (COND ((OR (= STS 0)                        ;UNUSED ENTRY
    197                        (= STS 3)                        ;UNUSED CODES
    198                        (= STS 6)
    199                        (= STS 7))
    200                    (ERROR 'BAD-PAGE-HASH-ENTRY-AT-ADR HASH 'FAIL-ACT)))
    201             (SETQ PHT2 (PHYS-MEM-READ (+ PHT-ADDR HASH 1)))     ;IN CORE, GET ADDRESS
    202             (COND ((AND (= 5 (LOGLDB-FROM-FIXNUM
    203                                %%PHT2-MAP-STATUS-CODE PHT2))  ;MAY BE IN PDL-BUFFER
    204                         (NOT (< ADR (SETQ TEM (QF-POINTER
    205                                                (CC-SYMBOLIC-EXAMINE-REGISTER
    206                                                 'A-PDL-BUFFER-VIRTUAL-ADDRESS)))))
    207                         (<= ADR (+ TEM (CC-SYMBOLIC-EXAMINE-REGISTER 'PP))))
    208                    (RETURN -2)))                        ;IN PDL-BUFFER
    209 ;IF DOING A WRITE-CYCLE INTO A PAGE, SET PHT1-MODIFIED BIT
    210 ;THIS HOPEFULLY ASSURES PAGE WILL GET WRITTEN ON DISK IF IT GETS SWAPPED OUT
    211 ;EVEN IF THE ACCESS IS NOT READ/WRITE.
    212             (COND (WRITE-CYCLE
    213                    (PHYS-MEM-WRITE (+ PHT-ADDR HASH)
    214                                    (LOGDPB-INTO-FIXNUM 1 %%PHT1-MODIFIED-BIT PHT1))))
    215             (RETURN (+ (LSH (LOGLDB-FROM-FIXNUM %%PHT2-PHYSICAL-PAGE-NUMBER PHT2) 8)
    216                        (LOGAND 377 ADR)))))) 
    217 )
    218 
    219 (DEFUN QF-FINDCORE NIL  ;CALL TO OBTAIN FREE PAGE OF CONS MEMORY. SWAP ONE OUT IF NECC, ETC.
    220   (DECLARE (FIXNUM PTR LIM PHT1 PHT2 TEM))
    221   (PROG (PTR LIM PHT1 PHT2 TEM FLAG)
    222         (SETQ LIM (+ PHT-ADDR SIZE-OF-PAGE-TABLE -2))   ;POINTS AT HIGHEST ENTRY
    223         (SETQ PTR PHT-ADDR)             ;LOOK FOR FLUSHABLE FROB FIRST
    224    L1   (SETQ PHT1 (PHYS-MEM-READ PTR))
    225         (SETQ TEM (LOGLDB-FROM-FIXNUM %%PHT1-SWAP-STATUS-CODE PHT1))    ;SWAP STATUS
    226         (COND ((= TEM %PHT-SWAP-STATUS-FLUSHABLE) (GO CF)))     ;FLUSHABLE
    227         (COND ((NOT (= PTR LIM)) (SETQ PTR (+ 2 PTR)) (GO L1)))
    228         (SETQ PTR (COND ((GET 'QF-HASH-RELOAD-POINTER 'QF-HASH-RELOAD-POINTER))
    229                         (T PHT-ADDR)))  ;FLUSH SOMETHING RANDOM
    230    L2   (SETQ PHT1 (PHYS-MEM-READ PTR))
     206 (COND ((< ADR (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-WIRED-SIZE))))
     207        ADR)
     208       (T (OR QF-PHT-CACHE (QF-REFILL-PHT-CACHE))
     209          (LET ((PHT-SIZE (CADR QF-PHT-CACHE)))
     210            (DECLARE (FIXNUM PHT-SIZE))
     211            (DO ((HASH (QF-COMPUTE-PAGE-HASH ADR) (+ HASH 2))
     212                 (PHT1)
     213                 (PHT2)
     214                 (TEM)(STS)
     215                 (COUNT (LSH PHT-SIZE -1) (1- COUNT)))
     216                ((= COUNT 0) -1)                        ;INACCESSIBLE
     217              (DECLARE (FIXNUM HASH PHT1 PHT2 COUNT TEM STS))
     218              (AND (>= HASH PHT-SIZE) (SETQ HASH (- HASH PHT-SIZE)))
     219              (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH)))
     220              (COND ((= 0 (LOGAND 100 PHT1))            ;NO VALID BIT
     221                     (RETURN -1))                       ;INACCESSIBLE
     222                    ((= 0 (LOGAND 77777400 (LOGXOR ADR PHT1)))  ;ADDRESS MATCH
     223                     (SETQ STS (LOGAND 7 PHT1))         ;ISOLATE SWAP STATUS CODE
     224                     (COND ((OR (= STS 0)               ;UNUSED ENTRY
     225                                (= STS 3)               ;UNUSED CODES
     226                                (= STS 6)
     227                                (= STS 7))
     228                            (ERROR 'BAD-PAGE-HASH-ENTRY-AT-ADR HASH 'FAIL-ACT)))
     229                     (SETQ PHT2 (PHYS-MEM-READ (+ PHT-ADDR HASH 1)))    ;IN CORE, GET ADDRESS
     230                     (COND ((AND (= 5 (LOGLDB-FROM-FIXNUM
     231                                        %%PHT2-MAP-STATUS-CODE PHT2))   ;MAY BE IN PDL-BUFFER
     232                                 (NOT (< ADR (SETQ TEM (QF-POINTER
     233                                                         (CC-SYMBOLIC-EXAMINE-REGISTER
     234                                                           'A-PDL-BUFFER-VIRTUAL-ADDRESS)))))
     235                                 (<= ADR (+ TEM (CC-SYMBOLIC-EXAMINE-REGISTER 'PP))))
     236                            (RETURN -2)))               ;IN PDL-BUFFER
     237                                ;IF DOING A WRITE-CYCLE INTO A PAGE, SET PHT1-MODIFIED BIT
     238                                ;THIS HOPEFULLY ASSURES PAGE WILL GET WRITTEN ON DISK IF IT
     239                                ;GETS SWAPPED OUT, EVEN IF THE ACCESS IS NOT READ/WRITE.
     240                     (COND (WRITE-CYCLE
     241                            (PHYS-MEM-WRITE (+ PHT-ADDR HASH)
     242                                            (LOGDPB-INTO-FIXNUM 1 %%PHT1-MODIFIED-BIT PHT1))))
     243                     (RETURN (+ (LSH (LOGLDB-FROM-FIXNUM %%PHT2-PHYSICAL-PAGE-NUMBER PHT2) 8)
     244                                (LOGAND 377 ADR))))))))))
     245
     246(DEFUN QF-FINDCORE ()   ;CALL TO OBTAIN FREE PAGE OF CONS MEMORY. SWAP ONE OUT IF NECC, ETC.
     247                        ;DOESN'T WORK SAME WAY AS MICROCODE ANY MORE
     248  (DECLARE (FIXNUM PTR LIM PHT1 PHT2 TEM PHTSIZE N))
     249  (PROG (PTR LIM PHT1 PHT2 TEM PHTSIZE N)
     250        (SETQ PHTSIZE (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-SIZE))))
     251        (SETQ LIM (+ PHT-ADDR PHTSIZE -2))      ;POINTS AT HIGHEST ENTRY
     252        (SETQ N 100.)                           ;Number of probes before giving up
     253        ;; Poking around at the other machine's page table is very slow, especially
     254        ;; if you do it wrong.  So just pick a random page and swap it out
     255        ;; if it isn't wired.
     256   PROBE
     257        (SETQ PTR (+ PHT-ADDR (* (RANDOM (// PHTSIZE 2)) 2)))
     258        (SETQ PHT1 (PHYS-MEM-READ PTR))
    231259        (SETQ TEM (LOGLDB-FROM-FIXNUM %%PHT1-SWAP-STATUS-CODE PHT1))
    232260        (COND ((OR (= TEM %PHT-SWAP-STATUS-NORMAL)
     261                   (= TEM %PHT-SWAP-STATUS-FLUSHABLE)
    233262                   (= TEM %PHT-SWAP-STATUS-AGE-TRAP))
    234263               (GO CF)))
    235         (COND ((= PTR LIM)
    236                (COND (FLAG (ERROR 'QF-FINDCORE 'NOTHING-TO-SWAP-OUT 'FAIL-ACT))
    237                      (T (SETQ FLAG T)
    238                         (SETQ PTR PHT-ADDR))))
    239               (T (SETQ PTR (+ 2 PTR))))
    240         (GO L2)
    241    CF   (PUTPROP 'QF-HASH-RELOAD-POINTER PTR 'QF-HASH-RELOAD-POINTER)
    242         (SETQ PHT2 (PHYS-MEM-READ (1+ PTR)))
     264        (OR (ZEROP (SETQ N (1- N))) (GO PROBE))
     265        (ERROR 'QF-FINDCORE 'NOTHING-TO-SWAP-OUT 'FAIL-ACT)
     266
     267   CF   (SETQ PHT2 (PHYS-MEM-READ (1+ PTR)))
    243268        (AND QF-FINDCORE-TRACE-SWITCH
    244269             (PRINT (LIST 'QF-FINDCORE 'PTR PTR 'PHT1 PHT1 'PHT2 PHT2)))
     
    285310                  PHYS-PAGE
    286311                  1)
    287     (DO ((PHT-MASK (- SIZE-OF-PAGE-TABLE 2))
    288          (HASH (LOGXOR (LOGLDB 1612 ADR) (LOGAND 777774 (LOGLDB 0622 ADR))) (+ HASH 2))
    289          (PHT1)
    290          (COUNT (LSH SIZE-OF-PAGE-TABLE -1) (1- COUNT)))
    291         ((= COUNT 0)
    292          (ERROR 'QF-SWAP-IN 'PAGE-HASH-TABLE-FULL 'FAIL-ACT)) ;UGH FINDCORE SHOULD HAVE DELETED
    293       (DECLARE (FIXNUM PHT-MASK HASH PHT1 PHT2 COUNT))
    294       (SETQ HASH (LOGAND HASH PHT-MASK))
    295       (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH)))
    296       (COND ((= 0 (LOGAND 100 PHT1))                    ;FOUND HOLE TO PUT NEW PHTE IN
    297              (PHYS-MEM-WRITE (+ PHT-ADDR HASH)
    298                      (QF-MAKE-Q (+ 101 (LOGAND ADR 77777400)) DTP-FIX))
    299              (PHYS-MEM-WRITE (+ PHT-ADDR HASH 1)
    300                      (QF-MAKE-Q (LOGDPB-INTO-FIXNUM ACCESS-STATUS-AND-META-BITS
    301                                         %%PHT2-ACCESS-STATUS-AND-META-BITS
    302                                   (LOGDPB-INTO-FIXNUM PHYS-PAGE %%PHT2-PHYSICAL-PAGE-NUMBER
    303                                         0))
    304                                 DTP-FIX))
    305              (PHYS-MEM-WRITE (+ PHYS-PAGE (QF-INITIAL-AREA-ORIGIN 'PHYSICAL-PAGE-DATA))
    306                              (+ (CC-SHIFT REGION-NUMBER 16.) HASH))
    307              (OR QF-PAGE-HASH-TABLE-EXTRA-CHECKING-FLAG (RETURN T))
    308              (AND (= 0 (CC-CHECK-PAGE-HASH-TABLE-ACCESSIBILITY)) (RETURN T))
    309              (PRINT (LIST 'QF-SWAP-IN-SCREW ADR HASH COUNT))
    310              (BREAK 'QF-SWAP-IN-SCREW T)
    311              (RETURN T)))))
     312    (OR QF-PHT-CACHE (QF-REFILL-PHT-CACHE))
     313    (LET ((PHT-SIZE (CADR QF-PHT-CACHE)))
     314      (DECLARE (FIXNUM PHT-SIZE))
     315      (DO ((HASH (QF-COMPUTE-PAGE-HASH ADR) (+ HASH 2))
     316           (PHT1)
     317           (COUNT (LSH PHT-SIZE -1) (1- COUNT)))
     318          ((= COUNT 0)  ;UGH FINDCORE SHOULD HAVE DELETED
     319           (ERROR 'QF-SWAP-IN 'PAGE-HASH-TABLE-FULL 'FAIL-ACT))
     320        (DECLARE (FIXNUM HASH PHT1 PHT2 COUNT))
     321        (AND (>= HASH PHT-SIZE) (SETQ HASH (- HASH PHT-SIZE)))
     322        (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH)))
     323        (COND ((= 0 (LOGAND 100 PHT1))                  ;FOUND HOLE TO PUT NEW PHTE IN
     324               (PHYS-MEM-WRITE (+ PHT-ADDR HASH)
     325                               (QF-MAKE-Q (+ 101 (LOGAND ADR 77777400)) DTP-FIX))
     326               (PHYS-MEM-WRITE (+ PHT-ADDR HASH 1)
     327                 (QF-MAKE-Q (LOGDPB-INTO-FIXNUM ACCESS-STATUS-AND-META-BITS
     328                                                %%PHT2-ACCESS-STATUS-AND-META-BITS
     329                                                (LOGDPB-INTO-FIXNUM PHYS-PAGE
     330                                                  %%PHT2-PHYSICAL-PAGE-NUMBER
     331                                                  0))
     332                            DTP-FIX))
     333               (PHYS-MEM-WRITE (+ PHYS-PAGE (QF-INITIAL-AREA-ORIGIN 'PHYSICAL-PAGE-DATA))
     334                               HASH)
     335               (OR QF-PAGE-HASH-TABLE-EXTRA-CHECKING-FLAG (RETURN T))
     336               (AND (= 0 (CC-CHECK-PAGE-HASH-TABLE-ACCESSIBILITY)) (RETURN T))
     337               (PRINT (LIST 'QF-SWAP-IN-SCREW ADR HASH COUNT))
     338               (BREAK 'QF-SWAP-IN-SCREW T)
     339               (RETURN T))))))
    312340;  (SETQ QF-VIRTUAL-ADDR-KNOWN-ADDR -1)                 ;FORGET OUR COPY OF THE MAP
    313341)
     
    315343(DEFUN QF-GET-DISK-ADR (VIRTUAL-PAGE-NUMBER)
    316344  (OR QF-PAGE-PARTITION-CACHE
    317       (LET ((A-DISK-OFFSET (CC-SYMBOLIC-EXAMINE-REGISTER 'A-DISK-OFFSET)) ;UCODE SHOULD HAVE SET THIS UP
    318             (A-VERSION (QF-POINTER (CC-SYMBOLIC-EXAMINE-REGISTER 'A-VERSION)))
     345      (LET ((A-VERSION (QF-POINTER (CC-SYMBOLIC-EXAMINE-REGISTER 'A-VERSION)))
    319346            (SYMBOL-VERSION (CC-LOOKUP-NAME 'VERSION-NUMBER)))
    320         (COND ((NOT (= A-VERSION SYMBOL-VERSION))
    321                (FORMAT T "~&Microcode ~D is running but you have the symbols for ~D;
    322    proceeding will probably destroy the core image.  Proceed anyway? "
    323                        A-VERSION SYMBOL-VERSION)
    324                (OR (Y-OR-N-P) (BREAK COUGH-AND-DIE))))
    325         (AND (< A-VERSION 627.) (SETQ A-DISK-OFFSET (// A-DISK-OFFSET 400)))
    326         (SETQ QF-PAGE-PARTITION-CACHE A-DISK-OFFSET)))
     347        (AND ( A-VERSION SYMBOL-VERSION)
     348             (FQUERY NIL "~&Microcode ~D is running but you have the symbols for ~D;
     349Type Y to load correct symbols, N to proceed anyway. "
     350                     A-VERSION SYMBOL-VERSION)
     351             (CC-LOAD-UCODE-SYMBOLS-FOR-VERSION A-VERSION))
     352        (LET ((A-DISK-OFFSET (CC-SYMBOLIC-EXAMINE-REGISTER 'A-DISK-OFFSET)))
     353                         ;UCODE SHOULD HAVE SET THIS UP
     354          (SETQ QF-PAGE-PARTITION-CACHE A-DISK-OFFSET))))
    327355  (+ VIRTUAL-PAGE-NUMBER QF-PAGE-PARTITION-CACHE))
    328356
     
    373401(DEFUN QF-REGION-NUMBER-OF-POINTER (PNTR)
    374402  (SETQ PNTR (QF-POINTER PNTR))
    375   (PROG (BOTLIM TOPLIM LBOUND HRANGE LOC LEN REGION REGION-ORIGIN TEM)
    376     (DECLARE (FIXNUM BOTLIM TOPLIM LBOUND HRANGE LOC LEN REGION REGION-ORIGIN TEM))
    377     (SETQ BOTLIM (QF-INITIAL-AREA-ORIGIN 'REGION-SORTED-BY-ORIGIN)
    378           TOPLIM (+ BOTLIM SIZE-OF-AREA-ARRAYS)
    379           LBOUND BOTLIM
    380           HRANGE SIZE-OF-AREA-ARRAYS
    381           REGION-ORIGIN (QF-INITIAL-AREA-ORIGIN 'REGION-ORIGIN))
    382  T0 (AND (= HRANGE 1) (GO T2))                          ;MOVING DOWN AND RANGE = 1 => DONE
    383  T1 (SETQ HRANGE (// (1+ HRANGE) 2))                    ;HALVE THE RANGE
    384     (SETQ TEM (+ LBOUND HRANGE))                        ;ADDRESS TO PROBE
    385     (OR (< TEM TOPLIM) (GO T0))                         ;RUNNING OFF TOP MOVE DOWN
    386     (SETQ LOC (QF-POINTER (PHYS-MEM-READ (+ REGION-ORIGIN (QF-POINTER (PHYS-MEM-READ TEM)))))) ;ORIGIN OF POSSIBLE REGION
    387     (AND (< PNTR LOC) (GO T0))                          ;MOVE DOWN
    388     (SETQ LBOUND TEM)
    389     (GO T1)                                             ;MOVE UP
    390 
    391  T2 (SETQ REGION (QF-POINTER (PHYS-MEM-READ LBOUND)))   ;GET PROPER REGION NUMBER
    392     (SETQ LOC (QF-POINTER (PHYS-MEM-READ (+ REGION-ORIGIN REGION))))    ;GET ITS ORIGIN
    393     (AND (> LOC PNTR) (GO LOS))
    394     (SETQ LEN (QF-POINTER (PHYS-MEM-READ (+ (QF-INITIAL-AREA-ORIGIN 'REGION-LENGTH) REGION))))
    395     (AND (< PNTR (+ LOC LEN))
    396          (RETURN REGION))
    397     (OR (= LEN 0) (GO LOS))
    398     (SETQ LBOUND (1+ LBOUND))                           ;ZERO LENGTH REGION TRY NEXT
    399     (GO T1)
    400 
    401 LOS (ERROR PNTR '|NOT IN ANY REGION - QF-REGION-NUMBER-OF-POINTER| 'FAIL-ACT) ))
     403  (LET ((QUANTUM (// PNTR %ADDRESS-SPACE-QUANTUM-SIZE))
     404        (BYTES-PER-WORD (// 32. %ADDRESS-SPACE-MAP-BYTE-SIZE)))
     405    (DECLARE (FIXNUM QUANTUM BYTES-PER-WORD))
     406    (LET ((WORD (PHYS-MEM-READ (+ (QF-INITIAL-AREA-ORIGIN 'ADDRESS-SPACE-MAP)
     407                                  (// QUANTUM BYTES-PER-WORD)))))
     408      (DECLARE (FIXNUM WORD))
     409      (SETQ WORD (LOGAND (1- (LSH 1 %ADDRESS-SPACE-MAP-BYTE-SIZE))
     410                         (#M LSH #Q ASH WORD (- (* (\ QUANTUM BYTES-PER-WORD)
     411                                                   %ADDRESS-SPACE-MAP-BYTE-SIZE)))))
     412      (COND ((NOT (ZEROP WORD)) WORD)
     413            (T (DO ((L AREA-LIST (CDR L))
     414                    (I 0 (1+ I)))
     415                   ((OR (NULL L) (EQ (CAR L) 'WORKING-STORAGE-AREA))
     416                    (ERROR PNTR '|NOT IN ANY REGION - QF-REGION-NUMBER-OF-POINTER| 'FAIL-ACT))
     417                 (AND (< PNTR (QF-INITIAL-AREA-ORIGIN (CADR L)))
     418                      (RETURN I))))))))
    402419
    403420
     
    434451  (COND ((QF-OBARRAY-NEW-P PACK)
    435452         (QF-SYMBOL-SEARCH PNAME PACK MACLISP-SYMBOL))
    436         (T (QF-SYMBOL-OLD PNAME PACK))))
     453        (T (FORMAT T "~%using old style obarray! ~s" PACK)
     454           (QF-SYMBOL-OLD PNAME PACK))))
    437455
    438456(DEFUN QF-OBARRAY-NEW-P (PACK)
     
    513531                  (SETQ HASH (QF-ROT-24-BIT (LOGXOR HASH CHAR) 7)))))
    514532
     533(DEFUN QF-PRINT-OLD-OBARRAY NIL
     534  (LET ((OBARRAYP (PHYS-MEM-READ (+ 400 %SYS-COM-OBARRAY-PNTR))))
     535    (COND ((= (QF-DATA-TYPE OBARRAYP) DTP-SYMBOL)
     536           (SETQ OBARRAYP (QF-VALUE-CELL-CONTENTS OBARRAYP))))
     537    (LET ((OBSCURE  (LOGLDB-FROM-FIXNUM %%ARRAY-INDEX-LENGTH-IF-SHORT
     538                                        (QF-MEM-READ OBARRAYP))))
     539      (SETQ OBARRAYP (+ 1 OBARRAYP))     ;ASSUME 1 DIMENSIONAL, SHORT, ETC.
     540      (DOTIMES (B OBSCURE)
     541        (CC-Q-PRINT-TOPLEV (QF-MEM-READ (+ OBARRAYP B)))))))
     542
     543
     544(DEFUN QF-APROPOS (STRING)
     545  (PROG (ADR HEADER)
     546        (SETQ ADR (QF-INITIAL-AREA-ORIGIN 'NR-SYM))
     547    L   (SETQ HEADER (QF-MEM-READ ADR))
     548        (COND ((NOT (= (QF-DATA-TYPE HEADER) DTP-SYMBOL-HEADER))
     549               (RETURN NIL))
     550              ((STRING-SEARCH STRING (QF-FETCH-STRING HEADER))
     551               (FORMAT T "~%Virt adr ~S " ADR)
     552               (CC-Q-PRINT-TOPLEV (QF-MAKE-Q ADR DTP-SYMBOL))))
     553        (SETQ ADR (+ LENGTH-OF-ATOM-HEAD ADR))
     554        (GO L)))
     555
     556(DEFUN QF-FETCH-STRING (HEAD-ADR)
     557  (QF-ARRAY-SETUP (QF-MAKE-Q (QF-POINTER HEAD-ADR) DTP-ARRAY-POINTER))
     558  (LET* ((LEN (COND (QF-ARRAY-HAS-LEADER-P
     559                     (QF-POINTER (QF-MEM-READ (- QF-ARRAY-HEADER-ADDRESS 2))))
     560                    (T QF-ARRAY-LENGTH)))
     561         (STR (MAKE-ARRAY NIL ART-STRING LEN)))
     562    (DO ((I 0 (1+ I))
     563         (ADR QF-ARRAY-DATA-ORIGIN)
     564         (CH) (WD))
     565        ((= I LEN) STR)
     566      (COND ((ZEROP (LOGAND 3 I))               ;Get next word
     567             (SETQ WD (QF-MEM-READ ADR)
     568                   ADR (1+ ADR))))
     569      (SETQ CH (LOGAND 377 WD)
     570            WD (CC-SHIFT WD -8))
     571      (AS-1 CH STR I))))
     572     
     573
     574(DEFUN QF-SXHASH-STRING (STRING)
     575  (DO ((I 0 (1+ I))
     576       (N (ARRAY-ACTIVE-LENGTH STRING))
     577       (HASH 0))
     578      ((
     579 I N)
     580       (IF (MINUSP HASH)
     581           (LOGXOR HASH -37777777)              ;-37777777 = 40000001
     582           HASH))
     583    (SETQ HASH (ROT (LOGXOR (LOGAND (AREF STRING I) 337) HASH) 7))))
     584
    515585;SEARCH OLD-STYLE BUCKET-LIST OBARRAY
    516 (DEFUN QF-SYMBOL-OLD (TEM OBARRAYP)
     586(DEFUN QF-SYMBOL-OLD (LISPSYM OBARRAYP)
    517587    (DECLARE (FIXNUM OBARRAYP HASH))
    518     (LET ((HASH (QF-PKG-HASH-STRING TEM))
     588    (LET ((HASH (QF-SXHASH-STRING (STRING LISPSYM)))
    519589          (OBSCURE NIL))
    520        (SETQ OBSCURE (LOGLDB-FROM-FIXNUM %%ARRAY-INDEX-LENGTH-IF-SHORT (QF-MEM-READ OBARRAYP)))
     590       (SETQ OBSCURE (LOGLDB-FROM-FIXNUM %%ARRAY-INDEX-LENGTH-IF-SHORT
     591                                         (QF-MEM-READ OBARRAYP)))
    521592       (SETQ OBARRAYP (+ 1 (\ HASH OBSCURE) OBARRAYP))   ;ASSUME 1 DIMENSIONAL, SHORT, ETC.
    522593       (DO ((BUCKET (QF-MEM-READ OBARRAYP) (QF-CDR BUCKET)))
     
    524595            (RETURN -1))
    525596         (DECLARE (FIXNUM BUCKET))
    526          (AND (QF-SAMEPNAMEP TEM
     597         (AND (QF-SAMEPNAMEP LISPSYM
    527598                   (SETQ OBSCURE (QF-MEM-READ BUCKET))) ;CAR
    528               (RETURN (PUTPROP TEM
     599              (RETURN (PUTPROP LISPSYM
    529600                              (QF-TYPED-POINTER OBSCURE)
    530601                              'REAL-MACHINE-ATOM-HEADER-POINTER))) ) ))
  • trunk/lisp/lcadr/qwmcr.lisp

    r203 r274  
    1313(DECLARE (SPECIAL CONSLP-OUTPUT-SYMBOL-PREDICTED-FILEPOS
    1414                  CONSLP-OUTPUT-CURRENT-FILEPOS
    15                   CONSLP-OUTPUT VERSION-NUMBER CONS-DISP-PARITY-BIT))
     15                  CONSLP-OUTPUT VERSION-NUMBER CONS-DISP-PARITY-BIT
     16                  CONSLP-OUTPUT-PATHNAME))
    1617
    1718(DECLARE (SPECIAL ASSEMBLER-SAVED-STATE))
     
    2627
    2728(DEFUN WRITE-MCR (BASE-VERSION-NUMBER)
    28  (PKG-BIND "MICRO-ASSEMBLER"    ;Try to reduces :s in symtab, etc.
    29   (LET ((FILE (OPEN (FORMAT NIL "DSK: LISPM1; ~A ~DMCR" CONSLP-OUTPUT VERSION-NUMBER)
    30                     '(:OUT :FIXNUM)))
    31         (CONSLP-OUTPUT-CURRENT-FILEPOS 0))
    32     (COND (BASE-VERSION-NUMBER
    33             (OUT32 FILE 3)    ;a fake main memory block
    34             (OUT32 FILE 0)    ; blocks to xfer
    35             (OUT32 FILE 0)    ; normally relative disk block, 0 says base version follows
    36             (OUT32 FILE BASE-VERSION-NUMBER)))
    37     (WRITE-I-MEM (FSYMEVAL 'I-MEM) 1 FILE)
    38     (WRITE-D-MEM (FSYMEVAL 'D-MEM) 2 FILE)
    39     (WRITE-MICRO-CODE-SYMBOL-AREA-PART-1 FILE)
    40     (WRITE-A-MEM (FSYMEVAL 'A-MEM) 4 FILE)
    41     (WRITE-MICRO-CODE-SYMBOL-AREA-PART-2 FILE)
    42     (CLOSE FILE))
    43   (WRITE-SYMBOL-TABLE CONSLP-OUTPUT)))
     29  (PKG-BIND "MICRO-ASSEMBLER"                   ;Try to reduces :s in symtab, etc.
     30    (WITH-OPEN-FILE (FILE (FUNCALL CONSLP-OUTPUT-PATHNAME ':NEW-TYPE-AND-VERSION
     31                                   "MCR" VERSION-NUMBER)
     32                          '(:OUT :FIXNUM))                     
     33      (LET ((CONSLP-OUTPUT-CURRENT-FILEPOS 0))
     34        (COND (BASE-VERSION-NUMBER
     35               (OUT32 FILE 3)   ;a fake main memory block
     36               (OUT32 FILE 0)   ; blocks to xfer
     37               (OUT32 FILE 0)   ; normally relative disk block, 0 says base version follows
     38               (OUT32 FILE BASE-VERSION-NUMBER)))
     39        (WRITE-I-MEM (FSYMEVAL 'I-MEM) 1 FILE)
     40        (WRITE-D-MEM (FSYMEVAL 'D-MEM) 2 FILE)
     41        (WRITE-MICRO-CODE-SYMBOL-AREA-PART-1 FILE)
     42        (WRITE-A-MEM (FSYMEVAL 'A-MEM) 4 FILE)
     43        (WRITE-MICRO-CODE-SYMBOL-AREA-PART-2 FILE)))
     44    (WRITE-SYMBOL-TABLE)))
    4445
    4546(DEFUN WRITE-D-MEM (ARRAY CODE FILE)
     
    115116;This writes an ascii file containing the symbol table
    116117; Warning; this function also exists in LCADR;WMCR
    117 (DEFUN WRITE-SYMBOL-TABLE (FILENAME)
    118   (LET ((OUT-FILE (OPEN (FORMAT NIL "DSK: LISPM1; ~A ~DSYM" FILENAME VERSION-NUMBER)
    119                         '(OUT BLOCK ASCII))))
     118(DEFUN WRITE-SYMBOL-TABLE ()
     119  (WITH-OPEN-FILE (OUT-FILE (FUNCALL CONSLP-OUTPUT-PATHNAME ':NEW-TYPE-AND-VERSION
     120                                     "SYM" VERSION-NUMBER)
     121                            '(:OUT :BLOCK :ASCII))
    120122    (PRINT -4 OUT-FILE) ;ASSEMBLER STATE INFO
    121123    (PRINT (MAKE-ASSEMBLER-STATE-LIST) OUT-FILE)
     
    123125    (CONS-DUMP-SYMBOLS OUT-FILE)
    124126    (PRINT -1 OUT-FILE)         ;EOF
    125     (CLOSE OUT-FILE)))
     127    ))
    126128
    127129(DEFUN MAKE-CONSTANT-LIST (LST)   ;FLUSH USAGE COUNT, LAST LOCN REF'ED AT.
  • trunk/lisp/lcadr/ucadr.lisp

    r211 r274  
    1 ;;;CADR MACHINE MICROCODE               -*-FUNDAMENTAL-*- TO THE OPERATION OF THE SYSTEM
     1;;;CADR MACHINE MICROCODE               -*-MIDAS-*-
    22;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
    33
     
    4545
    4646(MC-LINKAGE ( (T M-T) (B M-B) (R M-R) (C M-C) (TEM M-TEM) A-ZERO A-V-NIL A-V-TRUE
     47              A-DISK-RUN-LIGHT
    4748              SKIP-IF-ATOM SKIP-IF-NO-ATOM
    4849              D-READ-EXIT-VECTOR D-WRITE-EXIT-VECTOR D-CALL-EXIT-VECTOR
     
    5859              QMEQL QMEQ QMLSP QMGRP
    5960              XTCADD XTCSUB XTCMUL XTCDIV XTCAND XTCIOR XTCXOR   ;LAST-ARG-IN-T-ENTRYs
    60               XTNUMB XTLENG
     61              XTNUMB XTLENG XTFIXP XTFLTP
    6162              MC-STORE-NEXT-LIST MC-STORE-LAST-LIST
    6263              MC-SPREAD
     
    6667              GAHDRA GAHDR GAHD1 DSP-ARRAY-SETUP
    6768              TRAP-UNLESS-FIXNUM D-NUMARG D-FIXNUM-NUMARG2 TRAP ILLOP
    68               CONS-GET-AREA SCONS SCONS-T LCONS LIST-OF-NILS
     69              SCONS SCONS-D SCONS-T LCONS LCONS-D LIST-OF-NILS
    6970              FIXGET FIXGET-1 FXGTPP FNORM
    7071              FIXPACK-T FIXPACK-P FXUNPK-P-1 FXUNPK-T-2 M-T-TO-CPDL
     
    7879              D-QMRCL A-IPMARK P3ZERO QMEX1
    7980              QBND2 QBND4
    80               CONVERT-PDL-BUFFER-ADDRESS GET-PDL-BUFFER-INDEX BITBLT-DECODE-ARRAY
     81              CONVERT-PDL-BUFFER-ADDRESS GET-PDL-BUFFER-INDEX BITBLT-DECODE-ARRAY XAR2
    8182))
    8283
     
    101102(DEF-DATA-FIELD Q-ALL-BUT-CDR-CODE 36 0)
    102103(DEF-DATA-FIELD Q-ALL-BUT-POINTER-WITHIN-PAGE 30 8)
     104
     105;Stuff for address space quantization
     106(DEF-DATA-FIELD VMA-QUANTUM-BYTE
     107        (EVAL (- 24. (1- (HAULONG %ADDRESS-SPACE-QUANTUM-SIZE))))
     108        (EVAL (1- (HAULONG %ADDRESS-SPACE-QUANTUM-SIZE))))
     109(DEF-DATA-FIELD ADDRESS-SPACE-MAP-WORD-INDEX-BYTE
     110        (EVAL (- 24. (+ (1- (HAULONG %ADDRESS-SPACE-QUANTUM-SIZE))
     111                        (1- (HAULONG (// 32. %ADDRESS-SPACE-MAP-BYTE-SIZE))))))
     112        (EVAL (+ (1- (HAULONG %ADDRESS-SPACE-QUANTUM-SIZE))
     113                 (1- (HAULONG (// 32. %ADDRESS-SPACE-MAP-BYTE-SIZE))))))
     114(DEF-DATA-FIELD ADDRESS-SPACE-MAP-BYTE-NUMBER-BYTE
     115        (EVAL (1- (HAULONG (// 32. %ADDRESS-SPACE-MAP-BYTE-SIZE))))
     116        (EVAL (1- (HAULONG %ADDRESS-SPACE-QUANTUM-SIZE))))
     117(DEF-DATA-FIELD ADDRESS-SPACE-MAP-BYTE-MROT
     118        (EVAL (- 5 (1- (HAULONG %ADDRESS-SPACE-MAP-BYTE-SIZE))))
     119        (EVAL (1- (HAULONG %ADDRESS-SPACE-MAP-BYTE-SIZE))))
    103120
    104121(DEF-DATA-FIELD SIGN-BIT 1 31.)
     
    149166(ASSIGN SVCAPL 3)               ;APPLY-LAMBDA
    150167(ASSIGN SVCEXPT 6)              ;CALL OUT FOR EXPT
    151 
    152 
    153 ;INSTRUCTIONS FOR CHECKING FOR PAGE FAULTS, INTERRUPTS, SEQUENCE BREAKS
    154 ;ONE OF THESE MUST APPEAR AFTER EVERY INSTRUCTION THAT STARTS A MEMORY CYCLE.
    155 
    156 ;THIS ONE IS USED WHEN REFERENCING FIXED AREAS THAT SHOULD BE ALWAYS WIRED AND MAPPED
    157 ;E.G. INSIDE THE PAGE FAULT ROUTINES WHERE A RECURSIVE PAGE FAULT COULD NOT BE ALLOWED
     168(ASSIGN SVCEQL 4)               ;Call out for EQUAL
     169(ASSIGN SVCNUM1 7)              ;Call out for numeric functions of one arg.
     170(ASSIGN SVCNUM2 10)             ;Call out for numeric functions of two args.
     171
     172;;; Meter information definition
     173(ASSIGN METER-OVERHEAD-LENGTH 7)        ;Standard overhead for a meter
     174(DEF-DATA-FIELD METER-LENGTH 16. 16.)   ;Event number in header
     175(DEF-DATA-FIELD METER-EVENT-NUM 16. 0)  ;Length in header
     176
     177
     178
     179;Instructions for checking for page faults, interrupts, sequence breaks.
     180;One of these must appear after every instruction that starts a memory cycle.
     181
     182;This one is used when referencing fixed areas that should be always wired and mapped.
     183;E.G. inside the page fault routines where a recursive page fault could not be allowed
    158184(ASSIGN ILLOP-IF-PAGE-FAULT (PLUS CALL-CONDITIONAL PG-FAULT ILLOP))
    159185
    160 ;THESE TWO ARE WHAT ARE NORMALLY USED.  THEY CHECK FOR PAGE FAULTS AND
    161 ;INTERRUPTS (HANDLED ENTIRELY IN MICROCODE), BUT NOT SEQUENCE BREAKS.
     186;These two are what are normally used.  They check for page faults and
     187;interrupts (handled entirely in microcode), but not sequence breaks.
    162188(ASSIGN CHECK-PAGE-READ (PLUS CALL-CONDITIONAL PG-FAULT-OR-INTERRUPT PGF-R-I))
    163189(ASSIGN CHECK-PAGE-WRITE (PLUS CALL-CONDITIONAL PG-FAULT-OR-INTERRUPT PGF-W-I))
    164190
    165 ;THIS ONE IS USED WHEN YOU WANT TO BE ABLE TO WRITE A NOMINALLY READ-ONLY AREA,
    166 ;FOR INSTANCE IN THE TRANSPORTER WHEN IT IS FIXING A POINTER TO OLDSPACE.
    167 ;NOT CHECKING FOR INTERRUPTS IS JUST TO SAVE CODE.
     191;This one is used when you want to be able to write a nominally read-only area,
     192;for instance in the transporter when it is fixing a pointer to oldspace.
     193;Not checking for interrupts is just to save code.
    168194(ASSIGN CHECK-PAGE-WRITE-FORCE (PLUS CALL-CONDITIONAL PG-FAULT PGF-W-FORCE))
    169195
    170 ;THESE TWO ARE USED WHEN AN INTERRUPT IS NOT ALLOWED, EITHER BECAUSE WE
    171 ;ARE INSIDE THE INTERRUPT HANDLER, BECAUSE WE ARE RETRYING A CYCLE IN
    172 ;PGF-R/PGF-W, OR BECAUSE WE DON'T WANT TO LET THE INTERRUPT HANDLER CHANGE THE MAP.
    173 ;NOTE WELL: THESE SHOULD BE USED ONLY FOR REFERENCES WHICH MAY NEED TO REFILL
    174 ; THE MAP, BUT CANNOT TAKE AN ACTUAL DISK PAGE FAULT.  IF A SWAPIN FROM DISK
    175 ; HAPPENS, INTERRUPTS WILL BE ALLOWED WHILE WAITING FOR THE PAGE TO COME IN,
    176 ; HOWEVER, AN INTERRUPT CANNOT HAPPEN AFTER THE DATA HAS BEEN COPIED FROM
    177 ; MEMORY INTO THE MD IF THIS IS USED INSTEAD OF CHECK-PAGE-READ.
     196;This one is used for writing an old binding of a special variable
     197;back into the value cell, when a binding is being unbound.
     198;When writing into a location forwarded to A memory,
     199;it means that an old EVCP is no longer current even if
     200;the old binding being restored is not an EVCP itself.
     201(ASSIGN CHECK-PAGE-WRITE-BIND (PLUS CALL-CONDITIONAL PG-FAULT PGF-W-BIND))
     202
     203;These two are used when an interrupt is not allowed, either because we
     204;are inside the interrupt handler, because we are retrying a cycle in
     205;PGF-R/PGF-W, or because we don't want to let the interrupt handler change the map.
     206;Note well: these should be used only for references which may need to refill
     207; the map, but cannot take an actual disk page fault.  If a swap-in from disk
     208; happens, interrupts will be allowed while waiting for the page to come in;
     209; however, an interrupt cannot happen after the data has been copied from
     210; memory into the MD if this is used instead of CHECK-PAGE-READ.
    178211(ASSIGN CHECK-PAGE-READ-NO-INTERRUPT (PLUS CALL-CONDITIONAL PG-FAULT PGF-R))
    179212(ASSIGN CHECK-PAGE-WRITE-NO-INTERRUPT (PLUS CALL-CONDITIONAL PG-FAULT PGF-W))
    180 
    181 ;THESE TWO ARE USED WHEN WE WANT TO ALLOW BOTH INTERRUPTS AND SEQUENCE BREAKS.
    182 ;NOTE THAT THE VMA HAD BETTER NOT POINT TO UNBOXED STORAGE WHEN THESE ARE USED.
     213;This one is used from inside the page-fault-handler to try again after some
     214;progress has been made.  Point is, it must not affect A-PGF-MODE.
     215(ASSIGN CHECK-PAGE-WRITE-RETRY (PLUS CALL-CONDITIONAL PG-FAULT PGF-W-1))
     216
     217;These two are used when we want to allow both interrupts and sequence breaks.
     218;Note that the VMA had better not point to unboxed storage when these are used.
    183219(ASSIGN CHECK-PAGE-READ-SEQUENCE-BREAK
    184220        (PLUS CALL-CONDITIONAL PG-FAULT-INTERRUPT-OR-SEQUENCE-BREAK PGF-R-SB))
     
    186222        (PLUS CALL-CONDITIONAL PG-FAULT-INTERRUPT-OR-SEQUENCE-BREAK PGF-W-SB))
    187223
    188 ;THESE NAMES ARE FOR USE WITH THE CALL-CONDITIONAL AND JUMP-CONDITIONAL
    189 ;INSTRUCTIONS WHEN SPECIAL CIRCUMSTANCES DICTATE SPECIAL HANDLING
     224;These names are for use with the CALL-CONDITIONAL and JUMP-CONDITIONAL
     225;instructions when special circumstances dictate special handling
    190226(ASSIGN PG-FAULT JUMP-ON-PAGE-FAULT-CONDITION)
    191227(ASSIGN NO-PG-FAULT (PLUS JUMP-ON-PAGE-FAULT-CONDITION INVERT-JUMP-SENSE))
     
    211247(DEF-DATA-FIELD OAL-JUMP 14. 12.)
    212248(DEF-DATA-FIELD OAL-DISP 11. 12.)
     249(DEF-DATA-FIELD OAL-ALUF 4 3)
    213250
    214251(ASSIGN PDL-BUFFER-LOW-WARNING 20.)  ;MAX LENGTH BASIC FRAME + ADI
     
    235272(ASSIGN TRANSPORT-NO-TRAP (PLUS (I-ARG 21) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19
    236273                                DISPATCH-PUSH-OWN-ADDRESS D-TRANSPORT))
    237 (ASSIGN TRANSPORT-CDR (PLUS (I-ARG 12) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19
     274(ASSIGN TRANSPORT-CDR (PLUS (I-ARG 32) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19
    238275                            DISPATCH-PUSH-OWN-ADDRESS D-TRANSPORT))
    239276(ASSIGN TRANSPORT-WRITE (PLUS (I-ARG 23) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19
     
    249286;save taking frequent useless traps on EVCP's.  Also they have to not barf at
    250287;trap data types, such as DTP-NULL.
     288;NO-EVCP also used by PDL buffer refill now that its legal to have EVCPs on PDL.
     289
    251290(ASSIGN TRANSPORT-NO-EVCP (PLUS (I-ARG 20) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19
    252291                        DISPATCH-PUSH-OWN-ADDRESS D-TRANSPORT-NO-EVCP))
     
    349388                                                ;  ERROR EXCEPT (CAR NIL) = NIL
    350389                                                ;  NIL
    351                                                 ;  P-STRING ARRAY POINTER
     390                                                ;  UNUSED, WAS ONCE <P-STRING ARRAY POINTER>
    352391  (DEF-NEXT-FIELD M-CAR-NUM-MODE 2 M-FLAGS)     ;CAR OF NUMBER GIVES:
    353392                                                ;  ERROR
     
    389428        ;Checked after popping bindings (and thus maybe affecting A-INHIBIT-SCHEDULING-FLAG).
    390429        ; If appropriate, the bit is stuffed back into the hardware (at SB-REINSTATE).
     430  (DEF-NEXT-BIT M-METER-STACK-GROUP-ENABLE M-FLAGS)     ;1 IF METERING ON FOR THIS STACK GROUP
     431  (DEF-NEXT-BIT M-TRAP-ON-CALLS M-FLAGS)                ;1 => TRAP ON ACTIVATING STACK FRAME.
    391432
    392433  ( (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)      ;SAME STUFF ALSO IN A-FLAGS
     
    403444          (BYTE-VALUE M-TRANSPORT-FLAG 0)
    404445          (BYTE-VALUE M-STACK-GROUP-SWITCH-FLAG 0)
    405           (BYTE-VALUE M-DEFERRED-SEQUENCE-BREAK-FLAG 0)))
     446          (BYTE-VALUE M-DEFERRED-SEQUENCE-BREAK-FLAG 0)
     447          (BYTE-VALUE M-METER-STACK-GROUP-ENABLE 0)))
    406448
    407449
     
    441483(LOC 34)  ;%SEQUENCE-BREAK-SOURCE-ENABLE LISP VARIABLE MAPPED HERE, SEE QCOM.
    442484M-SB-SOURCE-ENABLE   ;each bit controls a potential source of sequence-breaks:
    443   (DEF-NEXT-BIT M-SBS-CALL M-SB-SOURCE-ENABLE)  ;Just the CALL key (maximum conservatism)
    444   (DEF-NEXT-BIT M-SBS-KBD M-SB-SOURCE-ENABLE)   ;Any KBD char
     485  ; Note: the numeric values of these bits are known by SI:SB-ON!
     486  (DEF-NEXT-BIT M-SBS-CALL M-SB-SOURCE-ENABLE)  ;Just the CALL key (OBSOLETE).
     487  (DEF-NEXT-BIT M-SBS-UNIBUS M-SB-SOURCE-ENABLE)   ;Any Unibus channel.
    445488  (DEF-NEXT-BIT M-SBS-CHAOS M-SB-SOURCE-ENABLE) ;Any CHAOS packet received.  Its
    446489                                                ; unclear if you really want to set this.
     
    448491       
    449492   ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))
     493
     494(LOC 35)        ;%METER-ENABLES lisp variable is mapped here, see qcom
     495M-METER-ENABLES ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))      ; Enables for microcode metering
    450496
    451497
     
    496542          (BYTE-VALUE M-TRANSPORT-FLAG 0)
    497543          (BYTE-VALUE M-STACK-GROUP-SWITCH-FLAG 0)
    498           (BYTE-VALUE M-DEFERRED-SEQUENCE-BREAK-FLAG 0)))
     544          (BYTE-VALUE M-DEFERRED-SEQUENCE-BREAK-FLAG 0)
     545          (BYTE-VALUE M-METER-STACK-GROUP-ENABLE 0)))
    499546
    500547A-PDL-BUFFER-ACTIVE-QS (0)
     
    504551A-TEM (0)
    505552A-SB-SOURCE-ENABLE ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))
     553A-METER-ENABLES ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))
    506554
    507555
     
    580628A-INHIBIT-READ-ONLY                     ;If non-NIL, you can write in read-only
    581629        ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0)  ;NIL
    582 A-SCAVENGER-WS-ENABLE                   ;If non-NIL, scavenger gets limited working set
    583         ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 5)  ;T
     630A-SCAVENGER-WS-ENABLE                   ;Controls scavenger working set feature.
     631        ((BYTE-VALUE Q-DATA-TYPE DTP-FIX) 0)  ;New scheme: lowest physical address
     632   ;NOT in scavenger working set.  Note this is semi-compatible with the old T or NIL
     633   ;scheme: both of these will turn off WS feature since only pointer is significant.
    584634A-METHOD-SUBROUTINE-POINTER             ;CONTINUATION POINT FOR SELECT METHOD SUBROUTINE
    585635        ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0)  ;RETURN OR NIL
     
    591641                                ;THIS IS THE ONE WHOSE PARAMETERS HAVE BEEN COMPUTED
    592642                                ;INTO A-TV-SCREEN-BUFFER-ADDRESS, ETC.
    593 A-READ-COMPARE-ENABLES ((BYTE-VALUE Q-DATA-TYPE DTP-FIX) 0)
     643;was called A-DISK-READ-COMPARE-ENABLES.
     644A-DISK-SWITCHES ((BYTE-VALUE Q-DATA-TYPE DTP-FIX) 0)
    594645                                                ;Bit 0 - read-compare after reads
    595646                                                ;Bit 1 - read-compare after writes
     647                                                ;Bit 2 - enable multiple page swapouts
     648                                                ;Bit 3 - enable multiple page swapins
    596649                                ;This loads as zero so COLD-BOOT won't read-compare
    597650A-MC-CODE-EXIT-VECTOR  ((BYTE-VALUE Q-DATA-TYPE DTP-FIX) 0)     ;Exit vector used by
     
    604657                                ;Increments whenever any new oldspace is created.
    605658                                ; Thus if this has changed, objects may have moved.
     659A-METER-GLOBAL-ENABLE
     660        ((PLUS (BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0))  ;T if all stack groups metered
     661A-METER-BUFFER-POINTER
     662        ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))      ;Pointer to disk buffer (must contain 1 block)
     663A-METER-DISK-ADDRESS
     664        ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))      ;Next disk address to write buffer out to
     665A-METER-DISK-COUNT
     666        ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))      ;Number of disk blocks left to write out
     667A-CURRENTLY-PREPARED-SHEET ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0)
     668                                        ;Error checking for the TV:PREPARE-SHEET macro
     669;Variables for mouse tracking
     670A-MOUSE-CURSOR-STATE ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))
     671                                ;0 disabled, 1 open, 2 off, 3 on
     672A-MOUSE-X ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))    ;Relative to MOUSE-SCREEN
     673A-MOUSE-Y ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))    ;Relative to MOUSE-SCREEN
     674A-MOUSE-CURSOR-X-OFFSET ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))      ;From top-left of pattern
     675A-MOUSE-CURSOR-Y-OFFSET ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))      ;to the reference point
     676A-MOUSE-CURSOR-WIDTH ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))
     677A-MOUSE-CURSOR-HEIGHT ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))
     678A-MOUSE-X-SPEED ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))      ;100ths per second, time averaged
     679A-MOUSE-Y-SPEED ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))      ;with time constant of 1/6 second
     680A-MOUSE-BUTTONS-BUFFER-IN-INDEX ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))
     681A-MOUSE-BUTTONS-BUFFER-OUT-INDEX ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))
     682A-MOUSE-WAKEUP ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0) ;Set to T when move or click
     683
     684;Remember higher lexical contexts for nonlocal lexical variables.
     685;Value is a list of pointers to stack frames.
     686A-LEXICAL-ENVIRONMENT ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0)
     687
     688;Point to an array which holds slots for the EVCPs which
     689;were "stored" into a-memory locations, above,
     690;so that closures can bind such locations.
     691A-AMEM-EVCP-VECTOR ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0)
     692
     693;Area for consing things that are not explicitly requested
     694;and should not go in a temporary area.
     695;Initialized from A-CNSADF at startup time.
     696A-BACKGROUND-CONS-AREA (0)
     697
    606698;END OF VECTOR AREA
    607699
    608 ;FOLLOWING LOCATIONS ARE GC'ABLE BUT NOT USER'REFERENCEABLE
     700;FOLLOWING LOCATIONS ARE GC-ABLE BUT NOT USER-REFERENCEABLE
    609701
    610702A-V-NIL         ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0) ;POINTER TO NIL
     
    612704
    613705A-END-Q-POINTERS ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL)) ;WASTE A LOCATION TO FIX FENCEPOST ERROR
     706
    614707;END "Q" STORAGE
    615708
     
    660753                                ;       status read back
    661754                                ;       ma read back
     755A-DISK-WAIT-TIME        (0)     ;Amount of time spent in page faults
     756A-DISK-PAGE-WRITE-APPENDS (0)   ;Pages appended to swapout operations.
     757A-DISK-PAGE-READ-APPENDS  (0)   ;Pages appended to swapin operations.
    662758
    663759;END OF COUNTER AREA.
     
    683779A-INTR-B        (0)     ;SAVE M-B
    684780A-INTR-T        (0)     ;SAVE M-T
     781A-INTR-LOCAL-UNIBUS-MODE  (0)   ;1 normal, 0 PDP11 arbitrates unibus.
    685782A-PGF-VMA (0)   ;PAGE FAULT HANDLER SAVES VMA HERE
    686783A-PGF-WMD (0)   ;PAGE FAULT HANDLER SAVES WRITE-MEMORY-DATA HERE
     
    688785A-PGF-A   (0)   ;PAGE FAULT HANDLER SAVES M-A HERE
    689786A-PGF-B   (0)   ;PAGE FAULT HANDLER SAVES M-B HERE
     787A-PGF-MODE (0)  ;PAGE FAULT HANDLER KEEPS A FLAG HERE.
    690788A-PDLB-TEM      (0)     ;TEMPORARY USED BY PDL-BUFFER LOADING/DUMPING ROUTINES
    691789A-FARY-TEM      (0)     ;TEMPORARY USED BY XFARY
     
    711809;Scavenger
    712810
    713 (ASSIGN SCAV-WS-SIZE 12.)       ;number of pages in scavenger working-set
    714 A-SCAV-PAGE-TABLE (REPEAT SCAV-WS-SIZE (-1)) ;-1 or virtual address of page brought in by scav
    715 A-SCAV-PAGE-TABLE-PTR ((A-MEM-LOC A-SCAV-PAGE-TABLE)) ;Re-use pointer for above
    716811A-SCAV-PTR (0)          ;Address of next Q to scavenge (with type bits from gc-pointer)
    717812A-SCAV-COUNT (0)        ;Number of Q's remaining to be scavenged in that block
     
    756851
    757852;PAGING VARIABLES AND CONSTANTS
    758 A-PHT-INDEX-MASK ((EVAL (- SIZE-OF-PAGE-TABLE 2))) ;Mask for page hash table indices
    759                                 ;Next two scan pointers must be inited on warm boot to
    760                                 ; greater than the number of wired pages in low core
    761                                 ; We init them to the equivalent of 48K
    762 A-FINDCORE-SCAN-POINTER (300)   ;Page frame number of next page to be looked at by FINDCORE
    763 A-AGING-SCAN-POINTER (300)      ;Page frame number of next page to be looked at by AGER
    764 A-PAGE-REGION-NUMBER (0)        ;Region number of page being swapped in (in left half!)
     853A-PHT-INDEX-MASK (0)            ;Mask for page hash table indices
     854A-PHT-INDEX-LIMIT (0)           ;All valid PHT indices are less than this
     855A-FINDCORE-SCAN-POINTER (0)     ;Page frame number of next page to be looked at by FINDCORE
     856A-AGING-SCAN-POINTER (0)        ;Page frame number of next page to be looked at by AGER
    765857A-V-PHYSICAL-PAGE-DATA-END      ;First location after last valid physical-page-data entry
    766858                        (1_31.) ;This has to be initialized to the most negative number!
     859A-PAGE-IN-PHT1 (0)              ;Argument to PAGE-IN-MAKE-KNOWN
    767860
    768861A-DISK-REGS-BASE (77377774)     ;XBUS ADDRESS 17377774
     
    788881A-DISK-ECC      (0)             ;Error correction data read back
    789882A-DISK-RETRY-STATE (0)          ;Count of retries
     883A-DISK-DOING-READ-COMPARE (0)
    790884A-DISK-IDLE-TIME (0)            ;Time since last disk op (other than background)
     885A-DISK-RESERVED-FOR-USER (0)    ;%DISK-OP in progress (inhibits background disk ops)
     886
     887(ASSIGN DISK-SWAP-OUT-CCW-BASE 700) ;build CCW lists for swap out starting here
     888(ASSIGN DISK-SWAP-OUT-CCW-MAX  720) ; and not above here.
     889(ASSIGN DISK-SWAP-IN-CCW-BASE 740)  ;build CCW lists for swap in starting here
     890(ASSIGN DISK-SWAP-IN-CCW-MAX  760)  ; and not above here.
    791891
    792892;Locations for DISK-SWAP-HANDLER
    793 A-DISK-SAVE-PGF-VMA (0)
    794 A-DISK-SAVE-PGF-WMD (0)
    795 A-DISK-SAVE-PGF-T (0)
     893A-DISK-SWAPIN-SIZE (0)
     894
     895A-DISK-SWAPIN-VIRTUAL-ADDRESS (0)
     896A-DISK-SWAPIN-PAGE-FRAME (0)            ;physical page frame
     897A-DISK-SWAPIN-PHT2-BITS (0)
     898
     899A-DISK-SWAP-OUT-CCW-POINTER (0)
     900A-DISK-SWAP-IN-CCW-POINTER (0)
     901
     902A-DISK-SAVE-PGF-VMA (0)         ;some of these are also used when building CCWs just
     903A-DISK-SAVE-PGF-WMD (0)         ; before calling DISK-SWAP-HANDLER
     904A-DISK-SAVE-PGF-T (0)           ; also near SWAPIN.
    796905A-DISK-SAVE-PGF-A (0)
    797906A-DISK-SAVE-PGF-B (0)
    798907A-DISK-SAVE-1 (0)
    799908A-DISK-SAVE-2 (0)
    800 A-DISK-SAVE-C (0)
     909A-DISK-SAVE-MODE (0)            ;save A-PGF-MODE
    801910
    802911A-DISK-CYL-BEG (0)      ;Typeless virtual address that lies at start of a cylinder
     
    835944                                        ;FOLLOWING ARE OTHER RANDOM UCODE ENTRIES.
    836945A-V-PAGE-TABLE-AREA     (0)
    837 A-V-PHYSICAL-PAGE-DATA (0)              ;FOR EACH PAGE FRAME, -1 IF IT IS OUT OF SERVICE, OR
    838                                         ; REGION NUMBER,,PHT INDEX FOR PAGE IN IT
     946A-V-PHYSICAL-PAGE-DATA  (0)             ;FOR EACH PAGE FRAME, -1 IF IT IS OUT OF SERVICE, OR
     947                                        ; GC DATA,,PHT INDEX FOR PAGE IN IT
     948                                        ; -1 IN PHT INDEX IF WIRED PAGE WITH NO PHT ENTRY
     949                                        ; GC DATA=0 IF NOT IN USE
    839950A-V-REGION-ORIGIN       (0)             ;VIRTUAL ADDRESS START OF REGION
    840951A-V-REGION-LENGTH       (0)             ;NUMBER OF QS IN REGION
    841952A-V-REGION-BITS         (0)             ;VARIOUS FIELDS, SEE QCOM
    842 A-V-REGION-SORTED-BY-ORIGIN (0)         ;REGION NUMBERS SORTED BY VIRTUAL ADDRESS
    843                                         ; LAST ENTRY REPLICATED THROUGH TO END OF AREA
    844                                         ; MUST HAVE DATA-TYPE DTP-FIX AND NO CDR-CODE
    845                                         ; DOES NOT INCLUDE FREE REGIONS AND FREE REGION#S
     953A-V-ADDRESS-SPACE-MAP   (0)             ;A BYTE FOR EACH ADDRESS SPACE QUANTUM, GIVING REGION#
     954                                        ; OR 0 IF FREE OR FIXED-AREA.  BYTE SIZE IS
     955                                        ; %ADDRESS-SPACE-MAP-BYTE-SIZE
    846956A-V-REGION-FREE-POINTER (0)             ;RELATIVE ALLOCATION POINT.  ALLOCATION IS UPWARDS
    847957A-V-REGION-GC-POINTER   (0)             ;VARIOUS USES, MAINLY RELATIVE DIRTY/CLEAN BOUNDARY
    848958A-V-REGION-LIST-THREAD  (0)             ;NEXT REGION# IN AREA, OR 1_23. + AREA# AT END OF LIST
    849                                         ; THREADS FREE REGIONS (IN FREE-AREA) AND FREE REGION#S
     959                                        ; THREADS FREE REGION TABLE SLOTS
    850960A-V-AREA-NAME           (0)             ;SYMBOL WHICH NAMES AREA (NIL FOR FREE AREA#S)
    851961A-V-AREA-REGION-LIST    (0)             ;FIRST REGION# IN AREA (FREE LIST FOR FREE AREA#S)
    852962A-V-AREA-REGION-SIZE    (0)             ;RECOMMENDED SIZE FOR NEW REGIONS
    853963A-V-AREA-MAXIMUM-SIZE   (0)             ;APPROXIMATE MAXIMUM #WDS IN THIS AREA
    854 A-V-FREE-AREA           (0)             ;OWNS REGIONS OF VIRTUAL ADDRESS SPACE WHICH ARE FREE
     964A-V-AREA-SWAP-RECOMMENDATIONS (0)       ;FIXNUM. SEE %%AREA-SWAP- SYMS.
     965A-V-GC-TABLE-AREA       (0)             ;GARBAGE COLLECTOR TABLES
    855966A-V-SUPPORT-ENTRY-VECTOR        (0)
    856967A-V-CONSTANTS-AREA      (0)             ;CONSTANTS PAGE (REF'ED IN ADR OF MACRO-CODE)
     
    861972A-V-MICRO-CODE-ENTRY-ARGS-INFO-AREA (0) ;MICRO-CODE-ENTRY-ARGS-INFO-AREA
    862973A-V-MICRO-CODE-ENTRY-MAX-PDL-USAGE (0)  ;MAXIMUM DEPTH ON PDL BEFORE MICRO TO MACRO CALL
    863 A-V-MICRO-CODE-EXIT-AREA        (0)     ;MICRO-CODE-EXIT-AREA  --obsolete flush this.
     974;Following areas are not used by microcode except for XRGN
     975;since they are not aligned on quantum boundaries
     976A-V-MICRO-CODE-ENTRY-ARGLIST-AREA (0)   ;VALUE FOR ARGLIST FUNCTION TO RETURN
     977A-V-MICRO-CODE-SYMBOL-NAME-AREA (0)     ;NAMES OF MICRO-CODE-SYMBOL-AREA ENTRIES
     978A-V-LINEAR-PDL-AREA (0)                 ;MAIN PDL
     979A-V-LINEAR-BIND-PDL-AREA (0)            ;CORRESPONDING BIND PDL
     980A-V-INIT-LIST-AREA (0)                  ;LIST CONSTANTS CREATED BY COLD LOAD
     981;Microcode -knows- that INIT-LIST-AREA is the last fixed area
     982
     983;This location -must- immediately follow the above table of fixed areas
     984A-V-FIRST-UNFIXED-AREA (0)              ;First address above fixed areas
    864985
    865986A-V-MISC-BASE   (0)     ;BASE OF DISPATCH TABLE FOR MISC-INST .
     
    8881009
    8891010;TEMPORARIES IN *CATCH, *THROW, ETC
     1011A-LAST-STACK-GROUP              ;LAST STACK GROUP LEFT
    8901012A-CATCH-MARK    (0)     ;MARK, IE, WHAT MUST BE IN FEF POINTER OF DESIRED FRAME
    8911013
     
    9071029A-PAGE-TRACE-VMA (0)    ;TEMP: ADDRESS REFERENCED
    9081030A-PAGE-TRACE-UPC (0)    ;TEMP: MICRO-PC AND SWAP-OUT FLAG
     1031
     1032;;; Metering variables
     1033A-METER-LENGTH  (0)                     ;Length of additional meter info
     1034A-METER-EVENT   (0)                     ;Number of the metered even
     1035A-METER-LOCK    (0)                     ;Lock during swap out of meter buffer
     1036A-METER-START-TIME (0)                  ;Microsecond clock reading saved here
    9091037
    9101038;CONNECTED WITH PDL-BUFFER MANAGEMENT
     
    9951123;A-REVERSE-FIRST-LEVEL-MAP-INIT-VALUE
    9961124;       (-1)    ;THIS ONE IS NEVER CHANGED (ENTRY #37)
     1125
     1126;Variables for mouse tracking
     1127A-MOUSE-X-FRACTION (0)  ;10 bits of fractional position
     1128A-MOUSE-Y-FRACTION (0)
     1129A-MOUSE-CURSOR-X (0)    ;Current location of cursor
     1130A-MOUSE-CURSOR-Y (0)    ; (only valid if state=3)
     1131A-MOUSE-LAST-H1 (0)     ;Last value input from hardware
     1132A-MOUSE-LAST-H2 (0)
     1133A-MOUSE-HARDWARE-ADDRESS (77772042)     ;764104 is Y, 764106 is X
     1134A-MOUSE-SCREEN-BUFFER-ADDRESS (0)       ;Data for screen (or sheet) mouse is on
     1135A-MOUSE-SCREEN-BUFFER-END-ADDRESS (0)
     1136A-MOUSE-SCREEN-LOCATIONS-PER-LINE (0)
     1137A-MOUSE-SCREEN-BUFFER-BIT-OFFSET (0)
     1138A-MOUSE-SCREEN-WIDTH (0)
     1139A-MOUSE-SCREEN-BUFFER-PIXEL-SIZE-MROT (0)
     1140A-MOUSE-SCREEN (0)
     1141A-MOUSE-SAVE-1 (0)
     1142A-MOUSE-SAVE-2 (0)
     1143A-MOUSE-SAVE-E (0)
     1144
     1145;Arrays at fixed locations in A memory, used for the mouse
     1146(ASSIGN MOUSE-CURSOR-PATTERN-AMEM-LOC 1600)     ;32x32 BIT ARRAY
     1147(ASSIGN MOUSE-BUTTONS-BUFFER-AMEM-LOC 1640)     ;8 4-WORD ART-Q ENTRIES
     1148(ASSIGN MOUSE-X-SCALE-ARRAY-AMEM-LOC 1700)      ;8 2-WORD ART-Q ENTRIES
     1149(ASSIGN MOUSE-Y-SCALE-ARRAY-AMEM-LOC 1720)      ;8 2-WORD ART-Q ENTRIES
    9971150
    9981151
     
    11471300;DISPATCH ON DATA TYPE.  DROPS THROUGH IN EITHER CASE BUT SKIPS IF ATOM.
    11481301;AN ATOM IS ANYTHING OTHER THAN A LIST.
    1149 SKIP-IF-ATOM   
     1302SKIP-IF-ATOM
    11501303        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;TRAP
    11511304        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;NULL
     
    11741327        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;INSTANCE-HEADER
    11751328        (P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)      ;ENTITY
     1329        (P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)      ;STACK-CLOSURE
    11761330 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
    11771331(END-DISPATCH)
     
    12101364        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;INSTANCE-HEADER
    12111365        (P-BIT R-BIT 0)                         ;ENTITY
     1366        (P-BIT R-BIT 0)                         ;STACK-CLOSURE
    12121367 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
    12131368(END-DISPATCH)
     
    12421397        (P-BIT R-BIT 0)                 ;INSTANCE-HEADER [NOT A LIST FOR PURPOSES OF THIS]
    12431398        (P-BIT R-BIT 0)                 ;ENTITY [NOT A LIST FOR PURPOSES OF THIS]
     1399        (P-BIT R-BIT 0)                 ;STACK-CLOSURE [NOT A LIST FOR PURPOSES OF THIS]
    12441400 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
    12451401(END-DISPATCH)
     
    12841440        (P-BIT ILLOP)                   ;INSTANCE-HEADER
    12851441        (CALL-ENTITY)                   ;ENTITY
     1442        (QCLS)                          ;STACK-CLOSURE
    12861443 (REPEAT NQZUSD (P-BIT ILLOP))
    12871444(END-DISPATCH)
     
    13181475        (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)       ;INSTANCE-HEADER
    13191476        (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)       ;ENTITY (eventually send message)
     1477        (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)       ;STACK-CLOSURE (eventually send message)
    13201478 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT TRAP))
    13211479(END-DISPATCH)
     
    13511509        (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)       ;INSTANCE-HEADER
    13521510        (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)       ;ENTITY (eventually send message)
     1511        (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)       ;STACK-CLOSURE
    13531512 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT TRAP))
    13541513(END-DISPATCH)
     
    13701529        (P-BIT TRAP)    ;ERROR
    13711530        (P-BIT R-BIT)   ;ERROR EXCEPT (CAR NIL) = NIL
    1372         (R-BIT)         ;NIL -> NIL
     1531        (XFALSE)        ;NIL
    13731532        (P-BIT TRAP)    ;UNUSED
    13741533(END-DISPATCH)
     
    14681627        (P-BIT TRAP)    ;INSTANCE-HEADER
    14691628        (P-BIT TRAP)    ;ENTITY
     1629        (P-BIT TRAP)    ;STACK-CLOSURE
    14701630 (REPEAT NQZUSD (P-BIT TRAP))
    14711631(END-DISPATCH)
     
    14991659        (P-BIT TRAP)    ;INSTANCE-HEADER
    15001660        (P-BIT TRAP)    ;ENTITY
     1661        (P-BIT TRAP)    ;STACK-CLOSURE
    15011662 (REPEAT NQZUSD (P-BIT TRAP))
    15021663(END-DISPATCH)
     
    15321693        (INHIBIT-XCT-NEXT-BIT TRAP)     ;INSTANCE-HEADER
    15331694        (INHIBIT-XCT-NEXT-BIT TRAP)     ;ENTITY
     1695        (INHIBIT-XCT-NEXT-BIT TRAP)     ;STACK-CLOSURE
    15341696 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRAP))
    15351697(END-DISPATCH)
     
    15511713        (QQARY)         ;STACK-GROUP HEAD
    15521714        (QQARY)         ;SPEC-PDL
    1553         (INHIBIT-XCT-NEXT-BIT TRAP)     ;TV BUFFER (OBSOLETE)
     1715        (QB16SRY)       ;HALF-FIX
    15541716        (QQARY)         ;REG-PDL
    15551717        (QFARY)         ;FLOAT
     1718        (QFFARY)        ;FPS-FLOAT
     1719        (QB16RY)        ;FAT-STRING
    15561720 (REPEAT NATUSD (INHIBIT-XCT-NEXT-BIT TRAP))
    15571721(END-DISPATCH)
     
    15721736        (QSQARY)        ;STACK-GROUP HEAD
    15731737        (QSQARY)        ;SPEC-PDL
    1574         (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)       ;TV BUFFER (OBSOLETE)
     1738        (QS16RY)        ;HALF-FIX
    15751739        (QSQARY)        ;REG-PDL
    15761740        (QSFARY)        ;FLOAT
     1741        (QSFFARY)       ;FPS-FLOAT
     1742        (QS16RY)        ;FAT-STRING
    15771743 (REPEAT NATUSD (P-BIT INHIBIT-XCT-NEXT-BIT TRAP))
    15781744(END-DISPATCH)
     
    15931759        (QSQARY)        ;STACK-GROUP HEAD
    15941760        (QSQARY)        ;SPEC-PDL
    1595         (TRAP)          ;TV-BUFFER (OBSOLETE)
     1761        (QS16RY)        ;HALF-FIX
    15961762        (QSQARY)        ;REG-PDL
    15971763        (QSFARY)        ;FLOAT
     1764        (QSFFARY)       ;FPS-FLOAT
     1765        (QS16RY)        ;FAT-STRING
    15981766 (REPEAT NATUSD (TRAP))
    15991767(END-DISPATCH)
     
    16131781        (P-BIT R-BIT)                           ;STACK-GROUP HEAD
    16141782        (P-BIT R-BIT)                           ;SPEC-PDL
    1615         (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)       ;TV BUFFER (OBSOLETE)
     1783        (P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)      ;HALF-FIX
    16161784        (P-BIT R-BIT)                           ;REG-PDL
    16171785        (P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)      ;FLOAT
     1786        (P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)      ;FPS-FLOAT     
     1787        (P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)      ;FAT-STRING
    16181788 (REPEAT NATUSD (P-BIT INHIBIT-XCT-NEXT-BIT TRAP))
    16191789(END-DISPATCH)
     
    18101980        (INHIBIT-XCT-NEXT-BIT TRAP)     ;INSTANCE-HEADER
    18111981        (INHIBIT-XCT-NEXT-BIT TRAP)     ;ENTITY
     1982        (INHIBIT-XCT-NEXT-BIT TRAP)     ;STACK-CLOSURE
    18121983 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRAP))
    18131984(END-DISPATCH)
     
    18422013        (R-BIT)                                 ;INSTANCE-HEADER, POPJ
    18432014        (R-BIT)                                 ;ENTITY, POPJ
     2015        (R-BIT)                                 ;STACK-CLOSURE, POPJ
    18442016 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
    18452017(END-DISPATCH)
     
    18772049        (P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)      ;INSTANCE-HEADER
    18782050        (XAGICL INHIBIT-XCT-NEXT-BIT)           ;ENTITY
     2051        (XAGICL INHIBIT-XCT-NEXT-BIT)           ;STACK-CLOSURE
    18792052 (REPEAT NQZUSD (P-BIT ILLOP INHIBIT-XCT-NEXT-BIT))
    18802053(END-DISPATCH)
     
    19372110        (INHIBIT-XCT-NEXT-BIT TRANS-OLD)        ;0 ENTITY
    19382111        (R-BIT)                                 ;1 ENTITY
     2112        (INHIBIT-XCT-NEXT-BIT TRANS-OLD)        ;0 STACK-CLOSURE
     2113        (R-BIT)                                 ;1 STACK-CLOSURE
    19392114 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRANS-TRAP))
    1940  (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRANS-TRAP))
     2115
     2116(REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRANS-TRAP))
    19412117(END-DISPATCH)
    19422118
     
    19982174        (INHIBIT-XCT-NEXT-BIT TRANS-OLD)        ;0 ENTITY
    19992175        (R-BIT)                                 ;1 ENTITY
     2176        (INHIBIT-XCT-NEXT-BIT TRANS-OLD)        ;0 STACK-CLOSURE
     2177        (R-BIT)                                 ;1 STACK-CLOSURE
    20002178 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRANS-TRAP))
    20012179 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRANS-TRAP))
     
    20282206        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;1 GC-FORWARD (SHOULDN'T SEE IN THIS CONTEXT)
    20292207        (INHIBIT-XCT-NEXT-BIT PB-TRANS)         ;0 EXTERNAL-VALUE-CELL-POINTER
    2030         (INHIBIT-XCT-NEXT-BIT PB-TRANS)         ;1 EXTERNAL-VALUE-CELL-POINTER
     2208        (P-BIT R-BIT)                           ;1 EXTERNAL-VALUE-CELL-POINTER
    20312209        (INHIBIT-XCT-NEXT-BIT PB-TRANS)         ;0 ONE-Q-FORWARD
    20322210        (INHIBIT-XCT-NEXT-BIT PB-TRANS)         ;1 ONE-Q-FORWARD
     
    20612239        (INHIBIT-XCT-NEXT-BIT PB-TRANS)         ;0 ENTITY
    20622240        (P-BIT R-BIT)                           ;1 ENTITY
     2241        (INHIBIT-XCT-NEXT-BIT PB-TRANS)         ;0 STACK-CLOSURE
     2242        (P-BIT R-BIT)                           ;1 STACK-CLOSURE
    20632243 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT PB-TRANS))
    20642244 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT PB-TRANS))
    20652245(END-DISPATCH)
     2246
    20662247
    20672248(START-DISPATCH 6 P-BIT)        ;GC-WRITE-TEST (MAP18: 0=EXTRA-PDL, 1=NORMAL)
     
    21222303        (R-BIT)                                 ;0 ENTITY
    21232304        (R-BIT)                                 ;1 ENTITY
     2305        (INHIBIT-XCT-NEXT-BIT STACK-CLOSURE-TRAP)       ;0 STACK-CLOSURE
     2306        (INHIBIT-XCT-NEXT-BIT STACK-CLOSURE-TRAP)       ;0 STACK-CLOSURE
    21242307 (REPEAT NQZUSD (R-BIT))
    21252308 (REPEAT NQZUSD (R-BIT))
     
    21412324        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;HEADER
    21422325        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;GC-FORWARD
    2143         (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;EXTERNAL-VALUE-CELL-POINTER
     2326        (P-BIT R-BIT 0)                         ;EXTERNAL-VALUE-CELL-POINTER this ok now.
    21442327        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;ONE-Q-FORWARD
    21452328        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;HEADER-FORWARD
     
    21582341        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;INSTANCE-HEADER
    21592342        (P-BIT R-BIT 0)                         ;ENTITY
     2343        (P-BIT R-BIT 0)                         ;STACK-CLOSURE
    21602344 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
    21612345(END-DISPATCH)
     
    23102494                (BYTE-VALUE M-TRANSPORT-FLAG 0)
    23112495                (BYTE-VALUE M-STACK-GROUP-SWITCH-FLAG 0)
    2312                 (BYTE-VALUE M-DEFERRED-SEQUENCE-BREAK-FLAG 0))))
     2496                (BYTE-VALUE M-DEFERRED-SEQUENCE-BREAK-FLAG 0)
     2497                (BYTE-VALUE M-METER-STACK-GROUP-ENABLE 0))))
    23132498        ((M-SB-SOURCE-ENABLE) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
    2314         ((A-TV-CURRENT-SHEET) A-V-NIL)          ;..
     2499        ((A-TV-CURRENT-SHEET) A-V-NIL)          ;Forget this cache
     2500        ((A-LEXICAL-ENVIRONMENT) A-V-NIL)       ;At top level wrt lexical bindings.
     2501        ((A-AMEM-EVCP-VECTOR) A-V-NIL)          ;Don't write all over memory
     2502        ((A-MOUSE-CURSOR-STATE) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))  ;Mouse off
    23152503        ((A-SCAV-COUNT) SETZ)                   ;Forget scavenger state
    2316         ((A-READ-COMPARE-ENABLES) DPB (M-CONSTANT -1)   ;Read-compare writes, not reads
    2317                 (BYTE-FIELD 1 1) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
     2504;This seems like an unnecessary waste of time:
     2505;       ((A-DISK-SWITCHES) DPB (M-CONSTANT -1)  ;Read-compare writes, not reads
     2506;               (BYTE-FIELD 1 1) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
    23182507        ((A-INHIBIT-SCHEDULING-FLAG) A-V-TRUE)  ;DISABLE SEQUENCE BREAKS
    23192508        ((A-INHIBIT-SCAVENGING-FLAG) A-V-TRUE)  ;GARBAGE COLLECTOR NOT TURNED ON UNTIL LATER
     2509        ((A-LCONS-CACHE-AREA) SETZ)             ;Forget these caches (disk-restore...)
     2510        ((A-SCONS-CACHE-AREA) SETZ)
    23202511        ((A-PAGE-TRACE-PTR) SETZ)               ;SHUT OFF PAGE-TRACE
     2512        ((A-METER-GLOBAL-ENABLE) A-V-NIL)       ;Turn off metering
     2513        ((A-METER-DISK-COUNT) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
    23212514        (CALL RESET-MACHINE)                    ;Reset and turn on interrupts, set up map
    23222515        ((VMA-START-READ) (A-CONSTANT 1031))    ;FETCH MISCELLANEOUS SCRATCHPAD LOCS
     
    23262519        (ILLOP-IF-PAGE-FAULT)
    23272520        ((A-CNSADF) Q-TYPED-POINTER READ-MEMORY-DATA)
     2521        ((A-BACKGROUND-CONS-AREA) A-CNSADF)
    23282522        ((A-NUM-CNSADF) Q-TYPED-POINTER READ-MEMORY-DATA)  ;DONT REALLY HACK EXTRA-PDL
    23292523                                                          ; INITIALLY.
     
    23352529        ;; Find out where to page off of if we don't know already
    23362530        (CALL-EQUAL A-DISK-OFFSET M-ZERO WARM-READ-LABEL)
    2337         ;; Get A-INITIAL-FEF, A-QTRSTKG, A-QCSTKG, A-QISTKG
     2531        ;; Clear the unused pages of the PHT and PPD out of the map
     2532        ((MD) DPB (M-CONSTANT -1) (BYTE-FIELD 8 0) A-V-PHYSICAL-PAGE-DATA-END)
     2533        ((MD) ADD MD (A-CONSTANT 1))            ;First page above PPD
     2534        (JUMP-GREATER-OR-EQUAL MD A-V-REGION-ORIGIN BEGCM2)
     2535BEGCM1  ((VMA-WRITE-MAP) (A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))
     2536        ((MD) ADD MD (A-CONSTANT (EVAL PAGE-SIZE)))
     2537        (JUMP-LESS-THAN MD A-V-REGION-ORIGIN BEGCM1)
     2538BEGCM2  ((MD) A-V-PAGE-TABLE-AREA)
     2539        ((MD) ADD MD A-PHT-INDEX-LIMIT)
     2540        (JUMP-GREATER-OR-EQUAL MD A-V-PHYSICAL-PAGE-DATA BEGCM4)
     2541BEGCM3  ((VMA-WRITE-MAP) (A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE)))
     2542        ((MD) ADD MD (A-CONSTANT (EVAL PAGE-SIZE)))
     2543        (JUMP-LESS-THAN MD A-V-PHYSICAL-PAGE-DATA BEGCM3)
     2544BEGCM4  ;; Get A-INITIAL-FEF, A-QTRSTKG, A-QCSTKG, A-QISTKG
    23382545        ((VMA) (BYTE-FIELD 9 0) (M-CONSTANT -1)) ;777 ;SCRATCH-PAD-INIT-AREA MINUS ONE
    23392546        ((M-K) (A-CONSTANT (A-MEM-LOC A-SCRATCH-PAD-BEG))) ;FIRST A MEM LOC TO BLT INTO
     
    23472554        ((VMA-START-READ) A-INITIAL-FEF)        ;INDIRECT
    23482555        (CHECK-PAGE-READ)
     2556        ;; Don't let garbage pointer leak through DISK-RESTORE
     2557        ;; There are a lot of these, we only get the ones that are known to cause trouble
     2558        ;; There are also the "method subroutine" and "sg calling args" guys
     2559        ((A-SELF) A-V-NIL)
     2560        ((A-SG-PREVIOUS-STACK-GROUP) A-V-NIL)
    23492561        (DISPATCH TRANSPORT READ-MEMORY-DATA)
    23502562        ((A-INITIAL-FEF) READ-MEMORY-DATA)
     
    23842596        ((VMA-START-READ) (A-CONSTANT (EVAL (PLUS 400 %SYS-COM-AREA-ORIGIN-PNTR))))
    23852597        (ILLOP-IF-PAGE-FAULT)
    2386         ((VMA) SUB READ-MEMORY-DATA (A-CONSTANT 1)) ;1- ADDR OF AREA-ORIGIN TABLE
     2598        ((VMA) SUB READ-MEMORY-DATA (A-CONSTANT 1)) ;1- ADDR OF REGION-ORIGIN TABLE
    23872599        ((M-K) (A-CONSTANT (A-MEM-LOC A-V-RESIDENT-SYMBOL-AREA)))
    23882600BEG02   ((VMA-START-READ) ADD VMA (A-CONSTANT 1))
     
    23902602        ((OA-REG-LOW) DPB M-K OAL-A-DEST A-ZERO)        ;DESTINATION
    23912603        ((A-GARBAGE) Q-POINTER READ-MEMORY-DATA (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
    2392         (JUMP-NOT-EQUAL-XCT-NEXT M-K
    2393                 (A-CONSTANT (A-MEM-LOC A-V-MICRO-CODE-ENTRY-MAX-PDL-USAGE)) BEG02)
    2394        ((M-K) ADD M-K (A-CONSTANT 1))
    2395         (POPJ)
     2604        ((M-K) ADD M-K (A-CONSTANT 1))
     2605        (JUMP-NOT-EQUAL M-K (A-CONSTANT (A-MEM-LOC A-V-FIRST-UNFIXED-AREA)) BEG02)
     2606        ;; Now find the end of the last fixed area, which is where we can start making regions
     2607        ;; Too bad the cold-load generator didn't store this anywhere for us
     2608        ((M-K) M-A-1 M-K (A-CONSTANT (A-MEM-LOC A-V-RESIDENT-SYMBOL-AREA)))
     2609        ((VMA-START-READ) ADD M-K A-V-REGION-LENGTH)
     2610        (ILLOP-IF-PAGE-FAULT)
     2611        ((M-K) ADD READ-MEMORY-DATA A-V-INIT-LIST-AREA) ;...the last fixed area
     2612        ;; Round up to next multiple of a quantum
     2613        (POPJ-AFTER-NEXT (M-K) ADD M-K (A-CONSTANT (EVAL (1- %ADDRESS-SPACE-QUANTUM-SIZE))))
     2614       ((A-V-FIRST-UNFIXED-AREA) SELECTIVE-DEPOSIT M-K
     2615                VMA-QUANTUM-BYTE (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
    23962616
    23972617
     
    26062826                                  (BYTE-VALUE Q-CDR-CODE CDR-NEXT))))
    26072827       (NO-OP)          ;NO PASS-AROUND PATH ON PDL-BUFFER
     2828
     2829
     2830;Get and set lexical variables inherited from outer contexts.
     2831XLOAD-FROM-HIGHER-CONTEXT
     2832        (MISC-INST-ENTRY %LOAD-FROM-HIGHER-CONTEXT)
     2833        (CALL XLOCATE-IN-HIGHER-CONTEXT)
     2834        (JUMP QCAR)
     2835
     2836XSTORE-IN-HIGHER-CONTEXT
     2837        (MISC-INST-ENTRY %STORE-IN-HIGHER-CONTEXT)
     2838        (CALL XLOCATE-IN-HIGHER-CONTEXT)
     2839        ((M-S) M-T)
     2840        (JUMP-XCT-NEXT QRAR1)
     2841       ((M-T) C-PDL-BUFFER-POINTER-POP)
     2842
     2843XLOCATE-IN-HIGHER-CONTEXT
     2844        (MISC-INST-ENTRY %LOCATE-IN-HIGHER-CONTEXT)
     2845;Compute in M-T the address of a local or arg in a higher lexical context.
     2846;Pops a word off the stack to specify where to find the local:
     2847;  Sign bit       0 => arg, 1 => local.
     2848;  Next 11. bits  Number of contexts to go up (0 => immediate higher context)
     2849;  Low 12. bits   Number of arg or local in that context.
     2850        ((M-A) C-PDL-BUFFER-POINTER-POP)
     2851        ((M-B) (BYTE-FIELD 11. 12.) M-A)
     2852        ((M-T) A-LEXICAL-ENVIRONMENT)
     2853XLOCATE-IN-HIGHER-CONTEXT-1
     2854        (JUMP-EQUAL M-B A-ZERO XLOCATE-IN-HIGHER-CONTEXT-3)
     2855        (CALL QCDR)
     2856        (JUMP-XCT-NEXT XLOCATE-IN-HIGHER-CONTEXT-1)
     2857       ((M-B) SUB M-B (A-CONSTANT 1))
     2858
     2859XLOCATE-IN-HIGHER-CONTEXT-3
     2860        (CALL QCAR)
     2861        (CALL-EQUAL M-T A-V-NIL TRAP)
     2862    (ERROR-TABLE ILLEGAL-INSTRUCTION)
     2863        (JUMP-IF-BIT-CLEAR BOXED-SIGN-BIT M-A XLOCATE-IN-HIGHER-CONTEXT-2)
     2864        ((VMA-START-READ) ADD M-T (EVAL %LP-ENTRY-STATE))
     2865        (CHECK-PAGE-READ)
     2866        ((M-B) (LISP-BYTE %%LP-ENS-MACRO-LOCAL-BLOCK-ORIGIN) MD)
     2867        ((M-T) ADD M-B A-T)
     2868        ((M-T) SUB M-T (A-CONSTANT 1))
     2869XLOCATE-IN-HIGHER-CONTEXT-2
     2870        ((M-B) (BYTE-FIELD 12. 0) M-A)
     2871        (POPJ-AFTER-NEXT
     2872         (M-T) ADD M-B A-T ALU-CARRY-IN-ONE)
     2873        ((M-T) DPB M-T Q-POINTER
     2874               (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
     2875
    26082876
    26092877;;; VARIOUS TRAPS
     
    28053073       ((C-PDL-BUFFER-POINTER-PUSH) M-T)
    28063074
     3075;;; These are not callable with MISC instructions, only as functions.
     3076;;; They are documented as taking an &REST argument but actually take 63 optional args.
     3077;;; When entered, the arguments are on the stack and M-R contains the number of them.
     3078;;; (M-AP)+1 is the first argument, (PP) is the last.
     3079        (MISC-INST-ENTRY LIST)
     3080XLIST   (JUMP-EQUAL M-R A-ZERO XFALSE)
     3081        (CALL-XCT-NEXT LCONS-D)
     3082       ((M-B) Q-POINTER M-R)
     3083XLIST0  ((WRITE-MEMORY-DATA) LDB C-PDL-BUFFER-POINTER-POP
     3084                Q-ALL-BUT-CDR-CODE (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
     3085        ((VMA) ADD M-T A-B)
     3086        ((M-T) DPB Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
     3087XLIST1  ((VMA-START-WRITE) SUB VMA (A-CONSTANT 1))
     3088        (CHECK-PAGE-WRITE)
     3089        (GC-WRITE-TEST)
     3090        ((M-B) SUB M-B (A-CONSTANT 1))
     3091XLIST2  (POPJ-LESS-OR-EQUAL M-B A-ZERO)
     3092        (JUMP-XCT-NEXT XLIST1)
     3093       ((WRITE-MEMORY-DATA) LDB C-PDL-BUFFER-POINTER-POP
     3094                Q-ALL-BUT-CDR-CODE (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
     3095
     3096        (MISC-INST-ENTRY LIST*)
     3097XLISTR  (JUMP-EQUAL M-R (A-CONSTANT 1) POPTJ)
     3098        (CALL-XCT-NEXT LCONS-D)
     3099       ((M-B) Q-POINTER M-R)
     3100XLISTR0 ((VMA) ADD M-T A-B)
     3101        ((M-T) DPB Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
     3102        ((WRITE-MEMORY-DATA) LDB C-PDL-BUFFER-POINTER-POP
     3103                Q-ALL-BUT-CDR-CODE (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-ERROR)))
     3104        ((VMA-START-WRITE) SUB VMA (A-CONSTANT 1))
     3105        (CHECK-PAGE-WRITE)
     3106        (GC-WRITE-TEST)
     3107        ((WRITE-MEMORY-DATA) LDB C-PDL-BUFFER-POINTER-POP
     3108                Q-ALL-BUT-CDR-CODE (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NORMAL)))
     3109        ((VMA-START-WRITE) SUB VMA (A-CONSTANT 1))
     3110        (CHECK-PAGE-WRITE)
     3111        (GC-WRITE-TEST)
     3112        (JUMP-XCT-NEXT XLIST2)
     3113       ((M-B) SUB M-B (A-CONSTANT 2))
     3114
     3115;;; Note that these two never pop their first argument.  This doesn't matter when
     3116;;; calling them as functions, but if you try to make a MISC-instruction interface
     3117;;; to these you will need to be aware of that.
     3118        (MISC-INST-ENTRY LIST-IN-AREA)
     3119XLISTA  (JUMP-EQUAL M-R (A-CONSTANT 1) XFALSE)
     3120        ((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT 1))
     3121        ((M-S) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)
     3122        ((M-B) SUB M-R (A-CONSTANT 1))
     3123        (JUMP-XCT-NEXT XLIST0)
     3124       (CALL LCONS)
     3125       
     3126        (MISC-INST-ENTRY LIST*-IN-AREA)
     3127XLISTRA (JUMP-EQUAL M-R (A-CONSTANT 2) POPTJ)
     3128        ((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT 1))
     3129        ((M-S) Q-TYPED-POINTER C-PDL-BUFFER-INDEX)
     3130        ((M-B) SUB M-R (A-CONSTANT 1))
     3131        (JUMP-XCT-NEXT XLISTR0)
     3132       (CALL LCONS)
     3133
    28073134
    28083135;THESE VARIOUS CONSING ROUTINES HAD BETTER NOT CLOBBER M-C.  OTHER REGS PROBABLY OK.
     3136
     3137(ERROR-TABLE DEFAULT-ARG-LOCATIONS XCONS (PP 1) (PP 0))
    28093138
    28103139XXCONS (MISC-INST-ENTRY XCONS)                  ;XCONS
    28113140        (JUMP-XCT-NEXT XXCON1)
    28123141       ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF)      ;USE DEFAULT AREA
     3142
     3143(ERROR-TABLE DEFAULT-ARG-LOCATIONS XCONS-IN-AREA (PP 1) (PP 0) M-S)
    28133144
    28143145XXCONA (MISC-INST-ENTRY XCONS-IN-AREA)          ;XCONS, WITH AREA AS THIRD ARG
     
    28203151       ((C-PDL-BUFFER-POINTER-PUSH) M-A)
    28213152
     3153(ERROR-TABLE DEFAULT-ARG-LOCATIONS NCONS (PP 1))
     3154
    28223155XNCONS (MISC-INST-ENTRY NCONS)                  ;NCONS
    28233156        (JUMP-XCT-NEXT XNCON1)
    28243157       ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF)
     3158
     3159(ERROR-TABLE DEFAULT-ARG-LOCATIONS NCONS-IN-AREA (PP 1) M-S)
    28253160
    28263161XNCONA (MISC-INST-ENTRY NCONS-IN-AREA)          ;NCONS, WITH AREA AS SECOND ARG
     
    28283163XNCON1  (JUMP-XCT-NEXT QCONS)
    28293164       ((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL)
     3165
     3166(ERROR-TABLE DEFAULT-ARG-LOCATIONS CONS PP PP)
    28303167
    28313168XCONS (MISC-INST-ENTRY CONS)                    ;CONS
     
    28483185       (NO-OP)
    28493186
     3187(ERROR-TABLE DEFAULT-ARG-LOCATIONS CONS-IN-AREA PP PP M-S)
     3188
    28503189XCONSA (MISC-INST-ENTRY CONS-IN-AREA)           ;CONS, WITH AREA AS THIRD ARG
    28513190        (JUMP-XCT-NEXT QCONS)
    28523191       ((M-S) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
    28533192
     3193;Assuming M-S set up with area,
     3194;cons a single-word cell with cdr-nil,
     3195;with contents taken from the stack.
     3196XNCONQ  (CALL-XCT-NEXT LCONS)                   ;ALLOCATE 1 Q, RETURN POINTER IN M-T,
     3197       ((M-B) (A-CONSTANT 1))                   ;ALLOCATE FROM LIST SPACE
     3198        ((WRITE-MEMORY-DATA) DPB Q-TYPED-POINTER
     3199                C-PDL-BUFFER-POINTER-POP
     3200                (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
     3201        ((VMA-START-WRITE M-T) DPB M-T Q-POINTER
     3202                (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
     3203        (CHECK-PAGE-WRITE)
     3204        (POPJ-AFTER-NEXT GC-WRITE-TEST)
     3205       (NO-OP)
    28543206
    28553207
     
    28723224; FOR OUT-OF-VIRTUAL-MEMORY WHICH SHOULDN'T HAPPEN AND MAY NOT WORK.
    28733225
    2874 ;DECODE AREA SPEC IN M-S.  RETURN FIXNUM, WITH DATA-TYPE, IN M-S.  MAY JUMP OR CALL TO TRAP.
    2875 ;ALSO CHECKS M-B.  (UNTYPED NUMBER OF FIXNUMS TO ALLOCATE.)
     3226;DECODE AREA SPEC IN M-S.  RETURN FIXNUM, WITH DATA-TYPE, IN M-S.
     3227;THIS CAN CALL TRAP OR JUMP TO IT, THUS CALLER MUST HAVE (ERROR-TABLE ARGTYP AREA M-S NIL)
    28763228;M-S MUST HAVE DATA-TYPE AND NO CDR-CODE/FLAG.
    2877 CONS-GET-AREA
     3229CONS-GET-AREA           (ERROR-TABLE RESTART CONS-GET-AREA)
    28783230        ((M-TEM) Q-DATA-TYPE M-S)
    2879         (JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-SYMBOL)) CONS-GET-AREA-1)
    2880 CONS-GET-AREA-0
     3231        (CALL-EQUAL M-TEM (A-CONSTANT (EVAL DTP-SYMBOL)) CONS-GET-AREA-1)
    28813232        (POPJ-AFTER-NEXT DISPATCH Q-DATA-TYPE M-S TRAP-UNLESS-FIXNUM)
    2882     (ERROR-TABLE ARGTYP AREA M-S NIL)
     3233    (ERROR-TABLE ARGTYP AREA M-S NIL CONS-GET-AREA)
    28833234       (CALL-GREATER-THAN M-S (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)
    28843235                                                (EVAL SIZE-OF-AREA-ARRAYS)))
     
    28863237
    28873238CONS-GET-AREA-1
    2888         (JUMP-EQUAL M-S A-V-NIL CONS-GET-AREA-2)
    28893239        ((VMA-START-READ) ADD M-S (A-CONSTANT 1))       ;Fetch value
    28903240        (CHECK-PAGE-READ)
    28913241        (DISPATCH TRANSPORT READ-MEMORY-DATA)
    2892         (JUMP-XCT-NEXT CONS-GET-AREA-0)
     3242        (POPJ-XCT-NEXT)
    28933243       ((M-S) Q-TYPED-POINTER READ-MEMORY-DATA)
    2894 
    2895 CONS-GET-AREA-2
    2896         (JUMP-XCT-NEXT CONS-GET-AREA-0)
    2897        ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF)
    28983244
    28993245;This entry used by number functions to cons a structure in extra-pdl
    29003246SCONS-T ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-NUM-CNSADF)
    2901 ;This is the normal entry, area in M-S
    2902 SCONS   (CALL-LESS-OR-EQUAL M-B A-ZERO TRAP)
     3247;This is the normal entry, area in M-S with no cdr code or flag bit
     3248SCONS   (JUMP-NOT-EQUAL M-S A-V-NIL SCONS-N)
     3249;This is the entry to cons in the default area
     3250SCONS-D ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF)
     3251;At this point M-S is a fixnum, unless there is a bug or use of an obsolete feature
     3252SCONS-N (CALL-LESS-OR-EQUAL M-B A-ZERO TRAP)
    29033253                (ERROR-TABLE CONS-ZERO-SIZE M-B)
    29043254        (JUMP-IF-BIT-SET M-TRANSPORT-FLAG SCONSR)       ;Transporter must avoid cache
     
    29123262       ((M-K) A-SCONS-CACHE-REGION)
    29133263
    2914 SCONSR  (CALL CONS-GET-AREA)                    ;Set up M-S
    2915     (ERROR-TABLE ARGTYP AREA M-S NIL)
     3264SCONSR          (ERROR-TABLE RESTART SCONSR)
     3265        (CALL CONS-GET-AREA)                            ;Set up M-S
     3266    (ERROR-TABLE ARGTYP AREA M-S NIL SCONSR)
    29163267        ((VMA-START-READ) ADD M-S A-V-AREA-REGION-LIST) ;Find appropriate region of the area
    29173268SCONS0  (CHECK-PAGE-READ)
     
    29363287
    29373288;A copy of the above code except for List representation-type, slightly different dispatch
    2938 LCONS   (CALL-LESS-OR-EQUAL M-B A-ZERO TRAP)
     3289;This is the normal entry, area in M-S with no cdr code or flag bit
     3290LCONS   (JUMP-NOT-EQUAL M-S A-V-NIL LCONS-N)
     3291;This is the entry to cons in the default area
     3292LCONS-D ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF)
     3293;At this point M-S is a fixnum, unless there is a bug or use of an obsolete feature
     3294LCONS-N (CALL-LESS-OR-EQUAL M-B A-ZERO TRAP)
    29393295                (ERROR-TABLE CONS-ZERO-SIZE M-B)
    29403296        (JUMP-IF-BIT-SET M-TRANSPORT-FLAG LCONSR)       ;Transporter must avoid cache
     
    29483304       ((M-K) A-LCONS-CACHE-REGION)
    29493305
    2950 LCONSR  (CALL CONS-GET-AREA)                    ;Set up M-S
    2951     (ERROR-TABLE ARGTYP AREA M-S NIL)
     3306LCONSR          (ERROR-TABLE RESTART LCONSR)
     3307        (CALL CONS-GET-AREA)                    ;Set up M-S
     3308    (ERROR-TABLE ARGTYP AREA M-S NIL LCONSR)
    29523309        ((VMA-START-READ) ADD M-S A-V-AREA-REGION-LIST) ;Find appropriate region of the area
    29533310LCONS0  (CHECK-PAGE-READ)
     
    30243381        (INHIBIT-XCT-NEXT-BIT CONSF5)           ;1 OLD (TRY NEXT REGION)
    30253382        (P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;2 NEW (ONLY IF NOT IN TRANSPORTER)
    3026         (P-BIT R-BIT)                           ;3 STATIC
    3027         (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;4 FIXED (ILLEGAL TO CONS IN)
    3028         (P-BIT R-BIT)                           ;5 EXITED
    3029         (INHIBIT-XCT-NEXT-BIT CONSF5)           ;6 EXIT (TRY NEXT REGION)
    3030         (P-BIT R-BIT)                           ;7 EXTRA-PDL
    3031         (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;10 WIRED (ILLEGAL TO CONS IN)
    3032         (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;11 USER-PAGED (ILLEGAL TO CONS IN)
    3033         (P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-COPY) ;12 COPY (ONLY IF IN TRANSPORTER)
    3034 (REPEAT 5 (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))   ;UNUSED CODE (ILLEGAL TO CONS IN)
     3383        (P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;3 NEW1 (ONLY IF NOT IN TRANSPORTER)
     3384        (P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;4 NEW2 (ONLY IF NOT IN TRANSPORTER)
     3385        (P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;5 NEW3 (ONLY IF NOT IN TRANSPORTER)
     3386        (P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;6 NEW4 (ONLY IF NOT IN TRANSPORTER)
     3387        (P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;7 NEW5 (ONLY IF NOT IN TRANSPORTER)
     3388        (P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;10 NEW6 (ONLY IF NOT IN TRANSPORTER)
     3389        (P-BIT R-BIT)                           ;11 STATIC
     3390        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;12 FIXED (ILLEGAL TO CONS IN)
     3391        (P-BIT R-BIT)                           ;13 EXTRA-PDL
     3392        (P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-COPY) ;14 COPY (ONLY IF IN TRANSPORTER)
     3393(REPEAT 3 (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))   ;UNUSED CODE (ILLEGAL TO CONS IN)
    30353394(END-DISPATCH)
    30363395
     
    32533612EXTRA-PDL-OV
    32543613        (JUMP-LESS-OR-EQUAL M-B A-3 EXTRA-PDL-OV-0)
    3255         (JUMP-XCT-NEXT SCONS)                   ;won't fit, cons in working storage instead
    3256        ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF)
     3614        (JUMP SCONS-D)                  ;won't fit, cons in working storage instead
    32573615
    32583616;FLUSH POINTERS TO EXTRA-PDL OUT OF "MACHINE", I.E. M-ZR - M-K, A-VERSION - A-END-Q-POINTERS,
     
    33433701RCONS1  ((VMA-START-READ) ADD M-S A-V-AREA-MAXIMUM-SIZE)
    33443702        (CHECK-PAGE-READ)
    3345         ((M-4) SUB READ-MEMORY-DATA A-4)        ;M-4 AMOUNT LEFT BEFORE OVERFLOW
    3346         ((OA-REG-HIGH) BOXED-SIGN-BIT M-4)      ;SIGN EXTEND TO 32 BITS
    3347         ((M-4) SELECTIVE-DEPOSIT M-ZERO Q-ALL-BUT-POINTER A-4)
     3703        ((MD) Q-POINTER READ-MEMORY-DATA)
     3704        ((M-4) Q-POINTER M-4)
     3705        ((M-4) SUB MD A-4)                      ;M-4 AMOUNT LEFT BEFORE OVERFLOW
    33483706        (JUMP-GREATER-OR-EQUAL M-4 A-3 RCONS2)  ;JUMP IF NO OVERFLOW PROBLEM
    33493707        (JUMP-IF-BIT-SET M-TRANSPORT-FLAG RCONS2A) ;INHIBIT EMBARRASSING TRAP OUT OF TRANSP
    33503708        (CALL-GREATER-THAN M-B A-4 TRAP)
    33513709    (ERROR-TABLE AREA-OVERFLOW M-S)
     3710        (JUMP-XCT-NEXT RCONS2)                  ;CONS MAXIMAL SIZE REGION
     3711       ((M-3) M-4)
    33523712RCONS2A ((M-3) M-B)                             ;ALMOST OVERFLOWING, ALLOCATE LESS (WIN?)
    33533713RCONS2  ((VMA-START-READ) ADD M-K A-V-REGION-BITS)      ;GET BITS FOR THIS REGION
     
    33573717        ((M-TEM) (LISP-BYTE %%REGION-SPACE-TYPE) M-4)
    33583718        (DISPATCH-XCT-NEXT (BYTE-FIELD 4 0) M-TEM D-RCONS)      ;Check region type
     3719             (ERROR-TABLE RCONS-FIXED)
    33593720RCONS3 ((M-4) IOR M-4 (A-CONSTANT (BYTE-MASK %%REGION-OLDSPACE-META-BIT))) ;Not oldspace
    33603721        ((M-4) DPB M-TEM (LISP-BYTE %%REGION-SPACE-TYPE) A-4)
     3722        ((VMA-START-READ) ADD M-S A-V-AREA-SWAP-RECOMMENDATIONS)
     3723        (CHECK-PAGE-READ)
     3724        ((M-4) DPB READ-MEMORY-DATA (LISP-BYTE %%REGION-SWAPIN-QUANTUM) A-4)
    33613725        (CALL-XCT-NEXT MAKE-REGION)             ;ALLOCATE A REGION OF THAT SIZE (TO M-K)
    33623726       ((M-4) DPB M-E (LISP-BYTE %%REGION-REPRESENTATION-TYPE) A-4)
     
    33863750        (P-BIT RCONS-DYNAM)     ;1 OLD (change into new)
    33873751        (P-BIT R-BIT)           ;2 NEW (copy it)
    3388         (P-BIT R-BIT)           ;3 STATIC (copy it)
    3389         (P-BIT ILLOP)           ;4 FIXED (not supposed to cons new regions)
    3390         (P-BIT R-BIT)           ;5 EXITED (copy it)
    3391         (P-BIT R-BIT)           ;6 EXIT (copy it)
    3392         (P-BIT R-BIT)           ;7 EXTRA-PDL (copy it)
    3393         (P-BIT ILLOP)           ;10 WIRED (not supposed to cons new regions)
    3394         (P-BIT ILLOP)           ;11 USER-PAGED (not supposed to cons new regions)
    3395         (P-BIT RCONS-DYNAM)     ;12 COPY (change into new)
    3396 (REPEAT 5 (P-BIT ILLOP))
     3752        (P-BIT R-BIT)           ;3 NEW1 (copy it)
     3753        (P-BIT R-BIT)           ;4 NEW2 (copy it)
     3754        (P-BIT R-BIT)           ;5 NEW3 (copy it)
     3755        (P-BIT R-BIT)           ;6 NEW4 (copy it)
     3756        (P-BIT R-BIT)           ;7 NEW5 (copy it)
     3757        (P-BIT R-BIT)           ;10 NEW6 (copy it)
     3758        (P-BIT R-BIT)           ;11 STATIC (copy it)
     3759        (P-BIT INHIBIT-XCT-NEXT-BIT TRAP) ;12 FIXED (not supposed to cons new regions)
     3760        (P-BIT R-BIT)           ;13 EXTRA-PDL (copy it)
     3761        (P-BIT RCONS-DYNAM)     ;14 COPY (change into new)
     3762(REPEAT 3 (P-BIT ILLOP))
    33973763(END-DISPATCH)
    33983764(LOCALITY I-MEM)
     
    34023768;;; M-3 HAS SIZE IN WORDS, M-4 HAS REGION-BITS
    34033769;;; SETS UP EVERYTHING ELSE EXCEPT REGION-LIST-THREAD, RETURNS REGION IN M-K, BASHES M-E, M-T
    3404 ;;; PRESERVES M-3 AND M-4, EXCEPT M-3 IS ROUNDED UP TO THE NEXT PAGE BOUNDARY
     3770;;; PRESERVES M-3 AND M-4, EXCEPT M-3 IS ROUNDED UP TO THE NEXT QUANTUM BOUNDARY
    34053771MAKE-REGION
    3406         ((M-3) ADD M-3 (A-CONSTANT (BYTE-MASK VMA-LOW-BITS)))   ;Round up to page boundary
    3407         ((M-3) SELECTIVE-DEPOSIT M-3 VMA-PAGE-ADDR-PART A-ZERO)
     3772        ((M-3) ADD M-3 (A-CONSTANT (EVAL (1- %ADDRESS-SPACE-QUANTUM-SIZE)))) ;Round up to
     3773        ((M-3) SELECTIVE-DEPOSIT M-3 VMA-QUANTUM-BYTE A-ZERO)                ; quantum bound
    34083774        ((A-REGION-CONS-ALARM) M+A+1 M-ZERO A-REGION-CONS-ALARM)
    34093775        ((M-TEM) VMA-PAGE-ADDR-PART M-3)        ;Length of region in pages
    34103776        ((A-PAGE-CONS-ALARM) ADD M-TEM A-PAGE-CONS-ALARM)
    3411         ;Check out the free regions
    3412         ((M-TEM) (A-CONSTANT (EVAL (FIND-POSITION-IN-LIST 'FREE-AREA AREA-LIST))))
    3413         ((VMA-START-READ) ADD M-TEM A-V-AREA-REGION-LIST)
     3777        ;; Search address-space-map for suitable number of consecutive zeros
     3778        ((M-T) A-V-FIRST-UNFIXED-AREA)          ;Starting address
     3779        ((M-TEM) A-DISK-MAXIMUM)                ;Ending address
     3780        ((M-K) DPB M-TEM VMA-PAGE-ADDR-PART (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
    34143781MAKE-REGION-1
    3415         (CHECK-PAGE-READ)
    3416         ((M-T) VMA)                             ;SAVE WHO POINTED AT THIS REGION
    3417         (CALL-IF-BIT-SET BOXED-SIGN-BIT READ-MEMORY-DATA TRAP)
    3418     (ERROR-TABLE VIRTUAL-MEMORY-OVERFLOW)
    3419         ((M-K) Q-POINTER READ-MEMORY-DATA)      ;REGION#
    3420         ((VMA-START-READ) ADD M-K A-V-REGION-LENGTH)
    3421         (CHECK-PAGE-READ)
    3422         ((M-TEM) Q-POINTER READ-MEMORY-DATA)
    3423         (JUMP-EQUAL M-TEM A-3 MAKE-REGION-3)    ;FITS EXACTLY
    3424         (JUMP-GREATER-THAN M-TEM A-3 MAKE-REGION-2)     ;SPLIT THIS FREE REGION
    3425         (JUMP-XCT-NEXT MAKE-REGION-1)
    3426        ((VMA-START-READ) ADD M-K A-V-REGION-LIST-THREAD)
    3427 
    3428 MAKE-REGION-2
    3429         ((WRITE-MEMORY-DATA-START-WRITE) SUB READ-MEMORY-DATA A-3)      ;NEW LENGTH
    3430         (CHECK-PAGE-WRITE)
    3431         ((VMA-START-READ) ADD M-K A-V-REGION-ORIGIN)
    3432         (CHECK-PAGE-READ)
    3433         ((M-T) Q-TYPED-POINTER READ-MEMORY-DATA)        ;ORIGIN FOR NEW REGION
    3434         ((WRITE-MEMORY-DATA-START-WRITE) ADD M-T A-3)   ;NEW ORIGIN FOR FREE REGION
    3435         (CHECK-PAGE-WRITE)
    3436 MAKE-REGION-4
    3437         ;; M-T HAS ORIGIN, M-3 HAS LENGTH, M-4 HAS BITS.  PUT REGION IN TABLES.
     3782        ((M-E) ADD M-T A-3)                     ;End of large enough region starting here
     3783MAKE-REGION-2   
     3784        (CALL-GREATER-OR-EQUAL M-T A-K TRAP)    ;Reached end of map, with no luck
     3785            (ERROR-TABLE VIRTUAL-MEMORY-OVERFLOW)
     3786        (CALL ADDRESS-SPACE-MAP-LOOKUP)         ;This could be optimized to save some mem rds?
     3787        (JUMP-NOT-EQUAL-XCT-NEXT M-TEM A-ZERO MAKE-REGION-1)
     3788       ((M-T) ADD M-T (A-CONSTANT (EVAL %ADDRESS-SPACE-QUANTUM-SIZE)))
     3789        (JUMP-LESS-THAN M-T A-E MAKE-REGION-2)  ;Found free space, but not big enough yet
     3790        ((M-T) SUB M-T A-3)                     ;Base address of free space found
     3791        ;; M-T has origin, M-3 has length, M-4 has bits.  Put region in tables.
    34383792        ((VMA-START-READ) (A-CONSTANT (EVAL (PLUS 400 %SYS-COM-FREE-REGION/#-LIST))))
    34393793        (CHECK-PAGE-READ)
    3440         ((M-K) Q-POINTER READ-MEMORY-DATA)      ;NUMBER OF NEW REGION
    3441         (CALL-EQUAL M-K A-ZERO TRAP)
    3442     (ERROR-TABLE REGION-TABLE-OVERFLOW)         ;WE HAVE LOST SOME OF FREE SPACE, TOO BAD
     3794        ((M-K) Q-POINTER READ-MEMORY-DATA)      ;Number of new region
     3795        (CALL-EQUAL M-K A-ZERO TRAP)            ;Out of region numbers
     3796            (ERROR-TABLE REGION-TABLE-OVERFLOW)
    34433797        ((VMA-START-READ) ADD M-K A-V-REGION-LIST-THREAD)       ;CDR OFF OF LIST
    34443798        (CHECK-PAGE-READ)
     
    34463800        ((VMA-START-WRITE) (A-CONSTANT (EVAL (PLUS 400 %SYS-COM-FREE-REGION/#-LIST))))
    34473801        (CHECK-PAGE-WRITE)
    3448 MAKE-REGION-3A
    3449         ;; SET UP REGION-SORTED-BY-ORIGIN
    3450         ((M-TEM) (A-CONSTANT (EVAL SIZE-OF-AREA-ARRAYS)))
    3451         ((VMA-START-READ) ADD M-TEM A-V-REGION-SORTED-BY-ORIGIN)
    3452         (ILLOP-IF-PAGE-FAULT)
    3453         ((M-TEM) SETZ)          ;TABLE INDEX
    3454         ((A-TEM1) ADD READ-MEMORY-DATA A-V-REGION-ORIGIN)       ;LAST ENTRY, IS REPLICATED
    3455 MAKE-REGION-5
    3456         (JUMP-EQUAL VMA A-TEM1 MAKE-REGION-5B)                  ;GOES AFTER ALL EXISTING ONES
    3457         ((VMA-START-READ) ADD M-TEM A-V-REGION-SORTED-BY-ORIGIN);SEARCH UP FOR WHERE THIS
    3458         (ILLOP-IF-PAGE-FAULT)                                   ; REGION BELONGS
    3459         ((VMA-START-READ) ADD READ-MEMORY-DATA A-V-REGION-ORIGIN)
    3460         (ILLOP-IF-PAGE-FAULT)
    3461         ((A-TEM2) Q-TYPED-POINTER READ-MEMORY-DATA)
    3462         (JUMP-GREATER-OR-EQUAL-XCT-NEXT M-T A-TEM2 MAKE-REGION-5)
    3463        ((M-TEM) ADD M-TEM (A-CONSTANT 1))
    3464         ;; GOES RIGHT HERE, M-TEM MINUS ONE, SHIFT EVERYTHING ELSE UP
    3465         ((A-TEM1) SUB M-TEM (A-CONSTANT 1))
    3466         ((M-TEM) ADD (M-CONSTANT -1) (A-CONSTANT (EVAL SIZE-OF-AREA-ARRAYS)))
    3467 MAKE-REGION-5A
    3468         ((VMA-START-READ) ADD M-TEM A-V-REGION-SORTED-BY-ORIGIN)
    3469         (ILLOP-IF-PAGE-FAULT)
    3470         ((WRITE-MEMORY-DATA) READ-MEMORY-DATA)
    3471         ((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))
    3472         (ILLOP-IF-PAGE-FAULT)
    3473         (JUMP-NOT-EQUAL-XCT-NEXT M-TEM A-TEM1 MAKE-REGION-5A)
    3474        ((M-TEM) SUB M-TEM (A-CONSTANT 1))
    3475         ((WRITE-MEMORY-DATA) Q-POINTER M-K (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
    3476         ((VMA-START-WRITE) M+A+1 M-TEM A-V-REGION-SORTED-BY-ORIGIN)
    3477         (ILLOP-IF-PAGE-FAULT)
    3478 MAKE-REGION-6
    3479         ;; PROCEED TO INITIALIZE THE VARIOUS TABLES, EXCEPT LIST-THREAD WHICH CALLER DOES.
     3802        ;; Proceed to initialize the various tables, except list-thread which caller does.
    34803803        ((WRITE-MEMORY-DATA) Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
    34813804        ((VMA-START-WRITE) ADD M-K A-V-REGION-ORIGIN)
     
    34873810        ((VMA-START-WRITE) ADD M-K A-V-REGION-BITS)
    34883811        (CHECK-PAGE-WRITE)
     3812        ;; Set up address-space-map
     3813        ((M-E) ADD M-T A-3)                     ;End of region
     3814MAKE-REGION-3
     3815        (CALL ADDRESS-SPACE-MAP-STORE)
     3816        ((M-T) ADD M-T (A-CONSTANT (EVAL %ADDRESS-SPACE-QUANTUM-SIZE)))
     3817        (JUMP-LESS-THAN M-T A-E MAKE-REGION-3)
     3818        ;; Finish setting up tables
    34893819        ((WRITE-MEMORY-DATA) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) ;FREE PTR = 0
    34903820        ((VMA-START-WRITE) ADD M-K A-V-REGION-FREE-POINTER)
    34913821        (CHECK-PAGE-WRITE)
    3492         (POPJ-AFTER-NEXT
    3493          (VMA-START-WRITE) ADD M-K A-V-REGION-GC-POINTER)
     3822        (POPJ-AFTER-NEXT (VMA-START-WRITE) ADD M-K A-V-REGION-GC-POINTER)
    34943823       (CHECK-PAGE-WRITE)
    3495 
    3496 MAKE-REGION-3   ;FREE REGION EXACTLY THE RIGHT SIZE, USE IT UP
    3497         ((VMA-START-READ) ADD M-K A-V-REGION-LIST-THREAD)       ;REMOVE FROM FREE LIST
    3498         (CHECK-PAGE-READ)
    3499         ((WRITE-MEMORY-DATA) READ-MEMORY-DATA)  ;ENSURE COMPLETION OF READ CYCLE
    3500         ((VMA-START-WRITE) M-T)
    3501         (CHECK-PAGE-WRITE)
    3502         ((VMA-START-READ) ADD M-K A-V-REGION-ORIGIN)
    3503         (CHECK-PAGE-READ)
    3504         (JUMP-XCT-NEXT MAKE-REGION-3A)
    3505        ((M-T) Q-TYPED-POINTER READ-MEMORY-DATA)
    3506 
    3507 MAKE-REGION-5B  ;THIS REGION HIGHER THAN ALL OTHERS, REPLICATE THROUGH END OF ARRAY
    3508                 ;M-TEM HAS THE INDEX OF THE SECOND OF THE REGION THAT USED TO BE REPLICATED
    3509         ((WRITE-MEMORY-DATA) Q-POINTER M-K (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
    3510         ((VMA-START-WRITE) ADD M-TEM A-V-REGION-SORTED-BY-ORIGIN)
    3511         (ILLOP-IF-PAGE-FAULT)
    3512         (JUMP-LESS-THAN-XCT-NEXT M-TEM (A-CONSTANT (EVAL SIZE-OF-AREA-ARRAYS))
    3513                 MAKE-REGION-5B)
    3514        ((M-TEM) ADD M-TEM (A-CONSTANT 1))
    3515         (JUMP MAKE-REGION-6)
    35163824
    35173825;;; SUBROUTINE TO CREATE A REGION, CALLED ONLY BY AREA-CREATOR
     
    35263834       (NO-OP)
    35273835
     3836;Given an address in M-T, look up in the address space map, return result in M-TEM
     3837ADDRESS-SPACE-MAP-LOOKUP
     3838        ;; Get word from ADDRESS-SPACE-MAP (assuming it starts on proper boundary!)
     3839        ((VMA-START-READ) ADDRESS-SPACE-MAP-WORD-INDEX-BYTE M-T A-V-ADDRESS-SPACE-MAP)
     3840        (ILLOP-IF-PAGE-FAULT)
     3841        ((M-TEM) ADDRESS-SPACE-MAP-BYTE-NUMBER-BYTE M-T)        ;Byte number in that word
     3842        ((M-TEM) DPB M-TEM ADDRESS-SPACE-MAP-BYTE-MROT A-ZERO)
     3843        (POPJ-AFTER-NEXT (OA-REG-LOW) SUB (M-CONSTANT 40) A-TEM) ;40 doesn't hurt here, IORed
     3844       ((M-TEM) (BYTE-FIELD (EVAL %ADDRESS-SPACE-MAP-BYTE-SIZE) 0) READ-MEMORY-DATA)
     3845
     3846;Given an address in M-T, store M-K into the address space map.
     3847ADDRESS-SPACE-MAP-STORE
     3848        ;; Get word from ADDRESS-SPACE-MAP (assuming it starts on proper boundary!)
     3849        ((VMA-START-READ) ADDRESS-SPACE-MAP-WORD-INDEX-BYTE M-T A-V-ADDRESS-SPACE-MAP)
     3850        (ILLOP-IF-PAGE-FAULT)
     3851        ((M-TEM) ADDRESS-SPACE-MAP-BYTE-NUMBER-BYTE M-T)        ;Byte number in that word
     3852        ((A-TEM1) READ-MEMORY-DATA)
     3853        (POPJ-AFTER-NEXT (OA-REG-LOW) DPB M-TEM ADDRESS-SPACE-MAP-BYTE-MROT A-ZERO)
     3854       ((WRITE-MEMORY-DATA-START-WRITE) DPB M-K
     3855                (BYTE-FIELD (EVAL %ADDRESS-SPACE-MAP-BYTE-SIZE) 0) A-TEM1)
    35283856
    35293857
    35303858;;; CALL THIS ROUTINE TO FREE UP A REGION, NUMBER IN M-K (MUST BE PURE NUMBER).
    3531 ;;; IF ADJACENT TO ANOTHER FREE REGION, COMPACTIFIES.
    3532 ;;; BASHES M-A,M-B,M-D,M-E,M-K,M-T, M-1...M-4, A-GC-TEM, A-TEM1...A-TEM3
     3859;;; BASHES M-A,M-B,M-D,M-E,M-K,M-T, M-1...M-2, A-TEM1...A-TEM3
    35333860
    35343861XFREE-REGION (MISC-INST-ENTRY %GC-FREE-REGION)
    3535         ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC XFALSE)))
    35363862        ((M-K) Q-POINTER C-PDL-BUFFER-POINTER-POP)
    35373863FREE-REGION
     
    35433869        (CALL-XCT-NEXT UPDATE-REGION-PHT);Note that this sets M-1 and M-2 to the region bounds
    35443870       ((MD) (A-CONSTANT (BYTE-VALUE MAP-STATUS-CODE 2))) ;Make read-only, no access, in PHT2
    3545                                 ;Referencing this region will halt in XRGNPF
    3546         ;; Remove from REGION-SORTED-BY-ORIGIN
    3547         ((M-TEM) (A-CONSTANT (EVAL SIZE-OF-AREA-ARRAYS)))
    3548         ((M-3 VMA-START-READ) ADD M-TEM A-V-REGION-SORTED-BY-ORIGIN)
    3549         (CHECK-PAGE-READ)
    3550         ((M-4) Q-POINTER READ-MEMORY-DATA)
    3551         (JUMP-EQUAL M-4 A-K FREE-REGION-S-2)    ;Jump if this was the highest region
    3552 FREE-REGION-S-1
    3553         ((VMA-START-READ) SUB VMA (A-CONSTANT 1))       ;Read out location to be bashed
    3554         (CHECK-PAGE-READ)
    3555         ((A-TEM1) M-4)
    3556         ((M-4) Q-POINTER READ-MEMORY-DATA)
    3557         ((WRITE-MEMORY-DATA-START-WRITE)                ;Bash with contents of next higher loc
    3558                 SELECTIVE-DEPOSIT READ-MEMORY-DATA Q-ALL-BUT-POINTER A-TEM1)
    3559         (CHECK-PAGE-WRITE)
    3560         (JUMP-GREATER-THAN-XCT-NEXT VMA A-V-REGION-SORTED-BY-ORIGIN FREE-REGION-S-1)
    3561        (JUMP-EQUAL M-4 A-K FREE-REGION-S-4)             ;Done if just removed this region
    3562         (CALL ILLOP)                                    ;Foo, region was not in table
    3563                                                         ;and we've lost the region-0 entry
    3564 
    3565 FREE-REGION-S-2
    3566         ((VMA-START-READ) SUB VMA (A-CONSTANT 1))       ;Find new highest region
    3567         (CHECK-PAGE-READ)
    3568         ((M-4) Q-POINTER READ-MEMORY-DATA)
    3569         (JUMP-EQUAL M-4 A-K FREE-REGION-S-2)
    3570 FREE-REGION-S-3
    3571         ((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))      ;And replicate it back up
    3572         (CHECK-PAGE-WRITE)
    3573         (JUMP-LESS-THAN VMA A-3 FREE-REGION-S-3)
    3574 FREE-REGION-S-4
    3575         ;; Search free region list, attempt to concatenate to adjacent free region
    3576         ;; M-K region#, M-1 base address, M-2 upper-bound address
    3577         ((M-TEM) (A-CONSTANT (EVAL (FIND-POSITION-IN-LIST 'FREE-AREA AREA-LIST))))
    3578         ((VMA-START-READ) ADD M-TEM A-V-AREA-REGION-LIST)
    3579 FREE-REGION-1
    3580         (CHECK-PAGE-READ)
    3581         ((A-GC-TEM) VMA)                                ;REMEMBER WHO POINTS HERE
    3582         (JUMP-IF-BIT-SET BOXED-SIGN-BIT READ-MEMORY-DATA FREE-REGION-7) ;NON-ADJACENT
    3583         ((M-4) Q-POINTER READ-MEMORY-DATA)
    3584         ((VMA-START-READ) ADD M-4 A-V-REGION-ORIGIN)    ;CHECK ADJACENCIES
    3585         (ILLOP-IF-PAGE-FAULT)
    3586         ((A-TEM2) Q-POINTER READ-MEMORY-DATA)
    3587         ((VMA-START-READ) ADD M-4 A-V-REGION-LENGTH)
    3588         (ILLOP-IF-PAGE-FAULT)
    3589         ((M-TEM) Q-POINTER READ-MEMORY-DATA)
    3590         (JUMP-EQUAL M-2 A-TEM2 FREE-REGION-6)
    3591         ((A-TEM3) ADD M-TEM A-TEM2)
    3592         (JUMP-EQUAL M-1 A-TEM3 FREE-REGION-5)
    3593         (JUMP-XCT-NEXT FREE-REGION-1)
    3594        ((VMA-START-READ) ADD M-4 A-V-REGION-LIST-THREAD)
    3595 
    3596 ;Region in M-K is right before region in M-4
    3597 FREE-REGION-6
    3598         ((M-2) ADD READ-MEMORY-DATA A-2)        ;NEW UPPER-BOUND, WITH FIXNUM TYPE
    3599         ((WRITE-MEMORY-DATA-START-WRITE) SUB M-2 A-1)   ;UPDATE REGION-LENGTH
    3600         (ILLOP-IF-PAGE-FAULT)
    3601         ((M-2) Q-POINTER M-2)                   ;REGION UPPER-BOUND AS PURE NUMBER
    3602         ((VMA) ADD M-4 A-V-REGION-ORIGIN)
    3603         (JUMP-XCT-NEXT FREE-REGION-4)
    3604        ((WRITE-MEMORY-DATA-START-WRITE) Q-POINTER M-1   ;UPDATE REGION-ORIGIN
    3605                 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
    3606 
    3607 ;REGION IN M-K IS RIGHT AFTER REGION IN M-4
    3608 FREE-REGION-5
    3609         ((M-1) A-TEM2)                          ;NEW BASE ADDRESS
    3610         ((M-TEM) SUB M-2 A-TEM2)                ;SUM OF REGION-LENGTHS
    3611         ((WRITE-MEMORY-DATA-START-WRITE) Q-POINTER M-TEM
    3612                 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
    3613 FREE-REGION-4
    3614         (ILLOP-IF-PAGE-FAULT)
    3615         ;; Put region in M-K onto free region-table-entry list, try again with M-4
     3871        ;; Put region in M-K onto free region-table-entry list
    36163872        ((VMA-START-READ) (A-CONSTANT (EVAL (PLUS 400 %SYS-COM-FREE-REGION/#-LIST))))
    36173873        (ILLOP-IF-PAGE-FAULT)
     
    36233879        ((VMA-START-WRITE) ADD M-K A-V-REGION-LIST-THREAD)
    36243880        (CHECK-PAGE-WRITE)
    3625         ((VMA-START-READ) ADD M-4 A-V-REGION-LIST-THREAD)       ;UNTHREAD M-4 REGION
    3626         (CHECK-PAGE-READ)
    3627         ((WRITE-MEMORY-DATA) READ-MEMORY-DATA)  ;COMPLETE READ CYCLE
    3628         ((VMA-START-WRITE) A-GC-TEM)            ;GUY WHO POINTED TO M-4 IS STILL IN A-GC-TEM
    3629         (CHECK-PAGE-WRITE)
    3630         (JUMP-XCT-NEXT FREE-REGION-S-4)
    3631        ((M-K) M-4)
    3632 
    3633 ;NO ADJACENCY, ADD THIS REGION TO FREE-AREA
    3634 FREE-REGION-7
    3635         ((M-TEM) (A-CONSTANT (EVAL (FIND-POSITION-IN-LIST 'FREE-AREA AREA-LIST))))
    3636         ((VMA-START-READ) ADD M-TEM A-V-AREA-REGION-LIST)
    3637         (CHECK-PAGE-READ)
    3638         ((A-TEM2) READ-MEMORY-DATA)
    3639         ((WRITE-MEMORY-DATA-START-WRITE) Q-POINTER M-K
    3640                 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
    3641         (CHECK-PAGE-WRITE)
    3642         ((WRITE-MEMORY-DATA) A-TEM2)
    3643         (POPJ-AFTER-NEXT
    3644          (VMA-START-WRITE) ADD M-K A-V-REGION-LIST-THREAD)
    3645        (CHECK-PAGE-WRITE)
     3881        ;; Remove from ADDRESS-SPACE-MAP
     3882        ;; Referencing these addresses will halt in PAGE-IN-GET-MAP-BITS
     3883        ((M-T) M-1)
     3884FREE-REGION-1
     3885        (CALL-XCT-NEXT ADDRESS-SPACE-MAP-STORE)
     3886       ((M-K) A-ZERO)
     3887        ((M-T) ADD M-T (A-CONSTANT (EVAL %ADDRESS-SPACE-QUANTUM-SIZE)))
     3888        (JUMP-LESS-THAN M-T A-2 FREE-REGION-1)
     3889        (POPJ-AFTER-NEXT (M-T) A-V-NIL)
     3890       (NO-OP)
    36463891
    36473892;Remove all information about the region in M-K from the page map,
     
    36743919;(%ALLOCATE-AND-INITIALIZE <data type for return> <data type for header> <header>
    36753920;                               <value for second word> <area> <nqs>)
     3921(ERROR-TABLE DEFAULT-ARG-LOCATIONS %ALLOCATE-AND-INITIALIZE PP PP PP PP PP PP)
     3922
    36763923XAAI (MISC-INST-ENTRY %ALLOCATE-AND-INITIALIZE)
     3924        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
     3925                Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
     3926    (ERROR-TABLE ARGTYP FIXNUM-GREATER-THAN-1 PP 5)
    36773927        ((M-1) Q-POINTER C-PDL-BUFFER-POINTER)  ;CHECK FOR ALLOC AT LEAST 2 WORDS
    3678         (CALL-LESS-THAN M-1 (A-CONSTANT 2) ILLOP)
     3928        (CALL-LESS-THAN M-1 (A-CONSTANT 2) TRAP)
     3929    (ERROR-TABLE ARGTYP FIXNUM-GREATER-THAN-1 PP 5)
    36793930        (CALL XALLB)                    ;ALLOCATE BLOCK, RETURN IN M-T, NO SEQUENCE BREAK
    3680                                         ; WHILE CRUFT IS PARTIALLY INITIALIZED
     3931                                        ; WHILE CRUFT IS PARTIALLY INITIALIZED.  POPS LAST ARG.
    36813932        ((VMA) ADD M-T (A-CONSTANT 1))  ;-> SECOND WORD
    36823933        ((WRITE-MEMORY-DATA-START-WRITE) C-PDL-BUFFER-POINTER-POP)
     
    36923943;(%ALLOCATE-AND-INITIALIZE-ARRAY <header as fixnum> <index length> <leader length>
    36933944;                                       <area> <nqs>)
     3945(ERROR-TABLE DEFAULT-ARG-LOCATIONS %ALLOCATE-AND-INITIALIZE-ARRAY PP PP PP PP PP)
     3946
    36943947XAAIA (MISC-INST-ENTRY %ALLOCATE-AND-INITIALIZE-ARRAY)
    36953948        (CALL XALLB)                    ;ALLOCATE BLOCK, RETURN IN M-T, NO SEQUENCE BREAK
     
    37013954                (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-ARRAY-POINTER)))
    37023955        ((M-E) ADD M-T A-B)             ;UPPER BOUND OF STORAGE, SAME DATA-TYPE AS M-T
     3956        ((M-E) SUB M-E (A-CONSTANT 1))          ;LAST LOCATION TO BE FILLED
    37033957        ((M-C) Q-POINTER C-PDL-BUFFER-POINTER-POP)      ;LEADER LENGTH
    37043958        ((M-B) Q-POINTER C-PDL-BUFFER-POINTER-POP)      ;INDEX LENGTH
     
    37243978        ;; THIS IS A NUMERIC OR STRING ARRAY, FILL WITH ZEROS
    37253979        ((WRITE-MEMORY-DATA) M-ZERO)
    3726         ((M-E) SUB M-E (A-CONSTANT 1))          ;LAST LOCATION TO BE FILLED
    37273980        (JUMP-GREATER-OR-EQUAL VMA A-E XAAIA3)  ;JUMP IF ZERO-LENGTH ARRAY
    37283981XAAIA2  ((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))
     
    37403993XALLB   (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
    37413994                Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    3742   (ERROR-TABLE ARGTYP FIXNUM PP NIL)
    3743         ((M-B) Q-POINTER C-PDL-BUFFER-POINTER-POP)      ;ARG 2 NUMBER OF QS
     3995  (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP NIL)
     3996        (CALL-IF-BIT-SET-XCT-NEXT BOXED-SIGN-BIT C-PDL-BUFFER-POINTER TRAP)
     3997       ((M-B) Q-POINTER C-PDL-BUFFER-POINTER-POP)       ;ARG 2 NUMBER OF QS
     3998  (ERROR-TABLE ARGTYP POSITIVE-FIXNUM M-B NIL)
    37443999        (CALL-XCT-NEXT SCONS)
    37454000       ((M-S) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;ARG 1 AREA
    3746         (JUMP FILL-WITH-NILS)
     4001        (JUMP-XCT-NEXT FILL-WITH-THINGS)
     4002       ((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL)
    37474003
    37484004;SUBROUTINE TO CONS UP A LIST OF NILS.  ARGS LIKE LCONS.
    37494005;NOTE THAT DATA-TYPE RETURNED IN M-T IS GARBAGE.
    37504006LIST-OF-NILS
     4007        ((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL)
     4008
     4009;SUBROUTINE TO CONS UP A LIST OF THINGS.  THE THING TO BE CONSED IS ON THE
     4010;STACK.  OTHERWISE, ARGS LIKE NCONS.  NOTE THAT DATA-TYPE RETURNED IN M-T
     4011;IS GARBAGE.
     4012LIST-OF-THINGS
    37514013        (CALL LCONS)
    3752 FILL-WITH-NILS
     4014FILL-WITH-THINGS
    37534015        ((M-3) M-B)                             ;NUMBER OF CELLS TO INITIALIZE
    3754         ((WRITE-MEMORY-DATA) DPB (M-CONSTANT -1) Q-CDR-CODE A-V-NIL)    ;CDR-NEXT
     4016        ((WRITE-MEMORY-DATA) LDB C-PDL-BUFFER-POINTER-POP       ;CDR-NEXT
     4017                Q-ALL-BUT-CDR-CODE (A-CONSTANT -1))
    37554018        ((VMA) SUB M-T (A-CONSTANT 1))
    3756         (JUMP-LESS-OR-EQUAL M-3 (A-CONSTANT 1) FILL-WITH-NILS-1)
    3757 FILL-WITH-NILS-0
     4019        (JUMP-LESS-OR-EQUAL M-3 (A-CONSTANT 1) FILL-WITH-THINGS-1)
     4020FILL-WITH-THINGS-0
    37584021        ((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))
    37594022        (CHECK-PAGE-WRITE)
    3760         (JUMP-GREATER-THAN-XCT-NEXT M-3 (A-CONSTANT 2) FILL-WITH-NILS-0)
     4023        (JUMP-GREATER-THAN-XCT-NEXT M-3 (A-CONSTANT 2) FILL-WITH-THINGS-0)
    37614024       ((M-3) SUB M-3 (A-CONSTANT 1))
    3762 FILL-WITH-NILS-1
     4025FILL-WITH-THINGS-1
    37634026        ((WRITE-MEMORY-DATA) Q-ALL-BUT-CDR-CODE WRITE-MEMORY-DATA
    37644027                        (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
     
    37974060        (CHECK-PAGE-READ)
    37984061        (POPJ-EQUAL M-T A-V-NIL)                ;Return NIL if garbage pointer input
    3799         ((M-B) Q-POINTER READ-MEMORY-DATA)      ;Origin address of region
     4062        ((M-B) Q-TYPED-POINTER READ-MEMORY-DATA)        ;Origin address of region
    38004063        ((VMA-START-READ) ADD M-T A-V-REGION-BITS)      ;Get representation type
    38014064        (CHECK-PAGE-READ)
     
    38654128        (INHIBIT-XCT-NEXT-BIT XFSHSI)           ;INSTANCE-HEADER
    38664129        (XFSHS1)                                ;ENTITY
     4130        (XFSHS1)                                ;STACK-CLOSURE
    38674131 (REPEAT NQZUSD-1 (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
    38684132        (XFSHS1)                                ;DATA-TYPE 37
     
    39774241
    39784242STRUCTURE-INFO
    3979         (DISPATCH MAP-STATUS-CODE MEMORY-MAP-DATA D-ASSURE-MAP-VALID)
     4243        (DISPATCH MAP-STATUS-CODE MEMORY-MAP-DATA D-GET-MAP-BITS) ;Ensure validity of meta bits
    39804244        ((M-K) MAP-SECOND-LEVEL-MAP MEMORY-MAP-DATA)    ;FOR DISPATCH BELOW, AND
    39814245                                                ; RETURNED TO CALLER.  NOTE 0 IN SIGN BIT.
     
    40514315        (INHIBIT-XCT-NEXT-BIT SINFSI)           ;INSTANCE-HEADER
    40524316        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;ENTITY
     4317        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;STACK-CLOSURE
    40534318 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
    40544319(END-DISPATCH)
     
    40644329;DTP-HEADER-FORWARD - include all DTP-BODY-FORWARD's that point here as unboxed Q's
    40654330SINFS-HFWD
    4066         (CALL-XCT-NEXT XRGN00)                  ;M-T gets region number
    4067        ((M-A MD) Q-POINTER VMA)
     4331        (CALL-XCT-NEXT XRGN1)                   ;M-T gets region number
     4332       ((M-A) Q-POINTER VMA (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
    40684333        ((VMA-START-READ) ADD M-T A-V-REGION-ORIGIN)
    40694334        (CHECK-PAGE-READ)
     
    41154380        (P-BIT ILLOP)   ;%HEADER-TYPE-COMPLEX
    41164381        (SINF-BIG)      ;%HEADER-TYPE-BIGNUM
    4117         (P-BIT ILLOP)   ;%HEADER-TYPE-RATIONAL-BIGNUM
     4382        (SINF-RAT)      ;%HEADER-TYPE-RATIONAL-BIGNUM
    41184383(REPEAT NHDUSD (P-BIT ILLOP))
    41194384(END-DISPATCH)
     
    41234388        (POPJ-AFTER-NEXT (M-4) (A-CONSTANT 2))  ;2 unboxed Q's
    41244389       (NO-OP) 
     4390
     4391SINF-RAT
     4392        (POPJ-AFTER-NEXT (M-3) (A-CONSTANT 3))  ;Headers and two number pointers.
     4393       (NO-OP)
    41254394
    41264395SINF-BIG
     
    42474516        (R-BIT)                                 ;STACK-GROUP HEAD
    42484517        (SINF-BNDPDL)                           ;BINDING-PDL
    4249         (INHIBIT-XCT-NEXT-BIT SINFSA-32B)       ;TV BUFFER
     4518        (INHIBIT-XCT-NEXT-BIT SINFSA-16B)       ;HALF-FIX
    42504519        (SINF-REGPDL)                           ;REG-PDL
    42514520        (INHIBIT-XCT-NEXT-BIT SINFSA-FLOAT)     ;FLOAT
     4521        (INHIBIT-XCT-NEXT-BIT SINFSA-32B)       ;FPS-FLOAT
     4522        (INHIBIT-XCT-NEXT-BIT SINFSA-16B)       ;FAT-STRING
    42524523 (REPEAT NATUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))
    42534524(END-DISPATCH)
     
    44114682
    44124683;GET ADDR ARG IN M-2, PDL ARG IN M-1, ERROR UNLESS BOTH FIXNUMS
    4413 FIXGET  (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)           ;GET PDL ARG
     4684FIXGET          (ERROR-TABLE RESTART FIXGET)
     4685        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)           ;GET PDL ARG
    44144686                        Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    4415    (ERROR-TABLE ARGTYP FIXNUM PP 0)
     4687   (ERROR-TABLE ARGTYP FIXNUM PP 0 FIXGET)
     4688   (ERROR-TABLE ARG-POPPED 0 PP M-T)
    44164689        ((M-1) C-PDL-BUFFER-POINTER-POP)
     4690                (ERROR-TABLE RESTART FIXGET0)
    44174691        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP) Q-DATA-TYPE M-T TRAP-UNLESS-FIXNUM)
    4418    (ERROR-TABLE ARGTYP FIXNUM M-T 1)
     4692   (ERROR-TABLE ARGTYP FIXNUM M-T 1 FIXGET0)
     4693   (ERROR-TABLE ARG-POPPED 0 PP M-T)
    44194694FIXGET-1
    44204695        ((OA-REG-HIGH) BOXED-SIGN-BIT M-T)              ;SIGN EXTEND (MUNG M SOURCE)
     
    44314706;M-1 HOLDS THE FIRST ARG, SQUARED N TIMES.
    44324707;M-T HOLDS THE PARTIAL PRODUCTS
     4708
     4709(ERROR-TABLE DEFAULT-ARG-LOCATIONS ^ PP PP)
    44334710
    44344711XUPARROW (MISC-INST-ENTRY ^)
     
    45394816QIBNDN  (CALL QBND1)            ;SAVE PRESENT BINDING
    45404817        ((M-T) A-V-NIL)         ;AND RE-BIND TO NIL
    4541 QIBDN1  ((VMA-START-READ) DPB M-B Q-POINTER
    4542                 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
    4543         (CHECK-PAGE-READ)
    4544         (DISPATCH TRANSPORT-NO-EVCP-WRITE READ-MEMORY-DATA)  ;CHASE FORWARDING PTR IF ANY
    4545         ((M-T WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT M-E
     4818QIBDN1  ((M-T WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT M-E
    45464819                Q-ALL-BUT-TYPED-POINTER A-T)
    45474820        (CHECK-PAGE-WRITE)
     
    45524825        (JUMP-XCT-NEXT QIBDN1)  ;AND REBIND TO POP(PDL)
    45534826       ((M-T) C-PDL-BUFFER-POINTER-POP)
     4827
     4828XUBI  (MISC-INST-ENTRY %USING-BINDING-INSTANCES)  ;One arg, a list of binding instances.
     4829        (JUMP-XCT-NEXT QCLS1)
     4830       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
    45544831
    45554832XBIND (MISC-INST-ENTRY BIND)
     
    45594836        (CALL-NOT-EQUAL M-ZR (A-CONSTANT (EVAL DTP-LOCATIVE)) TRAP)
    45604837   (ERROR-TABLE ARGTYP LOCATIVE PP 0 XBIND)
     4838   (ERROR-TABLE ARG-POPPED 0 PP M-T)
    45614839XBIND1  (JUMP-XCT-NEXT QIBDN1)
    45624840       (CALL QBND2)
     
    46554933
    46564934;;;ACTIVATE PENDING CALL
    4657 QMRCL   ((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER A-IPMARK)    ;COUNT ARGUMENTS
     4935QMRCL   (CALL-IF-BIT-SET M-TRAP-ON-CALLS TRAP)
     4936    (ERROR-TABLE CALL-TRAP)
     4937        ((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER A-IPMARK)    ;COUNT ARGUMENTS
    46584938        ((M-R) PDL-BUFFER-INDEX)                ;M-R PASSES ARG COUNT TO CALLED FCTN
     4939;Can someone add a comment saying what is wrong with
     4940;just storing the result of the subtraction in M-R?
    46594941        ((PDL-BUFFER-INDEX M-S) A-IPMARK)       ;GET FEF POINTER POINTER
    46604942        ((M-A) C-PDL-BUFFER-INDEX)              ;M-A := FUNCTION TO CALL
     
    48165098        (CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-INSTANCE-HEADER)) TRAP)
    48175099                (ERROR-TABLE DATA-TYPE-SCREWUP DTP-INSTANCE-HEADER)
     5100        ((M-A) VMA)                     ;Possibly-forwarded instance is where inst vars are
    48185101        ((M-C) Q-POINTER READ-MEMORY-DATA       ;Get address of instance-descriptor
    48195102                (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
     
    48435126        (CALL QBND4)                    ;Bind it up
    48445127        ((WRITE-MEMORY-DATA-START-WRITE) Q-TYPED-POINTER M-D A-E)
    4845         (CHECK-PAGE-WRITE)
     5128        (CHECK-PAGE-WRITE-BIND)
    48465129CALL-INSTANCE-2
    48475130        (DISPATCH Q-CDR-CODE M-B D-CALL-INSTANCE)       ;More bindings if this was CDR-NEXT
     
    48895172        (CALL-XCT-NEXT QCDR)
    48905173       ((M-T) C-PDL-BUFFER-POINTER-POP) ;GET BACK CLOSURE AND CDR IT.
    4891         (JUMP-EQUAL M-T A-V-NIL QCLS2)  ;Jump if no bindings to do
    4892 QCLS1   (CALL-XCT-NEXT QCAR)
     5174        (CALL QCLS1)
     5175QCLS2   ((PDL-BUFFER-INDEX) M-S)
     5176        (DISPATCH Q-DATA-TYPE M-A D-QMRCL)
     5177       (NO-OP)                  ;LEAVE, IF ANY, ALREADY DONE
     5178
     5179QCLS1   (POPJ-EQUAL M-T A-V-NIL)        ;Return if no bindings to do
     5180        (CALL-XCT-NEXT QCAR)
    48935181       ((M-D) M-T)
    48945182        ((M-B) M-T)                     ;Locn to bind
     
    49095197        (CALL QBND4)                    ;Bind it up
    49105198        ((WRITE-MEMORY-DATA-START-WRITE) Q-TYPED-POINTER M-T A-E)
    4911         (CHECK-PAGE-WRITE)
     5199        (CHECK-PAGE-WRITE-BIND)
    49125200QCLS3   (CALL-XCT-NEXT QCDR)
    49135201       ((M-T) M-D)
    4914         (JUMP-NOT-EQUAL M-T A-V-NIL QCLS1)
    4915 QCLS2   ((PDL-BUFFER-INDEX) M-S)
    4916         (DISPATCH Q-DATA-TYPE M-A D-QMRCL)
    4917        (NO-OP)                  ;LEAVE, IF ANY, ALREADY DONE
     5202        (JUMP QCLS1)
     5203
    49185204
    49195205
     
    49485234  ; THIS SERVES AS AN "OTHERWISE" CLAUSE.
    49495235        (CALL TRAP)                     ;SELECTED METHOD NOT FOUND
    4950   (ERROR-TABLE SELECTED-METHOD-NOT-FOUND M-A)
     5236  (ERROR-TABLE SELECTED-METHOD-NOT-FOUND M-A M-C)
    49515237
    49525238CSM-R   (JUMP-XCT-NEXT CSM-5)               ;RESUME SEARCH AT SAVED POINT
     
    49815267                                                                 ; IMMEDIATELY RETURN.
    49825268        (CALL-NOT-EQUAL M-ZR (A-CONSTANT (EVAL DTP-SELECT-METHOD)) TRAP)
    4983  (ERROR-TABLE SELECT-METHOD-BAD-SUBROUTINE-CALL)
     5269 (ERROR-TABLE SELECT-METHOD-BAD-SUBROUTINE-CALL M-A)
    49845270        (JUMP-XCT-NEXT CSM-3)
    49855271       ((M-T) LDB Q-POINTER READ-MEMORY-DATA
     
    50835369        ((VMA-START-READ) ADD M-D A-V-MICRO-CODE-ENTRY-AREA)  ;IF THIS A FIXNUM, ITS
    50845370        (CHECK-PAGE-READ)           ;INDEX TO MICRO-CODE-SYMBOL-AREA.  OTHERWISE, FCTN
     5371        ((M-ERROR-SUBSTATUS) A-ZERO)
    50855372        ((M-T) READ-MEMORY-DATA)    ;IS NOT REALLY MICROCODED NOW, AND THIS IS OTHER DEF.
    50865373        ((M-TEM) Q-DATA-TYPE M-T)   ;IF SO, PUT THIS IN LP-FEF SLOT AND TRY AGAIN.
     
    51155402
    51165403;;; DESTINATION RETURN  value in M-T.  Q-ALL-BUT-TYPED-POINTER bits must be 0.
    5117 QMDDR   (JUMP-NOT-EQUAL M-AP A-IPMARK QMDDR-THROW) ;CHECK FOR UNWIND-PROTECT
     5404QMDDR   ((M-TEM) Q-DATA-TYPE M-T)
     5405        (CALL-EQUAL M-TEM (A-CONSTANT (EVAL DTP-STACK-CLOSURE))
     5406                    STACK-CLOSURE-RETURN-TRAP)
     5407        (JUMP-NOT-EQUAL M-AP A-IPMARK QMDDR-THROW) ;CHECK FOR UNWIND-PROTECT
    51185408QMDDR0  (CALL-IF-BIT-SET M-QBBFL BBLKP)         ;POP BINDING BLOCK (IF STORED ONE)
    5119 QMEX1   ((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-CALL-STATE)))
    5120         ((M-C) C-PDL-BUFFER-INDEX)              ;M-C := CALL STATE
     5409QMEX1   ((PDL-BUFFER-INDEX) M-AP)               ;Save returning function for metering
     5410        ((M-A) C-PDL-BUFFER-INDEX)
     5411        ((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-CALL-STATE)))
     5412        ((M-C) C-PDL-BUFFER-INDEX)
     5413        (CALL-IF-BIT-SET (LISP-BYTE %%LP-CLS-TRAP-ON-EXIT) C-PDL-BUFFER-INDEX QMEX1-TRAP)
     5414        ((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-ENTRY-STATE)))
     5415        (CALL-IF-BIT-SET (LISP-BYTE %%LP-ENS-ENVIRONMENT-POINTER-POINTS-HERE)
     5416                         C-PDL-BUFFER-INDEX
     5417                         QMEX1-COPY)
    51215418        ;;*** next 2 instructions are temporary
    51225419        ((M-TEM) MICRO-STACK-POINTER)
     
    51345431        ((M-PDL-BUFFER-ACTIVE-QS) SUB M-PDL-BUFFER-ACTIVE-QS A-TEM1)
    51355432        ;; Make sure frame being returned to is in the pdl buffer
    5136         (CALL-LESS-THAN M-PDL-BUFFER-ACTIVE-QS 
     5433        (CALL-LESS-THAN M-PDL-BUFFER-ACTIVE-QS
    51375434                        (A-CONSTANT PDL-BUFFER-LOW-WARNING) PDL-BUFFER-REFILL)
    51385435        ;; Now restore the state of the frame being returned to.  We will restore
    51395436        ;; the FEF stuff even if it's not a FEF frame, at the cost of a slight
    51405437        ;; amount of time.
     5438        (CALL-IF-BIT-SET (LISP-BYTE %%METER-FUNCTION-ENTRY-EXIT-ENABLE)
     5439                M-METER-ENABLES METER-FUNCTION-EXIT)
    51415440        ((M-A) Q-POINTER C-PDL-BUFFER-INDEX)    ;FUNCTION RETURNING TO
    51425441        ((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-ENTRY-STATE)))
     
    51555454                        (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
    51565455
     5456;Here from QMDDR if data type of M-T is DTP-STACK-CLOSURE.
     5457;Copy the closure into the heap, in case the frame it is in
     5458;is about to go away.
     5459STACK-CLOSURE-RETURN-TRAP
     5460        ((MD) M-T)
     5461        ((VMA) A-MINUS-ONE)
     5462        (GC-WRITE-TEST)
     5463        (POPJ-XCT-NEXT)
     5464       ((M-T) MD)
     5465
     5466;;; M-A has the function returning from
     5467METER-FUNCTION-EXIT
     5468        ((A-METER-EVENT) (A-CONSTANT (EVAL %METER-FUNCTION-EXIT-EVENT)))
     5469        ((C-PDL-BUFFER-POINTER-PUSH) M-A)
     5470        (JUMP-XCT-NEXT METER-MICRO-WRITE-HEADER)
     5471       ((A-METER-LENGTH) (A-CONSTANT 1))        ;Number of meters pushed
     5472
     5473;This is here so I can put breakpoints before and after trapping.
     5474QMEX1-TRAP
     5475        ((VMA) A-ZERO)          ;Avoid illop due to pointer not in any region,
     5476        ((M-Q) A-ZERO)          ;which seems frequently to be true of VMA at QMEX1.
     5477        (CALL TRAP)
     5478    (ERROR-TABLE EXIT-TRAP)
     5479        (POPJ)
     5480
     5481
     5482;Copy the frame being exited into a list, if it has the bit set
     5483;saying that an environment pointer points at it.
     5484;The pointers to the frame are all in copied closure values of
     5485;LEXICAL-ENVIRONMENT, and all of them are in cells pointed to
     5486;by EVCPs located in the locals of this frame!  So we can find those
     5487;pointers and make them point instead at the newly made list copy.
     5488
     5489;Must preserve M-A and M-C, as well as M-T (the returned value).
     5490;Assumes PDL-BUFFER-INDEX points at the %LP-ENTRY-STATUS word of the frame.
     5491QMEX1-COPY
     5492        ((C-PDL-BUFFER-POINTER-PUSH) M-T)
     5493        ((M-K) LDB (LISP-BYTE %%LP-ENS-MACRO-LOCAL-BLOCK-ORIGIN) C-PDL-BUFFER-INDEX)
     5494;Get number of locals in frame, from the fef.
     5495        ((PDL-BUFFER-INDEX) M-AP)
     5496        ((VMA-START-READ) ADD C-PDL-BUFFER-INDEX (A-CONSTANT (EVAL %FEFHI-MISC)))
     5497        (CHECK-PAGE-READ)
     5498        ((M-B) (LISP-BYTE %%FEFHI-MS-LOCAL-BLOCK-LENGTH) READ-MEMORY-DATA)
     5499;M-B now has number of locals in the frame.
     5500;Save it for much later (QMEX1-FIND-CLOSURES).
     5501;Also get the total size of frame data to be copied.
     5502        ((C-PDL-BUFFER-POINTER-PUSH) M-B)
     5503        ((M-B) ADD M-B A-K)     
     5504;Cons a block that big, preserving the size in B.
     5505        ((C-PDL-BUFFER-POINTER-PUSH) M-B)
     5506        (CALL-XCT-NEXT LCONS)
     5507       ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-BACKGROUND-CONS-AREA)
     5508        ((M-B) C-PDL-BUFFER-POINTER-POP)
     5509        ((PDL-BUFFER-INDEX) M-AP)
     5510        ((VMA) M-T)
     5511        ((C-PDL-BUFFER-POINTER-PUSH) M-T)
     5512;Copy the args and locals into the newly consed list.
     5513;M-B has # left to copy, PDL-BUFFER-INDEX has where to copy from,
     5514;VMA has where to copy to.
     5515QMEX1-COPY-LOOP
     5516        ((MD-START-WRITE) Q-TYPED-POINTER C-PDL-BUFFER-INDEX
     5517                          (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))
     5518        ((PDL-BUFFER-INDEX) M+1 PDL-BUFFER-INDEX)
     5519        (CHECK-PAGE-WRITE)
     5520        ((M-B) SUB M-B (A-CONSTANT 1))
     5521        (JUMP-GREATER-THAN-XCT-NEXT M-B A-ZERO QMEX1-COPY-LOOP)
     5522       ((VMA) M+1 VMA)
     5523;Store CDR-NIL into the last word.
     5524        ((VMA) SUB VMA (A-CONSTANT 1))
     5525        ((MD-START-WRITE) Q-TYPED-POINTER MD
     5526                          (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
     5527        (CHECK-PAGE-WRITE)
     5528;Get back the pointer to this list and store it
     5529;into the forwarded copies of all the stack closures in this frame.
     5530;Find them by scanning thru the frame's locals.
     5531        (CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
     5532       ((M-K) M-AP)
     5533;M-D and M-T get original stack frame and copy, both with DTP-LIST.
     5534        ((M-D) M-K Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
     5535        ((M-T) LDB C-PDL-BUFFER-POINTER-POP Q-POINTER
     5536               (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
     5537        ((M-B) C-PDL-BUFFER-POINTER-POP)        ;pop number of locals.
     5538        ((M-K) A-LOCALP)        ;Get pdl index of first local.
     5539QMEX1-FIND-FORWARDS
     5540;Look for a local that is a forwarded list.
     5541        ((PDL-BUFFER-INDEX) M-K)
     5542        ((M-TEM) Q-DATA-TYPE C-PDL-BUFFER-INDEX)
     5543        (JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-EXTERNAL-VALUE-CELL-POINTER))
     5544             QMEX1-NOT-FORWARD)
     5545;Yes, find where forwarded to,
     5546;and if it points at our stack frame,
     5547;make it point at the new copy instead.
     5548        ((VMA-START-READ) C-PDL-BUFFER-INDEX)
     5549        (CHECK-PAGE-READ)
     5550        ((M-TEM) Q-TYPED-POINTER MD)
     5551        (JUMP-NOT-EQUAL M-TEM A-D QMEX1-NOT-FORWARD)
     5552        ((MD-START-WRITE) DPB MD Q-ALL-BUT-TYPED-POINTER A-T)
     5553        (CHECK-PAGE-WRITE)
     5554QMEX1-NOT-FORWARD
     5555        ((M-B) SUB M-B (A-CONSTANT 1))
     5556        (JUMP-GREATER-THAN-XCT-NEXT M-B A-ZERO QMEX1-FIND-FORWARDS)
     5557       ((M-K) M+1 M-K)
     5558        (POPJ-XCT-NEXT)
     5559       ((M-T) C-PDL-BUFFER-POINTER-POP)
     5560
    51575561
    51585562;Restore the micro-stack from the binding stack
     
    51885592
    51895593;STORE LAST VALUE IN ADI CALL, FLUSH ADI FROM PDL
    5190 ;MAY CLOBBER ALL REGISTERS EXCEPT M-C
     5594;MAY CLOBBER ALL REGISTERS EXCEPT M-C and M-A
    51915595QRAD1   ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QRAD1R)))  ;DONT CARE IF THIS
    51925596                                                        ; LAST OR NOT.
     
    52085612                Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    52095613  (ERROR-TABLE ARGTYP FIXNUM PP NIL)
     5614  (ERROR-TABLE ARG-POPPED 0 PP)
    52105615        ((M-C) Q-POINTER C-PDL-BUFFER-POINTER-POP) ;NUMBER OF VALUES TO RETURN
    52115616XRETN1  ((M-C) SUB M-C (A-CONSTANT 1))
    52125617        (JUMP-LESS-OR-EQUAL M-C A-ZERO XRETN2) ;LAST
    52135618        ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMDDR-KLUDGE))) ;RETURN ON LAST VAL
     5619        ((M-S) A-ZERO)
    52145620        (CALL-XCT-NEXT XRNVRPI)
    52155621       ((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER A-C)  ;NEXT ARGUMENT SLOT
     
    52185624XRET3 (MISC-INST-ENTRY %RETURN-3)
    52195625        ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMDDR-KLUDGE))) ;RETURN ON LAST VAL
     5626        ((M-S) A-ZERO)
    52205627        (CALL-XCT-NEXT XRNVRPI)
    52215628       ((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 2))
    52225629XRET2 (MISC-INST-ENTRY %RETURN-2)
    52235630        ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMDDR-KLUDGE))) ;RETURN ON LAST VAL
     5631        ((M-S) A-ZERO)
    52245632        (CALL-XCT-NEXT XRNVRPI)
    52255633       ((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 1))
     
    52285636
    52295637
     5638(ERROR-TABLE DEFAULT-ARG-LOCATIONS RETURN-LIST M-A)
     5639
    52305640XRETURN-LIST (MISC-INST-ENTRY RETURN-LIST)      ;This is always used with dest D-RETURN!
     5641        ((M-A) Q-TYPED-POINTER C-PDL-BUFFER-POINTER)
     5642        (JUMP-EQUAL M-A A-V-NIL RETURN-NO-VALUES)
     5643XRETURN-LIST1
    52315644        (CALL-XCT-NEXT QMD)                     ;Get cdr of list
    52325645       ((M-T) C-PDL-BUFFER-POINTER)
     
    52375650        ;Push the address to return to if have no more values wanted (return via QMDDR)
    52385651        ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC CPOPJ)))
     5652        ((M-S) A-ZERO)
    52395653        (CALL XRNVR)
    5240         (JUMP-XCT-NEXT XRETURN-LIST)
     5654        (JUMP-XCT-NEXT XRETURN-LIST1)
    52415655       ((C-PDL-BUFFER-POINTER-PUSH) M-C)
     5656
     5657;Come here with a NIL on the top of the stack.  Calls XRNVR with the M-S flag,
     5658;and either return returns to QMDDR.  We go through MVR so that in case the
     5659;caller used a multiple-value-list, we will clobber the ADI so that QMDDR won't
     5660;return any values into that list.
     5661RETURN-NO-VALUES
     5662        ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;Value is NIL, and flush the stack.
     5663        ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC CPOPJ)))
     5664        ((M-S) (A-CONSTANT 1))
     5665        (CALL XRNVR)
     5666        (POPJ)
    52425667
    52435668XRNV (MISC-INST-ENTRY RETURN-NEXT-VALUE)
    52445669        ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMDDR-KLUDGE))) ;GO TO QMDDR IF LAST
    52455670                                                ;  VALUE.
     5671        ((M-S) A-ZERO)
    52465672        (CALL-XCT-NEXT XRNVR)
    52475673       ((M-T) C-PDL-BUFFER-POINTER-POP)         ;FROB TO RETURN
     5674   (ERROR-TABLE ARG-POPPED 0 M-T)
    52485675        (POPJ)                                  ;NOT LAST VALUE, RETURN TO MAIN LOOP
    52495676
     
    52605687;For speed, we try to avoid taking page faults when referencing the pdl buffer.
    52615688;M-K will have the virtual address being referenced, MD its contents.
     5689;M-S must have the flag for MVR (q.v.).
    52625690XRNVRPI ((M-T) C-PDL-BUFFER-INDEX)              ;Return value from PDL[PI]
    52635691XRNVR   ((M-K) ADD M-AP (A-CONSTANT (EVAL %LP-CALL-STATE)))
     
    52735701
    52745702XRNVR2  (JUMP-IF-BIT-CLEAR (LISP-BYTE %%LP-CLS-ADI-PRESENT) MD XRNVX)   ;Not doing mult vals
    5275         (JUMP-XCT-NEXT MVR)                     ;Go return multiple values from this frame
    5276        ((M-S) (A-CONSTANT 1))
     5703        (JUMP MVR)                              ;Go return multiple values from this frame
    52775704
    52785705;MD gets contents of untyped virtual address in M-K, when likely to be in pdl buffer
     
    52995726;Documentation on calling sequence for XRNVR/MVR:
    53005727;M-T has the value to be returned.
    5301 ;M-S has a flag which is 1 when calling from a return-next-value operation,
    5302 ; 0 when called from QRAD1.  If M-S is 1 then if this is the last value expected
    5303 ; it should be returned the usual QMDDR way; QRAD1 will then be called which will
    5304 ; come back here to store the value.  At that point the ADI-RETURN-INFO will
    5305 ; be changed into ADI-USED-UP-RETURN-INFO which prevents accidentally returning
    5306 ; the same value more than once (which I don't think can happen anyway any more).
     5728;M-K has virtual address of LPCLS Q for the frame from which value is to be returned.
     5729;M-S has a flag which is 1 when we are returning no values; this only happens
     5730; from (return-list nil).
     5731;The calling sequence is hairy to implement the feature that if the callee returns
     5732;a value and the caller does not want further values after that one, the function
     5733;suddenly returns.
    53075734;There are two return addresses on the micro-stack.  If this was the last value
    53085735; expected, the first return is taken; if more values are expected the second
    53095736; return is taken.  In the return-next-value case the first return should be
    5310 ; QMDDR.  In the QRAD1 case both returns should be the same.
     5737; QMDDR, causing a sudden return.  In the QRAD1 case both returns should be the same,
     5738; since we are returning anyway whether or not this is the last value.
    53115739; In any case, both returns are flushed from the stack.
     5740;The sudden return works by storing the value in the block, as usual, and then
     5741; going to QMDDR to get the stack unwound and all, BUT first clobbering the
     5742; ADI type to be ADI-USED-UP-RETURN-INFO so that QMDDR won't store the value
     5743; all over again.
    53125744
    53135745;  ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC <THAT-WAS-LAST-VALUE-RETURN>)))
     
    53165748
    53175749;Clobbers A-TEM1, M-I, M-J, M-S, M-R, M-K plus calls QRDR1 (which doesnt clobber any more)
    5318 ;Plus calls CONS, which clobbers more.  Protects M-C but probably not anything else.
     5750;Plus calls CONS, which clobbers more.  Protects M-C and M-A but probably not anything else.
    53195751
    53205752;At this point M-K has the virtual address of the LPCLS Q for the frame
     
    53495781;Store in block
    53505782MVRB    (CALL-LESS-OR-EQUAL M-I A-ZERO ILLOP)   ;Returning too many values
    5351         (JUMP-EQUAL M-I A-S XRNVX)              ;Last and not doing return, turn into QMDDR!!
    53525783        ((M-I) SUB M-I (A-CONSTANT 1))
    53535784        ((M-TEM) MD)                            ;Store back decremented values count
    53545785        ((MD M-TEM) DPB M-I (LISP-BYTE %%ADI-RET-NUM-VALS-EXPECTING) A-TEM)
    5355         (JUMP-NOT-EQUAL M-S A-ZERO MVRB0)       ;From return, make it used-up.
     5786        (JUMP-NOT-EQUAL M-I A-ZERO MVRB0)       ;If last val expected, clobber ADI.
    53565787        ((MD) DPB (M-CONSTANT -1) (LISP-BYTE %%ADI-TYPE) A-TEM)
    53575788MVRB0   (CALL MKWRIT)
     
    53605791        (DISPATCH TRANSPORT READ-MEMORY-DATA)
    53615792        (CALL-XCT-NEXT MKWRIT)
    5362        ((MD M-I) ADD MD (A-CONSTANT 1))
    5363 MVRB1   ((VMA-START-READ) SUB M-I (A-CONSTANT 1))       ;No transport, since writing and no
     5793       ((MD M-R) ADD MD (A-CONSTANT 1))
     5794MVRB1   ((VMA-START-READ) SUB M-R (A-CONSTANT 1))       ;No transport, since writing and no
    53645795MVRB2   (CHECK-PAGE-READ)                               ;need to follow invisible pntrs here
    53655796        ((WRITE-MEMORY-DATA-START-WRITE)        ;Store the value
    53665797                SELECTIVE-DEPOSIT READ-MEMORY-DATA Q-ALL-BUT-TYPED-POINTER A-T)
    53675798        (CHECK-PAGE-WRITE)
     5799        (JUMP-EQUAL M-I A-ZERO XRNVX)           ;This was the last value expected.
    53685800        (POPJ-AFTER-NEXT GC-WRITE-TEST)         ;More expected, or doing return and that was
    53695801       ((M-GARBAGE) MICRO-STACK-DATA-POP)       ;last, take second return and flush first
     
    53755807;After the first time, it is a list-pointer to the last cons in the list.
    53765808;XNCONS mustn't clobber M-C, M-I, M-R; QRDR1 mustn't clobber M-C or M-R.
    5377 MVRC    ((M-TEM) MD)                            ;If from QRAD1, change to used-up-ADI
    5378         (CALL-EQUAL-XCT-NEXT M-S A-ZERO MKWRIT)
    5379        ((MD) DPB (M-CONSTANT -1) (LISP-BYTE %%ADI-TYPE) A-TEM)
     5809MVRC    (JUMP-EQUAL M-S (A-CONSTANT 1) MVRC1)   ;Returning no values?
    53805810        ((M-I) ADD M-K                          ;Save address of prev ADI Q
    53815811                (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE) -1)))
     
    53935823                ;and flush first return. (PNTR-AND-DATA necc. to avoid a byte-op)
    53945824
     5825;Returning no values.  Don't affect list, and clobber ADI-TYPE so that when
     5826;QRAD1 calls MVR, it won't affect the list either.
     5827MVRC1   ((M-TEM) MD)
     5828        ((MD) DPB (M-CONSTANT -1) (LISP-BYTE %%ADI-TYPE) A-TEM)
     5829        (CALL MKWRIT)
     5830        (POPJ-XCT-NEXT)                         ;More <infinite> values expected.
     5831       ((M-GARBAGE) MICRO-STACK-DATA-POP)
     5832
    53955833
    53965834;;; THROW CODE (*THROW, *UNWIND-STACK)
     
    54325870       ((M-GARBAGE) C-PDL-BUFFER-POINTER-POP)
    54335871
     5872METER-FUNCTION-UNWIND
     5873        ((A-METER-EVENT) (A-CONSTANT (EVAL %METER-FUNCTION-UNWIND-EVENT)))
     5874        (JUMP-XCT-NEXT METER-MICRO-WRITE-HEADER)
     5875       ((A-METER-LENGTH) M-ZERO)        ;Number of meters pushed
     5876
     5877;;; This like *UNWIND-STACK but takes its args in the order value, tag, count, action
     5878;;; and simply moves value to the destination if tag is NIL (normal exit from unwind-protect)
     5879XUWPCON (MISC-INST-ENTRY %UNWIND-PROTECT-CONTINUE)
     5880        ((A-CATCH-ACTION) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
     5881        ((A-CATCH-COUNT) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
     5882        ((M-1) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)        ;Tag
     5883        (POPJ-EQUAL-XCT-NEXT M-1 A-V-NIL)
     5884       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;Value
     5885        ((C-PDL-BUFFER-POINTER-PUSH) M-1)               ;Clobbered by meter code
     5886        (CALL-IF-BIT-SET (LISP-BYTE %%METER-FUNCTION-ENTRY-EXIT-ENABLE)
     5887                M-METER-ENABLES METER-FUNCTION-UNWIND)
     5888        (JUMP-XCT-NEXT XUWPCN1)                         ;Join *UNWIND-STACK
     5889       ((A-CATCH-MARK) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-U-ENTRY)
     5890                                         *CATCH-U-CODE-ENTRY-/#)))
     5891
    54345892XUWSTK (MISC-INST-ENTRY *UNWIND-STACK)
    54355893   (ERROR-TABLE RESTART *UNWIND-STACK)
     5894        (CALL-IF-BIT-SET-XCT-NEXT (LISP-BYTE %%METER-FUNCTION-ENTRY-EXIT-ENABLE)
     5895                M-METER-ENABLES METER-FUNCTION-UNWIND)
    54365896        ((A-CATCH-ACTION) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
    54375897        ((A-CATCH-COUNT) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
     
    54405900      ;                                  *CATCH-U-CODE-ENTRY-/#)))
    54415901
     5902(ERROR-TABLE DEFAULT-ARG-LOCATIONS *THROW A-CATCH-TAG M-T)
     5903
    54425904XTHROW (MISC-INST-ENTRY *THROW)
    54435905   (ERROR-TABLE RESTART *THROW)
     
    54455907        ((A-CATCH-MARK) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-U-ENTRY)
    54465908                                          *CATCH-U-CODE-ENTRY-/#)))
     5909        (CALL-IF-BIT-SET-XCT-NEXT (LISP-BYTE %%METER-FUNCTION-ENTRY-EXIT-ENABLE)
     5910                M-METER-ENABLES METER-FUNCTION-UNWIND)
    54475911        ((A-CATCH-ACTION) A-V-NIL)
    54485912        ((A-CATCH-COUNT) A-V-NIL)
    54495913XUWS0   ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)  ;Value thrown
    5450         ((M-1) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)  ;Tag
     5914XUWPCN1 ((M-1) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)  ;Tag
    54515915        (JUMP-EQUAL-XCT-NEXT M-1 A-V-TRUE XTHRW7)         ;Tag of T means all the way
    54525916       ((A-CATCH-TAG) M-1)                                ; so don't check first
     
    54555919;DROPS THROUGH
    54565920
    5457 ;DROPS IN
     5921
     5922;DROPS IN, or jumps back from XTHC5.
    54585923;Before actually going and munging anything, follow the open-call-block chain
    54595924;and find out whether the catch tag we're looking for actually exists.
     
    54625927;  M-B  Virtual address of next active call block (typeless)
    54635928;  M-C  Pdl buffer address of next call block (only low 10 bits valid)
     5929;  M-D  Typeless virtual address of outermost active frame we are popping
     5930;       that has the %%LP-CLS-TRAP-ON-EXIT bit set; or zero, if there is none.
    54645931;  M-1  arg into / result out of XTHCG
     5932XTHC0   ((M-D) A-ZERO)
    54655933        (CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
    54665934       ((M-K) M-AP)
     
    54775945        ((M-B) SUB M-B A-ZR)
    54785946XTHC4   ((M-ZR) (LISP-BYTE %%LP-CLS-DELTA-TO-OPEN-BLOCK) M-1)
     5947        (CALL-IF-BIT-SET (LISP-BYTE %%LP-CLS-TRAP-ON-EXIT) M-1 XTHC-TRAP-LATER)
    54795948        ((M-A) SUB M-A A-ZR)
    54805949        (JUMP-EQUAL-XCT-NEXT M-A A-B XTHC1)
     
    54855954        (CALL-XCT-NEXT XTHCG)
    54865955       ((M-1) ADD M-A (A-CONSTANT 1))                   ;GET FIRST ARG
    5487         (JUMP-EQUAL M-1 A-CATCH-TAG XTHRW7)             ;FOUND THE ONE WE'RE LOOKING FOR,
     5956        (JUMP-EQUAL M-1 A-CATCH-TAG XTHC5)              ;FOUND THE ONE WE'RE LOOKING FOR,
    54885957                                                        ;IT'S NOW SAFE TO GO THROW FOR REAL.
    5489         (JUMP-EQUAL M-1 A-V-NIL XTHRW7)                 ;FOUND CATCH-ALL, THATS OK TOO.
     5958        (JUMP-EQUAL M-1 A-V-NIL XTHC5)                  ;FOUND CATCH-ALL, THATS OK TOO.
    54905959XTHC3   (CALL-XCT-NEXT XTHCG)                           ;GET CALL STATE Q
    54915960       ((M-1) ADD M-A (A-CONSTANT (EVAL %LP-CALL-STATE)))
    54925961        (JUMP XTHC4)
     5962
     5963XTHC5   (JUMP-EQUAL M-D A-ZERO XTHRW7)
     5964        ((M-A) A-CATCH-TAG)
     5965        ((M-B) A-CATCH-COUNT)
     5966        ((M-C) A-CATCH-ACTION)
     5967        ((M-E) A-CATCH-MARK)
     5968        ((M-D) DPB M-D Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE)))
     5969        (CALL TRAP)
     5970    (ERROR-TABLE THROW-EXIT-TRAP)
     5971        ;Restart after clearing the trap-on-exit bit
     5972        ;of all the frames we are exiting.
     5973        ((A-CATCH-TAG) M-A)
     5974        ((A-CATCH-COUNT) M-B)
     5975        ((A-CATCH-ACTION) M-C)
     5976        ((A-CATCH-MARK) M-E)
     5977        (JUMP XTHC0)
     5978
     5979;Keep track of the lowest stack frame that has the %%LP-CLS-TRAP-ON-EXIT bit set.
     5980XTHC-TRAP-LATER
     5981        (POPJ-XCT-NEXT)
     5982        ((M-D) M-A)
    54935983
    54945984XTHC-ERROR
     
    55005990                                        ;It knows the tag is in M-A, the value is in M-T,
    55015991                                        ;the count is in M-B, and the action is in M-C.
    5502                                         ;It restarts at *THROW (should use *UNWIND-STACK)
    55035992
    55045993;GET A WORD WHOSE UNTYPED VIRTUAL ADDRESS IS IN M-1.  FOR SPEED, ATTEMPTS
     
    55976086                                                ; EXECUTION, CALL FUNCTION INSTEAD.
    55986087XTHRW6D ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMEX1)))
     6088        ((M-S) A-ZERO)
    55996089        (CALL XRNVR)                            ;FIRST VALUE IS VALUE THROWN (STILL IN M-T)
    56006090        ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMEX1)))
     6091        ((M-S) A-ZERO)
    56016092        (CALL-XCT-NEXT XRNVR)                   ;SECOND VALUE IS TAG
    56026093       ((M-T) A-CATCH-TAG)
    56036094        ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMEX1)))
     6095        ((M-S) A-ZERO)
    56046096        (CALL-XCT-NEXT XRNVR)                   ;THIRD VALUE IS COUNT
    56056097       ((M-T) A-CATCH-COUNT)
     
    57356227XAPDLR1 (CALL TRAP)
    57366228    (ERROR-TABLE STACK-FRAME-TOO-LARGE)
    5737 
     6229    (ERROR-TABLE ARG-POPPED 0 M-1)
     6230
     6231;This makes a list of specified length, full of NILs, on the stack.  Because it
     6232;pushes on the stack it must be done at "top level" in the function body, rather
     6233;than as an argument to a function, unless a SHRINK-PDL-SAVE-TOP instruction is
     6234;emitted at a suitable place.
    57386235XMSL (MISC-INST-ENTRY %MAKE-STACK-LIST)
    57396236        (CALL XAPDLR)                           ;M-1 GETS LIST LENGTH, CHECK FOR ROOM
     
    57496246       ((M-T) Q-POINTER M-K (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
    57506247
     6248;Like %MAKE-STACK-LIST but expects the contents of
     6249;the list to be on the stack already,
     6250;followed by a word containing the length, which we discard.
     6251;We fix the cdr codes and return a pointer.
     6252XMESL (MISC-INST-ENTRY %MAKE-EXPLICIT-STACK-LIST)
     6253        ((M-A) Q-POINTER C-PDL-BUFFER-POINTER-POP)
     6254        (JUMP-EQUAL M-A A-ZERO XFALSE)
     6255        ;Compute pointer to beginning of list.
     6256        (CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
     6257       ((M-K PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER A-A)
     6258        ;B gets CDR-NEXT.
     6259        ((M-B) DPB (M-CONSTANT -1) Q-CDR-CODE)
     6260        (JUMP-EQUAL M-A (A-CONSTANT 1) XMESL2)
     6261;Give all but last element of list CDR-NEXT.
     6262XMESL1
     6263        ((C-PDL-BUFFER-INDEX) Q-TYPED-POINTER C-PDL-BUFFER-INDEX A-B)
     6264        ((M-A) SUB M-A (A-CONSTANT 1))
     6265        ((PDL-BUFFER-INDEX) ADD PDL-BUFFER-INDEX (A-CONSTANT 1))
     6266        (JUMP-GREATER-THAN M-A (A-CONSTANT 1) XMESL1)
     6267XMESL2
     6268;Give last element CDR-NIL.
     6269        (POPJ-AFTER-NEXT
     6270         (C-PDL-BUFFER-INDEX) Q-TYPED-POINTER C-PDL-BUFFER-INDEX
     6271                              (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL)))
     6272        ((M-T) Q-POINTER M-K (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
     6273
     6274;A lexical closure is a pointer with type DTP-CLOSURE or DTP-STACK-CLOSURE
     6275;to a couple of lists on the stack which look like
     6276;(function ,(LOCF LEXICAL-ENVIRONMENT) ((,(%STACK-FRAME-POINTER) . ,LEXICAL-ENVIRONMENT)))
     6277;This uses six slots.  We expect the index of the first one within the local block.
     6278;We set up the third slot (to point to the fourth, cdr-nil),
     6279;the fourth slot (to point to the fifth, cdr-nil),
     6280;and the fifth (our own stack frame, cdr-normal).
     6281;Then we return a pointer to the first slot, with DTP-STACK-CLOSURE.
     6282XMLC (MISC-INST-ENTRY %MAKE-LEXICAL-CLOSURE)
     6283        ((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-ENTRY-STATE)))
     6284        ((M-B) (LISP-BYTE %%LP-ENS-MACRO-LOCAL-BLOCK-ORIGIN) C-PDL-BUFFER-INDEX)
     6285        ((M-B) ADD C-PDL-BUFFER-POINTER-POP A-B)
     6286;Put in M-T the memory address of the first slot.
     6287        ((M-K) ADD M-AP A-B)
     6288        ((PDL-BUFFER-INDEX) ADD M-K (A-CONSTANT 2))
     6289        (CALL CONVERT-PDL-BUFFER-ADDRESS)
     6290        ((M-T) DPB M-K Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-STACK-CLOSURE)))
     6291;Set up the third slot.
     6292        ((M-K) M+A+1 M-T (A-CONSTANT 2))
     6293        ((C-PDL-BUFFER-INDEX) DPB M-K Q-POINTER
     6294                              (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-LIST)
     6295                                                (BYTE-VALUE Q-CDR-CODE CDR-NIL))))
     6296;Set up the fourth slot.
     6297        ((PDL-BUFFER-INDEX) M+1 PDL-BUFFER-INDEX)
     6298        ((M-K) M+1 M-K)
     6299        ((C-PDL-BUFFER-INDEX) DPB M-K Q-POINTER
     6300                              (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-LIST)
     6301                                                (BYTE-VALUE Q-CDR-CODE CDR-NIL))))
     6302;Set up the fifth slot.
     6303        ((PDL-BUFFER-INDEX) M+1 PDL-BUFFER-INDEX)
     6304        (CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS)
     6305       ((M-K) M-AP)
     6306        ((C-PDL-BUFFER-INDEX) DPB M-K Q-POINTER
     6307                              (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-LIST)
     6308                                                (BYTE-VALUE Q-CDR-CODE CDR-NORMAL))))
     6309;Set up the sixth slot.
     6310        ((PDL-BUFFER-INDEX) M+1 PDL-BUFFER-INDEX)
     6311        (POPJ-AFTER-NEXT
     6312         (M-K) A-LEXICAL-ENVIRONMENT)
     6313        ((C-PDL-BUFFER-INDEX) DPB M-K Q-TYPED-POINTER
     6314                              (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-ERROR)))
     6315
    57516316;(%SPREAD LIST)D-NEXT sends the elements of the list which is
    57526317;on the top of the stack to D-NEXT.  (%SPREAD LIST)D-LAST is similar
    57536318;but sends the last one to D-LAST (i.e. activates an open-call).
    57546319;(%SPREAD LIST)D-PDL is identical to (%SPREAD LIST)D-NEXT
     6320(ERROR-TABLE DEFAULT-ARG-LOCATIONS %SPREAD M-D)
     6321
    57556322XSPREAD (MISC-INST-ENTRY %SPREAD)
    57566323        ((M-GARBAGE) MICRO-STACK-DATA-POP)      ;DON'T STORE IN DESTINATION
    57576324        ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)        ;LIST TO BE SPREAD
    57586325        ((M-C) M-INST-DEST)
     6326        ((M-D) M-T)                                     ;SAVE ORIGINAL ARG FOR ERROR MSG.
    57596327MC-SPREAD-0                                             ;ENTRY FOR MICROCOMPILED CODE
    57606328        ((PDL-BUFFER-INDEX) M-A-1 PDL-BUFFER-POINTER A-AP)      ;CURRENT FRAME SIZE (MOD 2000)
     
    59096477        ((M-K) PDL-BUFFER-POINTER)              ;LOC OF BLOCK AS PDL INDEX
    59106478        ((M-E) M-D)
    5911 LMVRB1  ((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL)   ;RESERVE SLOTS, FILL WITH NIL
     6479LMVRB1  ((C-PDL-BUFFER-POINTER-PUSH)            ;RESERVE SLOTS, FILL WITH NIL
     6480                DPB (M-CONSTANT -1) Q-CDR-CODE A-V-NIL) ;WITH CDR-NEXT
    59126481        (JUMP-GREATER-THAN-XCT-NEXT M-E (A-CONSTANT 1) LMVRB1)
    59136482       ((M-E) SUB M-E (A-CONSTANT 1))
     
    60146583        ((M-S) PDL-BUFFER-INDEX)                ;Must be in both M-S and PDL-BUFFER-INDEX
    60156584        (CALL-NOT-EQUAL M-S A-IPMARK ILLOP)     ;Frame not where it should be.  M-R lied?
    6016         ((M-A) C-PDL-BUFFER-INDEX)              ;Function to call
     6585       ((M-A) C-PDL-BUFFER-INDEX)               ;M-A := FUNCTION TO CALL
    60176586        (DISPATCH Q-DATA-TYPE M-A D-QMRCL)      ;Does MLLV if necc
    60186587       (CALL MLLV)
     
    62226791;*** WE STILL HAVE A PROBLEM WITH M-ERROR-SUBSTATUS NOT BEING PRESERVED
    62236792
    6224 QLENTR  ((PDL-BUFFER-INDEX) SUB M-S A-AP)       ;ASSURE ROOM IN PDL-BUFFER
     6793QLENTR  (CALL-IF-BIT-SET-XCT-NEXT (LISP-BYTE %%METER-FUNCTION-ENTRY-EXIT-ENABLE)
     6794                M-METER-ENABLES METER-FUNCTION-ENTRY)
     6795        ((PDL-BUFFER-INDEX) SUB M-S A-AP)       ;ASSURE ROOM IN PDL-BUFFER
    62256796        ((M-PDL-BUFFER-ACTIVE-QS) ADD PDL-BUFFER-INDEX A-PDL-BUFFER-ACTIVE-QS)
    62266797        (CALL-GREATER-THAN-XCT-NEXT M-PDL-BUFFER-ACTIVE-QS
     
    62626833        (JUMP-XCT-NEXT QFL2)
    62636834       ((M-E) SUB M-E (A-CONSTANT 1))
     6835
     6836METER-FUNCTION-ENTRY
     6837        ((A-METER-EVENT) (A-CONSTANT (EVAL %METER-FUNCTION-ENTRY-EVENT)))
     6838        ((C-PDL-BUFFER-POINTER-PUSH) M-A)
     6839        (JUMP-XCT-NEXT METER-MICRO-WRITE-HEADER)
     6840       ((A-METER-LENGTH) (A-CONSTANT 1))        ;Number of meters pushed
    62646841
    62656842SET-TOO-FEW-ARGS
     
    66447221;       (JUMP QBEQQ1)
    66457222
    6646 
    66477223;;FRAME BIND. BIND S-V S FROM FRAME FAST ENTERED USING S.V. MAP
    66487224FRMBN1  ((VMA-START-READ) ADD M-A (A-CONSTANT (EVAL %FEFHI-SV-BITMAP)))
     
    66847260        ((WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT
    66857261                READ-MEMORY-DATA Q-ALL-BUT-TYPED-POINTER A-B)
    6686         (CHECK-PAGE-WRITE)
    6687         (JUMP-IF-BIT-SET Q-FLAG-BIT M-B BBLKP2) ;Jump if last binding in block
     7262        (CHECK-PAGE-WRITE-BIND)
     7263BBLKP3  (JUMP-IF-BIT-SET Q-FLAG-BIT M-B BBLKP2) ;Jump if last binding in block
    66887264        (JUMP-NOT-EQUAL M-ZR A-ZERO BBLKP1)     ;Loop if BBLKP
    66897265        (POPJ-IF-BIT-CLEAR-XCT-NEXT M-DEFERRED-SEQUENCE-BREAK-FLAG)     ;Exit if QUNBND
     
    67487324;THE FOLLOWING IS A TEMPORARY KLUDGE UNTIL THE COMPILER BUG IS FIXED. 12/19/78 MOON, PER RMS
    67497325        ((M-B) (BYTE-FIELD 4 0) M-B)
     7326XPOPIP-2
    67507327        ((PDL-BUFFER-POINTER M-B) SUB PDL-BUFFER-POINTER A-B)
    67517328XPOPIP-1
     
    67617338
    67627339XSHRINK-PDL-SAVE-TOP (MISC-INST-ENTRY SHRINK-PDL-SAVE-TOP)
    6763         ((M-2) Q-POINTER C-PDL-BUFFER-POINTER-POP)              ;AMT TO DECREMENT PP BY
    6764         (POPJ-AFTER-NEXT
    6765          (M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)        ;THING TO RETURN
    6766        ((PDL-BUFFER-POINTER) SUB PDL-BUFFER-POINTER A-2)
     7340        ((M-B) Q-POINTER C-PDL-BUFFER-POINTER-POP)      ;AMT TO DECREMENT PP BY
     7341        (JUMP-XCT-NEXT XPOPIP-2)
     7342       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;THING TO RETURN
    67677343
    67687344XSPECIAL-PDL-INDEX (MISC-INST-ENTRY SPECIAL-PDL-INDEX)
     
    68057381;   NOTE- ALWAYS RETURNS 0 IN FIELDS OTHER THAN POINTER AND DATA TYPE
    68067382
    6807 QTADDD (MISC-INST-ENTRY CADDDR)
     7383(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAR M-T)
     7384
     7385QTA   (MISC-INST-ENTRY M-CAR)
    68087386        ((M-T) C-PDL-BUFFER-POINTER-POP)
    6809 QMADDD  (CALL QMD)              ;These also MC-LINKAGE entries
    6810 QMADD   (CALL QMD)
    6811 QMAD    (CALL QMD)
    68127387QMA
    68137388   (ERROR-TABLE RESTART CAR)
     
    68307405   (ERROR-TABLE ARGTYP CONS M-T T CAR CAR)
    68317406
    6832 QTDDDD (MISC-INST-ENTRY CDDDDR)
     7407
     7408
     7409(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDR M-T)
     7410
     7411QTD   (MISC-INST-ENTRY M-CDR)
    68337412        ((M-T) C-PDL-BUFFER-POINTER-POP)
    6834 QMDDDD  (CALL QMD)              ;These also MC-LINKAGE entries.
    6835 QMDDD   (CALL QMD)
    6836 QMDD    (CALL QMD)
    68377413QMD   
    68387414   (ERROR-TABLE RESTART CDR)
     
    68757451
    68767452
    6877 QTAAAA (MISC-INST-ENTRY CAAAAR)
     7453;; Multiple CAR/CDR functions.
     7454
     7455;; QMA, QMD, etc. take arg in M-T and return value in M-T.
     7456;; XCAAR, etc. pop arg off stack and return value in M-T.
     7457;; QTAD, etc., exist only for certain functions.
     7458;; They pop arg off stack like XCADR, etc., but do not set M-A.
     7459
     7460(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADDDR M-A)
     7461
     7462XCADDDR (MISC-INST-ENTRY CADDDR)
     7463        ((M-A) C-PDL-BUFFER-POINTER)
    68787464        ((M-T) C-PDL-BUFFER-POINTER-POP)
     7465QMADDD  (CALL QMD)              ;These also MC-LINKAGE entries
     7466QMADD   (CALL QMD)
     7467QMAD    (CALL QMD)
     7468        (JUMP QMA)
     7469
     7470(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAAAAR M-A)
     7471
     7472XCAAAAR (MISC-INST-ENTRY CAAAAR)
     7473        ((M-T) C-PDL-BUFFER-POINTER-POP)
     7474        ((M-A) M-T)
    68797475QMAAAA  (CALL QMA)                      ;These also MC-LINKAGEs
    68807476QMAAA   (CALL QMA)
     
    68827478        (JUMP QMA)
    68837479
    6884 QTAAAD (MISC-INST-ENTRY CAAADR)
     7480(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDDDR M-A)
     7481
     7482XCDDDDR (MISC-INST-ENTRY CDDDDR)
     7483        ((M-A) C-PDL-BUFFER-POINTER)
    68857484        ((M-T) C-PDL-BUFFER-POINTER-POP)
     7485QMDDDD  (CALL QMD)              ;These also MC-LINKAGE entries.
     7486QMDDD   (CALL QMD)
     7487QMDD    (CALL QMD)
     7488        (JUMP QMD)
     7489
     7490(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAAADR M-A)
     7491
     7492XCAAADR (MISC-INST-ENTRY CAAADR)
     7493        (CALL-XCT-NEXT QMD)
     7494       ((M-T) C-PDL-BUFFER-POINTER)
     7495    (ERROR-TABLE ARG-POPPED 0 PP)
     7496        (JUMP-XCT-NEXT QMAAA)
     7497       ((M-A) C-PDL-BUFFER-POINTER-POP)
     7498
    68867499QMAAAD  (CALL QMD)                      ;MC-LINKAGE
    68877500        (JUMP QMAAA)
    68887501
    6889 QTDDDA (MISC-INST-ENTRY CDDDAR)
    6890         ((M-T) C-PDL-BUFFER-POINTER-POP)
     7502(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDDAR M-A)
     7503
     7504XCDDDAR (MISC-INST-ENTRY CDDDAR)
     7505        (CALL-XCT-NEXT QMA)
     7506       ((M-T) C-PDL-BUFFER-POINTER)
     7507    (ERROR-TABLE ARG-POPPED 0 PP)
     7508        (JUMP-XCT-NEXT QMDDD)
     7509       ((M-A) C-PDL-BUFFER-POINTER-POP)
     7510
    68917511QMDDDA  (CALL QMA)                      ;MC-LINKAGE
    68927512        (JUMP QMDDD)
    68937513
    6894 QTAADD (MISC-INST-ENTRY CAADDR)
     7514(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAADDR M-A)
     7515
     7516XCAADDR (MISC-INST-ENTRY CAADDR)
    68957517        ((M-T) C-PDL-BUFFER-POINTER-POP)
     7518        ((M-A) M-T)
    68967519QMAADD  (CALL QMD)                      ;MC-LINKAGE
    68977520QMAAD   (CALL QMD)
    68987521        (JUMP QMAA)
    68997522
    6900 QTAADA (MISC-INST-ENTRY CAADAR)
    6901         ((M-T) C-PDL-BUFFER-POINTER-POP)
     7523(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAADAR M-A)
     7524
     7525XCAADAR (MISC-INST-ENTRY CAADAR)
     7526        (CALL-XCT-NEXT QMA)
     7527       ((M-T) C-PDL-BUFFER-POINTER)
     7528    (ERROR-TABLE ARG-POPPED 0 PP)
     7529        (JUMP-XCT-NEXT QMAAD)
     7530       ((M-A) C-PDL-BUFFER-POINTER-POP)
     7531
    69027532QMAADA  (CALL QMA)                      ;MC-LINKAGE
    69037533        (JUMP QMAAD)
    69047534
    6905 QTDDAA (MISC-INST-ENTRY CDDAAR)
     7535(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDAAR M-A)
     7536
     7537XCDDAAR (MISC-INST-ENTRY CDDAAR)
    69067538        ((M-T) C-PDL-BUFFER-POINTER-POP)
     7539        ((M-A) M-T)
    69077540QMDDAA  (CALL QMA)                      ;MC-LINKAGE
    69087541QMDDA   (CALL QMA)
    69097542        (JUMP QMDD)
    69107543
    6911 QTDDAD (MISC-INST-ENTRY CDDADR)
    6912         ((M-T) C-PDL-BUFFER-POINTER-POP)
     7544(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDADR M-A)
     7545
     7546XCDDADR (MISC-INST-ENTRY CDDADR)       
     7547        (CALL-XCT-NEXT QMD)
     7548       ((M-T) C-PDL-BUFFER-POINTER)
     7549    (ERROR-TABLE ARG-POPPED 0 PP)
     7550        (JUMP-XCT-NEXT QMDDA)
     7551       ((M-A) C-PDL-BUFFER-POINTER-POP)
     7552
    69137553QMDDAD  (CALL QMD)                      ;MC-LINKAGE
    69147554        (JUMP QMDDA)
    69157555
    6916 QTADAA (MISC-INST-ENTRY CADAAR)
     7556(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADAAR M-A)
     7557
     7558XCADAAR (MISC-INST-ENTRY CADAAR)
    69177559        ((M-T) C-PDL-BUFFER-POINTER-POP)
     7560        ((M-A) M-T)
    69187561QMADAA  (CALL QMA)                      ;MC-LINKAGE
    69197562QMADA   (CALL QMA)
    69207563        (JUMP QMAD)
    69217564
    6922 QTADAD (MISC-INST-ENTRY CADADR)
    6923         ((M-T) C-PDL-BUFFER-POINTER-POP)
     7565(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADADR M-A)
     7566
     7567XCADADR (MISC-INST-ENTRY CADADR)
     7568        (CALL-XCT-NEXT QMD)
     7569       ((M-T) C-PDL-BUFFER-POINTER)
     7570    (ERROR-TABLE ARG-POPPED 0 PP)
     7571        (JUMP-XCT-NEXT QMADA)
     7572       ((M-A) C-PDL-BUFFER-POINTER-POP)
     7573
    69247574QMADAD  (CALL QMD)                      ;MC-LINKAGE
    69257575        (JUMP QMADA)
    69267576
    6927 QTADDA (MISC-INST-ENTRY CADDAR)
    6928         ((M-T) C-PDL-BUFFER-POINTER-POP)
     7577(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADDAR M-A)
     7578
     7579XCADDAR (MISC-INST-ENTRY CADDAR)
     7580        (CALL-XCT-NEXT QMA)
     7581       ((M-T) C-PDL-BUFFER-POINTER)
     7582    (ERROR-TABLE ARG-POPPED 0 PP)
     7583        (JUMP-XCT-NEXT QMADD)
     7584       ((M-A) C-PDL-BUFFER-POINTER-POP)
     7585
    69297586QMADDA  (CALL QMA)                      ;MC-LINKAGE
    69307587        (JUMP QMADD)
    69317588
    6932 QTDADA (MISC-INST-ENTRY CDADAR)
     7589(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDADAR M-A)
     7590
     7591XCDADAR (MISC-INST-ENTRY CDADAR)
    69337592        ((M-T) C-PDL-BUFFER-POINTER-POP)
     7593        ((M-A) M-T)
    69347594QMDADA  (CALL QMA)                      ;MC-LINKAGE
    69357595QMDAD   (CALL QMD)
    69367596        (JUMP QMDA)
    69377597
    6938 QTDADD (MISC-INST-ENTRY CDADDR)
    6939         ((M-T) C-PDL-BUFFER-POINTER-POP)
     7598(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDADDR M-A)
     7599
     7600XCDADDR (MISC-INST-ENTRY CDADDR)
     7601        (CALL-XCT-NEXT QMD)
     7602       ((M-T) C-PDL-BUFFER-POINTER)
     7603    (ERROR-TABLE ARG-POPPED 0 PP)
     7604        (CALL-XCT-NEXT QMD)
     7605       ((M-A) C-PDL-BUFFER-POINTER-POP)
     7606        (JUMP QMDA)
     7607
    69407608QMDADD  (CALL QMD)                      ;MC-LINKAGE
    69417609        (JUMP QMDAD)
    69427610
    6943 QTDAAA (MISC-INST-ENTRY CDAAAR)
     7611(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDAAAR M-A)
     7612
     7613XCDAAAR (MISC-INST-ENTRY CDAAAR)
    69447614        ((M-T) C-PDL-BUFFER-POINTER-POP)
     7615        ((M-A) M-T)
    69457616QMDAAA  (CALL QMA)                      ;MC-LINKAGE
    69467617QMDAA   (CALL QMA)
     
    69487619        (JUMP QMD)
    69497620
    6950 QTDAAD (MISC-INST-ENTRY CDAADR)
    6951         ((M-T) C-PDL-BUFFER-POINTER-POP)
     7621(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDAADR M-A)
     7622
     7623XCDAADR (MISC-INST-ENTRY CDAADR)
     7624        (CALL-XCT-NEXT QMD)
     7625       ((M-T) C-PDL-BUFFER-POINTER)
     7626    (ERROR-TABLE ARG-POPPED 0 PP)
     7627        (JUMP-XCT-NEXT QMDAA)
     7628       ((M-A) C-PDL-BUFFER-POINTER-POP)
     7629
    69527630QMDAAD  (CALL QMD)                      ;MC-LINKAGE
    69537631        (JUMP QMDAA)
     
    69557633
    69567634
    6957 QTAAA (MISC-INST-ENTRY CAAAR)
     7635;For CAAAR ... CDDDR, the arg is in M-A whenever an error occurs.
     7636
     7637(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAAAR M-A)
     7638
     7639XCAAAR (MISC-INST-ENTRY CAAAR)
     7640        ((M-T) C-PDL-BUFFER-POINTER-POP)
    69587641        (JUMP-XCT-NEXT QMAAA)
    6959        ((M-T) C-PDL-BUFFER-POINTER-POP)
    6960 
    6961 QTAAD (MISC-INST-ENTRY CAADR)
     7642       ((M-A) M-T)
     7643
     7644(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAADR M-A)
     7645
     7646XCAADR (MISC-INST-ENTRY CAADR)
     7647        ((M-T) C-PDL-BUFFER-POINTER-POP)
    69627648        (JUMP-XCT-NEXT QMAAD)
    6963        ((M-T) C-PDL-BUFFER-POINTER-POP)
    6964 
    6965 QTADA (MISC-INST-ENTRY CADAR)
     7649       ((M-A) M-T)
     7650
     7651(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADAR M-A)
     7652
     7653XCADAR (MISC-INST-ENTRY CADAR)
     7654        ((M-T) C-PDL-BUFFER-POINTER-POP)
    69667655        (JUMP-XCT-NEXT QMADA)
    6967        ((M-T) C-PDL-BUFFER-POINTER-POP)
    6968 
    6969 QTADD (MISC-INST-ENTRY CADDR)
     7656       ((M-A) M-T)
     7657
     7658(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADDR M-A)
     7659
     7660XCADDR (MISC-INST-ENTRY CADDR)
     7661        ((M-T) C-PDL-BUFFER-POINTER-POP)
    69707662        (JUMP-XCT-NEXT QMADD)
    6971        ((M-T) C-PDL-BUFFER-POINTER-POP)
    6972 
    6973 QTDAA (MISC-INST-ENTRY CDAAR)
     7663       ((M-A) M-T)
     7664
     7665(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDAAR M-A)
     7666
     7667XCDAAR (MISC-INST-ENTRY CDAAR)
     7668        ((M-T) C-PDL-BUFFER-POINTER-POP)
    69747669        (JUMP-XCT-NEXT QMDAA)
    6975        ((M-T) C-PDL-BUFFER-POINTER-POP)
    6976 
    6977 QTDAD (MISC-INST-ENTRY CDADR)
     7670       ((M-A) M-T)
     7671
     7672(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDADR M-A)
     7673
     7674XCDADR (MISC-INST-ENTRY CDADR)
     7675        ((M-T) C-PDL-BUFFER-POINTER-POP)
    69787676        (JUMP-XCT-NEXT QMDAD)
    6979        ((M-T) C-PDL-BUFFER-POINTER-POP)
    6980 
    6981 QTDDA (MISC-INST-ENTRY CDDAR)
     7677       ((M-A) M-T)
     7678
     7679(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDAR M-A)
     7680
     7681XCDDAR (MISC-INST-ENTRY CDDAR)
     7682        ((M-T) C-PDL-BUFFER-POINTER-POP)
    69827683        (JUMP-XCT-NEXT QMDDA)
    6983        ((M-T) C-PDL-BUFFER-POINTER-POP)
    6984 
    6985 QTDDD (MISC-INST-ENTRY CDDDR)
     7684       ((M-A) M-T)
     7685
     7686(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDDR M-A)
     7687
     7688XCDDDR (MISC-INST-ENTRY CDDDR)
     7689        ((M-T) C-PDL-BUFFER-POINTER-POP)
    69867690        (JUMP-XCT-NEXT QMDDD)
    6987        ((M-T) C-PDL-BUFFER-POINTER-POP)
    6988 
    6989 QTAA  (MISC-INST-ENTRY M-CAAR)
    6990         (JUMP-XCT-NEXT QMAA)
    6991        ((M-T) C-PDL-BUFFER-POINTER-POP)
    6992 
    6993 QTAD  (MISC-INST-ENTRY M-CADR)
    6994         (JUMP-XCT-NEXT QMAD)
    6995        ((M-T) C-PDL-BUFFER-POINTER-POP)
    6996 
    6997 QTDA  (MISC-INST-ENTRY M-CDAR)
    6998         (JUMP-XCT-NEXT QMDA)
    6999        ((M-T) C-PDL-BUFFER-POINTER-POP)
    7000 
    7001 QTDD  (MISC-INST-ENTRY M-CDDR)
    7002         (JUMP-XCT-NEXT QMDD)
    7003        ((M-T) C-PDL-BUFFER-POINTER-POP)
    7004 
    7005 QTA   (MISC-INST-ENTRY M-CAR)
     7691       ((M-A) M-T)
     7692
     7693;For CAAR ... CDDR, the arg is in M-A unless an ARG-POPPED says it is elsewhere.
     7694
     7695(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAAR M-A)
     7696
     7697XCAAR  (MISC-INST-ENTRY M-CAAR)
     7698        (CALL-XCT-NEXT QMA)
     7699       ((M-T) C-PDL-BUFFER-POINTER)
     7700    (ERROR-TABLE ARG-POPPED 0 PP)
    70067701        (JUMP-XCT-NEXT QMA)
    7007        ((M-T) C-PDL-BUFFER-POINTER-POP)
    7008 
    7009 QTD   (MISC-INST-ENTRY M-CDR)
     7702       ((M-A) C-PDL-BUFFER-POINTER-POP)
     7703
     7704(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADR M-A)
     7705
     7706XCADR  (MISC-INST-ENTRY M-CADR)
     7707        (CALL-XCT-NEXT QMD)
     7708       ((M-T) C-PDL-BUFFER-POINTER)
     7709    (ERROR-TABLE ARG-POPPED 0 PP)
     7710        (JUMP-XCT-NEXT QMA)
     7711       ((M-A) C-PDL-BUFFER-POINTER-POP)
     7712
     7713(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDAR M-A)
     7714
     7715XCDAR  (MISC-INST-ENTRY M-CDAR)
     7716        (CALL-XCT-NEXT QMA)
     7717       ((M-T) C-PDL-BUFFER-POINTER)
     7718    (ERROR-TABLE ARG-POPPED 0 PP)
    70107719        (JUMP-XCT-NEXT QMD)
    7011        ((M-T) C-PDL-BUFFER-POINTER-POP)
     7720       ((M-A) C-PDL-BUFFER-POINTER-POP)
     7721
     7722(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDR M-A)
     7723
     7724XCDDR  (MISC-INST-ENTRY M-CDDR)
     7725        (CALL-XCT-NEXT QMD)
     7726       ((M-T) C-PDL-BUFFER-POINTER)
     7727    (ERROR-TABLE ARG-POPPED 0 PP)
     7728        (JUMP-XCT-NEXT QMD)
     7729       ((M-A) C-PDL-BUFFER-POINTER-POP)
     7730
     7731QTAD    (CALL QTD)
     7732        (JUMP QMA)
     7733
     7734QTDD    (CALL QTD)
     7735        (JUMP QMD)
     7736
     7737(ERROR-TABLE DEFAULT-ARG-LOCATIONS NTH PP M-T)
     7738(ERROR-TABLE DEFAULT-ARG-LOCATIONS NTHCDR PP M-T)
    70127739
    70137740XNTH (MISC-INST-ENTRY NTH)
     
    70167743XNTHCDR (MISC-INST-ENTRY NTHCDR)
    70177744        ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)        ;List
     7745                (ERROR-TABLE RESTART XNTHCDR0)
    70187746        (DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    7019             (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP 0)
    7020         (CALL-IF-BIT-SET BOXED-SIGN-BIT C-PDL-BUFFER-POINTER TRAP)
    7021             (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP 0)
     7747            (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP 0 XNTHCDR0)
     7748        (CALL-IF-BIT-SET-XCT-NEXT BOXED-SIGN-BIT C-PDL-BUFFER-POINTER TRAP)
     7749       ((M-B) Q-TYPED-POINTER C-PDL-BUFFER-POINTER)
     7750            (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP 0 XNTHCDR0)
    70227751        ((M-1) Q-POINTER C-PDL-BUFFER-POINTER-POP)              ;Count
    7023         (POPJ-EQUAL M-1 A-ZERO)
     7752        (POPJ-EQUAL-XCT-NEXT M-1 A-ZERO)
     7753       ((M-A) M-T)
    70247754XNTHCDR-1
    70257755        (CALL-NOT-EQUAL M-T A-V-NIL QCDR)
    70267756            (ERROR-TABLE CALLS-SUB NTHCDR)
     7757            (ERROR-TABLE ARG-POPPED 0 M-B M-A)
    70277758        (JUMP-GREATER-THAN-XCT-NEXT M-1 (A-CONSTANT 1) XNTHCDR-1)
    70287759       ((M-1) SUB M-1 (A-CONSTANT 1))
     
    70327763;;; RPLACA AND RPLACD
    70337764
     7765  (ERROR-TABLE DEFAULT-ARG-LOCATIONS RPLACA M-S M-T)
    70347766  (MISC-INST-ENTRY RPLACA)
    70357767XRPLCA  ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
     
    70377769   (ERROR-TABLE RESTART RPLACA)
    70387770QRAR1   (DISPATCH (I-ARG RPLACA-INVOKE-OP) Q-DATA-TYPE M-S QRACDT)
     7771   (ERROR-TABLE ARGTYP CONS M-S 0 RPLACA)
    70397772
    70407773QRASYM  (CALL-EQUAL M-S A-V-NIL TRAP)           ;RPLACA ING NIL ALWAYS ERROR
     
    70527785       ((M-T) M-S)
    70537786
    7054    (MISC-INST-ENTRY RPLACD)
     7787  (ERROR-TABLE DEFAULT-ARG-LOCATIONS RPLACD M-S M-T)
     7788  (MISC-INST-ENTRY RPLACD)
    70557789;MUSTN'T CLOBBER M-C OR M-R BECAUSE CALLED BY MULTIPLE-VALUE-LIST
    70567790;NOW CLOBBERS M-S, M-T, M-I, M-A
     
    70597793   (ERROR-TABLE RESTART RPLACD)
    70607794QRDR1   (DISPATCH (I-ARG RPLACD-INVOKE-OP) Q-DATA-TYPE M-S QRDCDT)
     7795   (ERROR-TABLE ARGTYP CONS M-S 0 RPLACD)
    70617796
    70627797QRDRSY  (DISPATCH M-CDR-SYM-MODE RPLACD-SYM-DISPATCH)
     
    70817816                READ-MEMORY-DATA Q-ALL-BUT-TYPED-POINTER A-T)
    70827817        (CHECK-PAGE-WRITE)                      ;NO SEQ BRK, CALLED BY MVR (???)
    7083         (POPJ-AFTER-NEXT GC-WRITE-TEST)
     7818QRDR2   (POPJ-AFTER-NEXT GC-WRITE-TEST)
    70847819       ((M-T) M-S)
    70857820
     7821RPLACD-NEXT-NIL
     7822        (JUMP-EQUAL M-T A-V-NIL QRDR2)          ;RPLACD WITH NIL AND CDR ALREADY NIL, NO-OP
    70867823RPLACD-CDR-NEXT
    7087 RPLACD-NEXT-NIL
    70887824;THIS CODE CAN SEQUENCE BREAK!!! BEWARE!!!
    70897825        ((C-PDL-BUFFER-POINTER-PUSH) M-S)               ;SAVE THIS SO WE CAN RETURN IT
    70907826        ((C-PDL-BUFFER-POINTER-PUSH) VMA)               ;ADDR OF CELL TO BE FORWARDED
    70917827        ((MD) VMA)                                      ;ADDRESS THE MAP
    7092         (DISPATCH MAP-STATUS-CODE MEMORY-MAP-DATA D-ASSURE-MAP-VALID)
     7828        (DISPATCH MAP-STATUS-CODE MEMORY-MAP-DATA D-GET-MAP-BITS) ;Ensure validity of meta bits
    70937829        ((M-TEM) (LISP-BYTE %%REGION-REPRESENTATION-TYPE) MEMORY-MAP-DATA)
    70947830        (CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL %REGION-REPRESENTATION-TYPE-LIST)) TRAP)
    70957831    (ERROR-TABLE RPLACD-WRONG-REPRESENTATION-TYPE M-S)
     7832    (ERROR-TABLE ARG-POPPED 0 (PP 1) M-T)
    70967833        ((C-PDL-BUFFER-POINTER-PUSH) M-I)               ;CAR OF NEW CELL
    70977834        ((C-PDL-BUFFER-POINTER-PUSH) M-T)               ;CDR OF NEW CELL
     
    71067843        (POPJ-AFTER-NEXT GC-WRITE-TEST)
    71077844       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;RETURN THE ORIGINAL FIRST ARG
     7845
     7846
     7847;;; EQUAL
     7848
     7849XEQUAL  (MISC-INST-ENTRY EQUAL)
     7850        ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
     7851        ((M-B) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)
     7852XEQUAL-0
     7853        (JUMP-EQUAL M-T A-B XTRUE)
     7854        ((M-1) Q-DATA-TYPE M-T)
     7855        ((M-2) Q-DATA-TYPE M-B)
     7856        (JUMP-NOT-EQUAL M-1 A-2 XFALSE)
     7857        (CALL XEQUAL-1)
     7858        (JUMP-EQUAL M-1 (A-CONSTANT (EVAL DTP-ARRAY-POINTER)) XEQUAL-ARRAY)
     7859        (DISPATCH Q-DATA-TYPE M-T SKIP-IF-NO-ATOM)
     7860        (JUMP XFALSE)
     7861
     7862        ;; Now we are a list   
     7863        ((C-PDL-BUFFER-POINTER-PUSH) M-T)
     7864        (CALL-XCT-NEXT QCAR3)
     7865       ((C-PDL-BUFFER-POINTER-PUSH) M-B)
     7866        ((M-B) M-T)
     7867        (CALL-XCT-NEXT QCAR3)
     7868       ((M-T) C-PDL-BUFFER-POINTER)
     7869        ;; If the micro stack is filling up, make new stack frame.
     7870        (JUMP-GREATER-THAN MICRO-STACK-PNTR-AND-DATA (A-CONSTANT 10._24.)
     7871                           XEQUAL-SLOW-RECURSE)
     7872        ;; Otherwise, test for EQUALity of the two cars.
     7873        (CALL XEQUAL-0)
     7874
     7875XEQUAL-CDR
     7876        (JUMP-EQUAL M-T A-V-NIL XEQUAL-DIFFERENT-CARS)
     7877        ;; If the cars match, tail-recursively check the two cdrs.
     7878        (CALL-XCT-NEXT QCDR)
     7879       ((M-T) C-PDL-BUFFER-POINTER-POP)
     7880        ((M-B) M-T)
     7881        (CALL-XCT-NEXT QCDR)
     7882       ((M-T) C-PDL-BUFFER-POINTER-POP)
     7883        (JUMP XEQUAL-0)
     7884
     7885XEQUAL-DIFFERENT-CARS
     7886        (POPJ-AFTER-NEXT (PDL-BUFFER-POINTER) SUB PDL-BUFFER-POINTER (A-CONSTANT 2))
     7887       (NO-OP)
     7888
     7889XEQUAL-SLOW-RECURSE
     7890        (CALL P3ZERO)
     7891        ((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVCEQL))
     7892        ((C-PDL-BUFFER-POINTER-PUSH) READ-MEMORY-DATA)
     7893        ((C-PDL-BUFFER-POINTER-PUSH) M-T)
     7894        ((C-PDL-BUFFER-POINTER-PUSH) M-B)
     7895        ((ARG-CALL MMCALL) (I-ARG 2))
     7896        (JUMP XEQUAL-CDR)
     7897
     7898        ;;Numbers are EQUAL if =
     7899XEQUAL-1
     7900        (DISPATCH-XCT-NEXT Q-DATA-TYPE M-T POPJ-IF-NOT-NUMBER)
     7901       ((M-A) (A-CONSTANT ARITH-2ARG-EQUAL))
     7902        ((M-GARBAGE) MICRO-STACK-DATA-POP)
     7903        ((C-PDL-BUFFER-POINTER-PUSH) M-B)
     7904        (DISPATCH-XCT-NEXT Q-DATA-TYPE M-B D-NUMARG1)
     7905       (NO-OP)
     7906        (JUMP XFALSE)                           ;Non-EQ fixnums
     7907
     7908XEQUAL-ARRAY
     7909        ((VMA-START-READ) M-T)
     7910        (CHECK-PAGE-READ)
     7911        (DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
     7912        ((M-1) (LISP-BYTE %%ARRAY-TYPE-FIELD) READ-MEMORY-DATA)
     7913        (JUMP-EQUAL M-1 (A-CONSTANT (EVAL (LSH ART-STRING ARRAY-TYPE-SHIFT))) XEQUAL-STRING)
     7914        (JUMP-NOT-EQUAL M-1 (A-CONSTANT (EVAL (LSH ART-FAT-STRING ARRAY-TYPE-SHIFT))) XFALSE)
     7915XEQUAL-STRING
     7916        ((VMA-START-READ) M-B)
     7917        (CHECK-PAGE-READ)
     7918        (DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
     7919        ((M-2) (LISP-BYTE %%ARRAY-TYPE-FIELD) READ-MEMORY-DATA)
     7920        (JUMP-EQUAL M-2 (A-CONSTANT (EVAL (LSH ART-STRING ARRAY-TYPE-SHIFT))) XEQUAL-STRING-1)
     7921        (JUMP-NOT-EQUAL M-2 (A-CONSTANT (EVAL (LSH ART-FAT-STRING ARRAY-TYPE-SHIFT))) XFALSE)
     7922XEQUAL-STRING-1
     7923        ((C-PDL-BUFFER-POINTER-PUSH) A-T)
     7924        ((C-PDL-BUFFER-POINTER-PUSH) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) )
     7925        ((C-PDL-BUFFER-POINTER-PUSH) A-B)
     7926        ((C-PDL-BUFFER-POINTER-PUSH) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
     7927        ((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL)
     7928        (JUMP XSTRING-EQUAL)                    ;No XCT-NEXT here
    71087929
    71097930
     
    71407961;UPON RETURN FROM THE ARRAY-TYPE-REF-DISPATCH.
    71417962
     7963                (ERROR-TABLE RESTART BEGIN-QARYR)       ;For error handler
    71427964QARYR   (CALL GAHD1)                            ;REFERENCE ARRAY
    71437965        (CALL-NOT-EQUAL M-D A-R TRAP)
     
    71457967        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
    71467968                        Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    7147    (ERROR-TABLE ARGTYP FIXNUM PP NIL)
     7969   (ERROR-TABLE ARGTYP FIXNUM PP NIL NIL AREF)
    71487970        ((M-Q) Q-POINTER C-PDL-BUFFER-POINTER-POP)
    71497971        (JUMP-NOT-EQUAL (A-CONSTANT 1) M-D QARY-MULTI)  ;MULTI DIM ARRAY
     
    71938015        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
    71948016                        Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    7195    (ERROR-TABLE ARGTYP FIXNUM PP NIL)
     8017   (ERROR-TABLE ARGTYP FIXNUM PP NIL NIL AREF)
    71968018        ((M-1) Q-POINTER C-PDL-BUFFER-POINTER-POP)
    71978019        ((M-Q) ADD Q-R A-1)                     ;ADD NEXT SUBSCRIPT
    71988020        (JUMP-EQUAL (A-CONSTANT 1) M-D QARY-M1) ;JUMP IF THROUGH, FINAL SUBSC IN M-Q
    71998021        (JUMP QARY-MULTI-1)
     8022                (ERROR-TABLE RESTART END-QARYR)
    72008023
    72018024
     
    72318054        (CALL GAHDRA)
    72328055  (ERROR-TABLE CALLS-SUB ARRAY-LENGTH)
     8056  (ERROR-TABLE ARG-POPPED 0 M-A)
    72338057XAIXL1  (POPJ-IF-BIT-CLEAR-XCT-NEXT (LISP-BYTE %%ARRAY-DISPLACED-BIT) M-B)
    72348058       ((M-T) DPB M-S Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
     
    72408064XAAIXL (MISC-INST-ENTRY ARRAY-ACTIVE-LENGTH)
    72418065        (CALL GAHDRA)
    7242    (ERROR-TABLE CALLS-SUB ARRAY-ACTIVE-LENGTH)
     8066  (ERROR-TABLE CALLS-SUB ARRAY-ACTIVE-LENGTH)
     8067  (ERROR-TABLE ARG-POPPED 0 M-A)
    72438068        (JUMP-IF-BIT-CLEAR (LISP-BYTE %%ARRAY-LEADER-BIT) M-B XAIXL1)
    72448069        ((VMA-START-READ) SUB M-A (A-CONSTANT 2))       ;Get fill pointer from leader
    72458070        (CHECK-PAGE-READ)
    72468071        ((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)          ;Fixnum there?
    7247         (JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-FIX)) XAIXL2) ;Yes, it's the fill ptr
     8072        (JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-FIX)) XAIXL2) ;Yes, it's the fill ptr
    72488073        (JUMP XAIXL1)                                   ;No, don't use garbage as fill ptr
    72498074
     
    73178142        (JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-ARRAY-POINTER)) QDACM2) ;DOUBLE INDIRECT
    73188143        (JUMP-XCT-NEXT QDACM1)                          ;JUST DISPLACED
    7319        ((M-E) READ-MEMORY-DATA)
     8144       ((M-E) Q-POINTER READ-MEMORY-DATA)
    73208145
    73218146
     
    73708195                (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
    73718196
     8197QB16SRY ((A-TEM1) (BYTE-FIELD 27 1) M-Q)        ;HALFWORD FIXNUM ARRAY
     8198        ((VMA-START-READ) ADD A-TEM1 M-E)
     8199        (CHECK-PAGE-READ)
     8200        (JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 0) M-Q A-ZERO QB16SRY-1)
     8201       ((M-T) (BYTE-FIELD 16. 0) READ-MEMORY-DATA
     8202                (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
     8203        ((M-T) (BYTE-FIELD 16. 16.) READ-MEMORY-DATA
     8204                (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
     8205QB16SRY-1
     8206        (POPJ-AFTER-NEXT POPJ-IF-BIT-CLEAR (BYTE-FIELD 1 15.) M-T)
     8207       ((M-T) DPB (M-CONSTANT -1) (BYTE-FIELD 8 16.) A-T)       ;NEGATIVE--EXTEND SIGN
     8208
    73728209QQARY   ((VMA-START-READ) ADD A-Q M-E)          ;Q ARRAY
    73738210        (CHECK-PAGE-READ)
     
    73758212       ((M-T) Q-TYPED-POINTER READ-MEMORY-DATA)
    73768213
    7377 QFARY   ((M-TEM) ADD M-Q A-Q)
     8214QFARY   ((M-TEM) ADD M-Q A-Q)                   ;FLOAT
    73788215        ((VMA-START-READ) ADD M-E A-TEM)
    73798216        (CHECK-PAGE-READ)
     
    73888225        (CALL-XCT-NEXT FLOPACK)
    73898226       ((M-1) READ-MEMORY-DATA)
    7390         ((M-S) C-PDL-BUFFER-POINTER-POP)
     8227QFARY1  ((M-S) C-PDL-BUFFER-POINTER-POP)
    73918228        ((M-K) C-PDL-BUFFER-POINTER-POP)
    73928229        ((M-I) C-PDL-BUFFER-POINTER-POP)
    73938230        (POPJ-AFTER-NEXT (M-E) C-PDL-BUFFER-POINTER-POP)
    73948231       ((M-B) C-PDL-BUFFER-POINTER-POP)
     8232
     8233QFFARY  ((VMA-START-READ) ADD M-Q A-E)          ;FPS-FLOAT
     8234        (CHECK-PAGE-READ)
     8235        ((C-PDL-BUFFER-POINTER-PUSH) M-B)
     8236        ((C-PDL-BUFFER-POINTER-PUSH) M-E)
     8237        ((C-PDL-BUFFER-POINTER-PUSH) M-I)
     8238        ((C-PDL-BUFFER-POINTER-PUSH) M-K)
     8239        ((C-PDL-BUFFER-POINTER-PUSH) M-S)
     8240        ((M-TEM) (BYTE-FIELD 16. 16.) READ-MEMORY-DATA)         ;Swap halves
     8241        ((M-TEM) DPB READ-MEMORY-DATA (BYTE-FIELD 16. 16.) A-TEM)
     8242        ((M-1) DPB M-TEM (BYTE-FIELD 23. 7) (A-CONSTANT 1_30.)) ;Positive fraction
     8243        ((M-I) (BYTE-FIELD 8 23.) M-TEM)        ;Excess-200 exponent
     8244        (CALL-EQUAL-XCT-NEXT M-I A-ZERO FLZERO) ;0.0 is a special case
     8245       ((M-I) ADD M-I (A-CONSTANT 1600))        ;Excess-2000 exponent
     8246        (CALL-IF-BIT-SET (BYTE-FIELD 1 31.) M-TEM FNEG1) ;If negative, negate
     8247        (JUMP-XCT-NEXT QFARY1)       
     8248       (CALL FLOPACK)
    73958249
    73968250
     
    74248278
    74258279     (MISC-INST-ENTRY G-L-P)            ;(G-L-P <ARRAY-POINTER-TO-ART-Q-LIST-ARRAY>)
    7426 XGLPAR  (CALL-XCT-NEXT GAHD1)           ; RETURNS LIST POINTER TO ARRAY CONTENTS
    7427        ((M-A) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;IF FILL-POINTER 0, RETURN NIL
    7428   (ERROR-TABLE CALLS-SUB G-L-P)
     8280XGLPAR  (CALL GAHDRA)                   ; RETURNS LIST POINTER TO ARRAY CONTENTS
     8281    (ERROR-TABLE CALLS-SUB G-L-P)       ;IF FILL-POINTER 0, RETURN NIL
     8282    (ERROR-TABLE ARG-POPPED 0 M-A)
    74298283        (JUMP-IF-BIT-CLEAR M-B (LISP-BYTE %%ARRAY-LEADER-BIT) XGLPA2) ;JUMP ON NO LEADER
    74308284        ((VMA-START-READ) SUB M-A (A-CONSTANT 2))       ;NO TRANSPORT SINCE JUST TOUCHED HDR
     
    74338287        (JUMP-EQUAL M-TEM (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) XFALSE)
    74348288XGLPA2  ((M-R) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST)))
    7435         (JUMP-XCT-NEXT XGLPA1)  ;RETURN POINTER TO ELEMENT NUMBER 0
     8289        (JUMP-XCT-NEXT XGLPA1)          ;RETURN POINTER TO ELEMENT NUMBER 0
    74368290       ((M-Q) A-ZERO)
    74378291
    74388292
    7439 ;Storing into arrays.  M-T has data to store, M-Q subscript, M-E etc. have GAHDR data
     8293;Storing into arrays.
     8294
     8295(ERROR-TABLE DEFAULT-ARG-LOCATIONS XSTORE M-T)
    74408296
    74418297XXSTOR (MISC-INST-ENTRY XSTORE)
     
    74448300       ((M-A) A-QLARYH)
    74458301   (ERROR-TABLE CALLS-SUB STORE)
     8302   (ERROR-TABLE ARG-POPPED 0 PP)
    74468303        ((M-Q) DPB M-ZERO Q-ALL-BUT-POINTER A-QLARYL)
    74478304        (CALL-IF-BIT-SET M-B (LISP-BYTE %%ARRAY-DISPLACED-BIT) DSP-ARRAY-SETUP)
     8305   (ERROR-TABLE ARG-POPPED 0 PP)
    74488306        (CALL-GREATER-OR-EQUAL M-Q A-S TRAP)    ;INDEX OUT OF BOUNDS
    74498307   (ERROR-TABLE SUBSCRIPT-OOB M-Q M-S)
     8308   (ERROR-TABLE ARG-POPPED 0 PP)
    74508309        (DISPATCH-XCT-NEXT (LISP-BYTE %%ARRAY-TYPE-FIELD)
    74518310                M-B ARRAY-TYPE-STORE-DISPATCH)
     
    74538312       ((M-T) C-PDL-BUFFER-POINTER-POP)
    74548313
     8314;Store routines for various types of arrays, reached via ARRAY-TYPE-STORE-DISPATCH.
     8315;M-T has data to store, M-Q subscript, M-E etc. have GAHDR data.
    74558316
    74568317;NOTE REFLECTING ABOUT 40 HACK NOT NECESSARY FOR DPB
     
    75208381        (POPJ)
    75218382
     8383;FPS-FLOAT has less precision than Lisp machine float, so round.
     8384QSFFARY ((M-J) M-I)                             ;Save M-I
     8385        ((C-PDL-BUFFER-POINTER-PUSH) M-T)       ;Value being stored
     8386        (CALL GET-FLONUM)
     8387        ;Transfer sign bit to M-TEM and get magnitude of fraction
     8388        (CALL-LESS-THAN-XCT-NEXT M-1 A-ZERO FNEG1)
     8389       ((M-TEM) SELECTIVE-DEPOSIT M-1 (BYTE-FIELD 1 31.) A-ZERO)
     8390        ;Round off fraction
     8391        ((M-4) (BYTE-FIELD 7 0) M-1)            ;Discarded bits of fraction
     8392        (CALL-EQUAL M-4 (A-CONSTANT 1_6) QSFFRY2)       ;Stable rounding
     8393        ((M-1) ADD M-1 (A-CONSTANT 1_6))
     8394        (CALL-IF-BIT-SET (BYTE-FIELD 1 31.) M-1 QSFFRY3)        ;Renormalize
     8395QSFFRY0 ((M-I) SUB M-I (A-CONSTANT 1600))       ;Get excess-200 exponent
     8396        (JUMP-LESS-OR-EQUAL M-I A-ZERO QSFFRY1) ;Underflow or zero => zero
     8397        ;Insert relevant fraction bits
     8398        ((M-TEM) (BYTE-FIELD 23. 7) M-1 A-TEM)
     8399        (JUMP-LESS-THAN-XCT-NEXT M-I (A-CONSTANT 400) QSFFRY1)
     8400       ((M-TEM) DPB M-I (BYTE-FIELD 8 23.) A-TEM)
     8401        ((M-TEM) DPB (M-CONSTANT -1) (BYTE-FIELD 31. 0) A-TEM)  ;Overflow => infinity
     8402QSFFRY1 ((M-1) (BYTE-FIELD 16. 16.) M-TEM)      ;Swap halves
     8403        ((WRITE-MEMORY-DATA) DPB M-TEM (BYTE-FIELD 16. 16.) A-1)       
     8404        ((VMA-START-WRITE) ADD M-E A-Q)
     8405        (CHECK-PAGE-WRITE)
     8406        (POPJ-AFTER-NEXT (M-I) M-J)
     8407       (NO-OP)
     8408
     8409QSFFRY2 (POPJ-AFTER-NEXT POPJ-IF-BIT-SET (BYTE-FIELD 1 7) M-1)
     8410        (JUMP QSFFRY0)                          ;If lsb 0, suppress adding 1
     8411
     8412QSFFRY3 (POPJ-AFTER-NEXT (M-1) (BYTE-FIELD 30. 1) M-1)  ;Shift fraction right 1
     8413       ((M-I) ADD M-I (A-CONSTANT 1))           ;And increment exponent
     8414
    75228415                               
     8416   (ERROR-TABLE DEFAULT-ARG-LOCATIONS ARRAY-PUSH PP M-T)
    75238417   (MISC-INST-ENTRY ARRAY-PUSH)
    75248418XFARY   ((M-T) C-PDL-BUFFER-POINTER-POP)
    75258419        (CALL-XCT-NEXT GAHDR)
    7526        ((M-A) C-PDL-BUFFER-POINTER-POP)
     8420       ((M-A) C-PDL-BUFFER-POINTER)
    75278421   (ERROR-TABLE CALLS-SUB ARRAY-PUSH)
    75288422        (CALL-IF-BIT-CLEAR (LISP-BYTE %%ARRAY-LEADER-BIT) M-B TRAP)
     
    75398433        (CALL-IF-BIT-SET (LISP-BYTE %%ARRAY-DISPLACED-BIT) M-B
    75408434                         DSP-ARRAY-SETUP)
    7541         (JUMP-GREATER-OR-EQUAL M-Q A-S XFALSE)  ;INDEX OUT OF BOUNDS, RETURN NIL, DON'T STORE
     8435        (JUMP-GREATER-OR-EQUAL M-Q A-S POP-THEN-XFALSE) ;INDEX OUT OF BOUNDS, RETURN NIL,
     8436                                                        ; DON'T STORE
    75428437        ((VMA) SUB M-A (A-CONSTANT 2))          ;KNOW WILL WIN NOW, MUNG
    75438438        ((WRITE-MEMORY-DATA-START-WRITE) ADD A-FARY-TEM M-ZERO ALU-CARRY-IN-ONE)
     
    75468441                        ARRAY-TYPE-FILL-DISPATCH)
    75478442   (ERROR-TABLE BAD-ARRAY-TYPE M-B)
     8443        ; ((M-T) A-FARY-TEM) and discard top of stack.
    75488444        (POPJ-AFTER-NEXT        ;RETURN ELEMENT NUMBER STORED INTO.
    7549          (M-T) A-FARY-TEM)
     8445         (M-T) SETA A-FARY-TEM C-PDL-BUFFER-POINTER-POP)
    75508446       ((M-T) IOR (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) M-T)
    75518447
     
    75698465   (MISC-INST-ENTRY STORE-ARRAY-LEADER)
    75708466XSALDR  (CALL XFLAD1)           ;STORE IN ARRAY LEADER
     8467  (ERROR-TABLE CALLS-SUB STORE-ARRAY-LEADER)
    75718468;NEEDS TRANSPORTER HACKERY HERE IF ONE-Q-FORWARD S IN ARRAY-LEADERS ARE TO BE SUPPORTED.
    75728469        ((M-T WRITE-MEMORY-DATA-START-WRITE)
     
    75848481       ((M-T) Q-TYPED-POINTER READ-MEMORY-DATA)
    75858482
     8483;Pop index and array off stack, and return in VMA the address
     8484;of the slot in the leader specified by the index.
    75868485XFLAD1  (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
    75878486                  Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM) ;COMPUTE ADDRESS
    75888487   (ERROR-TABLE ARGTYP FIXNUM PP 1)
     8488   (ERROR-TABLE ARG-POPPED 0 PP PP)
    75898489        ((M-Q) Q-POINTER C-PDL-BUFFER-POINTER-POP)              ;OR ARRAY LEADER ELEMENT
    75908490        (CALL-XCT-NEXT GAHDR)
    7591        ((M-A) C-PDL-BUFFER-POINTER-POP)
     8491       ((M-A) C-PDL-BUFFER-POINTER)
     8492   (ERROR-TABLE ARG-POPPED 0 M-Q)
    75928493        (CALL-IF-BIT-CLEAR (LISP-BYTE %%ARRAY-LEADER-BIT) M-B TRAP)     ;NO LEADER
    75938494   (ERROR-TABLE ARRAY-HAS-NO-LEADER M-A)
    75948495   (ERROR-TABLE RESTART XFLAD1-A)
     8496   (ERROR-TABLE ARG-POPPED 0 M-Q)
    75958497        ((VMA-START-READ) SUB M-A (A-CONSTANT 1))       ;GET LENGTH OF ARRAY LEADER
    75968498        (CHECK-PAGE-READ)       ;NO TRANSPORT SINCE JUST TOUCHED HEADER
     
    75988500        (CALL-GREATER-OR-EQUAL M-Q A-TEM1 TRAP)         ;SUBSCRIPT OUT OF BOUNDS
    75998501   (ERROR-TABLE SUBSCRIPT-OOB M-Q RMD XFLAD1-A)
     8502   (ERROR-TABLE ARG-POPPED 0 M-Q)
     8503        (C-PDL-BUFFER-POINTER-POP)
    76008504        (POPJ-AFTER-NEXT (A-TEM1) ADD M-Q (A-CONSTANT 2))
    76018505       ((VMA) SUB M-A A-TEM1)
     
    76048508        (CALL GAHDRA)
    76058509  (ERROR-TABLE CALLS-SUB ARRAY-HAS-LEADER-P)
     8510  ;; The following is ok because the arg is, unchanged, in M-A
     8511  ;; at the time when GAHRDA might get an error,
     8512  ;; and we don't need to worry about it after GAHDRA returns.
     8513  (ERROR-TABLE ARG-POPPED 0 M-A)
    76068514        (JUMP-IF-BIT-CLEAR (LISP-BYTE %%ARRAY-LEADER-BIT) M-B XFALSE)
    76078515        (JUMP XTRUE)
    76088516
     8517;;;??? This is very hard.
    76098518XAR1   (MISC-INST-ENTRY AR-1)
    76108519        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)
     
    77308639
    77318640
     8641(ERROR-TABLE DEFAULT-ARG-LOCATIONS COPY-ARRAY-CONTENTS-AND-LEADER M-C M-T)
     8642
    77328643XCARCL (MISC-INST-ENTRY COPY-ARRAY-CONTENTS-AND-LEADER)
    77338644        ((M-T) C-PDL-BUFFER-POINTER-POP)                ;TO
     
    77578668;(COPY-ARRAY-PORTION FROM-ARRAY FROM-START FROM-END TO-ARRAY TO-START TO-END)
    77588669;IF THE TO-LENGTH IS LONGER IT FILLS WITH 0 OR NIL
     8670;;;??? This one is hard to remember the args for.
    77598671XCAP (MISC-INST-ENTRY COPY-ARRAY-PORTION)
    77608672        ((M-R) Q-POINTER C-PDL-BUFFER-POINTER-POP)      ;TO-END
     
    77898701       ((M-A) M-T)
    77908702  (ERROR-TABLE CALLS-SUB COPY-ARRAY-CONTENTS)
     8703  (ERROR-TABLE ARG-POPPED 0 M-C M-T)
    77918704        ((M-A) M-C)                                     ;FROM-ARRAY
    77928705        ((M-R) M-S)                                     ;TO LENGTH
     
    77968709       ((M-K) M-B)                                      ;TO ARRAY HEADER
    77978710  (ERROR-TABLE CALLS-SUB COPY-ARRAY-CONTENTS)
     8711  (ERROR-TABLE ARG-POPPED 0 M-A M-T)
    77988712XCARC1  (JUMP-GREATER-OR-EQUAL M-I A-R XTRUE)           ;TO ARRAY DONE, RETURN
    77998713        (JUMP-GREATER-OR-EQUAL M-Q A-S XCARC3)          ;JUMP IF FROM ARRAY EXHAUSTED
     
    78018715                (LISP-BYTE %%ARRAY-TYPE-FIELD) M-B ARRAY-TYPE-REF-DISPATCH)
    78028716   (ERROR-TABLE BAD-ARRAY-TYPE M-B)
    7803 XCARC4 ((C-PDL-BUFFER-POINTER-PUSH) M-Q)
    7804         ((C-PDL-BUFFER-POINTER-PUSH) M-E)
     8717XCARC4 ((C-PDL-BUFFER-POINTER-PUSH) Q-POINTER M-Q
     8718                        (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
     8719        ((M-D) M-E)
    78058720        ((M-Q) M-I)
    78068721        ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC XCARC5)))
     
    78098724       ((M-E) M-C)
    78108725XCARC5  ((M-I) ADD M-I (A-CONSTANT 1))
    7811         ((M-E) C-PDL-BUFFER-POINTER-POP)
     8726        ((M-Q) Q-POINTER C-PDL-BUFFER-POINTER-POP)
     8727        ((M-Q) ADD M-Q (A-CONSTANT 1))
    78128728        (JUMP-XCT-NEXT XCARC1)
    7813        ((M-Q) ADD C-PDL-BUFFER-POINTER-POP (A-CONSTANT 1))
     8729       ((M-E) M-D)
    78148730
    78158731;COMPUTE FILLER VALUE IN M-T, REENTER AT XCARC4
     
    78378753        (JUMP DSP-ARRAY-SETUP)
    78388754
     8755;(%BLT from-address to-address n-words increment)
     8756;Increment is usually 1, less often -1 for backwards blt.
     8757XBLT (MISC-INST-ENTRY %BLT)
     8758        ((M-D) Q-POINTER C-PDL-BUFFER-POINTER-POP)
     8759        ((M-C) Q-POINTER C-PDL-BUFFER-POINTER-POP)
     8760        ((M-B) Q-POINTER C-PDL-BUFFER-POINTER-POP)
     8761        ((M-A) Q-POINTER C-PDL-BUFFER-POINTER-POP)
     8762        ((M-B) SUB M-B A-D)
     8763        ((M-A) SUB M-A A-D)
     8764XBLT1   (JUMP-EQUAL M-C (A-CONSTANT 0) XFALSE)
     8765        ((VMA-START-READ M-A) ADD M-A A-D)
     8766        (CHECK-PAGE-READ)
     8767        ((VMA-START-WRITE M-B) ADD M-B A-D)
     8768        (CHECK-PAGE-WRITE)
     8769        (JUMP-XCT-NEXT XBLT1)
     8770       ((M-C) SUB M-C (A-CONSTANT 1))
     8771
    78398772
    78408773XNUMBP (MISC-INST-ENTRY NUMBERP)
     
    78438776       ((M-T) A-V-NIL)
    78448777        (JUMP XTRUE)
     8778
     8779XFIXP (MISC-INST-ENTRY FIXP)
     8780        ((M-T) C-PDL-BUFFER-POINTER-POP)
     8781XTFIXP  ((M-TEM) Q-DATA-TYPE M-T)
     8782        (JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-FIX)) XTRUE)
     8783        ((M-4) (A-CONSTANT (EVAL %HEADER-TYPE-BIGNUM)))
     8784XFXFLP  (JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-EXTENDED-NUMBER)) XFALSE)
     8785        ((VMA-START-READ) M-T)
     8786        (CHECK-PAGE-READ)
     8787        ((M-T) A-V-TRUE)
     8788        (DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA)
     8789        (POPJ-AFTER-NEXT (M-TEM) (LISP-BYTE %%HEADER-TYPE-FIELD) READ-MEMORY-DATA)
     8790       (CALL-NOT-EQUAL M-TEM A-4 XFALSE)
     8791
     8792XFLTP (MISC-INST-ENTRY FLOATP)
     8793        ((M-T) C-PDL-BUFFER-POINTER-POP)
     8794XTFLTP  ((M-TEM) Q-DATA-TYPE M-T)
     8795        (JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-SMALL-FLONUM)) XTRUE)
     8796        (JUMP-XCT-NEXT XFXFLP)
     8797       ((M-4) (A-CONSTANT (EVAL %HEADER-TYPE-FLONUM)))
    78458798
    78468799XDATTP (MISC-INST-ENTRY %DATA-TYPE)
     
    78768829
    78778830
     8831(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-LDB-OFFSET PP M-C M-B)
     8832
    78788833XOPLDB(MISC-INST-ENTRY %P-LDB-OFFSET)
    78798834        (JUMP-XCT-NEXT XOPLD1)                  ;JOIN XLDB, BUT FIRST
    78808835       (CALL XOMR0)                             ;REFERENCE THE LOCATION
    78818836
     8837(ERROR-TABLE DEFAULT-ARG-LOCATIONS %LOGLDB PP M-1)
     8838
    78828839XLLDB (MISC-INST-ENTRY %LOGLDB)                 ;LDB FOR FIXNUMS
    78838840        (JUMP-XCT-NEXT XLLDB1)
    78848841       ((M-1) Q-POINTER C-PDL-BUFFER-POINTER-POP)
     8842
     8843(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-LDB PP VMA)
    78858844
    78868845;%P-LDB treats target Q just as 32 bits.  Data type is not interpreted.
     
    79168875        (DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)  ;Only the second operand is
    79178876            (ERROR-TABLE ARGTYP NUMBER PP 1 XLDB)   ;processed via NUMARG.  Thus LDB is
     8877            (ERROR-TABLE ARG-POPPED 0 PP PP)
    79188878       ((M-A) (A-CONSTANT ARITH-1ARG-LDB))          ;considered to be a one operand op.
     8879                (ERROR-TABLE RESTART XLDB0)
    79198880        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)   ;Arg1, byte pointer.  Must be fixnum.
    79208881                        Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    7921             (ERROR-TABLE ARGTYP FIXNUM PP 0)
     8882            (ERROR-TABLE ARGTYP FIXNUM PP 0 XLDB0)
     8883            (ERROR-TABLE ARG-POPPED 0 PP (FIXPACK M-1))
    79228884;Fixnum case.  Data to LDB out of (arg2) sign extended in M-1.
    79238885        ((M-K) (BYTE-FIELD 6 0) C-PDL-BUFFER-POINTER)    ;Get number of bits
     
    79268888                                           ; but if we didnt, it would cause lossage)
    79278889        (CALL-GREATER-THAN M-K (A-CONSTANT 23.) TRAP)
    7928     (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0)
     8890    (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0 XLDB0)
     8891    (ERROR-TABLE ARG-POPPED 0 PP (FIXPACK M-1))
    79298892        ((M-J) SUB M-K (A-CONSTANT 1))     ;Byte length minus one field
    79308893        ((M-E) (BYTE-FIELD (DIFFERENCE 23. 6) 6)
     
    79448907
    79458908BIGNUM-LDB      ;M-Q has bignum, M-C has bignum header, M-I has length of bignum.
     8909                (ERROR-TABLE RESTART BIGNUM-LDB)
    79468910        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)   ;Arg1, byte pointer.  Must be fixnum.
    79478911                        Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    7948             (ERROR-TABLE ARGTYP FIXNUM PP 0)
     8912            (ERROR-TABLE ARGTYP FIXNUM PP 0 BIGNUM-LDB)
     8913            (ERROR-TABLE ARG-POPPED 0 PP M-Q)
    79498914        ((M-K) (BYTE-FIELD 6 0) C-PDL-BUFFER-POINTER)    ;Get number of bits
    79508915        (CALL-GREATER-THAN M-K (A-CONSTANT 23.) TRAP)
    7951             (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0)
     8916            (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0 BIGNUM-LDB)
     8917            (ERROR-TABLE ARG-POPPED 0 PP M-Q)
    79528918        ((M-E) (BYTE-FIELD (DIFFERENCE 23. 6) 6)
    79538919                         C-PDL-BUFFER-POINTER)  ;Number of places over
     
    80569022       ((M-1) BYTE-INST M-1 A-ZERO)             ;RIGHT ADJUST BITS IN M-1 FOR NEXT TIME.
    80579023
     9024(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-DPB-OFFSET PP PP M-C M-B)
     9025
    80589026XOPDPB(MISC-INST-ENTRY %P-DPB-OFFSET)
    80599027        (JUMP-XCT-NEXT XOPDP1)                  ;JOIN XDPB, BUT FIRST
    80609028       (CALL XOMR0)                             ;REFERENCE THE DATA AND SET VMA
     9029
     9030(ERROR-TABLE DEFAULT-ARG-LOCATIONS %LOGDPB M-1 (+ (LSH M-E 6) M-K) M-2)
    80619031
    80629032XLDPB (MISC-INST-ENTRY %LOGDPB)    ;DPB FOR FIXNUMS ONLY, CAN STORE INTO SIGN BIT
     
    80709040          (M-T) DPB M-2 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
    80719041       (NO-OP)
     9042
     9043(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-DPB PP PP VMA)
    80729044
    80739045XPDPB (MISC-INST-ENTRY %P-DPB)
     
    80909062; DPB never changes the sign of quantity DPB'ed into, it extends
    80919063; the sign arbitrarily far to the left past the byte.
    8092 XDPB (MISC-INST-ENTRY DPB) (ERROR-TABLE RESTART DPB)
     9064XDPB (MISC-INST-ENTRY DPB) (ERROR-TABLE RESTART XDPB)
    80939065        ((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 2))      ;ADDRESS ARG1
    80949066        (DISPATCH Q-DATA-TYPE C-PDL-BUFFER-INDEX TRAP-UNLESS-FIXNUM)    ;MAKE SURE NOT BIGNUM
    8095     (ERROR-TABLE ARGTYP FIXNUM (PP -2) 0)
     9067    (ERROR-TABLE ARGTYP FIXNUM (PP -2) 0 XDPB)
     9068    (ERROR-TABLE ARG-POPPED 0 PP PP PP)
    80969069        (DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG) ;ONLY THE THIRD OPERAND IS
    80979070            (ERROR-TABLE ARGTYP NUMBER PP T XDPB)  ;PROCESSED VIA NUMARG. THUS DPB IS A
     9071            (ERROR-TABLE ARG-POPPED 0 PP PP PP)
    80989072       ((M-A) (A-CONSTANT ARITH-1ARG-DPB))         ;ONE OPERAND OP.
    80999073;FIXNUM CASE.  DATA TO DPB INTO (ARG3) SIGN EXTENDED IN M-1.
     9074                (ERROR-TABLE RESTART XDPB0)
    81009075        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)            ;ARG2, BYTE POINTER
    81019076                        Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    8102    (ERROR-TABLE ARGTYP FIXNUM PP 1)
     9077    (ERROR-TABLE ARGTYP FIXNUM PP 1 XDPB0)
     9078    (ERROR-TABLE ARG-POPPED 0 PP PP M-1)
    81039079        ((M-K) (BYTE-FIELD 6 0) C-PDL-BUFFER-POINTER) ;GET NUMBER OF BITS
    81049080        (JUMP-EQUAL M-K A-ZERO XDPB-ZERO)
    81059081        (CALL-GREATER-THAN M-K (A-CONSTANT 23.) TRAP)
    8106             (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0)
     9082    (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0 XDPB0)
     9083    (ERROR-TABLE ARG-POPPED 0 PP PP M-1)
    81079084        ((M-E) (BYTE-FIELD (DIFFERENCE 23. 6) 6)
    81089085                        C-PDL-BUFFER-POINTER-POP) ;GET NUMBER OF PLACES OVER
    8109 ASHDPB  ((M-J) SUB M-K (A-CONSTANT 1))
    8110         ((M-2) ADD M-K A-E)
    8111         (JUMP-GREATER-THAN M-2 (A-CONSTANT 31.) XDPB2A)
    8112         ((OA-REG-LOW) DPB M-J OAL-BYTL-1 A-E)           ;Will fit in machine
    8113         ((M-1) DPB C-PDL-BUFFER-POINTER-POP A-1)        ; word so go ahead
    8114         (JUMP RETURN-M-1)
     9086ASHDPB  ((M-2) ADD M-K A-E)                     ;M-2 maximum number of bits in result
     9087        (JUMP-GREATER-THAN M-2 (A-CONSTANT 32.) XDPB2A) ;Multi-word => use bignum code
     9088        (JUMP-LESS-THAN-XCT-NEXT M-1 A-ZERO ASHDPB-NEG)
     9089       ((M-J) SUB M-K (A-CONSTANT 1))           ;Single-word => use hardware DPB
     9090        ((OA-REG-LOW) DPB M-J OAL-BYTL-1 A-E)
     9091        ((M-1) DPB C-PDL-BUFFER-POINTER-POP A-1)
     9092        (JUMP-GREATER-OR-EQUAL M-1 A-ZERO RETURN-M-1)   ;Result in M-1 if sign didn't change
     9093        ((M-C) A-ZERO)                          ;Else it's a 2-word bignum
     9094        (JUMP-XCT-NEXT OVERFLOW-BIGNUM-CREATE)
     9095       ((M-2) A-ZERO)
     9096
     9097ASHDPB-NEG                                      ;Single-word DPB into negative number
     9098        ((OA-REG-LOW) DPB M-J OAL-BYTL-1 A-E)
     9099        ((M-1) DPB C-PDL-BUFFER-POINTER-POP A-1)
     9100        (JUMP-LESS-THAN M-1 A-ZERO RETURN-M-1)  ;Result in M-1 if sign didn't change
     9101        ((M-1) SUB M-ZERO A-1)                  ;Else it's a 2-word bignum
     9102        (JUMP-NOT-EQUAL-XCT-NEXT M-1 A-ZERO OVERFLOW-BIGNUM-CREATE-NEGATIVE)
     9103       ((M-2) A-ZERO)
     9104        (JUMP-XCT-NEXT OVERFLOW-BIGNUM-CREATE-NEGATIVE)
     9105       ((M-2) (A-CONSTANT 1))
    81159106
    81169107;Get here on DPB ing into fixnum at position beyond 31. bits.  Fake up bignum
     
    81359126        (CALL-GREATER-THAN M-K (A-CONSTANT 23.) TRAP)
    81369127            (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0)
     9128            (ERROR-TABLE ARG-POPPED PP PP M-T)
    81379129        (CALL-IF-BIT-SET BIGNUM-HEADER-SIGN M-C BIGNEG) ;GET 2'S COMPLEMENT REPRESENTATION
    81389130        ((M-E) (BYTE-FIELD (DIFFERENCE 23. 6) 6)
     
    81459137       ((M-E) SUB M-E (A-CONSTANT 31.))
    81469138        (CALL TRAP)
    8147            (ERROR-TABLE BIGNUM-NOT-BIG-ENUF-DPB)        ;SHOULDN'T HAPPEN
     9139           (ERROR-TABLE BIGNUM-NOT-BIG-ENOUGH-DPB)      ;SHOULDN'T HAPPEN
    81489140
    81499141BIGDPB1 ((VMA-START-READ) ADD M-T A-D)    ;FETCH WORD OF BIGNUM
     
    81949186       ((M-GARBAGE) C-PDL-BUFFER-POINTER-POP)   ;AND POP OTHER TWO ARGS
    81959187
     9188(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-MASK-FIELD-OFFSET PP M-C M-B)
     9189
    81969190XOPMF (MISC-INST-ENTRY %P-MASK-FIELD-OFFSET)
    81979191        (JUMP-XCT-NEXT XOPMF1)                  ;JOIN XMF, BUT FIRST
    81989192       (CALL XOMR0)                             ;REFERENCE THE LOCATION
    81999193
     9194(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-MASK-FIELD PP VMA)
     9195
    82009196XPMF  (MISC-INST-ENTRY %P-MASK-FIELD)
    82019197        ((VMA-START-READ) C-PDL-BUFFER-POINTER-POP)
     
    82039199XOPMF1  (JUMP-XCT-NEXT XPFM1)
    82049200       ((M-1) READ-MEMORY-DATA)
     9201
     9202(ERROR-TABLE DEFAULT-ARG-LOCATIONS MASK-FIELD PP M-1)
    82059203
    82069204XMF   (MISC-INST-ENTRY MASK-FIELD)      ;LIKE LDB BUT DATA IN ORIGINAL POSITION IN Q
     
    82219219                (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))
    82229220
     9221(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-DEPOSIT-FIELD-OFFSET PP PP M-C M-B)
     9222
    82239223XOPDF(MISC-INST-ENTRY %P-DEPOSIT-FIELD-OFFSET)
    82249224        (JUMP-XCT-NEXT XOPDF1)                  ;JOIN XDF, BUT FIRST
    82259225       (CALL XOMR0)                             ;REFERENCE THE LOCATION AND SET VMA
     9226
     9227(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-DEPOSIT-FIELD PP PP VMA)
    82269228
    82279229XPDF (MISC-INST-ENTRY %P-DEPOSIT-FIELD)
     
    82499251       ((M-T) SELECTIVE-DEPOSIT C-PDL-BUFFER-POINTER-POP A-TEM3)
    82509252
     9253(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-STORE-TAG-AND-POINTER PP M-A)
     9254
    82519255XCMBS (MISC-INST-ENTRY %P-STORE-TAG-AND-POINTER)
    8252         ((A-TEM3) Q-POINTER C-PDL-BUFFER-POINTER-POP) ;ARG3, VALUE FOR POINTER FIELD
     9256        ((M-A) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;ARG3, VALUE FOR POINTER FIELD
    82539257        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)         ;ARG3 ANY TYPE, MISCBITS MUST BE FIXNUM
    82549258                        Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM)
    82559259    (ERROR-TABLE ARGTYP FIXNUM PP 2)