Changeset 274

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

Update from System 78.

Location:
trunk/lisp/lcadr
Files:
9 removed
14 modified

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) 
     
    201201                                 "Strobe Early" "Strobe Late" 
    202202                                 "Servo Reverse -- Strobe Early"  ;NO COMMAS INSIDE STRINGS 
    203                                  "Servo Reverse -- Strobe Late"   : IN MACLISP 
     203                                 "Servo Reverse -- Strobe Late"   ; IN MACLISP 
    204204                                 "Servo Forward -- Strobe Early" 
    205205                                 "Servo Forward -- Strobe Late") 
     
    298298 
    299299;returns t if wins 
     300; if DISK-BLOCK-NUM a list, its (track head sector). 
    300301(DEFUN CC-DISK-XFER (FCN DISK-BLOCK-NUM CORE-PAGE-NUM N-BLOCKS) 
    301   (PROG (TRACK HEAD SECTOR DUSH ERRCNT STATUS) 
     302  (PROG (TRACK HEAD SECTOR DUSH ERRCNT STATUS 
     303         FINAL-DUSH FINAL-ADDRESS FINAL-SECTOR FINAL-HEAD FINAL-TRACK) 
    302304     (DECLARE (FIXNUM TRACK HEAD SECTOR DUSH ERRCNT STATUS)) 
    303305     (COND ((NOT CC-DISK-TYPE)(CC-DISK-INIT))) 
    304306     (SETQ ERRCNT CC-DISK-RETRY-COUNT) 
    305      (SETQ TRACK (// DISK-BLOCK-NUM BLOCKS-PER-CYLINDER)) 
    306      (SETQ SECTOR (\ DISK-BLOCK-NUM BLOCKS-PER-CYLINDER)) 
    307      (SETQ HEAD (// SECTOR BLOCKS-PER-TRACK) 
    308            SECTOR (\ SECTOR BLOCKS-PER-TRACK)) 
     307     (COND ((NUMBERP DISK-BLOCK-NUM) 
     308            (SETQ TRACK (// DISK-BLOCK-NUM BLOCKS-PER-CYLINDER)) 
     309            (SETQ SECTOR (\ DISK-BLOCK-NUM BLOCKS-PER-CYLINDER)) 
     310            (SETQ HEAD (// SECTOR BLOCKS-PER-TRACK) 
     311                  SECTOR (\ SECTOR BLOCKS-PER-TRACK)) 
     312            (SETQ FINAL-ADDRESS (+ DISK-BLOCK-NUM (1- N-BLOCKS)) 
     313                  FINAL-TRACK (// FINAL-ADDRESS BLOCKS-PER-CYLINDER) 
     314                  FINAL-SECTOR (\ FINAL-ADDRESS BLOCKS-PER-CYLINDER) 
     315                  FINAL-HEAD (// FINAL-SECTOR BLOCKS-PER-TRACK) 
     316                  FINAL-SECTOR (\ FINAL-SECTOR BLOCKS-PER-TRACK))) 
     317           (T (SETQ TRACK (CAR DISK-BLOCK-NUM) 
     318                    HEAD (CADR DISK-BLOCK-NUM) 
     319                    SECTOR (CADDR DISK-BLOCK-NUM))))                 
    309320     (SETQ DUSH (+ (CC-SHIFT TRACK 16.) (LSH HEAD 8) SECTOR)) 
    310321     (AND (> N-BLOCKS 366) ;We only want to use 1 page for the command list 
     
    327338       (AND (ZEROP (LOGAND 1 (SETQ STATUS (PHYS-MEM-READ CC-DISK-ADDRESS)))) 
    328339            (GO WAIT)))) 
     340     (SETQ FINAL-DUSH (PHYS-MEM-READ (+ CC-DISK-ADDRESS 2))) 
    329341     (COND ((NOT (ZEROP (LOGAND STATUS 47777560))) 
    330342                ; ERROR BITS: INTERNAL PARITY, NXM, MEM PAR, HEADER COMPARE, 
     
    337349            (PRINT 'RETRYING) 
    338350            (TERPRI) 
     351            ;(BREAK CC-DISK-ERROR T) 
     352            (GO LP)) 
     353           ((AND (NUMBERP FINAL-TRACK) 
     354                 (OR (NOT (= FINAL-TRACK (LDB 2014 FINAL-DUSH))) 
     355                     (NOT (= FINAL-HEAD (LDB 1010 FINAL-DUSH))) 
     356                     (NOT (= FINAL-SECTOR (LDB 0010 FINAL-DUSH))))) 
     357            (FORMAT T "~%Final disk address incorrect, is ~D,~D,~D; should be ~D,~D,~D" 
     358                    (LDB 2014 FINAL-DUSH) (LDB 1010 FINAL-DUSH) (LDB 0010 FINAL-DUSH) 
     359                    FINAL-TRACK FINAL-HEAD FINAL-SECTOR) 
     360            (BREAK 'CC-FINAL-DISK-ADDRESS-ERROR T) 
    339361            (GO LP))) 
    340362     (RETURN T)         ;won 
     
    344366; MAINLY GOOD FOR RETRYING TRANSFERS THAT LOSE, ETC. 
    345367(DEFUN CC-DISK-XFER-TRACK-HEAD-SECTOR (FCN TRACK HEAD SECTOR CORE-PAGE-NUM N-BLOCKS) 
    346   (DECLARE (FIXNUM TRACK HEAD SECTOR DUSH ERRCNT STATUS)) 
    347   (PROG (DUSH ERRCNT STATUS) 
    348      (SETQ ERRCNT CC-DISK-RETRY-COUNT) 
    349      (SETQ DUSH (+ (CC-SHIFT TRACK 16.) (LSH HEAD 8) SECTOR)) 
    350      (AND (> N-BLOCKS 366) ;We only want to use 1 page for the command list 
    351           (ERROR N-BLOCKS 'TOO-MANY-BLOCKS-FOR-CMD-LIST 'FAIL-ACT)) 
    352  LP  ;;Set up the command list, starting at location 12, a bit of a kludge 
    353      (DO ((I 12 (1+ I)) 
    354           (A CORE-PAGE-NUM (1+ A)) 
    355           (N N-BLOCKS (1- N))) 
    356          ((= N 0)) 
    357        (PHYS-MEM-WRITE I (+ (CC-SHIFT A 8) (COND ((= N 1) 0) (T 1))))) 
    358      (LET ((CTALK-BARF-AT-WRITE-ERRORS NIL))  ;THESE MIGHT NOT READ BACK EXACTLY THE SAME... 
    359       (PROG NIL  
    360        (PHYS-MEM-WRITE (+ CC-DISK-ADDRESS 0) FCN) ;Store command, does reset 
    361        (PHYS-MEM-WRITE (+ CC-DISK-ADDRESS 1) 12)  ;Store CLP 
    362        (SETQ CC-DISK-LAST-CMD FCN CC-DISK-LAST-CLP 12) 
    363        (PHYS-MEM-WRITE (+ CC-DISK-ADDRESS 2) DUSH)  ;Store disk address 
    364        (PHYS-MEM-WRITE (+ CC-DISK-ADDRESS 3) 0)   ;Start transfer 
    365   WAIT ;;This loop awaits completion 
    366        #M (SLEEP-JIFFIES 2) 
    367        #Q (PROCESS-SLEEP 2) 
    368        (AND (ZEROP (LOGAND 1 (SETQ STATUS (PHYS-MEM-READ CC-DISK-ADDRESS)))) 
    369             (GO WAIT)))) 
    370      (COND ((NOT (ZEROP (LOGAND STATUS 47777560))) 
    371                 ; ERROR BITS: INTERNAL PARITY, NXM, MEM PAR, HEADER COMPARE, 
    372                 ; HEADER ECC, ECC HARD, ECC SOFT, OVERRUN, TRANSFER ABORTED, 
    373                 ; START-BLOCK ERR, TIMEOUT, SEEK ERR, OFF LINE, OFF CYL, FAULT, 
    374                 ;    NO SEL, MUL SEL 
    375             (CC-DISK-ANALYZE) 
    376             (AND (ZEROP (SETQ ERRCNT (1- ERRCNT))) 
    377                  (RETURN NIL)) 
    378             (PRINT 'RETRYING) 
    379             (TERPRI) 
    380             (GO LP))) 
    381      )) 
     368  (CC-DISK-XFER FCN (LIST TRACK HEAD SECTOR) CORE-PAGE-NUM N-BLOCKS)) 
    382369 
    383370 
     
    533520    (CC-DISK-READ-IN-CORE 'PAGE))) 
    534521 
    535 (DEFUN CC-CHECK-PAGE-HASH-TABLE-ACCESSIBILITY NIL  
     522(DEFUN CC-CHECK-PAGE-HASH-TABLE-ACCESSIBILITY () 
    536523  (DO ((TABLE-ADR PHT-ADDR (+ TABLE-ADR 2)) 
    537524       (HASH-ADR) 
    538525       (PHT1) 
    539        (COUNT (LSH SIZE-OF-PAGE-TABLE -1) (1- COUNT)) 
     526       (COUNT (LSH (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-SIZE))) -1) 
     527              (1- COUNT)) 
    540528       (NUMBER-ERRORS 0)) 
    541529      ((= 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  
    119119  (PRINT 'CC-TEST-ARITH-COND-JUMP) 
    120120  (CC-TEST-ARITH-COND-JUMP) 
     121  (PRINT 'CC-GROSS-DATA-TESTS) 
     122  (CC-GROSS-DATA-TESTS ALL-MEMORIES) 
    121123  (PRINT 'CC-ADDRESS-TEST-A-MEM) 
    122124  (CC-ADDRESS-TEST-A-MEM) 
     
    129131 
    130132;Test each 4K separately since they have separate address drivers 
    131 (DEFUN CC-FAST-ADDRESS-TEST-C-MEM-BANKS (&OPTIONAL (NBANKS 3)) 
     133(DEFUN CC-FAST-ADDRESS-TEST-C-MEM-BANKS (&OPTIONAL (NBANKS 4)) 
    132134  (FORMAT T "CC-FAST-ADDRESS-TEST-C-MEM-BANKS~%") 
    133135  (DOTIMES (BANK NBANKS) 
    134136    (CC-FAST-ADDRESS-TEST 
    135137      (FORMAT NIL "CMEM-BANK ~A" BANK) (+ RACMO (* BANK 10000)) 48. 12.))) 
    136  
    137138 
    138139;;; Toplevel data path tests 
     
    673674    (AND (= (CC-READ-PC) 3)                     ;NORMAL HALT, DONE 
    674675         (RETURN (NREVERSE ERRORS))) 
    675     (SETQ ADDRESS (1+ (#Q ASH #M LSH (CC-READ-M-MEM CONS-M-SRC-LC) -6))  ;NEXT ADDRESS TO DO 
     676    (SETQ ADDRESS (1+ (logand 7777 
     677                              (#Q ASH #M LSH (CC-READ-M-MEM CONS-M-SRC-LC) 
     678                               -6)))  ;NEXT ADDRESS TO DO 
    676679          LOC (1- ADDRESS) 
    677680          GOOD (CC-READ-M-MEM CONS-M-SRC-MD)  
     
    792795       (ONES (SUB1 (EXPT 2 N-DATA-BITS))) 
    793796       (ZEROS 0) 
    794        (HIADR (+ REGADR (COND ((EQ MEM-NAME 'C-MEM) 30000)   ;CROCK 
    795                               (T (EXPT 2 N-ADDRESS-BITS))))) 
     797       (HIADR (+ REGADR (EXPT 2 N-ADDRESS-BITS))) 
    796798       (ERRORS 0)) 
    797799      ((= N 0)) 
     
    10901092;; the MROT field.  Doesn't currently test whether automatic fetching. 
    10911093;; Does test LC incrementing.  Eventually that should be tested. 
     1094;; Should test LC -> VMA data path. 
    10921095(DEFUN CC-TEST-LC-AFFECTS-SHIFT () 
    10931096  (CC-WRITE-A-MEM 1 0) 
     
    12201223            (PRIN1 VAL)) 
    12211224           (T (SETQ OK-CNT (1+ OK-CNT)))))) 
    1222   (cc-execute (w-c-mem 0) 
     1225  (cc-write-d-mem 0 (dpb 1 cons-disp-p-bit (dpb 1 cons-disp-n-bit 0))) 
     1226  (do ((cnt 0 (1+ cnt)) 
     1227       (adr 0 (lsh 1 cnt))) 
     1228      ((= adr 20000)) 
     1229    (cc-execute (w-c-mem adr) 
    12231230              cons-ir-op cons-op-dispatch 
    12241231              cons-ir-disp-lpc 1 
    12251232              cons-ir-disp-bytl 0 
    12261233              cons-ir-disp-addr 0) 
    1227   (cc-write-d-mem 0 (dpb 1 cons-disp-p-bit (dpb 1 cons-disp-n-bit 0))) 
    1228   (cc-save-micro-stack) 
    1229   (setq cc-saved-micro-stack-ptr 0) 
    1230   (as-1 -1 cc-micro-stack 0) 
    1231   (as-1 -1 cc-micro-stack 1) 
    1232   (cc-restore-micro-stack) 
    1233   (cc-write-pc 0) 
    1234   (cc-noop-clock)       ;dispatch inst to IR 
    1235   (cc-clock)            ;execute it 
    1236   (cc-noop-clock)       ;write spc 
    1237   (cc-save-micro-stack) 
    1238   (cond ((not (= cc-saved-micro-stack-ptr 1)) 
    1239          (format t "~%Dispatch push failed to advance USP ~s" cc-saved-micro-stack-ptr))) 
    1240   (cond ((not (= (setq tem (ar-1 cc-micro-stack 1)) 0)) 
    1241          (format t "~%Dispatch push own address at 0 pushed ~s instead" tem))) 
     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 adr) 
     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)) adr)) 
     1247           (format t "~%Dispatch push own address at adr ~s pushed ~s instead" adr tem))) 
     1248    (cc-execute (w-c-mem adr) 
     1249              cons-ir-op cons-op-dispatch 
     1250              cons-ir-disp-bytl 0 
     1251              cons-ir-disp-addr 0) 
     1252    (cc-save-micro-stack) 
     1253    (setq cc-saved-micro-stack-ptr 0) 
     1254    (as-1 -1 cc-micro-stack 0) 
     1255    (as-1 -1 cc-micro-stack 1) 
     1256    (cc-restore-micro-stack) 
     1257    (cc-write-pc adr) 
     1258    (cc-noop-clock)     ;dispatch inst to IR 
     1259    (cc-clock)          ;execute it 
     1260    (cc-noop-clock)     ;write spc 
     1261    (cc-save-micro-stack) 
     1262    (cond ((not (= cc-saved-micro-stack-ptr 1)) 
     1263           (format t "~%Dispatch push failed to advance USP ~s" cc-saved-micro-stack-ptr))) 
     1264    (cond ((not (= (setq tem (ar-1 cc-micro-stack 1)) (1+ adr))) 
     1265           (format t "~%Dispatch next address at adr ~s pushed ~s instead" adr tem)))) 
    12421266) 
    12431267 
     
    14801504 
    14811505 
    1482 (DEFUN CC-MEM-FILL (FROM TO &OPTIONAL (WORD 0) (FUNCTION (FUNCTION (LAMBDA (X) (1+ X))))) 
     1506(DEFUN CC-MEM-FILL (FROM TO &OPTIONAL (WORD 0) (FUNCTION (FUNCTION 1+))) 
    14831507  (DO ((ADR FROM (1+ ADR)) 
    14841508       (WORD WORD (FUNCALL FUNCTION WORD))) 
     
    14861510      (PHYS-MEM-WRITE ADR WORD))) 
    14871511 
    1488 (DEFUN CC-MEM-FILL-CHECK (FROM TO &OPTIONAL (WORD 0) 
    1489                                             (FUNCTION (FUNCTION (LAMBDA (X) (1+ X))))) 
     1512(DEFUN CC-MEM-FILL-CHECK (FROM TO &OPTIONAL (WORD 0) (FUNCTION (FUNCTION 1+))) 
    14901513  (DO ((ADR FROM (1+ ADR)) 
    14911514       (MEM-WORD 0) 
     
    15411564  `(LDB 1612 ,VMA)) 
    15421565 
    1543 (DEFUN CC-PARITY-SWEEP-INFO (PHYS-ADR-LIST &OPTIONAL (PRINT-AREA-SYMBOL T)) 
     1566(DEFUN CC-PARITY-SWEEP-INFO (PHYS-ADR-LIST 
     1567                             &OPTIONAL FIX-SINGLE-BIT-ERRORS (PRINT-AREA-SYMBOL T)) 
    15441568  (DO ((L PHYS-ADR-LIST (CDR L)) 
    15451569       (PHYS-ADR) (VIRT-ADR) (AREA-NUMBER) (AREA-SYMBOL) (CORE) (DISK)) 
     
    15551579            (SETQ CORE (QF-MEM-READ VIRT-ADR)) 
    15561580            (SETQ DISK (QF-MEM-READ-DISK-COPY VIRT-ADR))) 
    1557     (CC-PRINT-BITS (LOGXOR CORE DISK))) 
    1558 ) 
     1581    (CC-PRINT-BITS (LOGXOR CORE DISK)) 
     1582    (IF (AND FIX-SINGLE-BIT-ERRORS 
     1583             T  ;(SINGLE-BIT-P (LOGXOR CORE DISK)) 
     1584             ) 
     1585        (PROGN (FORMAT T "~%Fixing locn ~o to ~o" phys-adr disk) 
     1586               (PHYS-MEM-WRITE PHYS-ADR DISK))))) 
    15591587 
    15601588(DEFUN CC-PARITY-SWEEP (&OPTIONAL (NUMBER-OF-MEMORIES 2) 
     
    16921720  (process-sleep 60.) 
    16931721  (spy-write spy-clk 10)        ;Clear RUN, but leave DEBUG set 
     1722  (spy-write spy-mode 0)        ;Dont leave that random speed in there.  The cc-read-m-mem 
     1723                                ; may cause randomness if you do. 
    16941724  (let ((low (%unibus-read 764120))  ;Hardware synchronizes if you read this one first 
    16951725        (high (%unibus-read 764122))) 
     
    21752205 ) 
    21762206 
     2207(defun display-registers-for-debug-divide-test () 
     2208  (cond ((boundp display-registers-for-debug-divide-test-flag) 
     2209         (format T "~%A-MEM 1001 dividend  ~A    " (cc-read-a-mem 1001)) 
     2210         (format T "A-MEM 1002 divisor   ~A~%" (cc-read-a-mem 1002)) 
     2211         (format T "A-MEM 1003 rem       ~A    " (cc-read-a-mem 1003)) 
     2212         (format T "M-MEM 1    count     ~A" (cc-read-m-mem 1)) 
     2213         (format T "~%M-1                  ~A    " (cc-read-m-mem #o22)) 
     2214         (format T "A-2                  ~A" (cc-read-A-mem #o23)) 
     2215         (format T "~%Output Bus           ~A" (cc-read-obus))))) 
     2216 
     2217;(setq  display-registers-for-debug-divide-test-flag T) 
    21772218 
    21782219;first arg of NIL says use values in machine. 
    21792220(DEFUN CC-DIVIDE-TEST-LOOP (&OPTIONAL (DIVIDEND (RANDOM 37777777)) 
    21802221                            (DIVISOR (RANDOM 37777777))) 
    2181   (LET ((REM (\ DIVIDEND DIVISOR))) 
     2222  (LET ((REM (IF DIVIDEND (\ DIVIDEND DIVISOR)))) 
    21822223    (CC-WRITE-M-MEM 1 0)                        ;error count 
    21832224    (IF (NUMBERP DIVIDEND) 
     
    21902231) 
    21912232 
     2233(DEFUN CC-DIVIDE-SAVE-STATE NIL 
     2234  (LIST (CC-READ-A-MEM 1001) (CC-READ-A-MEM 1002) (CC-READ-A-MEM 1003))) 
     2235 
     2236(DEFUN CC-DIVIDE-RESTORE-STATE (STATE) 
     2237  (CC-WRITE-A-MEM 1001 (CAR STATE)) 
     2238  (CC-WRITE-A-MEM 1002 (CADR STATE)) 
     2239  (CC-WRITE-A-MEM 1003 (CADDR STATE))) 
     2240   
     2241(DEFUN CC-DIVIDE-COMPARE-STATE (STATE &AUX TEM) 
     2242  (IF (NOT (= (SETQ TEM (CC-READ-A-MEM 1001)) (CAR STATE))) 
     2243      (FORMAT T "~%1001 CLOBBERED FROM ~S TO ~S" TEM (CAR STATE))) 
     2244  (IF (NOT (= (SETQ TEM (CC-READ-A-MEM 1002)) (CADR STATE))) 
     2245      (FORMAT T "~%1002 CLOBBERED FROM ~S TO ~S" TEM (CADR STATE))) 
     2246  (IF (NOT (= (SETQ TEM (CC-READ-A-MEM 1003)) (CADDR STATE))) 
     2247      (FORMAT T "~%1003 CLOBBERED FROM ~S TO ~S" TEM (CADDR STATE)))) 
     2248 
     2249(comment 
    21922250(DEFUN CC-DIVIDE-TEST-LOOP-STATE NIL 
    2193   (LIST (CC-READ-A-MEM 1001) (CC-READ-A-MEM 1002))) 
    2194  
    2195 (DEFUN CC-DIVIDE-RESTORE-STATE (S) 
     2251  (LIST (CC-READ-A-MEM 1001) (CC-READ-A-MEM 1002))) ) 
     2252 
     2253(DEFUN CC-DIVIDE-RESTORE-STATE-AND-DIAGNOSE (S) 
    21962254  (DBG-RESET) 
    21972255  (CC-RESET-MACH) 
     
    22232281              (IF (SETQ TEM (ASSQ PC HIST)) 
    22242282                  (IF (NOT (= (CDR TEM) OBUS)) 
    2225                       (PROGN (FORMAT T "~%Multiple values observed at PC ~S, ~S ~S " 
     2283                      (COMMENT (PROGN (FORMAT T "~%Multiple values observed at PC ~S, ~S ~S " 
    22262284                                     PC OBUS (CDR TEM)) 
    2227                              (CC-PRINT-BITS (LOGXOR OBUS (CDR TEM))))) 
     2285                             (CC-PRINT-BITS (LOGXOR OBUS (CDR TEM)))))) 
    22282286                  (SETQ HIST (CONS (CONS PC OBUS) HIST)))) 
    22292287          (SPY-WRITE SPY-CLK 1))        ;continue 
     
    22542312  )) 
    22552313 
     2314;THIS DOESNT SEEM TO WORK JUST YET. 
     2315(DEFUN CC-PDL-BUFFER-PUSH-POP-CHECK () 
     2316  (DBG-RESET) 
     2317  (CC-RESET-MACH) 
     2318  (CC-EXECUTE (W-C-MEM 100) 
     2319      CONS-IR-FUNC-DEST CONS-FUNC-DEST-PDL-BUFFER-PUSH) 
     2320  (CC-EXECUTE (W-C-MEM 101) 
     2321      CONS-IR-M-SRC CONS-M-SRC-C-PDL-BUFFER-POINTER-POP) 
     2322  (CC-EXECUTE (W-C-MEM 102) 
     2323      CONS-IR-OP CONS-OP-JUMP 
     2324      CONS-IR-JUMP-ADDR 100 
     2325      CONS-IR-JUMP-COND CONS-JUMP-COND-UNC 
     2326      CONS-IR-N 1) 
     2327  (LET ((PP 1777) PC RPP INCR IR) 
     2328    (CC-WRITE-PDL-BUFFER-POINTER PP) 
     2329    (CC-SET-SPEED 2) 
     2330    (CC-COLON-START 100) 
     2331    (DOTIMES (C 1000) 
     2332      (CC-STOP-MACH) 
     2333      (SETQ PC (CC-READ-PC) 
     2334            IR (CC-READ-IR) 
     2335            RPP (CC-READ-PDL-BUFFER-POINTER)) 
     2336      (SETQ INCR (CDR (ASSQ PC '((100 . 0) (101 . 1) (102 . 0) (103 . 0))))) 
     2337      (IF (NULL INCR) 
     2338          (FORMAT T "~%PC was random ~S" PC) 
     2339          (IF (NOT (= (LOGAND 1777 (+ PP INCR)) RPP)) 
     2340              (FORMAT T "~%PP WRONG, WAS ~S SHOULD BE ~S" RPP (LOGAND 1777 (+ PP INCR))))) 
     2341      (CC-WRITE-IR IR) 
     2342      (CC-WRITE-PC PC) 
     2343      (CC-CLOCK) 
     2344      (SPY-WRITE SPY-CLK 1))   ;CONTINUE 
     2345    )) 
     2346 
     2347(DEFVAR KEY-BITS 
     2348        '((#/4 11) 
     2349          (#\PLUS-MINUS 21) 
     2350          (#\NETWORK 42) 
     2351          (#\MACRO 100) 
     2352          (#/C 164))) 
     2353 
     2354(DEFVAR *TEST-LOCAL-KEYBOARD* NIL) 
     2355(DEFUN KEYBOARD-DBG-READ (ADR) 
     2356  (IF *TEST-LOCAL-KEYBOARD* (%UNIBUS-READ ADR) (DBG-READ ADR))) 
     2357 
     2358(DEFUN KEYBOARD-DBG-WRITE (ADR DATA) 
     2359  (IF *TEST-LOCAL-KEYBOARD* (%UNIBUS-WRITE ADR DATA) (DBG-WRITE ADR DATA))) 
     2360 
     2361(DEFUN TEST-IO-KEYBOARD () 
     2362  (KEYBOARD-DBG-READ 764100)                            ;Clear out keyboard 
     2363  (IF (LDB-TEST 0501 (KEYBOARD-DBG-READ 764112)) 
     2364      (FORMAT T "~&Keyboard ready did not clear when read")) 
     2365  (DOLIST (L KEY-BITS) 
     2366    (APPLY 'TEST-KEY L)) 
     2367  ) 
     2368 
     2369(DEFUN TEST-KEY (KEY VALUE) 
     2370  (FORMAT T "~&Hold down the ~:C key on the debugee and then type space on this keyboard." 
     2371          KEY) 
     2372  (FUNCALL STANDARD-INPUT ':TYI) 
     2373  (LET ((READ-KEY (KEYBOARD-DBG-READ 764100))) 
     2374    (IF ( READ-KEY VALUE) 
     2375        (FORMAT T "Keyboard should have been ~O and was ~O" VALUE READ-KEY)))) 
     2376 
     2377(DEFUN CC-TEST-IO-BOARD (&OPTIONAL (*TEST-LOCAL-KEYBOARD* *TEST-LOCAL-KEYBOARD*)) 
     2378  (FORMAT T "~&Testing Time of day clock") 
     2379  (CHECK-ANDS-AND-OR 764120 16. 1000. "Time of day") 
     2380  ;; Enable remote mouse 
     2381  (KEYBOARD-DBG-WRITE 764112 1) 
     2382  (FORMAT T 
     2383          "~&Testing mouse Y direction, roll mouse upwards for a while 
     2384and then type space") 
     2385  (CHECK-ANDS-AND-OR 764104 12. NIL "Mouse Y position") 
     2386  (FORMAT T 
     2387          "~&Testing mouse X direction, roll mouse sideways for a while 
     2388and then type space") 
     2389  (CHECK-ANDS-AND-OR 764106 12. NIL "Mouse X position") 
     2390  (FORMAT T "~&Testing console beeper, should be beeping") 
     2391  (LOOP DO (KEYBOARD-DBG-READ 764110) UNTIL (FUNCALL STANDARD-INPUT ':TYI-NO-HANG)) 
     2392  (FORMAT T "~&Testing Chaosnet interface") 
     2393  (LET ((CHAOS:CHATST-USE-DEBUG (NOT *TEST-LOCAL-KEYBOARD*))) 
     2394    (CHAOS:CHATST))) 
     2395 
     2396(DEFUN CHECK-ANDS-AND-OR (ADDR BITS ITERATION NAME) 
     2397  (LET* ((MASK (1- (^ 2 BITS))) 
     2398         (AND MASK) 
     2399         (OR 0)) 
     2400    (DO ((I 0 (1+ I)) 
     2401         (RES)) 
     2402        ((IF (NULL ITERATION) 
     2403             (FUNCALL STANDARD-INPUT ':TYI-NO-HANG) 
     2404             ( 
     2405 I ITERATION))) 
     2406      (SETQ RES (LOGAND MASK (KEYBOARD-DBG-READ ADDR)) 
     2407            OR (LOGIOR OR RES) 
     2408            AND (LOGAND AND RES))) 
     2409    (IF (OR ( AND 0) ( OR MASK)) 
     2410        (FORMAT T "~&Bits in the ~A register not changing.~% LOGAND=~O LOGIOR=~O" 
     2411                NAME AND OR)))) 
     2412 
     2413(DEFCONST *SERIAL-IO-TESTS* 
     2414          '(((:BAUD 1200.) (:PARITY :ODD) 
     2415             (:NUMBER-OF-DATA-BITS 7) (:NUMBER-OF-STOP-BITS 2)) 
     2416            ((:BAUD 9600.) (:PARITY :EVEN) 
     2417             (:NUMBER-OF-DATA-BITS 8) (:NUMBER-OF-STOP-BITS 1)))) 
     2418 
     2419(DEFUN TEST-SERIAL-IO () 
     2420  (LET ((STREAM NIL)) 
     2421    (UNWIND-PROTECT 
     2422      (PROGN 
     2423        (SETQ STREAM (SI:MAKE-SERIAL-STREAM 
     2424                       ':NUMBER-OF-STOP-BITS 1 
     2425                       ':PARITY ':ODD)) 
     2426        (DOLIST (PROP '(:CHECK-PARITY-ERRORS :CHECK-OVER-RUN-ERRORS :CHECK-FRAMING-ERRORS)) 
     2427          (FUNCALL STREAM ':PUT PROP T)) 
     2428        (FORMAT T "~&Testing serial I/O using /"remote loop back/" in the UART.") 
     2429        (UNWIND-PROTECT 
     2430          (PROGN 
     2431            (FUNCALL STREAM ':PUT ':LOCAL-LOOP-BACK T) 
     2432            (TEST-SERIAL-IO-SERIES STREAM *SERIAL-IO-TESTS*)) 
     2433          (FUNCALL STREAM ':PUT ':LOCAL-LOOP-BACK NIL)) 
     2434        (FORMAT T "~2&Attach a loop-back plug; type N if you don't want to do this test, 
     2435or any other character to run the test.") 
     2436        (LET ((CHAR (FUNCALL STANDARD-INPUT ':TYI))) 
     2437          (COND ((NOT (CHAR-EQUAL #/N CHAR)) 
     2438                 (FORMAT T "~&Testing extra EIA-RS-232 bits.") 
     2439                 (TEST-SERIAL-IO-EIA-RS-232-BITS STREAM) 
     2440                 (TEST-SERIAL-IO-SERIES STREAM *SERIAL-IO-TESTS*))))) 
     2441      (CLOSE STREAM)))) 
     2442 
     2443(DEFVAR *SERIAL-IO-ERROR-COUNT*) 
     2444(DEFCONST *SERIAL-IO-ERROR-LIMIT* 5) 
     2445 
     2446(DEFUN TEST-SERIAL-IO-SERIES (STREAM SERIES) 
     2447  (DOLIST (TEST SERIES) 
     2448    (LET ((BASE 10.) 
     2449          (FIRST T) 
     2450          (*SERIAL-IO-ERROR-COUNT* 0)) 
     2451      (FORMAT T "~&") 
     2452      (DOLIST (CLAUSE TEST) 
     2453        (LET ((NAME (FIRST CLAUSE)) 
     2454              (VALUE (SECOND CLAUSE))) 
     2455          (IF (NOT FIRST) 
     2456              (FORMAT T "; ")) 
     2457          (SETQ FIRST NIL) 
     2458          (FORMAT T "~S = ~S" NAME VALUE) 
     2459          (FUNCALL STREAM ':PUT NAME VALUE))) 
     2460      (TEST-SERIAL-IO-CHARS STREAM)))) 
     2461 
     2462(DEFCONST *SERIAL-IO-TIMEOUT* 60.) 
     2463 
     2464(DEFUN TEST-SERIAL-IO-CHARS (STREAM) 
     2465  (DOTIMES (SENT-CHAR (^ 2 (FUNCALL STREAM ':GET ':NUMBER-OF-DATA-BITS))) 
     2466    (FUNCALL STREAM ':TYO SENT-CHAR) 
     2467    (COND ((PROCESS-WAIT-WITH-TIMEOUT "Serial In" *SERIAL-IO-TIMEOUT* STREAM ':LISTEN) 
     2468           (LET ((GOT-CHAR (FUNCALL STREAM ':TYI))) 
     2469             (COND ((NOT (= SENT-CHAR GOT-CHAR)) 
     2470                    (FORMAT T "~&Error: sent ~O and got back ~O (both octal)~%" 
     2471                            SENT-CHAR GOT-CHAR) 
     2472                    (INCF *SERIAL-IO-ERROR-COUNT*) 
     2473                    (COND ((< *SERIAL-IO-ERROR-COUNT* *SERIAL-IO-ERROR-LIMIT*) 
     2474                           (FORMAT T "~&Status of serial I//O line:~%") 
     2475                           (SI:SERIAL-STATUS))))))) 
     2476           (T 
     2477             (FORMAT T "~&Error: timed out waiting for character ~O (octal)~%" 
     2478                     SENT-CHAR))))) 
     2479 
     2480;;; Unfortunately, you can't read back clear-to-send (the LM-2 Serial I/O 
     2481;;; documentation is wishful thinking). 
     2482(DEFUN TEST-SERIAL-IO-EIA-RS-232-BITS (STREAM) 
     2483  (LOOP FOR SET IN '(:DATA-TERMINAL-READY :DATA-TERMINAL-READY) 
     2484        FOR GET IN '(:DATA-SET-READY      :CARRIER-DETECT) 
     2485        DO 
     2486        (FUNCALL STREAM ':PUT SET NIL) 
     2487        (IF (NOT (NULL (FUNCALL STREAM ':GET GET))) 
     2488            (FORMAT T "~&Error: Sent zero on ~S and got one on ~S.~%" SET GET)) 
     2489        (FUNCALL STREAM ':PUT SET T) 
     2490        (IF (NULL (FUNCALL STREAM ':GET GET)) 
     2491            (FORMAT T "~&Error: Sent one on ~S and got zero on ~S.~%" SET GET))) 
     2492  ;; Fix world. 
     2493  (FUNCALL STREAM ':PUT ':REQUEST-TO-SEND T) 
     2494  (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  
    130130   CONS-IR-STAT-BIT 5601 
    131131   CONS-IR-SPARE-BIT 5701 
     132   CONS-IR-PARITY-BIT 6001    ;Not normally read but returnned by CC-READ-C-MEM-WITH-PARITY. 
    132133   CONS-IR-A-SRC 4012 
    133134   CONS-IR-M-SRC 3206 
  • trunk/lisp/lcadr/lcadrd.lisp

    r205 r274  
    336336                      (FORMAT T "~%AND ~O IOR ~O" AND IOR)))))))) 
    337337 
    338 (DEFUN CC-READ-M-MEM-AND-CHECK-PARITY (ADR) 
     338(DEFUN CC-READ-M-MEM-AND-CHECK-PARITY (ADR &AUX DATA ERROR-P) 
    339339  (CC-EXECUTE CONS-IR-M-SRC ADR ;PUT IT ONTO THE OBUS 
    340340              CONS-IR-ALUF CONS-ALU-SETM 
    341341              CONS-IR-OB CONS-OB-ALU) 
    342   (PROG1 (CC-READ-OBUS) 
    343          (CC-NOOP-CLOCK) 
    344          (COND ((NOT (ZEROP (LOGLDB 101 (SPY-READ SPY-FLAG-1)))) 
    345                 (FORMAT T "~%BAD M-MEM PARITY, ADR ~S" ADR))))) 
     342  (SETQ DATA (CC-READ-OBUS)) 
     343  (CC-NOOP-CLOCK) 
     344  (COND ((SETQ ERROR-P (NOT (ZEROP (LOGLDB 101 (SPY-READ SPY-FLAG-1))))) 
     345         (FORMAT T "~%BAD M-MEM PARITY, ADR ~S" ADR))) 
     346  (PROG NIL (RETURN DATA ERROR-P))) 
    346347 
    347348(DEFUN CC-SWEEP-M-MEM NIL 
     
    409410  (CC-READ-IR))                 ;RETURN CONTENTS 
    410411 
     412(DEFUN CC-READ-C-MEM-WITH-PARITY (ADR) 
     413  (LET ((TEM (CC-READ-C-MEM ADR))) 
     414    (DPB (LDB 0501 (SPY-READ SPY-FLAG-2)) 
     415         CONS-IR-PARITY-BIT 
     416         TEM))) 
     417 
    411418;USED FOR SAVING & RESTORING 
    412419;OTHERWISE MICRO-DIAGNOSTICS WHICH RUN IN FOREIGN MACHINE BASH EACH OTHER 
     
    489496  T) 
    490497 
     498(DEFUN CC-WRITE-LC (VAL) 
     499  (CC-WRITE-FUNC-DEST CONS-FUNC-DEST-LC VAL)) 
     500 
     501(DEFUN CC-READ-LC () 
     502  (CC-READ-M-MEM CONS-M-SRC-LC)) 
     503 
    491504(DEFUN CC-WRITE-FUNC-DEST (ADR VAL) 
    492505  (CC-WRITE-MD VAL) 
     
    530543              CONS-IR-FUNC-DEST CONS-FUNC-DEST-PDL-BUFFER-INDEX)) 
    531544 
     545(DEFUN CC-READ-PDL-BUFFER-POINTER () 
     546  (CC-READ-M-MEM CONS-M-SRC-PDL-BUFFER-POINTER)) 
     547 
     548(DEFUN CC-WRITE-PDL-BUFFER-POINTER (VAL) 
     549  (CC-WRITE-MD VAL) 
     550  (CC-EXECUTE (WRITE) 
     551              CONS-IR-M-SRC CONS-M-SRC-MD 
     552              CONS-IR-ALUF CONS-ALU-SETM 
     553              CONS-IR-OB CONS-OB-ALU 
     554              CONS-IR-FUNC-DEST CONS-FUNC-DEST-PDL-BUFFER-POINTER) 
     555  VAL) 
     556 
    532557;READ THE PDL BUFFER 
    533558(DEFUN CC-READ-PDL-BUFFER (ADR) 
     
    550575              CONS-IR-OB CONS-OB-ALU 
    551576              CONS-IR-FUNC-DEST CONS-FUNC-DEST-C-PI)) 
     577 
     578(DEFUN CC-SCAN-P-MEM-FOR-BAD-PARITY (&OPTIONAL (PRINT-RUNNING-LOGAND-AND-LOGIOR NIL)) 
     579  (DO ((ADR 0 (1+ ADR)) 
     580       (AND 7777777777777777) 
     581       (IOR 0) 
     582       (ERRS 0)) 
     583      ((= ADR 2000) 
     584       (COND ((NOT (ZEROP ERRS)) 
     585              (FORMAT T "~%AND ~O IOR ~O" AND IOR)))) 
     586    (MULTIPLE-VALUE-BIND (DATA ERROR-P) 
     587        (CC-READ-P-MEM-AND-CHECK-PARITY ADR) 
     588      (COND (ERROR-P 
     589              (SETQ AND (LOGAND AND DATA) IOR (LOGIOR IOR DATA)) 
     590              (SETQ ERRS (1+ ERRS)) 
     591              (COND (PRINT-RUNNING-LOGAND-AND-LOGIOR 
     592                      (FORMAT T "~%AND ~O IOR ~O" AND IOR)))))))) 
     593 
     594(DEFUN CC-READ-P-MEM-AND-CHECK-PARITY (ADR &AUX DATA ERROR-P) 
     595  (OR CC-PDL-BUFFER-INDEX-CHANGED-FLAG 
     596      (CC-SAVE-PDL-BUFFER-INDEX))                       ;SAVE PDL INDEX IF NECESSARY 
     597  (CC-WRITE-PDL-BUFFER-INDEX ADR)                       ;ADDRESS THE PDL 
     598  (CC-EXECUTE CONS-IR-M-SRC CONS-M-SRC-C-PDL-BUFFER-INDEX       ;READ IT OUT 
     599              CONS-IR-ALUF CONS-ALU-SETM 
     600              CONS-IR-OB CONS-OB-ALU) 
     601  (SETQ DATA (CC-READ-OBUS)) 
     602  (CC-NOOP-CLOCK) 
     603  (COND ((SETQ ERROR-P (NOT (ZEROP (LOGLDB 201 (SPY-READ SPY-FLAG-1))))) 
     604         (FORMAT T "~%BAD P-MEM PARITY, ADR ~S" ADR))) 
     605  (PROG NIL (RETURN DATA ERROR-P))) 
     606 
    552607 
    553608;READ OUT THE MICRO STACK POINTER 
     
    800855                        T)))))) 
    801856 
    802 (DEFUN CC-SWEEP-LEVEL-1-MAP (&AUX (ADR-AND 7777) (ADR-IOR 0) (DATA-AND 37) (DATA-IOR 0) 
    803                                   DAT LOSEP (LOSES 0)) 
     857(DEFUN CC-SCAN-LEVEL-1-MAP-FOR-BAD-PARITY (&AUX (ADR-AND 7777) (ADR-IOR 0) 
     858                                           (DATA-AND 37) (DATA-IOR 0) 
     859                                           DAT LOSEP (LOSES 0)) 
    804860  (DOTIMES (ADR 10000) 
    805861    (MULTIPLE-VALUE (DAT LOSEP) 
     
    853909  #Q (LET ((OBUS (CC-READ-OBUS))) 
    854910        (DPB (LDB 2701 OBUS) 2701 (LDB 0027 OBUS)))) 
     911 
     912(DEFUN CC-READ-LEVEL-2-MAP-AND-CHECK-PARITY (ADR) 
     913  (CC-WRITE-MD (CC-ADDRESS-LEVEL-2-MAP ADR))    ;SET UP MD 
     914  (CC-EXECUTE CONS-IR-M-SRC CONS-M-SRC-MAP      ;READ OUT MAP 
     915              CONS-IR-ALUF CONS-ALU-SETM 
     916              CONS-IR-OB CONS-OB-ALU) 
     917  (LET ((OBUS (CC-READ-OBUS))) 
     918    (PROG1 (DPB (LDB 2701 OBUS) 2701 (LDB 0027 OBUS)) 
     919           (PROGN (CC-NOOP-CLOCK) 
     920                  (COND ((ZEROP (LOGLDB 1601 (SPY-READ SPY-FLAG-1))) 
     921                         (FORMAT T "~%BAD LEVEL-2-MAP PARITY, ADR ~S" ADR) 
     922                        T)))))) 
     923 
     924(DEFUN CC-SCAN-LEVEL-2-MAP-FOR-BAD-PARITY (&AUX (ADR-AND 1777) (ADR-IOR 0) 
     925                                           (DATA-AND 77777777) (DATA-IOR 0) 
     926                                           DAT LOSEP (LOSES 0)) 
     927  (DOTIMES (ADR 2000) 
     928    (MULTIPLE-VALUE (DAT LOSEP) 
     929      (CC-READ-LEVEL-2-MAP-AND-CHECK-PARITY ADR)) 
     930    (COND (LOSEP (SETQ ADR-AND (LOGAND ADR-AND ADR) 
     931                       ADR-IOR (LOGIOR ADR-IOR ADR) 
     932                       DATA-AND (LOGAND DATA-AND DAT) 
     933                       DATA-IOR (LOGIOR DATA-IOR DAT) 
     934                       LOSES (1+ LOSES))))) 
     935  (COND ((NOT (ZEROP LOSES)) 
     936         (FORMAT T "~%~D loses: ADRAND=~O, ADRIOR=~O, DATAAND=~O, DATAIOR=~O" 
     937                 LOSES ADR-AND ADR-IOR DATA-AND DATA-IOR)))) 
     938 
     939;find level 2 map entries which are non-zero but do not have access bit set. 
     940(DEFUN CC-SCAN-LEVEL-2-MAP-FOR-GARBAGE  (&OPTIONAL RUNNING-PRINTOUT 
     941                                         &AUX (ADR-AND 1777) (ADR-IOR 0) 
     942                                           (DATA-AND 77777777) (DATA-IOR 0) 
     943                                           DAT LOSEP (LOSES 0)) 
     944  (DOTIMES (ADR 2000) 
     945    (SETQ DAT (CC-READ-LEVEL-2-MAP-AND-CHECK-PARITY ADR)) 
     946    (SETQ LOSEP (AND (NOT (ZEROP DAT)) 
     947                     (ZEROP (LOGAND DAT 1_23.)))) 
     948    (COND (LOSEP (SETQ ADR-AND (LOGAND ADR-AND ADR) 
     949                       ADR-IOR (LOGIOR ADR-IOR ADR) 
     950                       DATA-AND (LOGAND DATA-AND DAT) 
     951                       DATA-IOR (LOGIOR DATA-IOR DAT) 
     952                       LOSES (1+ LOSES)) 
     953                 (IF RUNNING-PRINTOUT (FORMAT T "~%adr ~s, data ~s" ADR DAT))))) 
     954  (COND ((NOT (ZEROP LOSES)) 
     955         (FORMAT T "~%~D loses: ADRAND=~O, ADRIOR=~O, DATAAND=~O, DATAIOR=~O" 
     956                 LOSES ADR-AND ADR-IOR DATA-AND DATA-IOR)))) 
     957 
    855958;WRITE INTO LEVEL 2 MAP 
    856959(DEFUN CC-WRITE-LEVEL-2-MAP (ADR VAL) 
     
    12871390  (SETQ CC-LOW-LEVEL-FLAG (READ))) 
    12881391 
    1289 (SETQ PDP11-DISABLE T) ;CLEARLY 
    1290  
    12911392(DEFUN CC-PRINT-ERROR-STATUS (ERR-STS) 
    12921393       (COND ((EQ CC-LOW-LEVEL-FLAG 'VERY) 
     
    15691670  (SETQ CC-UPDATE-DISPLAY-FLAG T) 
    15701671  NIL) 
     1672 
  • 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) 
     
    234247  (DBG-WRITE (+ 766140 (* 2 LOC)) VAL)) 
    235248 
     249(DEFUN READ-UNIBUS-MAP (LOC) 
     250  (%UNIBUS-READ (+ 766140 (* 2 LOC)))) 
     251 
     252(DEFUN WRITE-UNIBUS-MAP (LOC VAL) 
     253  (%UNIBUS-WRITE (+ 766140 (* 2 LOC)) VAL)) 
     254 
     255;This run as warm initialization.  In the PDP11 slave case, it 
     256; assures there will be no collision with PDP11 memory. 
     257(DEFUN DBG-CLEAR-UNIBUS-MAP () "clear debugee's unibus map" 
     258  (DOTIMES (L 16.) 
     259    (DBG-WRITE-UNIBUS-MAP L 0))) 
     260 
     261;(ADD-INITIALIZATION "clear unibus map" '(CLEAR-UNIBUS-MAP) '(:SYSTEM)) 
     262;CLEAR-UNIBUS-MAP called from SI:LISP-REINITIALIZE.  Do it very early to 
     263; avoid screwwing ETHERNET code. 
     264(DEFUN CLEAR-UNIBUS-MAP ()  "clear this machine's unibus map" 
     265  (DOTIMES (L 16.) 
     266    (WRITE-UNIBUS-MAP L 0))) 
     267 
    236268;; Returns unibus location mapped into specified xbus location 
    237269(DEFUN DBG-SETUP-UNIBUS-MAP (LOC XBUS-LOC) 
    238270  (DBG-WRITE-UNIBUS-MAP LOC (+ 140000 (LDB 1016 XBUS-LOC))) 
     271  (+ 140000 (* LOC 2000) (* 4 (LOGAND 377 XBUS-LOC)))) 
     272 
     273(DEFUN SETUP-UNIBUS-MAP (LOC XBUS-LOC) 
     274  (WRITE-UNIBUS-MAP LOC (+ 140000 (LDB 1016 XBUS-LOC))) 
    239275  (+ 140000 (* LOC 2000) (* 4 (LOGAND 377 XBUS-LOC)))) 
    240276 
  • 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  
    605605(DEFUN CC-SET-CURRENT-MICROLOAD (PART) 
    606606  (COND ((NUMBERP PART) (SETQ PART (IMPLODE (APPEND '(M C R) (LIST (+ PART 60))))))) 
    607   (OR (MEMQ PART '(MCR1 MCR2)) 
    608       (ERROR '|Partition name should be MCR1 or MCR2| PART)) 
     607  (OR (STRING-EQUAL PART "MCR" 0 0 3) 
     608      (ERROR '|Partition name should be MCRn| PART)) 
    609609  (READ-LABEL) 
    610610  (SETQ INITIAL-MCR-NAME PART) 
     
    613613(DEFUN CC-SET-CURRENT-BAND (PART) 
    614614  (COND ((NUMBERP PART) (SETQ PART (IMPLODE (APPEND '(L O D) (LIST (+ PART 60))))))) 
    615   (OR (MEMQ PART '(LOD1 LOD2 LOD3 LOD4 LOD5 LOD6 LOD7)) 
     615  (OR (STRING-EQUAL PART "LOD" 0 0 3) 
    616616      (ERROR '|Partition name should be among LOD1...LOD7| PART)) 
    617617  (READ-LABEL) 
    618618  (SETQ INITIAL-LOD-NAME PART) 
    619619  (WRITE-LABEL)) 
     620 
     621;;; Only works on the real machine. 
     622(DEFUN CC-PRINT-DISK-LABEL ()  ;This is what I always think it is named. -- DLW 
     623  (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 
     
    103104 
    104105(DEFUN QF-PAGE-HASH-TABLE-LOOKUP (ADR)  ;RETURNS -1 OR PHYSICAL MEM ADR OF PHT1 WD 
    105  (SETQ ADR (QF-POINTER ADR))            ; OF HASH-TBL ENTRY FOR ADR 
    106  (DO ((PHT-MASK (- SIZE-OF-PAGE-TABLE 2)) 
    107       (HASH (LOGXOR (LOGLDB 1612 ADR) (LOGAND 777774 (LOGLDB 0622 ADR))) (+ HASH 2)) 
    108       (PHT1) 
    109       (COUNT (LSH SIZE-OF-PAGE-TABLE -1) (1- COUNT))) 
    110      ((= COUNT 0) -1)     ;INACESSIBLE (SHOULD NEVER HAPPEN, BUT AT LEAST DONT GET 
    111                           ; INTO INFINITE LOOP IF HASH TABLE GETS OVER-FULL) 
    112    (DECLARE (FIXNUM PHT-MASK HASH PHT1 PHT2 COUNT)) 
    113    (SETQ HASH (LOGAND HASH PHT-MASK)) 
    114    (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH))) 
    115    (COND ((= 0 (LOGAND 100 PHT1))       ;NO VALID BIT 
    116             (RETURN -1))                ;NOT FOUND 
    117          ((= 0 (LOGAND 77777400 (LOGXOR ADR PHT1)))  ;ADDRESS MATCH 
    118             (RETURN (+ PHT-ADDR HASH))))))      ;FOUND IT 
     106  (SETQ ADR (QF-POINTER ADR))           ; OF HASH-TBL ENTRY FOR ADR 
     107  (OR QF-PHT-CACHE (QF-REFILL-PHT-CACHE)) 
     108  (LET ((PHT-SIZE (CADR QF-PHT-CACHE))) 
     109    (DECLARE (FIXNUM PHT-SIZE)) 
     110    (DO ((HASH (QF-COMPUTE-PAGE-HASH ADR) (+ HASH 2)) 
     111         (PHT1) 
     112         (COUNT (LSH PHT-SIZE -1) (1- COUNT))) 
     113        ((= COUNT 0) -1)     ;INACESSIBLE (SHOULD NEVER HAPPEN, BUT AT LEAST DONT GET 
     114                             ; INTO INFINITE LOOP IF HASH TABLE GETS OVER-FULL) 
     115      (DECLARE (FIXNUM HASH PHT1 PHT2 COUNT)) 
     116      (AND (>= HASH PHT-SIZE) (SETQ HASH (- HASH PHT-SIZE))) 
     117      (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH))) 
     118      (COND ((= 0 (LOGAND 100 PHT1))    ;NO VALID BIT 
     119               (RETURN -1))             ;NOT FOUND 
     120            ((= 0 (LOGAND 77777400 (LOGXOR ADR PHT1)))  ;ADDRESS MATCH 
     121               (RETURN (+ PHT-ADDR HASH)))))))  ;FOUND IT 
    119122 
    120123;Linearly scan page hash table looking for info on given phys-adr. 
     
    123126       (HASH-LOCN 0 (+ HASH-LOCN 2)) 
    124127       (PHT1) (PHT2) 
    125        (COUNT (LSH SIZE-OF-PAGE-TABLE -1) (1- COUNT))) 
     128       (COUNT (LSH (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-SIZE))) -1) 
     129              (1- COUNT))) 
    126130      ((= COUNT 0) NIL) 
    127131    (COND ((AND (BIT-TEST 100 (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH-LOCN)))) 
     
    136140        (DECLARE (FIXNUM LEAD-POINTER LEAD-POINTER-HASH-ADR LEAD-POINTER-VIRT-ADR  
    137141                         LIM PHT1 PHT2 MOVED-POINTER PPDP)) 
    138         (SETQ LIM (+ PHT-ADDR SIZE-OF-PAGE-TABLE -2))           ;POINTS TO LAST VALID ENTRY 
     142        (SETQ LIM (+ PHT-ADDR 
     143                     (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-SIZE))) 
     144                     -2))               ;POINTS TO LAST VALID ENTRY 
    139145   L1   (PHYS-MEM-WRITE HOLE-POINTER (QF-MAKE-Q 0 DTP-FIX))     ;FLUSH GUY FROM TABLE 
    140146        (SETQ LEAD-POINTER HOLE-POINTER) 
     
    173179)) 
    174180 
     181(DEFUN QF-REFILL-PHT-CACHE () 
     182 (LET ((PHT-SIZE (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-SIZE))))) 
     183   (DECLARE (FIXNUM PHT-SIZE)) 
     184   (LET ((PHT-MASK (- (LSH 1 (HAULONG (- PHT-SIZE 2))) 2))) 
     185     (DECLARE (FIXNUM PHT-MASK)) 
     186     (SETQ QF-PHT-CACHE (LIST (QF-POINTER (CC-SYMBOLIC-EXAMINE-REGISTER 'A-VERSION)) 
     187                              PHT-SIZE 
     188                              PHT-MASK))))) 
     189 
    175190(DEFUN QF-COMPUTE-PAGE-HASH (ADR) 
    176     (LOGAND (- SIZE-OF-PAGE-TABLE 2) 
    177             (LOGXOR (LOGLDB 1612 ADR) (LOGAND 777774 (LOGLDB 0622 ADR))))) 
     191  (OR QF-PHT-CACHE (QF-REFILL-PHT-CACHE)) 
     192  (LET ((PHT-SIZE (CADR QF-PHT-CACHE)) (PHT-MASK (CADDR QF-PHT-CACHE))) 
     193   (DECLARE (FIXNUM PHT-SIZE PHT-MASK)) 
     194   (LET ((HASH (LOGAND (LOGXOR (LOGLDB 1612 ADR) 
     195                               (IF (> (CAR QF-PHT-CACHE) 703.)  ;New microcode 
     196                                   (LOGAND 777760 (LOGLDB 0424 ADR)) 
     197                                   (LOGAND 777774 (LOGLDB 0622 ADR)))) 
     198                       PHT-MASK))) 
     199     (DECLARE (FIXNUM HASH)) 
     200     (AND (>= HASH PHT-SIZE) (SETQ HASH (- HASH PHT-SIZE))) 
     201     HASH))) 
    178202 
    179203(DEFUN QF-VIRTUAL-MEM-MAP (ADR WRITE-CYCLE) 
    180204 (SETQ ADR (QF-POINTER ADR))            ;FLUSH DATA TYPE ETC. 
    181  (DO ((PHT-MASK (- SIZE-OF-PAGE-TABLE 2)) 
    182       (HASH (LOGXOR (LOGLDB 1612 ADR) (LOGAND 777774 (LOGLDB 0622 ADR))) (+ HASH 2)) 
    183       (PHT1) 
    184       (PHT2) 
    185       (TEM)(STS) 
    186       (COUNT (LSH SIZE-OF-PAGE-TABLE -1) (1- COUNT))) 
    187      ((= COUNT 0) -1)                                   ;INACCESSIBLE 
    188      (DECLARE (FIXNUM PHT-MASK HASH PHT1 PHT2 COUNT TEM STS)) 
    189      (SETQ HASH (LOGAND HASH PHT-MASK)) 
    190      (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH))) 
    191      (COND ((= 0 (LOGAND 100 PHT1))                     ;NO VALID BIT 
    192             (RETURN -1))                                ;INACCESSIBLE 
    193            ((= 0 (LOGAND 77777400 (LOGXOR ADR PHT1)))   ;ADDRESS MATCH 
    194             (SETQ STS (LOGAND 7 PHT1))                  ;ISOLATE SWAP STATUS CODE 
    195             (COND ((OR (= STS 0)                        ;UNUSED ENTRY 
    196                        (= STS 3)                        ;UNUSED CODES 
    197                        (= STS 6) 
    198                        (= STS 7)) 
    199                    (ERROR 'BAD-PAGE-HASH-ENTRY-AT-ADR HASH 'FAIL-ACT))) 
    200             (SETQ PHT2 (PHYS-MEM-READ (+ PHT-ADDR HASH 1)))     ;IN CORE, GET ADDRESS 
    201             (COND ((AND (= 5 (LOGLDB-FROM-FIXNUM 
    202                                %%PHT2-MAP-STATUS-CODE PHT2))  ;MAY BE IN PDL-BUFFER 
    203                         (NOT (< ADR (SETQ TEM (QF-POINTER 
    204                                                (CC-SYMBOLIC-EXAMINE-REGISTER  
    205                                                 'A-PDL-BUFFER-VIRTUAL-ADDRESS))))) 
    206                         (<= ADR (+ TEM (CC-SYMBOLIC-EXAMINE-REGISTER 'PP)))) 
    207                    (RETURN -2)))                        ;IN PDL-BUFFER 
    208 ;IF DOING A WRITE-CYCLE INTO A PAGE, SET PHT1-MODIFIED BIT 
    209 ;THIS HOPEFULLY ASSURES PAGE WILL GET WRITTEN ON DISK IF IT GETS SWAPPED OUT 
    210 ;EVEN IF THE ACCESS IS NOT READ/WRITE. 
    211             (COND (WRITE-CYCLE 
    212                    (PHYS-MEM-WRITE (+ PHT-ADDR HASH) 
    213                                    (LOGDPB-INTO-FIXNUM 1 %%PHT1-MODIFIED-BIT PHT1)))) 
    214             (RETURN (+ (LSH (LOGLDB-FROM-FIXNUM %%PHT2-PHYSICAL-PAGE-NUMBER PHT2) 8) 
    215                        (LOGAND 377 ADR))))))   
    216 ) 
    217  
    218 (DEFUN QF-FINDCORE NIL  ;CALL TO OBTAIN FREE PAGE OF CONS MEMORY. SWAP ONE OUT IF NECC, ETC. 
    219   (DECLARE (FIXNUM PTR LIM PHT1 PHT2 TEM)) 
    220   (PROG (PTR LIM PHT1 PHT2 TEM FLAG) 
    221         (SETQ LIM (+ PHT-ADDR SIZE-OF-PAGE-TABLE -2))   ;POINTS AT HIGHEST ENTRY 
    222         (SETQ PTR PHT-ADDR)             ;LOOK FOR FLUSHABLE FROB FIRST 
    223    L1   (SETQ PHT1 (PHYS-MEM-READ PTR)) 
    224         (SETQ TEM (LOGLDB-FROM-FIXNUM %%PHT1-SWAP-STATUS-CODE PHT1))    ;SWAP STATUS 
    225         (COND ((= TEM %PHT-SWAP-STATUS-FLUSHABLE) (GO CF)))     ;FLUSHABLE 
    226         (COND ((NOT (= PTR LIM)) (SETQ PTR (+ 2 PTR)) (GO L1))) 
    227         (SETQ PTR (COND ((GET 'QF-HASH-RELOAD-POINTER 'QF-HASH-RELOAD-POINTER)) 
    228                         (T PHT-ADDR)))  ;FLUSH SOMETHING RANDOM 
    229    L2   (SETQ PHT1 (PHYS-MEM-READ PTR)) 
     205 (COND ((< ADR (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-WIRED-SIZE)))) 
     206        ADR) 
     207       (T (OR QF-PHT-CACHE (QF-REFILL-PHT-CACHE)) 
     208          (LET ((PHT-SIZE (CADR QF-PHT-CACHE))) 
     209            (DECLARE (FIXNUM PHT-SIZE)) 
     210            (DO ((HASH (QF-COMPUTE-PAGE-HASH ADR) (+ HASH 2)) 
     211                 (PHT1) 
     212                 (PHT2) 
     213                 (TEM)(STS) 
     214                 (COUNT (LSH PHT-SIZE -1) (1- COUNT))) 
     215                ((= COUNT 0) -1)                        ;INACCESSIBLE 
     216              (DECLARE (FIXNUM HASH PHT1 PHT2 COUNT TEM STS)) 
     217              (AND (>= HASH PHT-SIZE) (SETQ HASH (- HASH PHT-SIZE))) 
     218              (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH))) 
     219              (COND ((= 0 (LOGAND 100 PHT1))            ;NO VALID BIT 
     220                     (RETURN -1))                       ;INACCESSIBLE 
     221                    ((= 0 (LOGAND 77777400 (LOGXOR ADR PHT1)))  ;ADDRESS MATCH 
     222                     (SETQ STS (LOGAND 7 PHT1))         ;ISOLATE SWAP STATUS CODE 
     223                     (COND ((OR (= STS 0)               ;UNUSED ENTRY 
     224                                (= STS 3)               ;UNUSED CODES 
     225                                (= STS 6) 
     226                                (= STS 7)) 
     227                            (ERROR 'BAD-PAGE-HASH-ENTRY-AT-ADR HASH 'FAIL-ACT))) 
     228                     (SETQ PHT2 (PHYS-MEM-READ (+ PHT-ADDR HASH 1)))    ;IN CORE, GET ADDRESS 
     229                     (COND ((AND (= 5 (LOGLDB-FROM-FIXNUM 
     230                                        %%PHT2-MAP-STATUS-CODE PHT2))   ;MAY BE IN PDL-BUFFER 
     231                                 (NOT (< ADR (SETQ TEM (QF-POINTER 
     232                                                         (CC-SYMBOLIC-EXAMINE-REGISTER  
     233                                                           'A-PDL-BUFFER-VIRTUAL-ADDRESS))))) 
     234                                 (<= ADR (+ TEM (CC-SYMBOLIC-EXAMINE-REGISTER 'PP)))) 
     235                            (RETURN -2)))               ;IN PDL-BUFFER 
     236                                ;IF DOING A WRITE-CYCLE INTO A PAGE, SET PHT1-MODIFIED BIT 
     237                                ;THIS HOPEFULLY ASSURES PAGE WILL GET WRITTEN ON DISK IF IT 
     238                                ;GETS SWAPPED OUT, EVEN IF THE ACCESS IS NOT READ/WRITE. 
     239                     (COND (WRITE-CYCLE 
     240                            (PHYS-MEM-WRITE (+ PHT-ADDR HASH) 
     241                                            (LOGDPB-INTO-FIXNUM 1 %%PHT1-MODIFIED-BIT PHT1)))) 
     242                     (RETURN (+ (LSH (LOGLDB-FROM-FIXNUM %%PHT2-PHYSICAL-PAGE-NUMBER PHT2) 8) 
     243                                (LOGAND 377 ADR)))))))))) 
     244 
     245(DEFUN QF-FINDCORE ()   ;CALL TO OBTAIN FREE PAGE OF CONS MEMORY. SWAP ONE OUT IF NECC, ETC. 
     246                        ;DOESN'T WORK SAME WAY AS MICROCODE ANY MORE 
     247  (DECLARE (FIXNUM PTR LIM PHT1 PHT2 TEM PHTSIZE N)) 
     248  (PROG (PTR LIM PHT1 PHT2 TEM PHTSIZE N) 
     249        (SETQ PHTSIZE (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-SIZE)))) 
     250        (SETQ LIM (+ PHT-ADDR PHTSIZE -2))      ;POINTS AT HIGHEST ENTRY 
     251        (SETQ N 100.)                           ;Number of probes before giving up 
     252        ;; Poking around at the other machine's page table is very slow, especially 
     253        ;; if you do it wrong.  So just pick a random page and swap it out 
     254        ;; if it isn't wired. 
     255   PROBE 
     256        (SETQ PTR (+ PHT-ADDR (* (RANDOM (// PHTSIZE 2)) 2))) 
     257        (SETQ PHT1 (PHYS-MEM-READ PTR)) 
    230258        (SETQ TEM (LOGLDB-FROM-FIXNUM %%PHT1-SWAP-STATUS-CODE PHT1)) 
    231259        (COND ((OR (= TEM %PHT-SWAP-STATUS-NORMAL) 
     260                   (= TEM %PHT-SWAP-STATUS-FLUSHABLE) 
    232261                   (= TEM %PHT-SWAP-STATUS-AGE-TRAP)) 
    233262               (GO CF))) 
    234         (COND ((= PTR LIM) 
    235                (COND (FLAG (ERROR 'QF-FINDCORE 'NOTHING-TO-SWAP-OUT 'FAIL-ACT)) 
    236                      (T (SETQ FLAG T) 
    237                         (SETQ PTR PHT-ADDR)))) 
    238               (T (SETQ PTR (+ 2 PTR)))) 
    239         (GO L2) 
    240    CF   (PUTPROP 'QF-HASH-RELOAD-POINTER PTR 'QF-HASH-RELOAD-POINTER) 
    241         (SETQ PHT2 (PHYS-MEM-READ (1+ PTR))) 
     263        (OR (ZEROP (SETQ N (1- N))) (GO PROBE)) 
     264        (ERROR 'QF-FINDCORE 'NOTHING-TO-SWAP-OUT 'FAIL-ACT) 
     265 
     266   CF   (SETQ PHT2 (PHYS-MEM-READ (1+ PTR))) 
    242267        (AND QF-FINDCORE-TRACE-SWITCH 
    243268             (PRINT (LIST 'QF-FINDCORE 'PTR PTR 'PHT1 PHT1 'PHT2 PHT2))) 
     
    284309                  PHYS-PAGE 
    285310                  1) 
    286     (DO ((PHT-MASK (- SIZE-OF-PAGE-TABLE 2)) 
    287          (HASH (LOGXOR (LOGLDB 1612 ADR) (LOGAND 777774 (LOGLDB 0622 ADR))) (+ HASH 2)) 
    288          (PHT1) 
    289          (COUNT (LSH SIZE-OF-PAGE-TABLE -1) (1- COUNT))) 
    290         ((= COUNT 0) 
    291          (ERROR 'QF-SWAP-IN 'PAGE-HASH-TABLE-FULL 'FAIL-ACT)) ;UGH FINDCORE SHOULD HAVE DELETED 
    292       (DECLARE (FIXNUM PHT-MASK HASH PHT1 PHT2 COUNT)) 
    293       (SETQ HASH (LOGAND HASH PHT-MASK)) 
    294       (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH))) 
    295       (COND ((= 0 (LOGAND 100 PHT1))                    ;FOUND HOLE TO PUT NEW PHTE IN 
    296              (PHYS-MEM-WRITE (+ PHT-ADDR HASH) 
    297                      (QF-MAKE-Q (+ 101 (LOGAND ADR 77777400)) DTP-FIX)) 
    298              (PHYS-MEM-WRITE (+ PHT-ADDR HASH 1) 
    299                      (QF-MAKE-Q (LOGDPB-INTO-FIXNUM ACCESS-STATUS-AND-META-BITS  
    300                                         %%PHT2-ACCESS-STATUS-AND-META-BITS  
    301                                   (LOGDPB-INTO-FIXNUM PHYS-PAGE %%PHT2-PHYSICAL-PAGE-NUMBER 
    302                                         0)) 
    303                                 DTP-FIX)) 
    304              (PHYS-MEM-WRITE (+ PHYS-PAGE (QF-INITIAL-AREA-ORIGIN 'PHYSICAL-PAGE-DATA)) 
    305                              (+ (CC-SHIFT REGION-NUMBER 16.) HASH)) 
    306              (OR QF-PAGE-HASH-TABLE-EXTRA-CHECKING-FLAG (RETURN T)) 
    307              (AND (= 0 (CC-CHECK-PAGE-HASH-TABLE-ACCESSIBILITY)) (RETURN T)) 
    308              (PRINT (LIST 'QF-SWAP-IN-SCREW ADR HASH COUNT)) 
    309              (BREAK 'QF-SWAP-IN-SCREW T) 
    310              (RETURN T))))) 
     311    (OR QF-PHT-CACHE (QF-REFILL-PHT-CACHE)) 
     312    (LET ((PHT-SIZE (CADR QF-PHT-CACHE))) 
     313      (DECLARE (FIXNUM PHT-SIZE)) 
     314      (DO ((HASH (QF-COMPUTE-PAGE-HASH ADR) (+ HASH 2)) 
     315           (PHT1) 
     316           (COUNT (LSH PHT-SIZE -1) (1- COUNT))) 
     317          ((= COUNT 0)  ;UGH FINDCORE SHOULD HAVE DELETED 
     318           (ERROR 'QF-SWAP-IN 'PAGE-HASH-TABLE-FULL 'FAIL-ACT)) 
     319        (DECLARE (FIXNUM HASH PHT1 PHT2 COUNT)) 
     320        (AND (>= HASH PHT-SIZE) (SETQ HASH (- HASH PHT-SIZE))) 
     321        (SETQ PHT1 (PHYS-MEM-READ (+ PHT-ADDR HASH))) 
     322        (COND ((= 0 (LOGAND 100 PHT1))                  ;FOUND HOLE TO PUT NEW PHTE IN 
     323               (PHYS-MEM-WRITE (+ PHT-ADDR HASH) 
     324                               (QF-MAKE-Q (+ 101 (LOGAND ADR 77777400)) DTP-FIX)) 
     325               (PHYS-MEM-WRITE (+ PHT-ADDR HASH 1) 
     326                 (QF-MAKE-Q (LOGDPB-INTO-FIXNUM ACCESS-STATUS-AND-META-BITS  
     327                                                %%PHT2-ACCESS-STATUS-AND-META-BITS  
     328                                                (LOGDPB-INTO-FIXNUM PHYS-PAGE 
     329                                                  %%PHT2-PHYSICAL-PAGE-NUMBER 
     330                                                  0)) 
     331                            DTP-FIX)) 
     332               (PHYS-MEM-WRITE (+ PHYS-PAGE (QF-INITIAL-AREA-ORIGIN 'PHYSICAL-PAGE-DATA)) 
     333                               HASH) 
     334               (OR QF-PAGE-HASH-TABLE-EXTRA-CHECKING-FLAG (RETURN T)) 
     335               (AND (= 0 (CC-CHECK-PAGE-HASH-TABLE-ACCESSIBILITY)) (RETURN T)) 
     336               (PRINT (LIST 'QF-SWAP-IN-SCREW ADR HASH COUNT)) 
     337               (BREAK 'QF-SWAP-IN-SCREW T) 
     338               (RETURN T)))))) 
    311339;  (SETQ QF-VIRTUAL-ADDR-KNOWN-ADDR -1)                 ;FORGET OUR COPY OF THE MAP 
    312340) 
     
    314342(DEFUN QF-GET-DISK-ADR (VIRTUAL-PAGE-NUMBER) 
    315343  (OR QF-PAGE-PARTITION-CACHE 
    316       (LET ((A-DISK-OFFSET (CC-SYMBOLIC-EXAMINE-REGISTER 'A-DISK-OFFSET)) ;UCODE SHOULD HAVE SET THIS UP 
    317             (A-VERSION (QF-POINTER (CC-SYMBOLIC-EXAMINE-REGISTER 'A-VERSION))) 
     344      (LET ((A-VERSION (QF-POINTER (CC-SYMBOLIC-EXAMINE-REGISTER 'A-VERSION))) 
    318345            (SYMBOL-VERSION (CC-LOOKUP-NAME 'VERSION-NUMBER))) 
    319         (COND ((NOT (= A-VERSION SYMBOL-VERSION)) 
    320                (FORMAT T "~&Microcode ~D is running but you have the symbols for ~D; 
    321    proceeding will probably destroy the core image.  Proceed anyway? " 
    322                        A-VERSION SYMBOL-VERSION) 
    323                (OR (Y-OR-N-P) (BREAK COUGH-AND-DIE)))) 
    324         (AND (< A-VERSION 627.) (SETQ A-DISK-OFFSET (// A-DISK-OFFSET 400))) 
    325         (SETQ QF-PAGE-PARTITION-CACHE A-DISK-OFFSET))) 
     346        (AND ( A-VERSION SYMBOL-VERSION) 
     347             (FQUERY NIL "~&Microcode ~D is running but you have the symbols for ~D; 
     348Type Y to load correct symbols, N to proceed anyway. " 
     349                     A-VERSION SYMBOL-VERSION) 
     350             (CC-LOAD-UCODE-SYMBOLS-FOR-VERSION A-VERSION)) 
     351        (LET ((A-DISK-OFFSET (CC-SYMBOLIC-EXAMINE-REGISTER 'A-DISK-OFFSET))) 
     352                         ;UCODE SHOULD HAVE SET THIS UP 
     353          (SETQ QF-PAGE-PARTITION-CACHE A-DISK-OFFSET)))) 
    326354  (+ VIRTUAL-PAGE-NUMBER QF-PAGE-PARTITION-CACHE)) 
    327355 
     
    371399(DEFUN QF-REGION-NUMBER-OF-POINTER (PNTR) 
    372400  (SETQ PNTR (QF-POINTER PNTR)) 
    373   (PROG (BOTLIM TOPLIM LBOUND HRANGE LOC LEN REGION REGION-ORIGIN TEM) 
    374     (DECLARE (FIXNUM BOTLIM TOPLIM LBOUND HRANGE LOC LEN REGION REGION-ORIGIN TEM)) 
    375     (SETQ BOTLIM (QF-INITIAL-AREA-ORIGIN 'REGION-SORTED-BY-ORIGIN) 
    376           TOPLIM (+ BOTLIM SIZE-OF-AREA-ARRAYS) 
    377           LBOUND BOTLIM 
    378           HRANGE SIZE-OF-AREA-ARRAYS 
    379           REGION-ORIGIN (QF-INITIAL-AREA-ORIGIN 'REGION-ORIGIN)) 
    380  T0 (AND (= HRANGE 1) (GO T2))                          ;MOVING DOWN AND RANGE = 1 => DONE 
    381  T1 (SETQ HRANGE (// (1+ HRANGE) 2))                    ;HALVE THE RANGE 
    382     (SETQ TEM (+ LBOUND HRANGE))                        ;ADDRESS TO PROBE 
    383     (OR (< TEM TOPLIM) (GO T0))                         ;RUNNING OFF TOP MOVE DOWN 
    384     (SETQ LOC (QF-POINTER (PHYS-MEM-READ (+ REGION-ORIGIN (QF-POINTER (PHYS-MEM-READ TEM)))))) ;ORIGIN OF POSSIBLE REGION 
    385     (AND (< PNTR LOC) (GO T0))                          ;MOVE DOWN 
    386     (SETQ LBOUND TEM) 
    387     (GO T1)                                             ;MOVE UP 
    388  
    389  T2 (SETQ REGION (QF-POINTER (PHYS-MEM-READ LBOUND)))   ;GET PROPER REGION NUMBER 
    390     (SETQ LOC (QF-POINTER (PHYS-MEM-READ (+ REGION-ORIGIN REGION))))    ;GET ITS ORIGIN 
    391     (AND (> LOC PNTR) (GO LOS)) 
    392     (SETQ LEN (QF-POINTER (PHYS-MEM-READ (+ (QF-INITIAL-AREA-ORIGIN 'REGION-LENGTH) REGION)))) 
    393     (AND (< PNTR (+ LOC LEN)) 
    394          (RETURN REGION)) 
    395     (OR (= LEN 0) (GO LOS)) 
    396     (SETQ LBOUND (1+ LBOUND))                           ;ZERO LENGTH REGION TRY NEXT 
    397     (GO T1) 
    398  
    399 LOS (ERROR PNTR '|NOT IN ANY REGION - QF-REGION-NUMBER-OF-POINTER| 'FAIL-ACT) )) 
     401  (LET ((QUANTUM (// PNTR %ADDRESS-SPACE-QUANTUM-SIZE)) 
     402        (BYTES-PER-WORD (// 32. %ADDRESS-SPACE-MAP-BYTE-SIZE))) 
     403    (DECLARE (FIXNUM QUANTUM BYTES-PER-WORD)) 
     404    (LET ((WORD (PHYS-MEM-READ (+ (QF-INITIAL-AREA-ORIGIN 'ADDRESS-SPACE-MAP) 
     405                                  (// QUANTUM BYTES-PER-WORD))))) 
     406      (DECLARE (FIXNUM WORD)) 
     407      (SETQ WORD (LOGAND (1- (LSH 1 %ADDRESS-SPACE-MAP-BYTE-SIZE)) 
     408                         (#M LSH #Q ASH WORD (- (* (\ QUANTUM BYTES-PER-WORD) 
     409                                                   %ADDRESS-SPACE-MAP-BYTE-SIZE))))) 
     410      (COND ((NOT (ZEROP WORD)) WORD) 
     411            (T (DO ((L AREA-LIST (CDR L)) 
     412                    (I 0 (1+ I))) 
     413                   ((OR (NULL L) (EQ (CAR L) 'WORKING-STORAGE-AREA)) 
     414                    (ERROR PNTR '|NOT IN ANY REGION - QF-REGION-NUMBER-OF-POINTER| 'FAIL-ACT)) 
     415                 (AND (< PNTR (QF-INITIAL-AREA-ORIGIN (CADR L))) 
     416                      (RETURN I)))))))) 
    400417 
    401418;;; OBARRAY STUFF 
     
    431448  (COND ((QF-OBARRAY-NEW-P PACK) 
    432449         (QF-SYMBOL-SEARCH PNAME PACK MACLISP-SYMBOL)) 
    433         (T (QF-SYMBOL-OLD PNAME PACK)))) 
     450        (T (FORMAT T "~%using old style obarray! ~s" PACK) 
     451           (QF-SYMBOL-OLD PNAME PACK)))) 
    434452 
    435453(DEFUN QF-OBARRAY-NEW-P (PACK) 
     
    510528                  (SETQ HASH (QF-ROT-24-BIT (LOGXOR HASH CHAR) 7))))) 
    511529 
     530(DEFUN QF-PRINT-OLD-OBARRAY NIL 
     531  (LET ((OBARRAYP (PHYS-MEM-READ (+ 400 %SYS-COM-OBARRAY-PNTR)))) 
     532    (COND ((= (QF-DATA-TYPE OBARRAYP) DTP-SYMBOL) 
     533           (SETQ OBARRAYP (QF-VALUE-CELL-CONTENTS OBARRAYP)))) 
     534    (LET ((OBSCURE  (LOGLDB-FROM-FIXNUM %%ARRAY-INDEX-LENGTH-IF-SHORT 
     535                                        (QF-MEM-READ OBARRAYP)))) 
     536      (SETQ OBARRAYP (+ 1 OBARRAYP))     ;ASSUME 1 DIMENSIONAL, SHORT, ETC. 
     537      (DOTIMES (B OBSCURE) 
     538        (CC-Q-PRINT-TOPLEV (QF-MEM-READ (+ OBARRAYP B))))))) 
     539 
     540 
     541(DEFUN QF-APROPOS (STRING) 
     542  (PROG (ADR HEADER) 
     543        (SETQ ADR (QF-INITIAL-AREA-ORIGIN 'NR-SYM)) 
     544    L   (SETQ HEADER (QF-MEM-READ ADR)) 
     545        (COND ((NOT (= (QF-DATA-TYPE HEADER) DTP-SYMBOL-HEADER)) 
     546               (RETURN NIL)) 
     547              ((STRING-SEARCH STRING (QF-FETCH-STRING HEADER)) 
     548               (FORMAT T "~%Virt adr ~S " ADR) 
     549               (CC-Q-PRINT-TOPLEV (QF-MAKE-Q ADR DTP-SYMBOL)))) 
     550        (SETQ ADR (+ LENGTH-OF-ATOM-HEAD ADR)) 
     551        (GO L))) 
     552 
     553(DEFUN QF-FETCH-STRING (HEAD-ADR) 
     554  (QF-ARRAY-SETUP (QF-MAKE-Q (QF-POINTER HEAD-ADR) DTP-ARRAY-POINTER)) 
     555  (LET* ((LEN (COND (QF-ARRAY-HAS-LEADER-P 
     556                     (QF-POINTER (QF-MEM-READ (- QF-ARRAY-HEADER-ADDRESS 2)))) 
     557                    (T QF-ARRAY-LENGTH))) 
     558         (STR (MAKE-ARRAY NIL ART-STRING LEN))) 
     559    (DO ((I 0 (1+ I)) 
     560         (ADR QF-ARRAY-DATA-ORIGIN) 
     561         (CH) (WD)) 
     562        ((= I LEN) STR) 
     563      (COND ((ZEROP (LOGAND 3 I))               ;Get next word 
     564             (SETQ WD (QF-MEM-READ ADR) 
     565                   ADR (1+ ADR)))) 
     566      (SETQ CH (LOGAND 377 WD) 
     567            WD (CC-SHIFT WD -8)) 
     568      (AS-1 CH STR I)))) 
     569       
     570 
     571(DEFUN QF-SXHASH-STRING (STRING) 
     572  (DO ((I 0 (1+ I)) 
     573       (N (ARRAY-ACTIVE-LENGTH STRING)) 
     574       (HASH 0)) 
     575      (( 
     576 I N) 
     577       (IF (MINUSP HASH) 
     578           (LOGXOR HASH -37777777)              ;-37777777 = 40000001 
     579           HASH)) 
     580    (SETQ HASH (ROT (LOGXOR (LOGAND (AREF STRING I) 337) HASH) 7)))) 
     581 
    512582;SEARCH OLD-STYLE BUCKET-LIST OBARRAY 
    513 (DEFUN QF-SYMBOL-OLD (TEM OBARRAYP) 
     583(DEFUN QF-SYMBOL-OLD (LISPSYM OBARRAYP) 
    514584    (DECLARE (FIXNUM OBARRAYP HASH)) 
    515     (LET ((HASH (QF-PKG-HASH-STRING TEM)) 
     585    (LET ((HASH (QF-SXHASH-STRING (STRING LISPSYM))) 
    516586          (OBSCURE NIL)) 
    517        (SETQ OBSCURE (LOGLDB-FROM-FIXNUM %%ARRAY-INDEX-LENGTH-IF-SHORT (QF-MEM-READ OBARRAYP))) 
     587       (SETQ OBSCURE (LOGLDB-FROM-FIXNUM %%ARRAY-INDEX-LENGTH-IF-SHORT 
     588                                         (QF-MEM-READ OBARRAYP))) 
    518589       (SETQ OBARRAYP (+ 1 (\ HASH OBSCURE) OBARRAYP))   ;ASSUME 1 DIMENSIONAL, SHORT, ETC. 
    519590       (DO ((BUCKET (QF-MEM-READ OBARRAYP) (QF-CDR BUCKET))) 
     
    521592            (RETURN -1)) 
    522593         (DECLARE (FIXNUM BUCKET)) 
    523          (AND (QF-SAMEPNAMEP TEM 
     594         (AND (QF-SAMEPNAMEP LISPSYM 
    524595                   (SETQ OBSCURE (QF-MEM-READ BUCKET))) ;CAR 
    525               (RETURN (PUTPROP TEM  
     596              (RETURN (PUTPROP LISPSYM  
    526597                              (QF-TYPED-POINTER OBSCURE)  
    527598                              '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 ;INSTRUCTIONS FOR CHECKING FOR PAGE FAULTS, INTERRUPTS, SEQUENCE BREAKS 
    153 ;ONE OF THESE MUST APPEAR AFTER EVERY INSTRUCTION THAT STARTS A MEMORY CYCLE. 
    154  
    155 ;THIS ONE IS USED WHEN REFERENCING FIXED AREAS THAT SHOULD BE ALWAYS WIRED AND MAPPED 
    156 ;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;Instructions for checking for page faults, interrupts, sequence breaks. 
     179;One of these must appear after every instruction that starts a memory cycle. 
     180 
     181;This one is used when referencing fixed areas that should be always wired and mapped. 
     182;E.G. inside the page fault routines where a recursive page fault could not be allowed 
    157183(ASSIGN ILLOP-IF-PAGE-FAULT (PLUS CALL-CONDITIONAL PG-FAULT ILLOP)) 
    158184 
    159 ;THESE TWO ARE WHAT ARE NORMALLY USED.  THEY CHECK FOR PAGE FAULTS AND 
    160 ;INTERRUPTS (HANDLED ENTIRELY IN MICROCODE), BUT NOT SEQUENCE BREAKS. 
     185;These two are what are normally used.  They check for page faults and 
     186;interrupts (handled entirely in microcode), but not sequence breaks. 
    161187(ASSIGN CHECK-PAGE-READ (PLUS CALL-CONDITIONAL PG-FAULT-OR-INTERRUPT PGF-R-I)) 
    162188(ASSIGN CHECK-PAGE-WRITE (PLUS CALL-CONDITIONAL PG-FAULT-OR-INTERRUPT PGF-W-I)) 
    163189 
    164 ;THIS ONE IS USED WHEN YOU WANT TO BE ABLE TO WRITE A NOMINALLY READ-ONLY AREA, 
    165 ;FOR INSTANCE IN THE TRANSPORTER WHEN IT IS FIXING A POINTER TO OLDSPACE. 
    166 ;NOT CHECKING FOR INTERRUPTS IS JUST TO SAVE CODE. 
     190;This one is used when you want to be able to write a nominally read-only area, 
     191;for instance in the transporter when it is fixing a pointer to oldspace. 
     192;Not checking for interrupts is just to save code. 
    167193(ASSIGN CHECK-PAGE-WRITE-FORCE (PLUS CALL-CONDITIONAL PG-FAULT PGF-W-FORCE)) 
    168194 
    169 ;THESE TWO ARE USED WHEN AN INTERRUPT IS NOT ALLOWED, EITHER BECAUSE WE 
    170 ;ARE INSIDE THE INTERRUPT HANDLER, BECAUSE WE ARE RETRYING A CYCLE IN 
    171 ;PGF-R/PGF-W, OR BECAUSE WE DON'T WANT TO LET THE INTERRUPT HANDLER CHANGE THE MAP. 
    172 ;NOTE WELL: THESE SHOULD BE USED ONLY FOR REFERENCES WHICH MAY NEED TO REFILL 
    173 ; THE MAP, BUT CANNOT TAKE AN ACTUAL DISK PAGE FAULT.  IF A SWAPIN FROM DISK 
    174 ; HAPPENS, INTERRUPTS WILL BE ALLOWED WHILE WAITING FOR THE PAGE TO COME IN, 
    175 ; HOWEVER, AN INTERRUPT CANNOT HAPPEN AFTER THE DATA HAS BEEN COPIED FROM 
    176 ; MEMORY INTO THE MD IF THIS IS USED INSTEAD OF CHECK-PAGE-READ. 
     195;This one is used for writing an old binding of a special variable 
     196;back into the value cell, when a binding is being unbound. 
     197;When writing into a location forwarded to A memory, 
     198;it means that an old EVCP is no longer current even if 
     199;the old binding being restored is not an EVCP itself. 
     200(ASSIGN CHECK-PAGE-WRITE-BIND (PLUS CALL-CONDITIONAL PG-FAULT PGF-W-BIND)) 
     201 
     202;These two are used when an interrupt is not allowed, either because we 
     203;are inside the interrupt handler, because we are retrying a cycle in 
     204;PGF-R/PGF-W, or because we don't want to let the interrupt handler change the map. 
     205;Note well: these should be used only for references which may need to refill 
     206; the map, but cannot take an actual disk page fault.  If a swap-in from disk 
     207; happens, interrupts will be allowed while waiting for the page to come in; 
     208; however, an interrupt cannot happen after the data has been copied from 
     209; memory into the MD if this is used instead of CHECK-PAGE-READ. 
    177210(ASSIGN CHECK-PAGE-READ-NO-INTERRUPT (PLUS CALL-CONDITIONAL PG-FAULT PGF-R)) 
    178211(ASSIGN CHECK-PAGE-WRITE-NO-INTERRUPT (PLUS CALL-CONDITIONAL PG-FAULT PGF-W)) 
    179  
    180 ;THESE TWO ARE USED WHEN WE WANT TO ALLOW BOTH INTERRUPTS AND SEQUENCE BREAKS. 
    181 ;NOTE THAT THE VMA HAD BETTER NOT POINT TO UNBOXED STORAGE WHEN THESE ARE USED. 
     212;This one is used from inside the page-fault-handler to try again after some 
     213;progress has been made.  Point is, it must not affect A-PGF-MODE. 
     214(ASSIGN CHECK-PAGE-WRITE-RETRY (PLUS CALL-CONDITIONAL PG-FAULT PGF-W-1)) 
     215 
     216;These two are used when we want to allow both interrupts and sequence breaks. 
     217;Note that the VMA had better not point to unboxed storage when these are used. 
    182218(ASSIGN CHECK-PAGE-READ-SEQUENCE-BREAK 
    183219        (PLUS CALL-CONDITIONAL PG-FAULT-INTERRUPT-OR-SEQUENCE-BREAK PGF-R-SB)) 
     
    185221        (PLUS CALL-CONDITIONAL PG-FAULT-INTERRUPT-OR-SEQUENCE-BREAK PGF-W-SB)) 
    186222 
    187 ;THESE NAMES ARE FOR USE WITH THE CALL-CONDITIONAL AND JUMP-CONDITIONAL 
    188 ;INSTRUCTIONS WHEN SPECIAL CIRCUMSTANCES DICTATE SPECIAL HANDLING 
     223;These names are for use with the CALL-CONDITIONAL and JUMP-CONDITIONAL 
     224;instructions when special circumstances dictate special handling 
    189225(ASSIGN PG-FAULT JUMP-ON-PAGE-FAULT-CONDITION) 
    190226(ASSIGN NO-PG-FAULT (PLUS JUMP-ON-PAGE-FAULT-CONDITION INVERT-JUMP-SENSE)) 
     
    209245(DEF-DATA-FIELD OAL-JUMP 14. 12.) 
    210246(DEF-DATA-FIELD OAL-DISP 11. 12.) 
     247(DEF-DATA-FIELD OAL-ALUF 4 3) 
    211248 
    212249(ASSIGN PDL-BUFFER-LOW-WARNING 20.)  ;MAX LENGTH BASIC FRAME + ADI 
     
    233270(ASSIGN TRANSPORT-NO-TRAP (PLUS (I-ARG 21) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19 
    234271                                DISPATCH-PUSH-OWN-ADDRESS D-TRANSPORT)) 
    235 (ASSIGN TRANSPORT-CDR (PLUS (I-ARG 12) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19 
     272(ASSIGN TRANSPORT-CDR (PLUS (I-ARG 32) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19 
    236273                            DISPATCH-PUSH-OWN-ADDRESS D-TRANSPORT)) 
    237274(ASSIGN TRANSPORT-WRITE (PLUS (I-ARG 23) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19 
     
    247284;save taking frequent useless traps on EVCP's.  Also they have to not barf at 
    248285;trap data types, such as DTP-NULL. 
     286;NO-EVCP also used by PDL buffer refill now that its legal to have EVCPs on PDL. 
     287 
    249288(ASSIGN TRANSPORT-NO-EVCP (PLUS (I-ARG 20) Q-DATA-TYPE-PLUS-ONE-BIT DISPATCH-ON-MAP-19 
    250289                        DISPATCH-PUSH-OWN-ADDRESS D-TRANSPORT-NO-EVCP)) 
     
    345384                                                ;  ERROR EXCEPT (CAR NIL) = NIL 
    346385                                                ;  NIL 
    347                                                 ;  P-STRING ARRAY POINTER 
     386                                                ;  UNUSED, WAS ONCE <P-STRING ARRAY POINTER> 
    348387  (DEF-NEXT-FIELD M-CAR-NUM-MODE 2 M-FLAGS)     ;CAR OF NUMBER GIVES:  
    349388                                                ;  ERROR 
     
    385424        ;Checked after popping bindings (and thus maybe affecting A-INHIBIT-SCHEDULING-FLAG). 
    386425        ; If appropriate, the bit is stuffed back into the hardware (at SB-REINSTATE). 
     426  (DEF-NEXT-BIT M-METER-STACK-GROUP-ENABLE M-FLAGS)     ;1 IF METERING ON FOR THIS STACK GROUP 
     427  (DEF-NEXT-BIT M-TRAP-ON-CALLS M-FLAGS)                ;1 => TRAP ON ACTIVATING STACK FRAME. 
    387428 
    388429  ( (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX)      ;SAME STUFF ALSO IN A-FLAGS 
     
    399440          (BYTE-VALUE M-TRANSPORT-FLAG 0) 
    400441          (BYTE-VALUE M-STACK-GROUP-SWITCH-FLAG 0) 
    401           (BYTE-VALUE M-DEFERRED-SEQUENCE-BREAK-FLAG 0))) 
     442          (BYTE-VALUE M-DEFERRED-SEQUENCE-BREAK-FLAG 0) 
     443          (BYTE-VALUE M-METER-STACK-GROUP-ENABLE 0))) 
    402444 
    403445M-PDL-BUFFER-ACTIVE-QS (0)      ;HOLDS QS BETWEEN A-PDL-BUFFER-HEAD AND M-AP INCLUSIVE 
     
    436478(LOC 34)  ;%SEQUENCE-BREAK-SOURCE-ENABLE LISP VARIABLE MAPPED HERE, SEE QCOM. 
    437479M-SB-SOURCE-ENABLE   ;each bit controls a potential source of sequence-breaks: 
    438   (DEF-NEXT-BIT M-SBS-CALL M-SB-SOURCE-ENABLE)  ;Just the CALL key (maximum conservatism) 
    439   (DEF-NEXT-BIT M-SBS-KBD M-SB-SOURCE-ENABLE)   ;Any KBD char 
     480  ; Note: the numeric values of these bits are known by SI:SB-ON! 
     481  (DEF-NEXT-BIT M-SBS-CALL M-SB-SOURCE-ENABLE)  ;Just the CALL key (OBSOLETE). 
     482  (DEF-NEXT-BIT M-SBS-UNIBUS M-SB-SOURCE-ENABLE)   ;Any Unibus channel. 
    440483  (DEF-NEXT-BIT M-SBS-CHAOS M-SB-SOURCE-ENABLE) ;Any CHAOS packet received.  Its 
    441484                                                ; unclear if you really want to set this. 
     
    443486         
    444487   ((BYTE-VALUE Q-DATA-TYPE DTP-FIX)) 
     488 
     489(LOC 35)        ;%METER-ENABLES lisp variable is mapped here, see qcom 
     490M-METER-ENABLES ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))      ; Enables for microcode metering 
    445491 
    446492(LOCALITY A-MEM) 
     
    490536          (BYTE-VALUE M-TRANSPORT-FLAG 0) 
    491537          (BYTE-VALUE M-STACK-GROUP-SWITCH-FLAG 0) 
    492           (BYTE-VALUE M-DEFERRED-SEQUENCE-BREAK-FLAG 0))) 
     538          (BYTE-VALUE M-DEFERRED-SEQUENCE-BREAK-FLAG 0) 
     539          (BYTE-VALUE M-METER-STACK-GROUP-ENABLE 0))) 
    493540 
    494541A-PDL-BUFFER-ACTIVE-QS (0) 
     
    498545A-TEM (0) 
    499546A-SB-SOURCE-ENABLE ((BYTE-VALUE Q-DATA-TYPE DTP-FIX)) 
     547A-METER-ENABLES ((BYTE-VALUE Q-DATA-TYPE DTP-FIX)) 
    500548 
    501549(LOC 40);SKIP OVER M-CONSTANTS 
     
    573621A-INHIBIT-READ-ONLY                     ;If non-NIL, you can write in read-only 
    574622        ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0)  ;NIL 
    575 A-SCAVENGER-WS-ENABLE                   ;If non-NIL, scavenger gets limited working set 
    576         ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 5)  ;T 
     623A-SCAVENGER-WS-ENABLE                   ;Controls scavenger working set feature. 
     624        ((BYTE-VALUE Q-DATA-TYPE DTP-FIX) 0)  ;New scheme: lowest physical address  
     625   ;NOT in scavenger working set.  Note this is semi-compatible with the old T or NIL 
     626   ;scheme: both of these will turn off WS feature since only pointer is significant. 
    577627A-METHOD-SUBROUTINE-POINTER             ;CONTINUATION POINT FOR SELECT METHOD SUBROUTINE 
    578628        ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0)  ;RETURN OR NIL 
     
    584634                                ;THIS IS THE ONE WHOSE PARAMETERS HAVE BEEN COMPUTED 
    585635                                ;INTO A-TV-SCREEN-BUFFER-ADDRESS, ETC. 
    586 A-READ-COMPARE-ENABLES ((BYTE-VALUE Q-DATA-TYPE DTP-FIX) 0) 
     636;was called A-DISK-READ-COMPARE-ENABLES. 
     637A-DISK-SWITCHES ((BYTE-VALUE Q-DATA-TYPE DTP-FIX) 0) 
    587638                                                ;Bit 0 - read-compare after reads 
    588639                                                ;Bit 1 - read-compare after writes 
     640                                                ;Bit 2 - enable multiple page swapouts 
     641                                                ;Bit 3 - enable multiple page swapins 
    589642                                ;This loads as zero so COLD-BOOT won't read-compare 
    590643A-MC-CODE-EXIT-VECTOR  ((BYTE-VALUE Q-DATA-TYPE DTP-FIX) 0)     ;Exit vector used by 
     
    597650                                ;Increments whenever any new oldspace is created. 
    598651                                ; Thus if this has changed, objects may have moved. 
     652A-METER-GLOBAL-ENABLE 
     653        ((PLUS (BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0))  ;T if all stack groups metered 
     654A-METER-BUFFER-POINTER 
     655        ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))      ;Pointer to disk buffer (must contain 1 block) 
     656A-METER-DISK-ADDRESS 
     657        ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))      ;Next disk address to write buffer out to 
     658A-METER-DISK-COUNT 
     659        ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))      ;Number of disk blocks left to write out 
     660A-CURRENTLY-PREPARED-SHEET ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0) 
     661                                        ;Error checking for the TV:PREPARE-SHEET macro 
     662;Variables for mouse tracking 
     663A-MOUSE-CURSOR-STATE ((BYTE-VALUE Q-DATA-TYPE DTP-FIX)) 
     664                                ;0 disabled, 1 open, 2 off, 3 on 
     665A-MOUSE-X ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))    ;Relative to MOUSE-SCREEN 
     666A-MOUSE-Y ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))    ;Relative to MOUSE-SCREEN 
     667A-MOUSE-CURSOR-X-OFFSET ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))      ;From top-left of pattern 
     668A-MOUSE-CURSOR-Y-OFFSET ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))      ;to the reference point 
     669A-MOUSE-CURSOR-WIDTH ((BYTE-VALUE Q-DATA-TYPE DTP-FIX)) 
     670A-MOUSE-CURSOR-HEIGHT ((BYTE-VALUE Q-DATA-TYPE DTP-FIX)) 
     671A-MOUSE-X-SPEED ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))      ;100ths per second, time averaged 
     672A-MOUSE-Y-SPEED ((BYTE-VALUE Q-DATA-TYPE DTP-FIX))      ;with time constant of 1/6 second 
     673A-MOUSE-BUTTONS-BUFFER-IN-INDEX ((BYTE-VALUE Q-DATA-TYPE DTP-FIX)) 
     674A-MOUSE-BUTTONS-BUFFER-OUT-INDEX ((BYTE-VALUE Q-DATA-TYPE DTP-FIX)) 
     675A-MOUSE-WAKEUP ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0) ;Set to T when move or click 
     676 
     677;Remember higher lexical contexts for nonlocal lexical variables. 
     678;Value is a list of pointers to stack frames. 
     679A-LEXICAL-ENVIRONMENT ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0) 
     680 
     681;Point to an array which holds slots for the EVCPs which 
     682;were "stored" into a-memory locations, above, 
     683;so that closures can bind such locations. 
     684A-AMEM-EVCP-VECTOR ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0) 
     685 
     686;Area for consing things that are not explicitly requested 
     687;and should not go in a temporary area. 
     688;Initialized from A-CNSADF at startup time. 
     689A-BACKGROUND-CONS-AREA (0) 
     690 
    599691;END OF VECTOR AREA 
    600692 
    601 ;FOLLOWING LOCATIONS ARE GC'ABLE BUT NOT USER'REFERENCEABLE 
     693;FOLLOWING LOCATIONS ARE GC-ABLE BUT NOT USER-REFERENCEABLE 
    602694 
    603695A-V-NIL         ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL) 0) ;POINTER TO NIL 
     
    605697 
    606698A-END-Q-POINTERS ((BYTE-VALUE Q-DATA-TYPE DTP-SYMBOL)) ;WASTE A LOCATION TO FIX FENCEPOST ERROR 
     699 
    607700;END "Q" STORAGE 
    608701 
     
    652745                                ;       status read back 
    653746                                ;       ma read back 
     747A-DISK-WAIT-TIME        (0)     ;Amount of time spent in page faults 
     748A-DISK-PAGE-WRITE-APPENDS (0)   ;Pages appended to swapout operations. 
     749A-DISK-PAGE-READ-APPENDS  (0)   ;Pages appended to swapin operations. 
    654750 
    655751;END OF COUNTER AREA. 
     
    675771A-INTR-B        (0)     ;SAVE M-B 
    676772A-INTR-T        (0)     ;SAVE M-T 
     773A-INTR-LOCAL-UNIBUS-MODE  (0)   ;1 normal, 0 PDP11 arbitrates unibus. 
    677774A-PGF-VMA (0)   ;PAGE FAULT HANDLER SAVES VMA HERE 
    678775A-PGF-WMD (0)   ;PAGE FAULT HANDLER SAVES WRITE-MEMORY-DATA HERE 
     
    680777A-PGF-A   (0)   ;PAGE FAULT HANDLER SAVES M-A HERE 
    681778A-PGF-B   (0)   ;PAGE FAULT HANDLER SAVES M-B HERE 
     779A-PGF-MODE (0)  ;PAGE FAULT HANDLER KEEPS A FLAG HERE. 
    682780A-PDLB-TEM      (0)     ;TEMPORARY USED BY PDL-BUFFER LOADING/DUMPING ROUTINES 
    683781A-FARY-TEM      (0)     ;TEMPORARY USED BY XFARY 
     
    703801;Scavenger 
    704802 
    705 (ASSIGN SCAV-WS-SIZE 12.)       ;number of pages in scavenger working-set 
    706 A-SCAV-PAGE-TABLE (REPEAT SCAV-WS-SIZE (-1)) ;-1 or virtual address of page brought in by scav 
    707 A-SCAV-PAGE-TABLE-PTR ((A-MEM-LOC A-SCAV-PAGE-TABLE)) ;Re-use pointer for above 
    708803A-SCAV-PTR (0)          ;Address of next Q to scavenge (with type bits from gc-pointer) 
    709804A-SCAV-COUNT (0)        ;Number of Q's remaining to be scavenged in that block 
     
    748843 
    749844;PAGING VARIABLES AND CONSTANTS 
    750 A-PHT-INDEX-MASK ((EVAL (- SIZE-OF-PAGE-TABLE 2))) ;Mask for page hash table indices 
    751                                 ;Next two scan pointers must be inited on warm boot to 
    752                                 ; greater than the number of wired pages in low core 
    753                                 ; We init them to the equivalent of 48K 
    754 A-FINDCORE-SCAN-POINTER (300)   ;Page frame number of next page to be looked at by FINDCORE 
    755 A-AGING-SCAN-POINTER (300)      ;Page frame number of next page to be looked at by AGER 
    756 A-PAGE-REGION-NUMBER (0)        ;Region number of page being swapped in (in left half!) 
     845A-PHT-INDEX-MASK (0)            ;Mask for page hash table indices 
     846A-PHT-INDEX-LIMIT (0)           ;All valid PHT indices are less than this 
     847A-FINDCORE-SCAN-POINTER (0)     ;Page frame number of next page to be looked at by FINDCORE 
     848A-AGING-SCAN-POINTER (0)        ;Page frame number of next page to be looked at by AGER 
    757849A-V-PHYSICAL-PAGE-DATA-END      ;First location after last valid physical-page-data entry 
    758850                        (1_31.) ;This has to be initialized to the most negative number! 
     851A-PAGE-IN-PHT1 (0)              ;Argument to PAGE-IN-MAKE-KNOWN 
    759852 
    760853A-DISK-REGS-BASE (77377774)     ;XBUS ADDRESS 17377774 
     
    780873A-DISK-ECC      (0)             ;Error correction data read back 
    781874A-DISK-RETRY-STATE (0)          ;Count of retries 
     875A-DISK-DOING-READ-COMPARE (0) 
    782876A-DISK-IDLE-TIME (0)            ;Time since last disk op (other than background) 
     877A-DISK-RESERVED-FOR-USER (0)    ;%DISK-OP in progress (inhibits background disk ops) 
     878 
     879(ASSIGN DISK-SWAP-OUT-CCW-BASE 700) ;build CCW lists for swap out starting here 
     880(ASSIGN DISK-SWAP-OUT-CCW-MAX  720) ; and not above here. 
     881(ASSIGN DISK-SWAP-IN-CCW-BASE 740)  ;build CCW lists for swap in starting here 
     882(ASSIGN DISK-SWAP-IN-CCW-MAX  760)  ; and not above here. 
    783883 
    784884;Locations for DISK-SWAP-HANDLER 
    785 A-DISK-SAVE-PGF-VMA (0) 
    786 A-DISK-SAVE-PGF-WMD (0) 
    787 A-DISK-SAVE-PGF-T (0) 
     885A-DISK-SWAPIN-SIZE (0) 
     886 
     887A-DISK-SWAPIN-VIRTUAL-ADDRESS (0) 
     888A-DISK-SWAPIN-PAGE-FRAME (0)            ;physical page frame 
     889A-DISK-SWAPIN-PHT2-BITS (0) 
     890 
     891A-DISK-SWAP-OUT-CCW-POINTER (0) 
     892A-DISK-SWAP-IN-CCW-POINTER (0) 
     893 
     894A-DISK-SAVE-PGF-VMA (0)         ;some of these are also used when building CCWs just 
     895A-DISK-SAVE-PGF-WMD (0)         ; before calling DISK-SWAP-HANDLER 
     896A-DISK-SAVE-PGF-T (0)           ; also near SWAPIN. 
    788897A-DISK-SAVE-PGF-A (0) 
    789898A-DISK-SAVE-PGF-B (0) 
    790899A-DISK-SAVE-1 (0) 
    791900A-DISK-SAVE-2 (0) 
    792 A-DISK-SAVE-C (0) 
     901A-DISK-SAVE-MODE (0)            ;save A-PGF-MODE 
    793902 
    794903A-DISK-CYL-BEG (0)      ;Typeless virtual address that lies at start of a cylinder 
     
    826935                                        ;FOLLOWING ARE OTHER RANDOM UCODE ENTRIES.  
    827936A-V-PAGE-TABLE-AREA     (0) 
    828 A-V-PHYSICAL-PAGE-DATA (0)              ;FOR EACH PAGE FRAME, -1 IF IT IS OUT OF SERVICE, OR 
    829                                         ; REGION NUMBER,,PHT INDEX FOR PAGE IN IT 
     937A-V-PHYSICAL-PAGE-DATA  (0)             ;FOR EACH PAGE FRAME, -1 IF IT IS OUT OF SERVICE, OR 
     938                                        ; GC DATA,,PHT INDEX FOR PAGE IN IT 
     939                                        ; -1 IN PHT INDEX IF WIRED PAGE WITH NO PHT ENTRY 
     940                                        ; GC DATA=0 IF NOT IN USE 
    830941A-V-REGION-ORIGIN       (0)             ;VIRTUAL ADDRESS START OF REGION 
    831942A-V-REGION-LENGTH       (0)             ;NUMBER OF QS IN REGION 
    832943A-V-REGION-BITS         (0)             ;VARIOUS FIELDS, SEE QCOM 
    833 A-V-REGION-SORTED-BY-ORIGIN (0)         ;REGION NUMBERS SORTED BY VIRTUAL ADDRESS 
    834                                         ; LAST ENTRY REPLICATED THROUGH TO END OF AREA 
    835                                         ; MUST HAVE DATA-TYPE DTP-FIX AND NO CDR-CODE 
    836                                         ; DOES NOT INCLUDE FREE REGIONS AND FREE REGION#S 
     944A-V-ADDRESS-SPACE-MAP   (0)             ;A BYTE FOR EACH ADDRESS SPACE QUANTUM, GIVING REGION# 
     945                                        ; OR 0 IF FREE OR FIXED-AREA.  BYTE SIZE IS 
     946                                        ; %ADDRESS-SPACE-MAP-BYTE-SIZE 
    837947A-V-REGION-FREE-POINTER (0)             ;RELATIVE ALLOCATION POINT.  ALLOCATION IS UPWARDS 
    838948A-V-REGION-GC-POINTER   (0)             ;VARIOUS USES, MAINLY RELATIVE DIRTY/CLEAN BOUNDARY 
    839949A-V-REGION-LIST-THREAD  (0)             ;NEXT REGION# IN AREA, OR 1_23. + AREA# AT END OF LIST 
    840                                         ; THREADS FREE REGIONS (IN FREE-AREA) AND FREE REGION#S 
     950                                        ; THREADS FREE REGION TABLE SLOTS 
    841951A-V-AREA-NAME           (0)             ;SYMBOL WHICH NAMES AREA (NIL FOR FREE AREA#S) 
    842952A-V-AREA-REGION-LIST    (0)             ;FIRST REGION# IN AREA (FREE LIST FOR FREE AREA#S) 
    843953A-V-AREA-REGION-SIZE    (0)             ;RECOMMENDED SIZE FOR NEW REGIONS 
    844954A-V-AREA-MAXIMUM-SIZE   (0)             ;APPROXIMATE MAXIMUM #WDS IN THIS AREA 
    845 A-V-FREE-AREA           (0)             ;OWNS REGIONS OF VIRTUAL ADDRESS SPACE WHICH ARE FREE 
     955A-V-AREA-SWAP-RECOMMENDATIONS (0)       ;FIXNUM. SEE %%AREA-SWAP- SYMS. 
     956A-V-GC-TABLE-AREA       (0)             ;GARBAGE COLLECTOR TABLES 
    846957A-V-SUPPORT-ENTRY-VECTOR        (0) 
    847958A-V-CONSTANTS-AREA      (0)             ;CONSTANTS PAGE (REF'ED IN ADR OF MACRO-CODE) 
     
    852963A-V-MICRO-CODE-ENTRY-ARGS-INFO-AREA (0) ;MICRO-CODE-ENTRY-ARGS-INFO-AREA 
    853964A-V-MICRO-CODE-ENTRY-MAX-PDL-USAGE (0)  ;MAXIMUM DEPTH ON PDL BEFORE MICRO TO MACRO CALL 
    854 A-V-MICRO-CODE-EXIT-AREA        (0)     ;MICRO-CODE-EXIT-AREA  --obsolete flush this. 
     965;Following areas are not used by microcode except for XRGN 
     966;since they are not aligned on quantum boundaries 
     967A-V-MICRO-CODE-ENTRY-ARGLIST-AREA (0)   ;VALUE FOR ARGLIST FUNCTION TO RETURN 
     968A-V-MICRO-CODE-SYMBOL-NAME-AREA (0)     ;NAMES OF MICRO-CODE-SYMBOL-AREA ENTRIES 
     969A-V-LINEAR-PDL-AREA (0)                 ;MAIN PDL 
     970A-V-LINEAR-BIND-PDL-AREA (0)            ;CORRESPONDING BIND PDL 
     971A-V-INIT-LIST-AREA (0)                  ;LIST CONSTANTS CREATED BY COLD LOAD 
     972;Microcode -knows- that INIT-LIST-AREA is the last fixed area 
     973 
     974;This location -must- immediately follow the above table of fixed areas 
     975A-V-FIRST-UNFIXED-AREA (0)              ;First address above fixed areas 
    855976 
    856977A-V-MISC-BASE   (0)     ;BASE OF DISPATCH TABLE FOR MISC-INST .  
     
    878999 
    8791000;TEMPORARIES IN *CATCH, *THROW, ETC 
     1001A-LAST-STACK-GROUP              ;LAST STACK GROUP LEFT 
    8801002A-CATCH-MARK    (0)     ;MARK, IE, WHAT MUST BE IN FEF POINTER OF DESIRED FRAME 
    8811003 
     
    8971019A-PAGE-TRACE-VMA (0)    ;TEMP: ADDRESS REFERENCED 
    8981020A-PAGE-TRACE-UPC (0)    ;TEMP: MICRO-PC AND SWAP-OUT FLAG 
     1021 
     1022;;; Metering variables 
     1023A-METER-LENGTH  (0)                     ;Length of additional meter info 
     1024A-METER-EVENT   (0)                     ;Number of the metered even 
     1025A-METER-LOCK    (0)                     ;Lock during swap out of meter buffer 
     1026A-METER-START-TIME (0)                  ;Microsecond clock reading saved here 
    8991027 
    9001028;CONNECTED WITH PDL-BUFFER MANAGEMENT 
     
    9851113;A-REVERSE-FIRST-LEVEL-MAP-INIT-VALUE 
    9861114;       (-1)    ;THIS ONE IS NEVER CHANGED (ENTRY #37) 
     1115 
     1116;Variables for mouse tracking 
     1117A-MOUSE-X-FRACTION (0)  ;10 bits of fractional position 
     1118A-MOUSE-Y-FRACTION (0) 
     1119A-MOUSE-CURSOR-X (0)    ;Current location of cursor 
     1120A-MOUSE-CURSOR-Y (0)    ; (only valid if state=3) 
     1121A-MOUSE-LAST-H1 (0)     ;Last value input from hardware 
     1122A-MOUSE-LAST-H2 (0) 
     1123A-MOUSE-HARDWARE-ADDRESS (77772042)     ;764104 is Y, 764106 is X 
     1124A-MOUSE-SCREEN-BUFFER-ADDRESS (0)       ;Data for screen (or sheet) mouse is on 
     1125A-MOUSE-SCREEN-BUFFER-END-ADDRESS (0) 
     1126A-MOUSE-SCREEN-LOCATIONS-PER-LINE (0) 
     1127A-MOUSE-SCREEN-BUFFER-BIT-OFFSET (0) 
     1128A-MOUSE-SCREEN-WIDTH (0) 
     1129A-MOUSE-SCREEN-BUFFER-PIXEL-SIZE-MROT (0) 
     1130A-MOUSE-SCREEN (0) 
     1131A-MOUSE-SAVE-1 (0) 
     1132A-MOUSE-SAVE-2 (0) 
     1133A-MOUSE-SAVE-E (0) 
     1134 
     1135;Arrays at fixed locations in A memory, used for the mouse 
     1136(ASSIGN MOUSE-CURSOR-PATTERN-AMEM-LOC 1600)     ;32x32 BIT ARRAY 
     1137(ASSIGN MOUSE-BUTTONS-BUFFER-AMEM-LOC 1640)     ;8 4-WORD ART-Q ENTRIES 
     1138(ASSIGN MOUSE-X-SCALE-ARRAY-AMEM-LOC 1700)      ;8 2-WORD ART-Q ENTRIES 
     1139(ASSIGN MOUSE-Y-SCALE-ARRAY-AMEM-LOC 1720)      ;8 2-WORD ART-Q ENTRIES 
    9871140 
    9881141;;; DISPATCH TABLES 
     
    11341287;DISPATCH ON DATA TYPE.  DROPS THROUGH IN EITHER CASE BUT SKIPS IF ATOM.  
    11351288;AN ATOM IS ANYTHING OTHER THAN A LIST. 
    1136 SKIP-IF-ATOM     
     1289SKIP-IF-ATOM 
    11371290        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;TRAP 
    11381291        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;NULL 
     
    11611314        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;INSTANCE-HEADER 
    11621315        (P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)      ;ENTITY 
     1316        (P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)      ;STACK-CLOSURE 
    11631317 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)) 
    11641318(END-DISPATCH) 
     
    11971351        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;INSTANCE-HEADER 
    11981352        (P-BIT R-BIT 0)                         ;ENTITY 
     1353        (P-BIT R-BIT 0)                         ;STACK-CLOSURE 
    11991354 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)) 
    12001355(END-DISPATCH) 
     
    12291384        (P-BIT R-BIT 0)                 ;INSTANCE-HEADER [NOT A LIST FOR PURPOSES OF THIS] 
    12301385        (P-BIT R-BIT 0)                 ;ENTITY [NOT A LIST FOR PURPOSES OF THIS] 
     1386        (P-BIT R-BIT 0)                 ;STACK-CLOSURE [NOT A LIST FOR PURPOSES OF THIS] 
    12311387 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)) 
    12321388(END-DISPATCH) 
     
    12701426        (P-BIT ILLOP)                   ;INSTANCE-HEADER 
    12711427        (CALL-ENTITY)                   ;ENTITY 
     1428        (QCLS)                          ;STACK-CLOSURE 
    12721429 (REPEAT NQZUSD (P-BIT ILLOP)) 
    12731430(END-DISPATCH) 
     
    13031460        (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)       ;INSTANCE-HEADER 
    13041461        (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)       ;ENTITY (eventually send message) 
     1462        (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)       ;STACK-CLOSURE (eventually send message) 
    13051463 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)) 
    13061464(END-DISPATCH) 
     
    13361494        (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)       ;INSTANCE-HEADER 
    13371495        (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)       ;ENTITY (eventually send message) 
     1496        (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)       ;STACK-CLOSURE 
    13381497 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)) 
    13391498(END-DISPATCH) 
     
    13541513        (P-BIT TRAP)    ;ERROR 
    13551514        (P-BIT R-BIT)   ;ERROR EXCEPT (CAR NIL) = NIL 
    1356         (R-BIT)         ;NIL -> NIL 
     1515        (XFALSE)        ;NIL 
    13571516        (P-BIT TRAP)    ;UNUSED 
    13581517(END-DISPATCH) 
     
    14501609        (P-BIT TRAP)    ;INSTANCE-HEADER 
    14511610        (P-BIT TRAP)    ;ENTITY 
     1611        (P-BIT TRAP)    ;STACK-CLOSURE 
    14521612 (REPEAT NQZUSD (P-BIT TRAP)) 
    14531613(END-DISPATCH) 
     
    14811641        (P-BIT TRAP)    ;INSTANCE-HEADER 
    14821642        (P-BIT TRAP)    ;ENTITY 
     1643        (P-BIT TRAP)    ;STACK-CLOSURE 
    14831644 (REPEAT NQZUSD (P-BIT TRAP)) 
    14841645(END-DISPATCH) 
     
    15131674        (INHIBIT-XCT-NEXT-BIT TRAP)     ;INSTANCE-HEADER 
    15141675        (INHIBIT-XCT-NEXT-BIT TRAP)     ;ENTITY 
     1676        (INHIBIT-XCT-NEXT-BIT TRAP)     ;STACK-CLOSURE 
    15151677 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRAP)) 
    15161678(END-DISPATCH) 
     
    15311693        (QQARY)         ;STACK-GROUP HEAD 
    15321694        (QQARY)         ;SPEC-PDL 
    1533         (INHIBIT-XCT-NEXT-BIT TRAP)     ;TV BUFFER (OBSOLETE) 
     1695        (QB16SRY)       ;HALF-FIX 
    15341696        (QQARY)         ;REG-PDL 
    15351697        (QFARY)         ;FLOAT 
     1698        (QFFARY)        ;FPS-FLOAT 
     1699        (QB16RY)        ;FAT-STRING 
    15361700 (REPEAT NATUSD (INHIBIT-XCT-NEXT-BIT TRAP)) 
    15371701(END-DISPATCH) 
     
    15521716        (QSQARY)        ;STACK-GROUP HEAD 
    15531717        (QSQARY)        ;SPEC-PDL 
    1554         (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)       ;TV BUFFER (OBSOLETE) 
     1718        (QS16RY)        ;HALF-FIX 
    15551719        (QSQARY)        ;REG-PDL 
    15561720        (QSFARY)        ;FLOAT 
     1721        (QSFFARY)       ;FPS-FLOAT 
     1722        (QS16RY)        ;FAT-STRING 
    15571723 (REPEAT NATUSD (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)) 
    15581724(END-DISPATCH) 
     
    15731739        (QSQARY)        ;STACK-GROUP HEAD 
    15741740        (QSQARY)        ;SPEC-PDL 
    1575         (TRAP)          ;TV-BUFFER (OBSOLETE) 
     1741        (QS16RY)        ;HALF-FIX 
    15761742        (QSQARY)        ;REG-PDL 
    15771743        (QSFARY)        ;FLOAT 
     1744        (QSFFARY)       ;FPS-FLOAT 
     1745        (QS16RY)        ;FAT-STRING 
    15781746 (REPEAT NATUSD (TRAP)) 
    15791747(END-DISPATCH) 
     
    15931761        (P-BIT R-BIT)                           ;STACK-GROUP HEAD 
    15941762        (P-BIT R-BIT)                           ;SPEC-PDL 
    1595         (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)       ;TV BUFFER (OBSOLETE) 
     1763        (P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)      ;HALF-FIX 
    15961764        (P-BIT R-BIT)                           ;REG-PDL 
    15971765        (P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)      ;FLOAT 
     1766        (P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)      ;FPS-FLOAT       
     1767        (P-BIT R-BIT INHIBIT-XCT-NEXT-BIT)      ;FAT-STRING 
    15981768 (REPEAT NATUSD (P-BIT INHIBIT-XCT-NEXT-BIT TRAP)) 
    15991769(END-DISPATCH) 
     
    17861956        (INHIBIT-XCT-NEXT-BIT TRAP)     ;INSTANCE-HEADER 
    17871957        (INHIBIT-XCT-NEXT-BIT TRAP)     ;ENTITY 
     1958        (INHIBIT-XCT-NEXT-BIT TRAP)     ;STACK-CLOSURE 
    17881959 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRAP)) 
    17891960(END-DISPATCH) 
     
    18181989        (R-BIT)                                 ;INSTANCE-HEADER, POPJ 
    18191990        (R-BIT)                                 ;ENTITY, POPJ 
     1991        (R-BIT)                                 ;STACK-CLOSURE, POPJ 
    18201992 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)) 
    18211993(END-DISPATCH) 
     
    18522024        (P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)      ;INSTANCE-HEADER 
    18532025        (XAGICL INHIBIT-XCT-NEXT-BIT)           ;ENTITY 
     2026        (XAGICL INHIBIT-XCT-NEXT-BIT)           ;STACK-CLOSURE 
    18542027 (REPEAT NQZUSD (P-BIT ILLOP INHIBIT-XCT-NEXT-BIT)) 
    18552028(END-DISPATCH) 
     
    19112084        (INHIBIT-XCT-NEXT-BIT TRANS-OLD)        ;0 ENTITY 
    19122085        (R-BIT)                                 ;1 ENTITY 
     2086        (INHIBIT-XCT-NEXT-BIT TRANS-OLD)        ;0 STACK-CLOSURE 
     2087        (R-BIT)                                 ;1 STACK-CLOSURE 
    19132088 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRANS-TRAP)) 
    1914  (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRANS-TRAP)) 
     2089 
     2090(REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRANS-TRAP)) 
    19152091(END-DISPATCH) 
    19162092 
     
    19712147        (INHIBIT-XCT-NEXT-BIT TRANS-OLD)        ;0 ENTITY 
    19722148        (R-BIT)                                 ;1 ENTITY 
     2149        (INHIBIT-XCT-NEXT-BIT TRANS-OLD)        ;0 STACK-CLOSURE 
     2150        (R-BIT)                                 ;1 STACK-CLOSURE 
    19732151 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRANS-TRAP)) 
    19742152 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT TRANS-TRAP)) 
     
    20002178        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;1 GC-FORWARD (SHOULDN'T SEE IN THIS CONTEXT) 
    20012179        (INHIBIT-XCT-NEXT-BIT PB-TRANS)         ;0 EXTERNAL-VALUE-CELL-POINTER 
    2002         (INHIBIT-XCT-NEXT-BIT PB-TRANS)         ;1 EXTERNAL-VALUE-CELL-POINTER 
     2180        (P-BIT R-BIT)                           ;1 EXTERNAL-VALUE-CELL-POINTER 
    20032181        (INHIBIT-XCT-NEXT-BIT PB-TRANS)         ;0 ONE-Q-FORWARD 
    20042182        (INHIBIT-XCT-NEXT-BIT PB-TRANS)         ;1 ONE-Q-FORWARD 
     
    20332211        (INHIBIT-XCT-NEXT-BIT PB-TRANS)         ;0 ENTITY 
    20342212        (P-BIT R-BIT)                           ;1 ENTITY 
     2213        (INHIBIT-XCT-NEXT-BIT PB-TRANS)         ;0 STACK-CLOSURE 
     2214        (P-BIT R-BIT)                           ;1 STACK-CLOSURE 
    20352215 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT PB-TRANS)) 
    20362216 (REPEAT NQZUSD (INHIBIT-XCT-NEXT-BIT PB-TRANS)) 
    20372217(END-DISPATCH) 
    2038 (START-DISPATCH 6 P-BIT)       ;GC-WRITE-TEST (MAP18: 0=EXTRA-PDL, 1=NORMAL) 
     2218 
     2219(START-DISPATCH 6 P-BIT)        ;GC-WRITE-TEST (MAP18: 0=EXTRA-PDL, 1=NORMAL) 
    20392220;EITHER DROPS THROUGH (P-R) OR CALLS (P-N) MAGIC ROUTINE. 
    20402221;CURRENTLY ANYWAY, DOESN'T TRAP ON ILL DATA TYPES.  THAT WOULD NEED AN I-ARG TO SUPPRESS IT. 
     
    20932274        (R-BIT)                                 ;0 ENTITY 
    20942275        (R-BIT)                                 ;1 ENTITY 
     2276        (INHIBIT-XCT-NEXT-BIT STACK-CLOSURE-TRAP)       ;0 STACK-CLOSURE 
     2277        (INHIBIT-XCT-NEXT-BIT STACK-CLOSURE-TRAP)       ;0 STACK-CLOSURE 
    20952278 (REPEAT NQZUSD (R-BIT)) 
    20962279 (REPEAT NQZUSD (R-BIT)) 
     
    21112294        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;HEADER 
    21122295        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;GC-FORWARD 
    2113         (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;EXTERNAL-VALUE-CELL-POINTER 
     2296        (P-BIT R-BIT 0)                         ;EXTERNAL-VALUE-CELL-POINTER this ok now. 
    21142297        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;ONE-Q-FORWARD 
    21152298        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;HEADER-FORWARD 
     
    21282311        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;INSTANCE-HEADER 
    21292312        (P-BIT R-BIT 0)                         ;ENTITY 
     2313        (P-BIT R-BIT 0)                         ;STACK-CLOSURE 
    21302314 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)) 
    21312315(END-DISPATCH) 
     
    22792463                (BYTE-VALUE M-TRANSPORT-FLAG 0) 
    22802464                (BYTE-VALUE M-STACK-GROUP-SWITCH-FLAG 0) 
    2281                 (BYTE-VALUE M-DEFERRED-SEQUENCE-BREAK-FLAG 0)))) 
     2465                (BYTE-VALUE M-DEFERRED-SEQUENCE-BREAK-FLAG 0) 
     2466                (BYTE-VALUE M-METER-STACK-GROUP-ENABLE 0)))) 
    22822467        ((M-SB-SOURCE-ENABLE) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
    2283         ((A-TV-CURRENT-SHEET) A-V-NIL)          ;.. 
     2468        ((A-TV-CURRENT-SHEET) A-V-NIL)          ;Forget this cache 
     2469        ((A-LEXICAL-ENVIRONMENT) A-V-NIL)       ;At top level wrt lexical bindings. 
     2470        ((A-AMEM-EVCP-VECTOR) A-V-NIL)          ;Don't write all over memory 
     2471        ((A-MOUSE-CURSOR-STATE) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)))  ;Mouse off 
    22842472        ((A-SCAV-COUNT) SETZ)                   ;Forget scavenger state 
    2285         ((A-READ-COMPARE-ENABLES) DPB (M-CONSTANT -1)   ;Read-compare writes, not reads 
    2286                 (BYTE-FIELD 1 1) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
     2473;This seems like an unnecessary waste of time: 
     2474;       ((A-DISK-SWITCHES) DPB (M-CONSTANT -1)  ;Read-compare writes, not reads 
     2475;               (BYTE-FIELD 1 1) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
    22872476        ((A-INHIBIT-SCHEDULING-FLAG) A-V-TRUE)  ;DISABLE SEQUENCE BREAKS 
    22882477        ((A-INHIBIT-SCAVENGING-FLAG) A-V-TRUE)  ;GARBAGE COLLECTOR NOT TURNED ON UNTIL LATER 
     2478        ((A-LCONS-CACHE-AREA) SETZ)             ;Forget these caches (disk-restore...) 
     2479        ((A-SCONS-CACHE-AREA) SETZ) 
    22892480        ((A-PAGE-TRACE-PTR) SETZ)               ;SHUT OFF PAGE-TRACE 
     2481        ((A-METER-GLOBAL-ENABLE) A-V-NIL)       ;Turn off metering 
     2482        ((A-METER-DISK-COUNT) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
    22902483        (CALL RESET-MACHINE)                    ;Reset and turn on interrupts, set up map 
    22912484        ((VMA-START-READ) (A-CONSTANT 1031))    ;FETCH MISCELLANEOUS SCRATCHPAD LOCS 
     
    22952488        (ILLOP-IF-PAGE-FAULT) 
    22962489        ((A-CNSADF) Q-TYPED-POINTER READ-MEMORY-DATA) 
     2490        ((A-BACKGROUND-CONS-AREA) A-CNSADF) 
    22972491        ((A-NUM-CNSADF) Q-TYPED-POINTER READ-MEMORY-DATA)  ;DONT REALLY HACK EXTRA-PDL 
    22982492                                                          ; INITIALLY. 
     
    23042498        ;; Find out where to page off of if we don't know already  
    23052499        (CALL-EQUAL A-DISK-OFFSET M-ZERO WARM-READ-LABEL) 
    2306         ;; Get A-INITIAL-FEF, A-QTRSTKG, A-QCSTKG, A-QISTKG 
     2500        ;; Clear the unused pages of the PHT and PPD out of the map 
     2501        ((MD) DPB (M-CONSTANT -1) (BYTE-FIELD 8 0) A-V-PHYSICAL-PAGE-DATA-END) 
     2502        ((MD) ADD MD (A-CONSTANT 1))            ;First page above PPD 
     2503        (JUMP-GREATER-OR-EQUAL MD A-V-REGION-ORIGIN BEGCM2) 
     2504BEGCM1  ((VMA-WRITE-MAP) (A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE))) 
     2505        ((MD) ADD MD (A-CONSTANT (EVAL PAGE-SIZE))) 
     2506        (JUMP-LESS-THAN MD A-V-REGION-ORIGIN BEGCM1) 
     2507BEGCM2  ((MD) A-V-PAGE-TABLE-AREA) 
     2508        ((MD) ADD MD A-PHT-INDEX-LIMIT) 
     2509        (JUMP-GREATER-OR-EQUAL MD A-V-PHYSICAL-PAGE-DATA BEGCM4) 
     2510BEGCM3  ((VMA-WRITE-MAP) (A-CONSTANT (BYTE-MASK MAP-WRITE-ENABLE-SECOND-LEVEL-WRITE))) 
     2511        ((MD) ADD MD (A-CONSTANT (EVAL PAGE-SIZE))) 
     2512        (JUMP-LESS-THAN MD A-V-PHYSICAL-PAGE-DATA BEGCM3) 
     2513BEGCM4  ;; Get A-INITIAL-FEF, A-QTRSTKG, A-QCSTKG, A-QISTKG 
    23072514        ((VMA) (BYTE-FIELD 9 0) (M-CONSTANT -1)) ;777 ;SCRATCH-PAD-INIT-AREA MINUS ONE 
    23082515        ((M-K) (A-CONSTANT (A-MEM-LOC A-SCRATCH-PAD-BEG))) ;FIRST A MEM LOC TO BLT INTO 
     
    23162523        ((VMA-START-READ) A-INITIAL-FEF)        ;INDIRECT 
    23172524        (CHECK-PAGE-READ) 
     2525        ;; Don't let garbage pointer leak through DISK-RESTORE 
     2526        ;; There are a lot of these, we only get the ones that are known to cause trouble 
     2527        ;; There are also the "method subroutine" and "sg calling args" guys 
     2528        ((A-SELF) A-V-NIL) 
     2529        ((A-SG-PREVIOUS-STACK-GROUP) A-V-NIL) 
    23182530        (DISPATCH TRANSPORT READ-MEMORY-DATA) 
    23192531        ((A-INITIAL-FEF) READ-MEMORY-DATA) 
     
    23532565        ((VMA-START-READ) (A-CONSTANT (EVAL (PLUS 400 %SYS-COM-AREA-ORIGIN-PNTR)))) 
    23542566        (ILLOP-IF-PAGE-FAULT) 
    2355         ((VMA) SUB READ-MEMORY-DATA (A-CONSTANT 1)) ;1- ADDR OF AREA-ORIGIN TABLE 
     2567        ((VMA) SUB READ-MEMORY-DATA (A-CONSTANT 1)) ;1- ADDR OF REGION-ORIGIN TABLE 
    23562568        ((M-K) (A-CONSTANT (A-MEM-LOC A-V-RESIDENT-SYMBOL-AREA))) 
    23572569BEG02   ((VMA-START-READ) ADD VMA (A-CONSTANT 1)) 
     
    23592571        ((OA-REG-LOW) DPB M-K OAL-A-DEST A-ZERO)        ;DESTINATION 
    23602572        ((A-GARBAGE) Q-POINTER READ-MEMORY-DATA (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
    2361         (JUMP-NOT-EQUAL-XCT-NEXT M-K 
    2362                 (A-CONSTANT (A-MEM-LOC A-V-MICRO-CODE-ENTRY-MAX-PDL-USAGE)) BEG02) 
    2363        ((M-K) ADD M-K (A-CONSTANT 1)) 
    2364         (POPJ) 
     2573        ((M-K) ADD M-K (A-CONSTANT 1)) 
     2574        (JUMP-NOT-EQUAL M-K (A-CONSTANT (A-MEM-LOC A-V-FIRST-UNFIXED-AREA)) BEG02) 
     2575        ;; Now find the end of the last fixed area, which is where we can start making regions 
     2576        ;; Too bad the cold-load generator didn't store this anywhere for us 
     2577        ((M-K) M-A-1 M-K (A-CONSTANT (A-MEM-LOC A-V-RESIDENT-SYMBOL-AREA))) 
     2578        ((VMA-START-READ) ADD M-K A-V-REGION-LENGTH) 
     2579        (ILLOP-IF-PAGE-FAULT) 
     2580        ((M-K) ADD READ-MEMORY-DATA A-V-INIT-LIST-AREA) ;...the last fixed area 
     2581        ;; Round up to next multiple of a quantum 
     2582        (POPJ-AFTER-NEXT (M-K) ADD M-K (A-CONSTANT (EVAL (1- %ADDRESS-SPACE-QUANTUM-SIZE)))) 
     2583       ((A-V-FIRST-UNFIXED-AREA) SELECTIVE-DEPOSIT M-K 
     2584                VMA-QUANTUM-BYTE (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
    23652585 
    23662586;;; MAIN INSTRUCTION EXECUTING LOOP 
     
    25732793                                  (BYTE-VALUE Q-CDR-CODE CDR-NEXT)))) 
    25742794       (NO-OP)          ;NO PASS-AROUND PATH ON PDL-BUFFER 
    2575  
     2795 
     2796;Get and set lexical variables inherited from outer contexts. 
     2797XLOAD-FROM-HIGHER-CONTEXT 
     2798        (MISC-INST-ENTRY %LOAD-FROM-HIGHER-CONTEXT) 
     2799        (CALL XLOCATE-IN-HIGHER-CONTEXT) 
     2800        (JUMP QCAR) 
     2801 
     2802XSTORE-IN-HIGHER-CONTEXT 
     2803        (MISC-INST-ENTRY %STORE-IN-HIGHER-CONTEXT) 
     2804        (CALL XLOCATE-IN-HIGHER-CONTEXT) 
     2805        ((M-S) M-T) 
     2806        (JUMP-XCT-NEXT QRAR1) 
     2807       ((M-T) C-PDL-BUFFER-POINTER-POP) 
     2808 
     2809XLOCATE-IN-HIGHER-CONTEXT 
     2810        (MISC-INST-ENTRY %LOCATE-IN-HIGHER-CONTEXT) 
     2811;Compute in M-T the address of a local or arg in a higher lexical context. 
     2812;Pops a word off the stack to specify where to find the local: 
     2813;  Sign bit       0 => arg, 1 => local. 
     2814;  Next 11. bits  Number of contexts to go up (0 => immediate higher context) 
     2815;  Low 12. bits   Number of arg or local in that context. 
     2816        ((M-A) C-PDL-BUFFER-POINTER-POP) 
     2817        ((M-B) (BYTE-FIELD 11. 12.) M-A) 
     2818        ((M-T) A-LEXICAL-ENVIRONMENT) 
     2819XLOCATE-IN-HIGHER-CONTEXT-1 
     2820        (JUMP-EQUAL M-B A-ZERO XLOCATE-IN-HIGHER-CONTEXT-3) 
     2821        (CALL QCDR) 
     2822        (JUMP-XCT-NEXT XLOCATE-IN-HIGHER-CONTEXT-1) 
     2823       ((M-B) SUB M-B (A-CONSTANT 1)) 
     2824 
     2825XLOCATE-IN-HIGHER-CONTEXT-3 
     2826        (CALL QCAR) 
     2827        (CALL-EQUAL M-T A-V-NIL TRAP) 
     2828    (ERROR-TABLE ILLEGAL-INSTRUCTION) 
     2829        (JUMP-IF-BIT-CLEAR BOXED-SIGN-BIT M-A XLOCATE-IN-HIGHER-CONTEXT-2) 
     2830        ((VMA-START-READ) ADD M-T (EVAL %LP-ENTRY-STATE)) 
     2831        (CHECK-PAGE-READ) 
     2832        ((M-B) (LISP-BYTE %%LP-ENS-MACRO-LOCAL-BLOCK-ORIGIN) MD) 
     2833        ((M-T) ADD M-B A-T) 
     2834        ((M-T) SUB M-T (A-CONSTANT 1)) 
     2835XLOCATE-IN-HIGHER-CONTEXT-2 
     2836        ((M-B) (BYTE-FIELD 12. 0) M-A) 
     2837        (POPJ-AFTER-NEXT 
     2838         (M-T) ADD M-B A-T ALU-CARRY-IN-ONE) 
     2839        ((M-T) DPB M-T Q-POINTER 
     2840               (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE))) 
     2841 
    25762842;;; VARIOUS TRAPS 
    25772843 
     
    27683034            DPB M-C Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
    27693035       ((C-PDL-BUFFER-POINTER-PUSH) M-T) 
     3036 
     3037;;; These are not callable with MISC instructions, only as functions. 
     3038;;; They are documented as taking an &REST argument but actually take 63 optional args. 
     3039;;; When entered, the arguments are on the stack and M-R contains the number of them. 
     3040;;; (M-AP)+1 is the first argument, (PP) is the last. 
     3041        (MISC-INST-ENTRY LIST) 
     3042XLIST   (JUMP-EQUAL M-R A-ZERO XFALSE) 
     3043        (CALL-XCT-NEXT LCONS-D) 
     3044       ((M-B) Q-POINTER M-R) 
     3045XLIST0  ((WRITE-MEMORY-DATA) LDB C-PDL-BUFFER-POINTER-POP 
     3046                Q-ALL-BUT-CDR-CODE (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL))) 
     3047        ((VMA) ADD M-T A-B) 
     3048        ((M-T) DPB Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST))) 
     3049XLIST1  ((VMA-START-WRITE) SUB VMA (A-CONSTANT 1)) 
     3050        (CHECK-PAGE-WRITE) 
     3051        (GC-WRITE-TEST) 
     3052        ((M-B) SUB M-B (A-CONSTANT 1)) 
     3053XLIST2  (POPJ-LESS-OR-EQUAL M-B A-ZERO) 
     3054        (JUMP-XCT-NEXT XLIST1) 
     3055       ((WRITE-MEMORY-DATA) LDB C-PDL-BUFFER-POINTER-POP 
     3056                Q-ALL-BUT-CDR-CODE (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT))) 
     3057 
     3058        (MISC-INST-ENTRY LIST*) 
     3059XLISTR  (JUMP-EQUAL M-R (A-CONSTANT 1) POPTJ) 
     3060        (CALL-XCT-NEXT LCONS-D) 
     3061       ((M-B) Q-POINTER M-R) 
     3062XLISTR0 ((VMA) ADD M-T A-B) 
     3063        ((M-T) DPB Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST))) 
     3064        ((WRITE-MEMORY-DATA) LDB C-PDL-BUFFER-POINTER-POP 
     3065                Q-ALL-BUT-CDR-CODE (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-ERROR))) 
     3066        ((VMA-START-WRITE) SUB VMA (A-CONSTANT 1)) 
     3067        (CHECK-PAGE-WRITE) 
     3068        (GC-WRITE-TEST) 
     3069        ((WRITE-MEMORY-DATA) LDB C-PDL-BUFFER-POINTER-POP 
     3070                Q-ALL-BUT-CDR-CODE (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NORMAL))) 
     3071        ((VMA-START-WRITE) SUB VMA (A-CONSTANT 1)) 
     3072        (CHECK-PAGE-WRITE) 
     3073        (GC-WRITE-TEST) 
     3074        (JUMP-XCT-NEXT XLIST2) 
     3075       ((M-B) SUB M-B (A-CONSTANT 2)) 
     3076 
     3077;;; Note that these two never pop their first argument.  This doesn't matter when 
     3078;;; calling them as functions, but if you try to make a MISC-instruction interface 
     3079;;; to these you will need to be aware of that. 
     3080        (MISC-INST-ENTRY LIST-IN-AREA) 
     3081XLISTA  (JUMP-EQUAL M-R (A-CONSTANT 1) XFALSE) 
     3082        ((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT 1)) 
     3083        ((M-S) Q-TYPED-POINTER C-PDL-BUFFER-INDEX) 
     3084        ((M-B) SUB M-R (A-CONSTANT 1)) 
     3085        (JUMP-XCT-NEXT XLIST0) 
     3086       (CALL LCONS) 
     3087         
     3088        (MISC-INST-ENTRY LIST*-IN-AREA) 
     3089XLISTRA (JUMP-EQUAL M-R (A-CONSTANT 2) POPTJ) 
     3090        ((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT 1)) 
     3091        ((M-S) Q-TYPED-POINTER C-PDL-BUFFER-INDEX) 
     3092        ((M-B) SUB M-R (A-CONSTANT 1)) 
     3093        (JUMP-XCT-NEXT XLISTR0) 
     3094       (CALL LCONS) 
    27703095 
    27713096;THESE VARIOUS CONSING ROUTINES HAD BETTER NOT CLOBBER M-C.  OTHER REGS PROBABLY OK. 
     3097 
     3098(ERROR-TABLE DEFAULT-ARG-LOCATIONS XCONS (PP 1) (PP 0)) 
    27723099 
    27733100XXCONS (MISC-INST-ENTRY XCONS)                  ;XCONS 
    27743101        (JUMP-XCT-NEXT XXCON1) 
    27753102       ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF)      ;USE DEFAULT AREA 
     3103 
     3104(ERROR-TABLE DEFAULT-ARG-LOCATIONS XCONS-IN-AREA (PP 1) (PP 0) M-S) 
    27763105 
    27773106XXCONA (MISC-INST-ENTRY XCONS-IN-AREA)          ;XCONS, WITH AREA AS THIRD ARG 
     
    27833112       ((C-PDL-BUFFER-POINTER-PUSH) M-A) 
    27843113 
     3114(ERROR-TABLE DEFAULT-ARG-LOCATIONS NCONS (PP 1)) 
     3115 
    27853116XNCONS (MISC-INST-ENTRY NCONS)                  ;NCONS 
    27863117        (JUMP-XCT-NEXT XNCON1) 
    27873118       ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF) 
     3119 
     3120(ERROR-TABLE DEFAULT-ARG-LOCATIONS NCONS-IN-AREA (PP 1) M-S) 
    27883121 
    27893122XNCONA (MISC-INST-ENTRY NCONS-IN-AREA)          ;NCONS, WITH AREA AS SECOND ARG 
     
    27913124XNCON1  (JUMP-XCT-NEXT QCONS) 
    27923125       ((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL) 
     3126 
     3127(ERROR-TABLE DEFAULT-ARG-LOCATIONS CONS PP PP) 
    27933128 
    27943129XCONS (MISC-INST-ENTRY CONS)                    ;CONS 
     
    28113146       (NO-OP) 
    28123147 
     3148(ERROR-TABLE DEFAULT-ARG-LOCATIONS CONS-IN-AREA PP PP M-S) 
     3149 
    28133150XCONSA (MISC-INST-ENTRY CONS-IN-AREA)           ;CONS, WITH AREA AS THIRD ARG 
    28143151        (JUMP-XCT-NEXT QCONS) 
    28153152       ((M-S) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) 
    28163153 
     3154;Assuming M-S set up with area, 
     3155;cons a single-word cell with cdr-nil, 
     3156;with contents taken from the stack. 
     3157XNCONQ  (CALL-XCT-NEXT LCONS)                   ;ALLOCATE 1 Q, RETURN POINTER IN M-T, 
     3158       ((M-B) (A-CONSTANT 1))                   ;ALLOCATE FROM LIST SPACE 
     3159        ((WRITE-MEMORY-DATA) DPB Q-TYPED-POINTER  
     3160                C-PDL-BUFFER-POINTER-POP  
     3161                (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL))) 
     3162        ((VMA-START-WRITE M-T) DPB M-T Q-POINTER 
     3163                (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST))) 
     3164        (CHECK-PAGE-WRITE) 
     3165        (POPJ-AFTER-NEXT GC-WRITE-TEST) 
     3166       (NO-OP) 
    28173167 
    28183168;;; STORAGE ALLOCATION STUFF 
     
    28343184; FOR OUT-OF-VIRTUAL-MEMORY WHICH SHOULDN'T HAPPEN AND MAY NOT WORK. 
    28353185 
    2836 ;DECODE AREA SPEC IN M-S.  RETURN FIXNUM, WITH DATA-TYPE, IN M-S.  MAY JUMP OR CALL TO TRAP. 
    2837 ;ALSO CHECKS M-B.  (UNTYPED NUMBER OF FIXNUMS TO ALLOCATE.) 
     3186;DECODE AREA SPEC IN M-S.  RETURN FIXNUM, WITH DATA-TYPE, IN M-S. 
     3187;THIS CAN CALL TRAP OR JUMP TO IT, THUS CALLER MUST HAVE (ERROR-TABLE ARGTYP AREA M-S NIL) 
    28383188;M-S MUST HAVE DATA-TYPE AND NO CDR-CODE/FLAG. 
    2839 CONS-GET-AREA 
     3189CONS-GET-AREA           (ERROR-TABLE RESTART CONS-GET-AREA) 
    28403190        ((M-TEM) Q-DATA-TYPE M-S) 
    2841         (JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-SYMBOL)) CONS-GET-AREA-1) 
    2842 CONS-GET-AREA-0 
     3191        (CALL-EQUAL M-TEM (A-CONSTANT (EVAL DTP-SYMBOL)) CONS-GET-AREA-1) 
    28433192        (POPJ-AFTER-NEXT DISPATCH Q-DATA-TYPE M-S TRAP-UNLESS-FIXNUM) 
    2844     (ERROR-TABLE ARGTYP AREA M-S NIL) 
     3193    (ERROR-TABLE ARGTYP AREA M-S NIL CONS-GET-AREA) 
    28453194       (CALL-GREATER-THAN M-S (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-FIX) 
    28463195                                                (EVAL SIZE-OF-AREA-ARRAYS))) 
     
    28483197 
    28493198CONS-GET-AREA-1 
    2850         (JUMP-EQUAL M-S A-V-NIL CONS-GET-AREA-2) 
    28513199        ((VMA-START-READ) ADD M-S (A-CONSTANT 1))       ;Fetch value 
    28523200        (CHECK-PAGE-READ) 
    28533201        (DISPATCH TRANSPORT READ-MEMORY-DATA) 
    2854         (JUMP-XCT-NEXT CONS-GET-AREA-0) 
     3202        (POPJ-XCT-NEXT) 
    28553203       ((M-S) Q-TYPED-POINTER READ-MEMORY-DATA) 
    2856  
    2857 CONS-GET-AREA-2 
    2858         (JUMP-XCT-NEXT CONS-GET-AREA-0) 
    2859        ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF) 
    28603204 
    28613205;This entry used by number functions to cons a structure in extra-pdl  
    28623206SCONS-T ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-NUM-CNSADF) 
    2863 ;This is the normal entry, area in M-S 
    2864 SCONS   (CALL-LESS-OR-EQUAL M-B A-ZERO TRAP) 
     3207;This is the normal entry, area in M-S with no cdr code or flag bit 
     3208SCONS   (JUMP-NOT-EQUAL M-S A-V-NIL SCONS-N) 
     3209;This is the entry to cons in the default area 
     3210SCONS-D ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF) 
     3211;At this point M-S is a fixnum, unless there is a bug or use of an obsolete feature  
     3212SCONS-N (CALL-LESS-OR-EQUAL M-B A-ZERO TRAP) 
    28653213                (ERROR-TABLE CONS-ZERO-SIZE M-B) 
    28663214        (JUMP-IF-BIT-SET M-TRANSPORT-FLAG SCONSR)       ;Transporter must avoid cache 
     
    28743222       ((M-K) A-SCONS-CACHE-REGION) 
    28753223 
    2876 SCONSR  (CALL CONS-GET-AREA)                    ;Set up M-S 
    2877     (ERROR-TABLE ARGTYP AREA M-S NIL) 
     3224SCONSR          (ERROR-TABLE RESTART SCONSR) 
     3225        (CALL CONS-GET-AREA)                            ;Set up M-S 
     3226    (ERROR-TABLE ARGTYP AREA M-S NIL SCONSR) 
    28783227        ((VMA-START-READ) ADD M-S A-V-AREA-REGION-LIST) ;Find appropriate region of the area 
    28793228SCONS0  (CHECK-PAGE-READ) 
     
    28983247 
    28993248;A copy of the above code except for List representation-type, slightly different dispatch 
    2900 LCONS   (CALL-LESS-OR-EQUAL M-B A-ZERO TRAP) 
     3249;This is the normal entry, area in M-S with no cdr code or flag bit 
     3250LCONS   (JUMP-NOT-EQUAL M-S A-V-NIL LCONS-N) 
     3251;This is the entry to cons in the default area 
     3252LCONS-D ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF) 
     3253;At this point M-S is a fixnum, unless there is a bug or use of an obsolete feature  
     3254LCONS-N (CALL-LESS-OR-EQUAL M-B A-ZERO TRAP) 
    29013255                (ERROR-TABLE CONS-ZERO-SIZE M-B) 
    29023256        (JUMP-IF-BIT-SET M-TRANSPORT-FLAG LCONSR)       ;Transporter must avoid cache 
     
    29103264       ((M-K) A-LCONS-CACHE-REGION) 
    29113265 
    2912 LCONSR  (CALL CONS-GET-AREA)                    ;Set up M-S 
    2913     (ERROR-TABLE ARGTYP AREA M-S NIL) 
     3266LCONSR          (ERROR-TABLE RESTART LCONSR) 
     3267        (CALL CONS-GET-AREA)                    ;Set up M-S 
     3268    (ERROR-TABLE ARGTYP AREA M-S NIL LCONSR) 
    29143269        ((VMA-START-READ) ADD M-S A-V-AREA-REGION-LIST) ;Find appropriate region of the area 
    29153270LCONS0  (CHECK-PAGE-READ) 
     
    29863341        (INHIBIT-XCT-NEXT-BIT CONSF5)           ;1 OLD (TRY NEXT REGION) 
    29873342        (P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;2 NEW (ONLY IF NOT IN TRANSPORTER) 
    2988         (P-BIT R-BIT)                           ;3 STATIC 
    2989         (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;4 FIXED (ILLEGAL TO CONS IN) 
    2990         (P-BIT R-BIT)                           ;5 EXITED 
    2991         (INHIBIT-XCT-NEXT-BIT CONSF5)           ;6 EXIT (TRY NEXT REGION) 
    2992         (P-BIT R-BIT)                           ;7 EXTRA-PDL 
    2993         (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;10 WIRED (ILLEGAL TO CONS IN) 
    2994         (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;11 USER-PAGED (ILLEGAL TO CONS IN) 
    2995         (P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-COPY) ;12 COPY (ONLY IF IN TRANSPORTER) 
    2996 (REPEAT 5 (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))   ;UNUSED CODE (ILLEGAL TO CONS IN) 
     3343        (P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;3 NEW1 (ONLY IF NOT IN TRANSPORTER) 
     3344        (P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;4 NEW2 (ONLY IF NOT IN TRANSPORTER) 
     3345        (P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;5 NEW3 (ONLY IF NOT IN TRANSPORTER) 
     3346        (P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;6 NEW4 (ONLY IF NOT IN TRANSPORTER) 
     3347        (P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;7 NEW5 (ONLY IF NOT IN TRANSPORTER) 
     3348        (P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-NEW) ;10 NEW6 (ONLY IF NOT IN TRANSPORTER) 
     3349        (P-BIT R-BIT)                           ;11 STATIC 
     3350        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;12 FIXED (ILLEGAL TO CONS IN) 
     3351        (P-BIT R-BIT)                           ;13 EXTRA-PDL 
     3352        (P-BIT INHIBIT-XCT-NEXT-BIT CONS-CHECK-COPY) ;14 COPY (ONLY IF IN TRANSPORTER) 
     3353(REPEAT 3 (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP))   ;UNUSED CODE (ILLEGAL TO CONS IN) 
    29973354(END-DISPATCH) 
    29983355 
     
    32133570EXTRA-PDL-OV 
    32143571        (JUMP-LESS-OR-EQUAL M-B A-3 EXTRA-PDL-OV-0) 
    3215         (JUMP-XCT-NEXT SCONS)                   ;won't fit, cons in working storage instead 
    3216        ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-CNSADF) 
     3572        (JUMP SCONS-D)                  ;won't fit, cons in working storage instead 
    32173573 
    32183574;FLUSH POINTERS TO EXTRA-PDL OUT OF "MACHINE", I.E. M-ZR - M-K, A-VERSION - A-END-Q-POINTERS, 
     
    33023658RCONS1  ((VMA-START-READ) ADD M-S A-V-AREA-MAXIMUM-SIZE) 
    33033659        (CHECK-PAGE-READ) 
    3304         ((M-4) SUB READ-MEMORY-DATA A-4)        ;M-4 AMOUNT LEFT BEFORE OVERFLOW 
    3305         ((OA-REG-HIGH) BOXED-SIGN-BIT M-4)      ;SIGN EXTEND TO 32 BITS 
    3306         ((M-4) SELECTIVE-DEPOSIT M-ZERO Q-ALL-BUT-POINTER A-4) 
     3660        ((MD) Q-POINTER READ-MEMORY-DATA) 
     3661        ((M-4) Q-POINTER M-4) 
     3662        ((M-4) SUB MD A-4)                      ;M-4 AMOUNT LEFT BEFORE OVERFLOW 
    33073663        (JUMP-GREATER-OR-EQUAL M-4 A-3 RCONS2)  ;JUMP IF NO OVERFLOW PROBLEM 
    33083664        (JUMP-IF-BIT-SET M-TRANSPORT-FLAG RCONS2A) ;INHIBIT EMBARRASSING TRAP OUT OF TRANSP 
    33093665        (CALL-GREATER-THAN M-B A-4 TRAP) 
    33103666    (ERROR-TABLE AREA-OVERFLOW M-S) 
     3667        (JUMP-XCT-NEXT RCONS2)                  ;CONS MAXIMAL SIZE REGION 
     3668       ((M-3) M-4) 
    33113669RCONS2A ((M-3) M-B)                             ;ALMOST OVERFLOWING, ALLOCATE LESS (WIN?) 
    33123670RCONS2  ((VMA-START-READ) ADD M-K A-V-REGION-BITS)      ;GET BITS FOR THIS REGION 
     
    33163674        ((M-TEM) (LISP-BYTE %%REGION-SPACE-TYPE) M-4) 
    33173675        (DISPATCH-XCT-NEXT (BYTE-FIELD 4 0) M-TEM D-RCONS)      ;Check region type 
     3676             (ERROR-TABLE RCONS-FIXED) 
    33183677RCONS3 ((M-4) IOR M-4 (A-CONSTANT (BYTE-MASK %%REGION-OLDSPACE-META-BIT))) ;Not oldspace 
    33193678        ((M-4) DPB M-TEM (LISP-BYTE %%REGION-SPACE-TYPE) A-4) 
     3679        ((VMA-START-READ) ADD M-S A-V-AREA-SWAP-RECOMMENDATIONS) 
     3680        (CHECK-PAGE-READ) 
     3681        ((M-4) DPB READ-MEMORY-DATA (LISP-BYTE %%REGION-SWAPIN-QUANTUM) A-4) 
    33203682        (CALL-XCT-NEXT MAKE-REGION)             ;ALLOCATE A REGION OF THAT SIZE (TO M-K) 
    33213683       ((M-4) DPB M-E (LISP-BYTE %%REGION-REPRESENTATION-TYPE) A-4) 
     
    33453707        (P-BIT RCONS-DYNAM)     ;1 OLD (change into new) 
    33463708        (P-BIT R-BIT)           ;2 NEW (copy it) 
    3347         (P-BIT R-BIT)           ;3 STATIC (copy it) 
    3348         (P-BIT ILLOP)           ;4 FIXED (not supposed to cons new regions) 
    3349         (P-BIT R-BIT)           ;5 EXITED (copy it) 
    3350         (P-BIT R-BIT)           ;6 EXIT (copy it) 
    3351         (P-BIT R-BIT)           ;7 EXTRA-PDL (copy it) 
    3352         (P-BIT ILLOP)           ;10 WIRED (not supposed to cons new regions) 
    3353         (P-BIT ILLOP)           ;11 USER-PAGED (not supposed to cons new regions) 
    3354         (P-BIT RCONS-DYNAM)     ;12 COPY (change into new) 
    3355 (REPEAT 5 (P-BIT ILLOP)) 
     3709        (P-BIT R-BIT)           ;3 NEW1 (copy it) 
     3710        (P-BIT R-BIT)           ;4 NEW2 (copy it) 
     3711        (P-BIT R-BIT)           ;5 NEW3 (copy it) 
     3712        (P-BIT R-BIT)           ;6 NEW4 (copy it) 
     3713        (P-BIT R-BIT)           ;7 NEW5 (copy it) 
     3714        (P-BIT R-BIT)           ;10 NEW6 (copy it) 
     3715        (P-BIT R-BIT)           ;11 STATIC (copy it) 
     3716        (P-BIT INHIBIT-XCT-NEXT-BIT TRAP) ;12 FIXED (not supposed to cons new regions) 
     3717        (P-BIT R-BIT)           ;13 EXTRA-PDL (copy it) 
     3718        (P-BIT RCONS-DYNAM)     ;14 COPY (change into new) 
     3719(REPEAT 3 (P-BIT ILLOP)) 
    33563720(END-DISPATCH) 
    33573721(LOCALITY I-MEM) 
     
    33603724;;; M-3 HAS SIZE IN WORDS, M-4 HAS REGION-BITS 
    33613725;;; SETS UP EVERYTHING ELSE EXCEPT REGION-LIST-THREAD, RETURNS REGION IN M-K, BASHES M-E, M-T 
    3362 ;;; PRESERVES M-3 AND M-4, EXCEPT M-3 IS ROUNDED UP TO THE NEXT PAGE BOUNDARY 
     3726;;; PRESERVES M-3 AND M-4, EXCEPT M-3 IS ROUNDED UP TO THE NEXT QUANTUM BOUNDARY 
    33633727MAKE-REGION 
    3364         ((M-3) ADD M-3 (A-CONSTANT (BYTE-MASK VMA-LOW-BITS)))   ;Round up to page boundary 
    3365         ((M-3) SELECTIVE-DEPOSIT M-3 VMA-PAGE-ADDR-PART A-ZERO) 
     3728        ((M-3) ADD M-3 (A-CONSTANT (EVAL (1- %ADDRESS-SPACE-QUANTUM-SIZE)))) ;Round up to 
     3729        ((M-3) SELECTIVE-DEPOSIT M-3 VMA-QUANTUM-BYTE A-ZERO)                ; quantum bound 
    33663730        ((A-REGION-CONS-ALARM) M+A+1 M-ZERO A-REGION-CONS-ALARM) 
    33673731        ((M-TEM) VMA-PAGE-ADDR-PART M-3)        ;Length of region in pages 
    33683732        ((A-PAGE-CONS-ALARM) ADD M-TEM A-PAGE-CONS-ALARM) 
    3369         ;Check out the free regions 
    3370         ((M-TEM) (A-CONSTANT (EVAL (FIND-POSITION-IN-LIST 'FREE-AREA AREA-LIST)))) 
    3371         ((VMA-START-READ) ADD M-TEM A-V-AREA-REGION-LIST) 
     3733        ;; Search address-space-map for suitable number of consecutive zeros 
     3734        ((M-T) A-V-FIRST-UNFIXED-AREA)          ;Starting address 
     3735        ((M-TEM) A-DISK-MAXIMUM)                ;Ending address 
     3736        ((M-K) DPB M-TEM VMA-PAGE-ADDR-PART (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
    33723737MAKE-REGION-1 
    3373         (CHECK-PAGE-READ) 
    3374         ((M-T) VMA)                             ;SAVE WHO POINTED AT THIS REGION 
    3375         (CALL-IF-BIT-SET BOXED-SIGN-BIT READ-MEMORY-DATA TRAP) 
    3376     (ERROR-TABLE VIRTUAL-MEMORY-OVERFLOW) 
    3377         ((M-K) Q-POINTER READ-MEMORY-DATA)      ;REGION# 
    3378         ((VMA-START-READ) ADD M-K A-V-REGION-LENGTH) 
    3379         (CHECK-PAGE-READ) 
    3380         ((M-TEM) Q-POINTER READ-MEMORY-DATA) 
    3381         (JUMP-EQUAL M-TEM A-3 MAKE-REGION-3)    ;FITS EXACTLY 
    3382         (JUMP-GREATER-THAN M-TEM A-3 MAKE-REGION-2)     ;SPLIT THIS FREE REGION 
    3383         (JUMP-XCT-NEXT MAKE-REGION-1) 
    3384        ((VMA-START-READ) ADD M-K A-V-REGION-LIST-THREAD) 
    3385  
    3386 MAKE-REGION-2 
    3387         ((WRITE-MEMORY-DATA-START-WRITE) SUB READ-MEMORY-DATA A-3)      ;NEW LENGTH 
    3388         (CHECK-PAGE-WRITE) 
    3389         ((VMA-START-READ) ADD M-K A-V-REGION-ORIGIN) 
    3390         (CHECK-PAGE-READ) 
    3391         ((M-T) Q-TYPED-POINTER READ-MEMORY-DATA)        ;ORIGIN FOR NEW REGION 
    3392         ((WRITE-MEMORY-DATA-START-WRITE) ADD M-T A-3)   ;NEW ORIGIN FOR FREE REGION 
    3393         (CHECK-PAGE-WRITE) 
    3394 MAKE-REGION-4 
    3395         ;; M-T HAS ORIGIN, M-3 HAS LENGTH, M-4 HAS BITS.  PUT REGION IN TABLES. 
     3738        ((M-E) ADD M-T A-3)                     ;End of large enough region starting here 
     3739MAKE-REGION-2    
     3740        (CALL-GREATER-OR-EQUAL M-T A-K TRAP)    ;Reached end of map, with no luck 
     3741            (ERROR-TABLE VIRTUAL-MEMORY-OVERFLOW) 
     3742        (CALL ADDRESS-SPACE-MAP-LOOKUP)         ;This could be optimized to save some mem rds? 
     3743        (JUMP-NOT-EQUAL-XCT-NEXT M-TEM A-ZERO MAKE-REGION-1) 
     3744       ((M-T) ADD M-T (A-CONSTANT (EVAL %ADDRESS-SPACE-QUANTUM-SIZE))) 
     3745        (JUMP-LESS-THAN M-T A-E MAKE-REGION-2)  ;Found free space, but not big enough yet 
     3746        ((M-T) SUB M-T A-3)                     ;Base address of free space found 
     3747        ;; M-T has origin, M-3 has length, M-4 has bits.  Put region in tables. 
    33963748        ((VMA-START-READ) (A-CONSTANT (EVAL (PLUS 400 %SYS-COM-FREE-REGION/#-LIST)))) 
    33973749        (CHECK-PAGE-READ) 
    3398         ((M-K) Q-POINTER READ-MEMORY-DATA)      ;NUMBER OF NEW REGION 
    3399         (CALL-EQUAL M-K A-ZERO TRAP) 
    3400     (ERROR-TABLE REGION-TABLE-OVERFLOW)         ;WE HAVE LOST SOME OF FREE SPACE, TOO BAD 
     3750        ((M-K) Q-POINTER READ-MEMORY-DATA)      ;Number of new region 
     3751        (CALL-EQUAL M-K A-ZERO TRAP)            ;Out of region numbers 
     3752            (ERROR-TABLE REGION-TABLE-OVERFLOW) 
    34013753        ((VMA-START-READ) ADD M-K A-V-REGION-LIST-THREAD)       ;CDR OFF OF LIST 
    34023754        (CHECK-PAGE-READ) 
     
    34043756        ((VMA-START-WRITE) (A-CONSTANT (EVAL (PLUS 400 %SYS-COM-FREE-REGION/#-LIST)))) 
    34053757        (CHECK-PAGE-WRITE) 
    3406 MAKE-REGION-3A 
    3407         ;; SET UP REGION-SORTED-BY-ORIGIN 
    3408         ((M-TEM) (A-CONSTANT (EVAL SIZE-OF-AREA-ARRAYS))) 
    3409         ((VMA-START-READ) ADD M-TEM A-V-REGION-SORTED-BY-ORIGIN) 
    3410         (ILLOP-IF-PAGE-FAULT) 
    3411         ((M-TEM) SETZ)          ;TABLE INDEX 
    3412         ((A-TEM1) ADD READ-MEMORY-DATA A-V-REGION-ORIGIN)       ;LAST ENTRY, IS REPLICATED 
    3413 MAKE-REGION-5 
    3414         (JUMP-EQUAL VMA A-TEM1 MAKE-REGION-5B)                  ;GOES AFTER ALL EXISTING ONES 
    3415         ((VMA-START-READ) ADD M-TEM A-V-REGION-SORTED-BY-ORIGIN);SEARCH UP FOR WHERE THIS 
    3416         (ILLOP-IF-PAGE-FAULT)                                   ; REGION BELONGS 
    3417         ((VMA-START-READ) ADD READ-MEMORY-DATA A-V-REGION-ORIGIN) 
    3418         (ILLOP-IF-PAGE-FAULT) 
    3419         ((A-TEM2) Q-TYPED-POINTER READ-MEMORY-DATA) 
    3420         (JUMP-GREATER-OR-EQUAL-XCT-NEXT M-T A-TEM2 MAKE-REGION-5) 
    3421        ((M-TEM) ADD M-TEM (A-CONSTANT 1)) 
    3422         ;; GOES RIGHT HERE, M-TEM MINUS ONE, SHIFT EVERYTHING ELSE UP 
    3423         ((A-TEM1) SUB M-TEM (A-CONSTANT 1)) 
    3424         ((M-TEM) ADD (M-CONSTANT -1) (A-CONSTANT (EVAL SIZE-OF-AREA-ARRAYS))) 
    3425 MAKE-REGION-5A 
    3426         ((VMA-START-READ) ADD M-TEM A-V-REGION-SORTED-BY-ORIGIN) 
    3427         (ILLOP-IF-PAGE-FAULT) 
    3428         ((WRITE-MEMORY-DATA) READ-MEMORY-DATA) 
    3429         ((VMA-START-WRITE) ADD VMA (A-CONSTANT 1)) 
    3430         (ILLOP-IF-PAGE-FAULT) 
    3431         (JUMP-NOT-EQUAL-XCT-NEXT M-TEM A-TEM1 MAKE-REGION-5A) 
    3432        ((M-TEM) SUB M-TEM (A-CONSTANT 1)) 
    3433         ((WRITE-MEMORY-DATA) Q-POINTER M-K (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
    3434         ((VMA-START-WRITE) M+A+1 M-TEM A-V-REGION-SORTED-BY-ORIGIN) 
    3435         (ILLOP-IF-PAGE-FAULT) 
    3436 MAKE-REGION-6 
    3437         ;; PROCEED TO INITIALIZE THE VARIOUS TABLES, EXCEPT LIST-THREAD WHICH CALLER DOES. 
     3758        ;; Proceed to initialize the various tables, except list-thread which caller does. 
    34383759        ((WRITE-MEMORY-DATA) Q-POINTER M-T (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
    34393760        ((VMA-START-WRITE) ADD M-K A-V-REGION-ORIGIN) 
     
    34453766        ((VMA-START-WRITE) ADD M-K A-V-REGION-BITS) 
    34463767        (CHECK-PAGE-WRITE) 
     3768        ;; Set up address-space-map 
     3769        ((M-E) ADD M-T A-3)                     ;End of region 
     3770MAKE-REGION-3 
     3771        (CALL ADDRESS-SPACE-MAP-STORE) 
     3772        ((M-T) ADD M-T (A-CONSTANT (EVAL %ADDRESS-SPACE-QUANTUM-SIZE))) 
     3773        (JUMP-LESS-THAN M-T A-E MAKE-REGION-3) 
     3774        ;; Finish setting up tables 
    34473775        ((WRITE-MEMORY-DATA) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) ;FREE PTR = 0 
    34483776        ((VMA-START-WRITE) ADD M-K A-V-REGION-FREE-POINTER) 
    34493777        (CHECK-PAGE-WRITE) 
    3450         (POPJ-AFTER-NEXT 
    3451          (VMA-START-WRITE) ADD M-K A-V-REGION-GC-POINTER) 
     3778        (POPJ-AFTER-NEXT (VMA-START-WRITE) ADD M-K A-V-REGION-GC-POINTER) 
    34523779       (CHECK-PAGE-WRITE) 
    3453  
    3454 MAKE-REGION-3   ;FREE REGION EXACTLY THE RIGHT SIZE, USE IT UP 
    3455         ((VMA-START-READ) ADD M-K A-V-REGION-LIST-THREAD)       ;REMOVE FROM FREE LIST 
    3456         (CHECK-PAGE-READ) 
    3457         ((WRITE-MEMORY-DATA) READ-MEMORY-DATA)  ;ENSURE COMPLETION OF READ CYCLE 
    3458         ((VMA-START-WRITE) M-T) 
    3459         (CHECK-PAGE-WRITE) 
    3460         ((VMA-START-READ) ADD M-K A-V-REGION-ORIGIN) 
    3461         (CHECK-PAGE-READ) 
    3462         (JUMP-XCT-NEXT MAKE-REGION-3A) 
    3463        ((M-T) Q-TYPED-POINTER READ-MEMORY-DATA) 
    3464  
    3465 MAKE-REGION-5B  ;THIS REGION HIGHER THAN ALL OTHERS, REPLICATE THROUGH END OF ARRAY 
    3466                 ;M-TEM HAS THE INDEX OF THE SECOND OF THE REGION THAT USED TO BE REPLICATED 
    3467         ((WRITE-MEMORY-DATA) Q-POINTER M-K (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
    3468         ((VMA-START-WRITE) ADD M-TEM A-V-REGION-SORTED-BY-ORIGIN) 
    3469         (ILLOP-IF-PAGE-FAULT) 
    3470         (JUMP-LESS-THAN-XCT-NEXT M-TEM (A-CONSTANT (EVAL SIZE-OF-AREA-ARRAYS)) 
    3471                 MAKE-REGION-5B) 
    3472        ((M-TEM) ADD M-TEM (A-CONSTANT 1)) 
    3473         (JUMP MAKE-REGION-6) 
    34743780 
    34753781;;; SUBROUTINE TO CREATE A REGION, CALLED ONLY BY AREA-CREATOR 
     
    34843790       (NO-OP) 
    34853791 
     3792;Given an address in M-T, look up in the address space map, return result in M-TEM 
     3793ADDRESS-SPACE-MAP-LOOKUP 
     3794        ;; Get word from ADDRESS-SPACE-MAP (assuming it starts on proper boundary!) 
     3795        ((VMA-START-READ) ADDRESS-SPACE-MAP-WORD-INDEX-BYTE M-T A-V-ADDRESS-SPACE-MAP) 
     3796        (ILLOP-IF-PAGE-FAULT) 
     3797        ((M-TEM) ADDRESS-SPACE-MAP-BYTE-NUMBER-BYTE M-T)        ;Byte number in that word 
     3798        ((M-TEM) DPB M-TEM ADDRESS-SPACE-MAP-BYTE-MROT A-ZERO) 
     3799        (POPJ-AFTER-NEXT (OA-REG-LOW) SUB (M-CONSTANT 40) A-TEM) ;40 doesn't hurt here, IORed 
     3800       ((M-TEM) (BYTE-FIELD (EVAL %ADDRESS-SPACE-MAP-BYTE-SIZE) 0) READ-MEMORY-DATA) 
     3801 
     3802;Given an address in M-T, store M-K into the address space map. 
     3803ADDRESS-SPACE-MAP-STORE 
     3804        ;; Get word from ADDRESS-SPACE-MAP (assuming it starts on proper boundary!) 
     3805        ((VMA-START-READ) ADDRESS-SPACE-MAP-WORD-INDEX-BYTE M-T A-V-ADDRESS-SPACE-MAP) 
     3806        (ILLOP-IF-PAGE-FAULT) 
     3807        ((M-TEM) ADDRESS-SPACE-MAP-BYTE-NUMBER-BYTE M-T)        ;Byte number in that word 
     3808        ((A-TEM1) READ-MEMORY-DATA) 
     3809        (POPJ-AFTER-NEXT (OA-REG-LOW) DPB M-TEM ADDRESS-SPACE-MAP-BYTE-MROT A-ZERO) 
     3810       ((WRITE-MEMORY-DATA-START-WRITE) DPB M-K  
     3811                (BYTE-FIELD (EVAL %ADDRESS-SPACE-MAP-BYTE-SIZE) 0) A-TEM1) 
    34863812 
    34873813;;; CALL THIS ROUTINE TO FREE UP A REGION, NUMBER IN M-K (MUST BE PURE NUMBER). 
    3488 ;;; IF ADJACENT TO ANOTHER FREE REGION, COMPACTIFIES. 
    3489 ;;; BASHES M-A,M-B,M-D,M-E,M-K,M-T, M-1...M-4, A-GC-TEM, A-TEM1...A-TEM3 
     3814;;; BASHES M-A,M-B,M-D,M-E,M-K,M-T, M-1...M-2, A-TEM1...A-TEM3 
    34903815 
    34913816XFREE-REGION (MISC-INST-ENTRY %GC-FREE-REGION) 
    3492         ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC XFALSE))) 
    34933817        ((M-K) Q-POINTER C-PDL-BUFFER-POINTER-POP) 
    34943818FREE-REGION 
     
    35003824        (CALL-XCT-NEXT UPDATE-REGION-PHT);Note that this sets M-1 and M-2 to the region bounds 
    35013825       ((MD) (A-CONSTANT (BYTE-VALUE MAP-STATUS-CODE 2))) ;Make read-only, no access, in PHT2 
    3502                                 ;Referencing this region will halt in XRGNPF 
    3503         ;; Remove from REGION-SORTED-BY-ORIGIN 
    3504         ((M-TEM) (A-CONSTANT (EVAL SIZE-OF-AREA-ARRAYS))) 
    3505         ((M-3 VMA-START-READ) ADD M-TEM A-V-REGION-SORTED-BY-ORIGIN) 
    3506         (CHECK-PAGE-READ) 
    3507         ((M-4) Q-POINTER READ-MEMORY-DATA) 
    3508         (JUMP-EQUAL M-4 A-K FREE-REGION-S-2)    ;Jump if this was the highest region 
    3509 FREE-REGION-S-1 
    3510         ((VMA-START-READ) SUB VMA (A-CONSTANT 1))       ;Read out location to be bashed 
    3511         (CHECK-PAGE-READ) 
    3512         ((A-TEM1) M-4) 
    3513         ((M-4) Q-POINTER READ-MEMORY-DATA) 
    3514         ((WRITE-MEMORY-DATA-START-WRITE)                ;Bash with contents of next higher loc 
    3515                 SELECTIVE-DEPOSIT READ-MEMORY-DATA Q-ALL-BUT-POINTER A-TEM1) 
    3516         (CHECK-PAGE-WRITE) 
    3517         (JUMP-GREATER-THAN-XCT-NEXT VMA A-V-REGION-SORTED-BY-ORIGIN FREE-REGION-S-1) 
    3518        (JUMP-EQUAL M-4 A-K FREE-REGION-S-4)             ;Done if just removed this region 
    3519         (CALL ILLOP)                                    ;Foo, region was not in table 
    3520                                                         ;and we've lost the region-0 entry 
    3521  
    3522 FREE-REGION-S-2 
    3523         ((VMA-START-READ) SUB VMA (A-CONSTANT 1))       ;Find new highest region 
    3524         (CHECK-PAGE-READ) 
    3525         ((M-4) Q-POINTER READ-MEMORY-DATA) 
    3526         (JUMP-EQUAL M-4 A-K FREE-REGION-S-2) 
    3527 FREE-REGION-S-3 
    3528         ((VMA-START-WRITE) ADD VMA (A-CONSTANT 1))      ;And replicate it back up 
    3529         (CHECK-PAGE-WRITE) 
    3530         (JUMP-LESS-THAN VMA A-3 FREE-REGION-S-3) 
    3531 FREE-REGION-S-4 
    3532         ;; Search free region list, attempt to concatenate to adjacent free region 
    3533         ;; M-K region#, M-1 base address, M-2 upper-bound address 
    3534         ((M-TEM) (A-CONSTANT (EVAL (FIND-POSITION-IN-LIST 'FREE-AREA AREA-LIST)))) 
    3535         ((VMA-START-READ) ADD M-TEM A-V-AREA-REGION-LIST) 
    3536 FREE-REGION-1 
    3537         (CHECK-PAGE-READ) 
    3538         ((A-GC-TEM) VMA)                                ;REMEMBER WHO POINTS HERE 
    3539         (JUMP-IF-BIT-SET BOXED-SIGN-BIT READ-MEMORY-DATA FREE-REGION-7) ;NON-ADJACENT 
    3540         ((M-4) Q-POINTER READ-MEMORY-DATA) 
    3541         ((VMA-START-READ) ADD M-4 A-V-REGION-ORIGIN)    ;CHECK ADJACENCIES 
    3542         (ILLOP-IF-PAGE-FAULT) 
    3543         ((A-TEM2) Q-POINTER READ-MEMORY-DATA) 
    3544         ((VMA-START-READ) ADD M-4 A-V-REGION-LENGTH) 
    3545         (ILLOP-IF-PAGE-FAULT) 
    3546         ((M-TEM) Q-POINTER READ-MEMORY-DATA) 
    3547         (JUMP-EQUAL M-2 A-TEM2 FREE-REGION-6) 
    3548         ((A-TEM3) ADD M-TEM A-TEM2) 
    3549         (JUMP-EQUAL M-1 A-TEM3 FREE-REGION-5) 
    3550         (JUMP-XCT-NEXT FREE-REGION-1) 
    3551        ((VMA-START-READ) ADD M-4 A-V-REGION-LIST-THREAD) 
    3552  
    3553 ;Region in M-K is right before region in M-4 
    3554 FREE-REGION-6 
    3555         ((M-2) ADD READ-MEMORY-DATA A-2)        ;NEW UPPER-BOUND, WITH FIXNUM TYPE 
    3556         ((WRITE-MEMORY-DATA-START-WRITE) SUB M-2 A-1)   ;UPDATE REGION-LENGTH 
    3557         (ILLOP-IF-PAGE-FAULT) 
    3558         ((M-2) Q-POINTER M-2)                   ;REGION UPPER-BOUND AS PURE NUMBER 
    3559         ((VMA) ADD M-4 A-V-REGION-ORIGIN) 
    3560         (JUMP-XCT-NEXT FREE-REGION-4) 
    3561        ((WRITE-MEMORY-DATA-START-WRITE) Q-POINTER M-1   ;UPDATE REGION-ORIGIN 
    3562                 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
    3563  
    3564 ;REGION IN M-K IS RIGHT AFTER REGION IN M-4 
    3565 FREE-REGION-5 
    3566         ((M-1) A-TEM2)                          ;NEW BASE ADDRESS 
    3567         ((M-TEM) SUB M-2 A-TEM2)                ;SUM OF REGION-LENGTHS 
    3568         ((WRITE-MEMORY-DATA-START-WRITE) Q-POINTER M-TEM 
    3569                 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
    3570 FREE-REGION-4 
    3571         (ILLOP-IF-PAGE-FAULT) 
    3572         ;; Put region in M-K onto free region-table-entry list, try again with M-4 
     3826        ;; Put region in M-K onto free region-table-entry list 
    35733827        ((VMA-START-READ) (A-CONSTANT (EVAL (PLUS 400 %SYS-COM-FREE-REGION/#-LIST)))) 
    35743828        (ILLOP-IF-PAGE-FAULT) 
     
    35803834        ((VMA-START-WRITE) ADD M-K A-V-REGION-LIST-THREAD) 
    35813835        (CHECK-PAGE-WRITE) 
    3582         ((VMA-START-READ) ADD M-4 A-V-REGION-LIST-THREAD)       ;UNTHREAD M-4 REGION 
    3583         (CHECK-PAGE-READ) 
    3584         ((WRITE-MEMORY-DATA) READ-MEMORY-DATA)  ;COMPLETE READ CYCLE 
    3585         ((VMA-START-WRITE) A-GC-TEM)            ;GUY WHO POINTED TO M-4 IS STILL IN A-GC-TEM 
    3586         (CHECK-PAGE-WRITE) 
    3587         (JUMP-XCT-NEXT FREE-REGION-S-4) 
    3588        ((M-K) M-4) 
    3589  
    3590 ;NO ADJACENCY, ADD THIS REGION TO FREE-AREA 
    3591 FREE-REGION-7 
    3592         ((M-TEM) (A-CONSTANT (EVAL (FIND-POSITION-IN-LIST 'FREE-AREA AREA-LIST)))) 
    3593         ((VMA-START-READ) ADD M-TEM A-V-AREA-REGION-LIST) 
    3594         (CHECK-PAGE-READ) 
    3595         ((A-TEM2) READ-MEMORY-DATA) 
    3596         ((WRITE-MEMORY-DATA-START-WRITE) Q-POINTER M-K 
    3597                 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
    3598         (CHECK-PAGE-WRITE) 
    3599         ((WRITE-MEMORY-DATA) A-TEM2) 
    3600         (POPJ-AFTER-NEXT 
    3601          (VMA-START-WRITE) ADD M-K A-V-REGION-LIST-THREAD) 
    3602        (CHECK-PAGE-WRITE) 
     3836        ;; Remove from ADDRESS-SPACE-MAP 
     3837        ;; Referencing these addresses will halt in PAGE-IN-GET-MAP-BITS 
     3838        ((M-T) M-1) 
     3839FREE-REGION-1 
     3840        (CALL-XCT-NEXT ADDRESS-SPACE-MAP-STORE) 
     3841       ((M-K) A-ZERO) 
     3842        ((M-T) ADD M-T (A-CONSTANT (EVAL %ADDRESS-SPACE-QUANTUM-SIZE))) 
     3843        (JUMP-LESS-THAN M-T A-2 FREE-REGION-1) 
     3844        (POPJ-AFTER-NEXT (M-T) A-V-NIL) 
     3845       (NO-OP) 
    36033846 
    36043847;Remove all information about the region in M-K from the page map, 
     
    36303873;(%ALLOCATE-AND-INITIALIZE <data type for return> <data type for header> <header>  
    36313874;                               <value for second word> <area> <nqs>) 
     3875(ERROR-TABLE DEFAULT-ARG-LOCATIONS %ALLOCATE-AND-INITIALIZE PP PP PP PP PP PP) 
     3876 
    36323877XAAI (MISC-INST-ENTRY %ALLOCATE-AND-INITIALIZE) 
     3878        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP) 
     3879                Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM) 
     3880    (ERROR-TABLE ARGTYP FIXNUM-GREATER-THAN-1 PP 5) 
    36333881        ((M-1) Q-POINTER C-PDL-BUFFER-POINTER)  ;CHECK FOR ALLOC AT LEAST 2 WORDS 
    3634         (CALL-LESS-THAN M-1 (A-CONSTANT 2) ILLOP) 
     3882        (CALL-LESS-THAN M-1 (A-CONSTANT 2) TRAP) 
     3883    (ERROR-TABLE ARGTYP FIXNUM-GREATER-THAN-1 PP 5) 
    36353884        (CALL XALLB)                    ;ALLOCATE BLOCK, RETURN IN M-T, NO SEQUENCE BREAK 
    3636                                         ; WHILE CRUFT IS PARTIALLY INITIALIZED 
     3885                                        ; WHILE CRUFT IS PARTIALLY INITIALIZED.  POPS LAST ARG. 
    36373886        ((VMA) ADD M-T (A-CONSTANT 1))  ;-> SECOND WORD 
    36383887        ((WRITE-MEMORY-DATA-START-WRITE) C-PDL-BUFFER-POINTER-POP) 
     
    36483897;(%ALLOCATE-AND-INITIALIZE-ARRAY <header as fixnum> <index length> <leader length>  
    36493898;                                       <area> <nqs>) 
     3899(ERROR-TABLE DEFAULT-ARG-LOCATIONS %ALLOCATE-AND-INITIALIZE-ARRAY PP PP PP PP PP) 
     3900 
    36503901XAAIA (MISC-INST-ENTRY %ALLOCATE-AND-INITIALIZE-ARRAY) 
    36513902        (CALL XALLB)                    ;ALLOCATE BLOCK, RETURN IN M-T, NO SEQUENCE BREAK 
     
    36573908                (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-ARRAY-POINTER))) 
    36583909        ((M-E) ADD M-T A-B)             ;UPPER BOUND OF STORAGE, SAME DATA-TYPE AS M-T 
     3910        ((M-E) SUB M-E (A-CONSTANT 1))          ;LAST LOCATION TO BE FILLED 
    36593911        ((M-C) Q-POINTER C-PDL-BUFFER-POINTER-POP)      ;LEADER LENGTH 
    36603912        ((M-B) Q-POINTER C-PDL-BUFFER-POINTER-POP)      ;INDEX LENGTH 
     
    36803932        ;; THIS IS A NUMERIC OR STRING ARRAY, FILL WITH ZEROS 
    36813933        ((WRITE-MEMORY-DATA) M-ZERO) 
    3682         ((M-E) SUB M-E (A-CONSTANT 1))          ;LAST LOCATION TO BE FILLED 
    36833934        (JUMP-GREATER-OR-EQUAL VMA A-E XAAIA3)  ;JUMP IF ZERO-LENGTH ARRAY 
    36843935XAAIA2  ((VMA-START-WRITE) ADD VMA (A-CONSTANT 1)) 
     
    36963947XALLB   (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP) 
    36973948                Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM) 
    3698   (ERROR-TABLE ARGTYP FIXNUM PP NIL) 
    3699         ((M-B) Q-POINTER C-PDL-BUFFER-POINTER-POP)      ;ARG 2 NUMBER OF QS 
     3949  (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP NIL) 
     3950        (CALL-IF-BIT-SET-XCT-NEXT BOXED-SIGN-BIT C-PDL-BUFFER-POINTER TRAP) 
     3951       ((M-B) Q-POINTER C-PDL-BUFFER-POINTER-POP)       ;ARG 2 NUMBER OF QS 
     3952  (ERROR-TABLE ARGTYP POSITIVE-FIXNUM M-B NIL) 
    37003953        (CALL-XCT-NEXT SCONS) 
    37013954       ((M-S) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;ARG 1 AREA 
    3702         (JUMP FILL-WITH-NILS) 
     3955        (JUMP-XCT-NEXT FILL-WITH-THINGS) 
     3956       ((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL) 
    37033957 
    37043958;SUBROUTINE TO CONS UP A LIST OF NILS.  ARGS LIKE LCONS. 
    37053959;NOTE THAT DATA-TYPE RETURNED IN M-T IS GARBAGE. 
    37063960LIST-OF-NILS 
     3961        ((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL) 
     3962 
     3963;SUBROUTINE TO CONS UP A LIST OF THINGS.  THE THING TO BE CONSED IS ON THE 
     3964;STACK.  OTHERWISE, ARGS LIKE NCONS.  NOTE THAT DATA-TYPE RETURNED IN M-T 
     3965;IS GARBAGE. 
     3966LIST-OF-THINGS 
    37073967        (CALL LCONS) 
    3708 FILL-WITH-NILS 
     3968FILL-WITH-THINGS 
    37093969        ((M-3) M-B)                             ;NUMBER OF CELLS TO INITIALIZE 
    3710         ((WRITE-MEMORY-DATA) DPB (M-CONSTANT -1) Q-CDR-CODE A-V-NIL)    ;CDR-NEXT 
     3970        ((WRITE-MEMORY-DATA) LDB C-PDL-BUFFER-POINTER-POP       ;CDR-NEXT 
     3971                Q-ALL-BUT-CDR-CODE (A-CONSTANT -1)) 
    37113972        ((VMA) SUB M-T (A-CONSTANT 1)) 
    3712         (JUMP-LESS-OR-EQUAL M-3 (A-CONSTANT 1) FILL-WITH-NILS-1) 
    3713 FILL-WITH-NILS-0 
     3973        (JUMP-LESS-OR-EQUAL M-3 (A-CONSTANT 1) FILL-WITH-THINGS-1) 
     3974FILL-WITH-THINGS-0 
    37143975        ((VMA-START-WRITE) ADD VMA (A-CONSTANT 1)) 
    37153976        (CHECK-PAGE-WRITE) 
    3716         (JUMP-GREATER-THAN-XCT-NEXT M-3 (A-CONSTANT 2) FILL-WITH-NILS-0) 
     3977        (JUMP-GREATER-THAN-XCT-NEXT M-3 (A-CONSTANT 2) FILL-WITH-THINGS-0) 
    37173978       ((M-3) SUB M-3 (A-CONSTANT 1)) 
    3718 FILL-WITH-NILS-1 
     3979FILL-WITH-THINGS-1 
    37193980        ((WRITE-MEMORY-DATA) Q-ALL-BUT-CDR-CODE WRITE-MEMORY-DATA 
    37203981                        (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL))) 
     
    37524013        (CHECK-PAGE-READ) 
    37534014        (POPJ-EQUAL M-T A-V-NIL)                ;Return NIL if garbage pointer input 
    3754         ((M-B) Q-POINTER READ-MEMORY-DATA)      ;Origin address of region 
     4015        ((M-B) Q-TYPED-POINTER READ-MEMORY-DATA)        ;Origin address of region 
    37554016        ((VMA-START-READ) ADD M-T A-V-REGION-BITS)      ;Get representation type 
    37564017        (CHECK-PAGE-READ) 
     
    38194080        (INHIBIT-XCT-NEXT-BIT XFSHSI)           ;INSTANCE-HEADER 
    38204081        (XFSHS1)                                ;ENTITY 
     4082        (XFSHS1)                                ;STACK-CLOSURE 
    38214083 (REPEAT NQZUSD-1 (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)) 
    38224084        (XFSHS1)                                ;DATA-TYPE 37 
     
    39304192 
    39314193STRUCTURE-INFO 
    3932         (DISPATCH MAP-STATUS-CODE MEMORY-MAP-DATA D-ASSURE-MAP-VALID) 
     4194        (DISPATCH MAP-STATUS-CODE MEMORY-MAP-DATA D-GET-MAP-BITS) ;Ensure validity of meta bits 
    39334195        ((M-K) MAP-SECOND-LEVEL-MAP MEMORY-MAP-DATA)    ;FOR DISPATCH BELOW, AND 
    39344196                                                ; RETURNED TO CALLER.  NOTE 0 IN SIGN BIT. 
     
    40034265        (INHIBIT-XCT-NEXT-BIT SINFSI)           ;INSTANCE-HEADER 
    40044266        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;ENTITY 
     4267        (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)      ;STACK-CLOSURE 
    40054268 (REPEAT NQZUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)) 
    40064269(END-DISPATCH) 
     
    40164279;DTP-HEADER-FORWARD - include all DTP-BODY-FORWARD's that point here as unboxed Q's 
    40174280SINFS-HFWD 
    4018         (CALL-XCT-NEXT XRGN00)                  ;M-T gets region number 
    4019        ((M-A MD) Q-POINTER VMA) 
     4281        (CALL-XCT-NEXT XRGN1)                   ;M-T gets region number 
     4282       ((M-A) Q-POINTER VMA (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
    40204283        ((VMA-START-READ) ADD M-T A-V-REGION-ORIGIN) 
    40214284        (CHECK-PAGE-READ) 
     
    40674330        (P-BIT ILLOP)   ;%HEADER-TYPE-COMPLEX 
    40684331        (SINF-BIG)      ;%HEADER-TYPE-BIGNUM 
    4069         (P-BIT ILLOP)   ;%HEADER-TYPE-RATIONAL-BIGNUM 
     4332        (SINF-RAT)      ;%HEADER-TYPE-RATIONAL-BIGNUM 
    40704333(REPEAT NHDUSD (P-BIT ILLOP)) 
    40714334(END-DISPATCH) 
     
    40754338        (POPJ-AFTER-NEXT (M-4) (A-CONSTANT 2))  ;2 unboxed Q's 
    40764339       (NO-OP)   
     4340 
     4341SINF-RAT 
     4342        (POPJ-AFTER-NEXT (M-3) (A-CONSTANT 3))  ;Headers and two number pointers. 
     4343       (NO-OP) 
    40774344 
    40784345SINF-BIG 
     
    41994466        (R-BIT)                                 ;STACK-GROUP HEAD 
    42004467        (SINF-BNDPDL)                           ;BINDING-PDL 
    4201         (INHIBIT-XCT-NEXT-BIT SINFSA-32B)       ;TV BUFFER 
     4468        (INHIBIT-XCT-NEXT-BIT SINFSA-16B)       ;HALF-FIX 
    42024469        (SINF-REGPDL)                           ;REG-PDL 
    42034470        (INHIBIT-XCT-NEXT-BIT SINFSA-FLOAT)     ;FLOAT 
     4471        (INHIBIT-XCT-NEXT-BIT SINFSA-32B)       ;FPS-FLOAT 
     4472        (INHIBIT-XCT-NEXT-BIT SINFSA-16B)       ;FAT-STRING 
    42044473 (REPEAT NATUSD (P-BIT INHIBIT-XCT-NEXT-BIT ILLOP)) 
    42054474(END-DISPATCH) 
     
    43604629 
    43614630;GET ADDR ARG IN M-2, PDL ARG IN M-1, ERROR UNLESS BOTH FIXNUMS 
    4362 FIXGET  (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)           ;GET PDL ARG 
     4631FIXGET          (ERROR-TABLE RESTART FIXGET) 
     4632        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)           ;GET PDL ARG 
    43634633                        Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM) 
    4364    (ERROR-TABLE ARGTYP FIXNUM PP 0) 
     4634   (ERROR-TABLE ARGTYP FIXNUM PP 0 FIXGET) 
     4635   (ERROR-TABLE ARG-POPPED 0 PP M-T) 
    43654636        ((M-1) C-PDL-BUFFER-POINTER-POP) 
     4637                (ERROR-TABLE RESTART FIXGET0) 
    43664638        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP) Q-DATA-TYPE M-T TRAP-UNLESS-FIXNUM) 
    4367    (ERROR-TABLE ARGTYP FIXNUM M-T 1) 
     4639   (ERROR-TABLE ARGTYP FIXNUM M-T 1 FIXGET0) 
     4640   (ERROR-TABLE ARG-POPPED 0 PP M-T) 
    43684641FIXGET-1 
    43694642        ((OA-REG-HIGH) BOXED-SIGN-BIT M-T)              ;SIGN EXTEND (MUNG M SOURCE) 
     
    43794652;M-1 HOLDS THE FIRST ARG, SQUARED N TIMES. 
    43804653;M-T HOLDS THE PARTIAL PRODUCTS 
     4654 
     4655(ERROR-TABLE DEFAULT-ARG-LOCATIONS ^ PP PP) 
    43814656 
    43824657XUPARROW (MISC-INST-ENTRY ^) 
     
    44854760QIBNDN  (CALL QBND1)            ;SAVE PRESENT BINDING 
    44864761        ((M-T) A-V-NIL)         ;AND RE-BIND TO NIL 
    4487 QIBDN1  ((VMA-START-READ) DPB M-B Q-POINTER  
    4488                 (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE))) 
    4489         (CHECK-PAGE-READ) 
    4490         (DISPATCH TRANSPORT-NO-EVCP-WRITE READ-MEMORY-DATA)  ;CHASE FORWARDING PTR IF ANY 
    4491         ((M-T WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT M-E 
     4762QIBDN1  ((M-T WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT M-E 
    44924763                Q-ALL-BUT-TYPED-POINTER A-T) 
    44934764        (CHECK-PAGE-WRITE) 
     
    44984769        (JUMP-XCT-NEXT QIBDN1)  ;AND REBIND TO POP(PDL) 
    44994770       ((M-T) C-PDL-BUFFER-POINTER-POP) 
     4771 
     4772XUBI  (MISC-INST-ENTRY %USING-BINDING-INSTANCES)  ;One arg, a list of binding instances. 
     4773        (JUMP-XCT-NEXT QCLS1) 
     4774       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) 
    45004775 
    45014776XBIND (MISC-INST-ENTRY BIND) 
     
    45054780        (CALL-NOT-EQUAL M-ZR (A-CONSTANT (EVAL DTP-LOCATIVE)) TRAP) 
    45064781   (ERROR-TABLE ARGTYP LOCATIVE PP 0 XBIND) 
     4782   (ERROR-TABLE ARG-POPPED 0 PP M-T) 
    45074783XBIND1  (JUMP-XCT-NEXT QIBDN1) 
    45084784       (CALL QBND2) 
     
    45994875 
    46004876;;;ACTIVATE PENDING CALL 
    4601 QMRCL   ((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER A-IPMARK)    ;COUNT ARGUMENTS 
     4877QMRCL   (CALL-IF-BIT-SET M-TRAP-ON-CALLS TRAP) 
     4878    (ERROR-TABLE CALL-TRAP) 
     4879        ((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER A-IPMARK)    ;COUNT ARGUMENTS 
    46024880        ((M-R) PDL-BUFFER-INDEX)                ;M-R PASSES ARG COUNT TO CALLED FCTN 
     4881;Can someone add a comment saying what is wrong with 
     4882;just storing the result of the subtraction in M-R? 
    46034883        ((PDL-BUFFER-INDEX M-S) A-IPMARK)       ;GET FEF POINTER POINTER 
    46044884        ((M-A) C-PDL-BUFFER-INDEX)              ;M-A := FUNCTION TO CALL 
     
    47585038        (CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-INSTANCE-HEADER)) TRAP) 
    47595039                (ERROR-TABLE DATA-TYPE-SCREWUP DTP-INSTANCE-HEADER) 
     5040        ((M-A) VMA)                     ;Possibly-forwarded instance is where inst vars are 
    47605041        ((M-C) Q-POINTER READ-MEMORY-DATA       ;Get address of instance-descriptor 
    47615042                (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE))) 
     
    47855066        (CALL QBND4)                    ;Bind it up 
    47865067        ((WRITE-MEMORY-DATA-START-WRITE) Q-TYPED-POINTER M-D A-E) 
    4787         (CHECK-PAGE-WRITE) 
     5068        (CHECK-PAGE-WRITE-BIND) 
    47885069CALL-INSTANCE-2 
    47895070        (DISPATCH Q-CDR-CODE M-B D-CALL-INSTANCE)       ;More bindings if this was CDR-NEXT 
     
    48315112        (CALL-XCT-NEXT QCDR) 
    48325113       ((M-T) C-PDL-BUFFER-POINTER-POP) ;GET BACK CLOSURE AND CDR IT. 
    4833         (JUMP-EQUAL M-T A-V-NIL QCLS2)  ;Jump if no bindings to do 
    4834 QCLS1   (CALL-XCT-NEXT QCAR) 
     5114        (CALL QCLS1) 
     5115QCLS2   ((PDL-BUFFER-INDEX) M-S) 
     5116        (DISPATCH Q-DATA-TYPE M-A D-QMRCL) 
     5117       (NO-OP)                  ;LEAVE, IF ANY, ALREADY DONE 
     5118 
     5119QCLS1   (POPJ-EQUAL M-T A-V-NIL)        ;Return if no bindings to do 
     5120        (CALL-XCT-NEXT QCAR) 
    48355121       ((M-D) M-T) 
    48365122        ((M-B) M-T)                     ;Locn to bind 
     
    48515137        (CALL QBND4)                    ;Bind it up 
    48525138        ((WRITE-MEMORY-DATA-START-WRITE) Q-TYPED-POINTER M-T A-E) 
    4853         (CHECK-PAGE-WRITE) 
     5139        (CHECK-PAGE-WRITE-BIND) 
    48545140QCLS3   (CALL-XCT-NEXT QCDR) 
    48555141       ((M-T) M-D) 
    4856         (JUMP-NOT-EQUAL M-T A-V-NIL QCLS1) 
    4857 QCLS2   ((PDL-BUFFER-INDEX) M-S) 
    4858         (DISPATCH Q-DATA-TYPE M-A D-QMRCL) 
    4859        (NO-OP)                  ;LEAVE, IF ANY, ALREADY DONE 
     5142        (JUMP QCLS1) 
     5143 
    48605144 
    48615145CALL-SELECT-METHOD 
     
    48895173  ; THIS SERVES AS AN "OTHERWISE" CLAUSE. 
    48905174        (CALL TRAP)                     ;SELECTED METHOD NOT FOUND 
    4891   (ERROR-TABLE SELECTED-METHOD-NOT-FOUND M-A) 
     5175  (ERROR-TABLE SELECTED-METHOD-NOT-FOUND M-A M-C) 
    48925176 
    48935177CSM-R   (JUMP-XCT-NEXT CSM-5)               ;RESUME SEARCH AT SAVED POINT 
     
    49225206                                                                 ; IMMEDIATELY RETURN. 
    49235207        (CALL-NOT-EQUAL M-ZR (A-CONSTANT (EVAL DTP-SELECT-METHOD)) TRAP) 
    4924  (ERROR-TABLE SELECT-METHOD-BAD-SUBROUTINE-CALL) 
     5208 (ERROR-TABLE SELECT-METHOD-BAD-SUBROUTINE-CALL M-A) 
    49255209        (JUMP-XCT-NEXT CSM-3) 
    49265210       ((M-T) LDB Q-POINTER READ-MEMORY-DATA 
     
    50225306        ((VMA-START-READ) ADD M-D A-V-MICRO-CODE-ENTRY-AREA)  ;IF THIS A FIXNUM, ITS 
    50235307        (CHECK-PAGE-READ)           ;INDEX TO MICRO-CODE-SYMBOL-AREA.  OTHERWISE, FCTN 
     5308        ((M-ERROR-SUBSTATUS) A-ZERO) 
    50245309        ((M-T) READ-MEMORY-DATA)    ;IS NOT REALLY MICROCODED NOW, AND THIS IS OTHER DEF. 
    50255310        ((M-TEM) Q-DATA-TYPE M-T)   ;IF SO, PUT THIS IN LP-FEF SLOT AND TRY AGAIN. 
     
    50545339 
    50555340;;; DESTINATION RETURN  value in M-T.  Q-ALL-BUT-TYPED-POINTER bits must be 0. 
    5056 QMDDR   (JUMP-NOT-EQUAL M-AP A-IPMARK QMDDR-THROW) ;CHECK FOR UNWIND-PROTECT 
     5341QMDDR   ((M-TEM) Q-DATA-TYPE M-T) 
     5342        (CALL-EQUAL M-TEM (A-CONSTANT (EVAL DTP-STACK-CLOSURE)) 
     5343                    STACK-CLOSURE-RETURN-TRAP) 
     5344        (JUMP-NOT-EQUAL M-AP A-IPMARK QMDDR-THROW) ;CHECK FOR UNWIND-PROTECT 
    50575345QMDDR0  (CALL-IF-BIT-SET M-QBBFL BBLKP)         ;POP BINDING BLOCK (IF STORED ONE) 
    5058 QMEX1   ((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-CALL-STATE))) 
    5059         ((M-C) C-PDL-BUFFER-INDEX)              ;M-C := CALL STATE 
     5346QMEX1   ((PDL-BUFFER-INDEX) M-AP)               ;Save returning function for metering 
     5347        ((M-A) C-PDL-BUFFER-INDEX) 
     5348        ((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-CALL-STATE))) 
     5349        ((M-C) C-PDL-BUFFER-INDEX) 
     5350        (CALL-IF-BIT-SET (LISP-BYTE %%LP-CLS-TRAP-ON-EXIT) C-PDL-BUFFER-INDEX QMEX1-TRAP) 
     5351        ((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-ENTRY-STATE))) 
     5352        (CALL-IF-BIT-SET (LISP-BYTE %%LP-ENS-ENVIRONMENT-POINTER-POINTS-HERE) 
     5353                         C-PDL-BUFFER-INDEX 
     5354                         QMEX1-COPY) 
    50605355        ;;*** next 2 instructions are temporary 
    50615356        ((M-TEM) MICRO-STACK-POINTER) 
     
    50735368        ((M-PDL-BUFFER-ACTIVE-QS) SUB M-PDL-BUFFER-ACTIVE-QS A-TEM1) 
    50745369        ;; Make sure frame being returned to is in the pdl buffer 
    5075         (CALL-LESS-THAN M-PDL-BUFFER-ACTIVE-QS  
     5370        (CALL-LESS-THAN M-PDL-BUFFER-ACTIVE-QS 
    50765371                        (A-CONSTANT PDL-BUFFER-LOW-WARNING) PDL-BUFFER-REFILL) 
    50775372        ;; Now restore the state of the frame being returned to.  We will restore 
    50785373        ;; the FEF stuff even if it's not a FEF frame, at the cost of a slight 
    50795374        ;; amount of time. 
     5375        (CALL-IF-BIT-SET (LISP-BYTE %%METER-FUNCTION-ENTRY-EXIT-ENABLE) 
     5376                M-METER-ENABLES METER-FUNCTION-EXIT) 
    50805377        ((M-A) Q-POINTER C-PDL-BUFFER-INDEX)    ;FUNCTION RETURNING TO 
    50815378        ((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-ENTRY-STATE))) 
     
    50935390       ((C-PDL-BUFFER-POINTER-PUSH) DPB M-T Q-ALL-BUT-CDR-CODE 
    50945391                        (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT))) 
     5392 
     5393;Here from QMDDR if data type of M-T is DTP-STACK-CLOSURE. 
     5394;Copy the closure into the heap, in case the frame it is in 
     5395;is about to go away. 
     5396STACK-CLOSURE-RETURN-TRAP 
     5397        ((MD) M-T) 
     5398        ((VMA) A-MINUS-ONE) 
     5399        (GC-WRITE-TEST) 
     5400        (POPJ-XCT-NEXT) 
     5401       ((M-T) MD) 
     5402 
     5403;;; M-A has the function returning from 
     5404METER-FUNCTION-EXIT 
     5405        ((A-METER-EVENT) (A-CONSTANT (EVAL %METER-FUNCTION-EXIT-EVENT))) 
     5406        ((C-PDL-BUFFER-POINTER-PUSH) M-A) 
     5407        (JUMP-XCT-NEXT METER-MICRO-WRITE-HEADER) 
     5408       ((A-METER-LENGTH) (A-CONSTANT 1))        ;Number of meters pushed 
     5409 
     5410;This is here so I can put breakpoints before and after trapping. 
     5411QMEX1-TRAP 
     5412        ((VMA) A-ZERO)          ;Avoid illop due to pointer not in any region, 
     5413        ((M-Q) A-ZERO)          ;which seems frequently to be true of VMA at QMEX1. 
     5414        (CALL TRAP) 
     5415    (ERROR-TABLE EXIT-TRAP) 
     5416        (POPJ) 
     5417 
     5418;Copy the frame being exited into a list, if it has the bit set 
     5419;saying that an environment pointer points at it. 
     5420;The pointers to the frame are all in copied closure values of 
     5421;LEXICAL-ENVIRONMENT, and all of them are in cells pointed to 
     5422;by EVCPs located in the locals of this frame!  So we can find those 
     5423;pointers and make them point instead at the newly made list copy. 
     5424 
     5425;Must preserve M-A and M-C, as well as M-T (the returned value). 
     5426;Assumes PDL-BUFFER-INDEX points at the %LP-ENTRY-STATUS word of the frame. 
     5427QMEX1-COPY 
     5428        ((C-PDL-BUFFER-POINTER-PUSH) M-T) 
     5429        ((M-K) LDB (LISP-BYTE %%LP-ENS-MACRO-LOCAL-BLOCK-ORIGIN) C-PDL-BUFFER-INDEX) 
     5430;Get number of locals in frame, from the fef. 
     5431        ((PDL-BUFFER-INDEX) M-AP) 
     5432        ((VMA-START-READ) ADD C-PDL-BUFFER-INDEX (A-CONSTANT (EVAL %FEFHI-MISC))) 
     5433        (CHECK-PAGE-READ) 
     5434        ((M-B) (LISP-BYTE %%FEFHI-MS-LOCAL-BLOCK-LENGTH) READ-MEMORY-DATA) 
     5435;M-B now has number of locals in the frame. 
     5436;Save it for much later (QMEX1-FIND-CLOSURES). 
     5437;Also get the total size of frame data to be copied. 
     5438        ((C-PDL-BUFFER-POINTER-PUSH) M-B) 
     5439        ((M-B) ADD M-B A-K)      
     5440;Cons a block that big, preserving the size in B. 
     5441        ((C-PDL-BUFFER-POINTER-PUSH) M-B) 
     5442        (CALL-XCT-NEXT LCONS) 
     5443       ((M-S) DPB M-ZERO Q-ALL-BUT-TYPED-POINTER A-BACKGROUND-CONS-AREA) 
     5444        ((M-B) C-PDL-BUFFER-POINTER-POP) 
     5445        ((PDL-BUFFER-INDEX) M-AP) 
     5446        ((VMA) M-T) 
     5447        ((C-PDL-BUFFER-POINTER-PUSH) M-T) 
     5448;Copy the args and locals into the newly consed list. 
     5449;M-B has # left to copy, PDL-BUFFER-INDEX has where to copy from, 
     5450;VMA has where to copy to. 
     5451QMEX1-COPY-LOOP 
     5452        ((MD-START-WRITE) Q-TYPED-POINTER C-PDL-BUFFER-INDEX 
     5453                          (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NEXT))) 
     5454        ((PDL-BUFFER-INDEX) M+1 PDL-BUFFER-INDEX) 
     5455        (CHECK-PAGE-WRITE) 
     5456        ((M-B) SUB M-B (A-CONSTANT 1)) 
     5457        (JUMP-GREATER-THAN-XCT-NEXT M-B A-ZERO QMEX1-COPY-LOOP) 
     5458       ((VMA) M+1 VMA) 
     5459;Store CDR-NIL into the last word. 
     5460        ((VMA) SUB VMA (A-CONSTANT 1)) 
     5461        ((MD-START-WRITE) Q-TYPED-POINTER MD 
     5462                          (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL))) 
     5463        (CHECK-PAGE-WRITE) 
     5464;Get back the pointer to this list and store it 
     5465;into the forwarded copies of all the stack closures in this frame. 
     5466;Find them by scanning thru the frame's locals. 
     5467        (CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS) 
     5468       ((M-K) M-AP) 
     5469;M-D and M-T get original stack frame and copy, both with DTP-LIST. 
     5470        ((M-D) M-K Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST))) 
     5471        ((M-T) LDB C-PDL-BUFFER-POINTER-POP Q-POINTER 
     5472               (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST))) 
     5473        ((M-B) C-PDL-BUFFER-POINTER-POP)        ;pop number of locals. 
     5474        ((M-K) A-LOCALP)        ;Get pdl index of first local. 
     5475QMEX1-FIND-FORWARDS 
     5476;Look for a local that is a forwarded list. 
     5477        ((PDL-BUFFER-INDEX) M-K) 
     5478        ((M-TEM) Q-DATA-TYPE C-PDL-BUFFER-INDEX) 
     5479        (JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-EXTERNAL-VALUE-CELL-POINTER)) 
     5480             QMEX1-NOT-FORWARD) 
     5481;Yes, find where forwarded to, 
     5482;and if it points at our stack frame, 
     5483;make it point at the new copy instead. 
     5484        ((VMA-START-READ) C-PDL-BUFFER-INDEX) 
     5485        (CHECK-PAGE-READ) 
     5486        ((M-TEM) Q-TYPED-POINTER MD) 
     5487        (JUMP-NOT-EQUAL M-TEM A-D QMEX1-NOT-FORWARD) 
     5488        ((MD-START-WRITE) DPB MD Q-ALL-BUT-TYPED-POINTER A-T) 
     5489        (CHECK-PAGE-WRITE) 
     5490QMEX1-NOT-FORWARD 
     5491        ((M-B) SUB M-B (A-CONSTANT 1)) 
     5492        (JUMP-GREATER-THAN-XCT-NEXT M-B A-ZERO QMEX1-FIND-FORWARDS) 
     5493       ((M-K) M+1 M-K) 
     5494        (POPJ-XCT-NEXT) 
     5495       ((M-T) C-PDL-BUFFER-POINTER-POP) 
    50955496 
    50965497;Restore the micro-stack from the binding stack 
     
    51255526 
    51265527;STORE LAST VALUE IN ADI CALL, FLUSH ADI FROM PDL 
    5127 ;MAY CLOBBER ALL REGISTERS EXCEPT M-C 
     5528;MAY CLOBBER ALL REGISTERS EXCEPT M-C and M-A 
    51285529QRAD1   ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QRAD1R)))  ;DONT CARE IF THIS  
    51295530                                                        ; LAST OR NOT. 
     
    51455546                Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM) 
    51465547  (ERROR-TABLE ARGTYP FIXNUM PP NIL) 
     5548  (ERROR-TABLE ARG-POPPED 0 PP) 
    51475549        ((M-C) Q-POINTER C-PDL-BUFFER-POINTER-POP) ;NUMBER OF VALUES TO RETURN 
    51485550XRETN1  ((M-C) SUB M-C (A-CONSTANT 1)) 
    51495551        (JUMP-LESS-OR-EQUAL M-C A-ZERO XRETN2) ;LAST 
    51505552        ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMDDR-KLUDGE))) ;RETURN ON LAST VAL 
     5553        ((M-S) A-ZERO) 
    51515554        (CALL-XCT-NEXT XRNVRPI) 
    51525555       ((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER A-C)  ;NEXT ARGUMENT SLOT 
     
    51555558XRET3 (MISC-INST-ENTRY %RETURN-3) 
    51565559        ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMDDR-KLUDGE))) ;RETURN ON LAST VAL 
     5560        ((M-S) A-ZERO) 
    51575561        (CALL-XCT-NEXT XRNVRPI) 
    51585562       ((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 2)) 
    51595563XRET2 (MISC-INST-ENTRY %RETURN-2) 
    51605564        ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMDDR-KLUDGE))) ;RETURN ON LAST VAL 
     5565        ((M-S) A-ZERO) 
    51615566        (CALL-XCT-NEXT XRNVRPI) 
    51625567       ((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 1)) 
     
    51645569       ((M-T) C-PDL-BUFFER-POINTER) 
    51655570 
     5571(ERROR-TABLE DEFAULT-ARG-LOCATIONS RETURN-LIST M-A) 
     5572 
    51665573XRETURN-LIST (MISC-INST-ENTRY RETURN-LIST)      ;This is always used with dest D-RETURN! 
     5574        ((M-A) Q-TYPED-POINTER C-PDL-BUFFER-POINTER) 
     5575        (JUMP-EQUAL M-A A-V-NIL RETURN-NO-VALUES) 
     5576XRETURN-LIST1 
    51675577        (CALL-XCT-NEXT QMD)                     ;Get cdr of list 
    51685578       ((M-T) C-PDL-BUFFER-POINTER) 
     
    51735583        ;Push the address to return to if have no more values wanted (return via QMDDR) 
    51745584        ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC CPOPJ))) 
     5585        ((M-S) A-ZERO) 
    51755586        (CALL XRNVR) 
    5176         (JUMP-XCT-NEXT XRETURN-LIST) 
     5587        (JUMP-XCT-NEXT XRETURN-LIST1) 
    51775588       ((C-PDL-BUFFER-POINTER-PUSH) M-C) 
     5589 
     5590;Come here with a NIL on the top of the stack.  Calls XRNVR with the M-S flag, 
     5591;and either return returns to QMDDR.  We go through MVR so that in case the 
     5592;caller used a multiple-value-list, we will clobber the ADI so that QMDDR won't 
     5593;return any values into that list. 
     5594RETURN-NO-VALUES 
     5595        ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;Value is NIL, and flush the stack. 
     5596        ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC CPOPJ))) 
     5597        ((M-S) (A-CONSTANT 1)) 
     5598        (CALL XRNVR) 
     5599        (POPJ) 
    51785600 
    51795601XRNV (MISC-INST-ENTRY RETURN-NEXT-VALUE) 
    51805602        ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMDDR-KLUDGE))) ;GO TO QMDDR IF LAST 
    51815603                                                ;  VALUE. 
     5604        ((M-S) A-ZERO) 
    51825605        (CALL-XCT-NEXT XRNVR) 
    51835606       ((M-T) C-PDL-BUFFER-POINTER-POP)         ;FROB TO RETURN 
     5607   (ERROR-TABLE ARG-POPPED 0 M-T) 
    51845608        (POPJ)                                  ;NOT LAST VALUE, RETURN TO MAIN LOOP 
    51855609 
     
    51965620;For speed, we try to avoid taking page faults when referencing the pdl buffer. 
    51975621;M-K will have the virtual address being referenced, MD its contents. 
     5622;M-S must have the flag for MVR (q.v.). 
    51985623XRNVRPI ((M-T) C-PDL-BUFFER-INDEX)              ;Return value from PDL[PI] 
    51995624XRNVR   ((M-K) ADD M-AP (A-CONSTANT (EVAL %LP-CALL-STATE))) 
     
    52095634 
    52105635XRNVR2  (JUMP-IF-BIT-CLEAR (LISP-BYTE %%LP-CLS-ADI-PRESENT) MD XRNVX)   ;Not doing mult vals 
    5211         (JUMP-XCT-NEXT MVR)                     ;Go return multiple values from this frame 
    5212        ((M-S) (A-CONSTANT 1)) 
     5636        (JUMP MVR)                              ;Go return multiple values from this frame 
    52135637 
    52145638;MD gets contents of untyped virtual address in M-K, when likely to be in pdl buffer 
     
    52345658;Documentation on calling sequence for XRNVR/MVR: 
    52355659;M-T has the value to be returned. 
    5236 ;M-S has a flag which is 1 when calling from a return-next-value operation, 
    5237 ; 0 when called from QRAD1.  If M-S is 1 then if this is the last value expected 
    5238 ; it should be returned the usual QMDDR way; QRAD1 will then be called which will 
    5239 ; come back here to store the value.  At that point the ADI-RETURN-INFO will 
    5240 ; be changed into ADI-USED-UP-RETURN-INFO which prevents accidentally returning 
    5241 ; the same value more than once (which I don't think can happen anyway any more). 
     5660;M-K has virtual address of LPCLS Q for the frame from which value is to be returned. 
     5661;M-S has a flag which is 1 when we are returning no values; this only happens 
     5662; from (return-list nil). 
     5663;The calling sequence is hairy to implement the feature that if the callee returns 
     5664;a value and the caller does not want further values after that one, the function 
     5665;suddenly returns. 
    52425666;There are two return addresses on the micro-stack.  If this was the last value 
    52435667; expected, the first return is taken; if more values are expected the second 
    52445668; return is taken.  In the return-next-value case the first return should be 
    5245 ; QMDDR.  In the QRAD1 case both returns should be the same. 
     5669; QMDDR, causing a sudden return.  In the QRAD1 case both returns should be the same, 
     5670; since we are returning anyway whether or not this is the last value. 
    52465671; In any case, both returns are flushed from the stack. 
     5672;The sudden return works by storing the value in the block, as usual, and then 
     5673; going to QMDDR to get the stack unwound and all, BUT first clobbering the 
     5674; ADI type to be ADI-USED-UP-RETURN-INFO so that QMDDR won't store the value 
     5675; all over again. 
    52475676 
    52485677;  ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC <THAT-WAS-LAST-VALUE-RETURN>))) 
     
    52515680 
    52525681;Clobbers A-TEM1, M-I, M-J, M-S, M-R, M-K plus calls QRDR1 (which doesnt clobber any more) 
    5253 ;Plus calls CONS, which clobbers more.  Protects M-C but probably not anything else. 
     5682;Plus calls CONS, which clobbers more.  Protects M-C and M-A but probably not anything else. 
    52545683 
    52555684;At this point M-K has the virtual address of the LPCLS Q for the frame 
     
    52845713;Store in block 
    52855714MVRB    (CALL-LESS-OR-EQUAL M-I A-ZERO ILLOP)   ;Returning too many values 
    5286         (JUMP-EQUAL M-I A-S XRNVX)              ;Last and not doing return, turn into QMDDR!! 
    52875715        ((M-I) SUB M-I (A-CONSTANT 1)) 
    52885716        ((M-TEM) MD)                            ;Store back decremented values count 
    52895717        ((MD M-TEM) DPB M-I (LISP-BYTE %%ADI-RET-NUM-VALS-EXPECTING) A-TEM) 
    5290         (JUMP-NOT-EQUAL M-S A-ZERO MVRB0)       ;From return, make it used-up. 
     5718        (JUMP-NOT-EQUAL M-I A-ZERO MVRB0)       ;If last val expected, clobber ADI. 
    52915719        ((MD) DPB (M-CONSTANT -1) (LISP-BYTE %%ADI-TYPE) A-TEM) 
    52925720MVRB0   (CALL MKWRIT) 
     
    52955723        (DISPATCH TRANSPORT READ-MEMORY-DATA) 
    52965724        (CALL-XCT-NEXT MKWRIT) 
    5297        ((MD M-I) ADD MD (A-CONSTANT 1)) 
    5298 MVRB1   ((VMA-START-READ) SUB M-I (A-CONSTANT 1))       ;No transport, since writing and no 
     5725       ((MD M-R) ADD MD (A-CONSTANT 1)) 
     5726MVRB1   ((VMA-START-READ) SUB M-R (A-CONSTANT 1))       ;No transport, since writing and no 
    52995727MVRB2   (CHECK-PAGE-READ)                               ;need to follow invisible pntrs here 
    53005728        ((WRITE-MEMORY-DATA-START-WRITE)        ;Store the value 
    53015729                SELECTIVE-DEPOSIT READ-MEMORY-DATA Q-ALL-BUT-TYPED-POINTER A-T) 
    53025730        (CHECK-PAGE-WRITE) 
     5731        (JUMP-EQUAL M-I A-ZERO XRNVX)           ;This was the last value expected. 
    53035732        (POPJ-AFTER-NEXT GC-WRITE-TEST)         ;More expected, or doing return and that was 
    53045733       ((M-GARBAGE) MICRO-STACK-DATA-POP)       ;last, take second return and flush first 
     
    53105739;After the first time, it is a list-pointer to the last cons in the list. 
    53115740;XNCONS mustn't clobber M-C, M-I, M-R; QRDR1 mustn't clobber M-C or M-R. 
    5312 MVRC    ((M-TEM) MD)                            ;If from QRAD1, change to used-up-ADI 
    5313         (CALL-EQUAL-XCT-NEXT M-S A-ZERO MKWRIT) 
    5314        ((MD) DPB (M-CONSTANT -1) (LISP-BYTE %%ADI-TYPE) A-TEM) 
     5741MVRC    (JUMP-EQUAL M-S (A-CONSTANT 1) MVRC1)   ;Returning no values? 
    53155742        ((M-I) ADD M-K                          ;Save address of prev ADI Q 
    53165743                (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE) -1))) 
     
    53275754       ((M-T) SETA A-R MICRO-STACK-PNTR-AND-DATA-POP)    ;Restore value being returned  
    53285755                ;and flush first return. (PNTR-AND-DATA necc. to avoid a byte-op) 
     5756 
     5757;Returning no values.  Don't affect list, and clobber ADI-TYPE so that when 
     5758;QRAD1 calls MVR, it won't affect the list either. 
     5759MVRC1   ((M-TEM) MD) 
     5760        ((MD) DPB (M-CONSTANT -1) (LISP-BYTE %%ADI-TYPE) A-TEM) 
     5761        (CALL MKWRIT) 
     5762        (POPJ-XCT-NEXT)                         ;More <infinite> values expected. 
     5763       ((M-GARBAGE) MICRO-STACK-DATA-POP) 
    53295764 
    53305765;;; THROW CODE (*THROW, *UNWIND-STACK) 
     
    53665801       ((M-GARBAGE) C-PDL-BUFFER-POINTER-POP) 
    53675802 
     5803METER-FUNCTION-UNWIND 
     5804        ((A-METER-EVENT) (A-CONSTANT (EVAL %METER-FUNCTION-UNWIND-EVENT))) 
     5805        (JUMP-XCT-NEXT METER-MICRO-WRITE-HEADER) 
     5806       ((A-METER-LENGTH) M-ZERO)        ;Number of meters pushed 
     5807 
     5808;;; This like *UNWIND-STACK but takes its args in the order value, tag, count, action 
     5809;;; and simply moves value to the destination if tag is NIL (normal exit from unwind-protect) 
     5810XUWPCON (MISC-INST-ENTRY %UNWIND-PROTECT-CONTINUE) 
     5811        ((A-CATCH-ACTION) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) 
     5812        ((A-CATCH-COUNT) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) 
     5813        ((M-1) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)        ;Tag 
     5814        (POPJ-EQUAL-XCT-NEXT M-1 A-V-NIL) 
     5815       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;Value 
     5816        ((C-PDL-BUFFER-POINTER-PUSH) M-1)               ;Clobbered by meter code 
     5817        (CALL-IF-BIT-SET (LISP-BYTE %%METER-FUNCTION-ENTRY-EXIT-ENABLE) 
     5818                M-METER-ENABLES METER-FUNCTION-UNWIND) 
     5819        (JUMP-XCT-NEXT XUWPCN1)                         ;Join *UNWIND-STACK 
     5820       ((A-CATCH-MARK) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-U-ENTRY) 
     5821                                         *CATCH-U-CODE-ENTRY-/#))) 
     5822 
    53685823XUWSTK (MISC-INST-ENTRY *UNWIND-STACK) 
    53695824   (ERROR-TABLE RESTART *UNWIND-STACK) 
     5825        (CALL-IF-BIT-SET-XCT-NEXT (LISP-BYTE %%METER-FUNCTION-ENTRY-EXIT-ENABLE) 
     5826                M-METER-ENABLES METER-FUNCTION-UNWIND) 
    53705827        ((A-CATCH-ACTION) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) 
    53715828        ((A-CATCH-COUNT) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) 
     
    53745831      ;                                  *CATCH-U-CODE-ENTRY-/#))) 
    53755832 
     5833(ERROR-TABLE DEFAULT-ARG-LOCATIONS *THROW A-CATCH-TAG M-T) 
     5834 
    53765835XTHROW (MISC-INST-ENTRY *THROW) 
    53775836   (ERROR-TABLE RESTART *THROW) 
     
    53795838        ((A-CATCH-MARK) (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-U-ENTRY) 
    53805839                                          *CATCH-U-CODE-ENTRY-/#))) 
     5840        (CALL-IF-BIT-SET-XCT-NEXT (LISP-BYTE %%METER-FUNCTION-ENTRY-EXIT-ENABLE) 
     5841                M-METER-ENABLES METER-FUNCTION-UNWIND) 
    53815842        ((A-CATCH-ACTION) A-V-NIL) 
    53825843        ((A-CATCH-COUNT) A-V-NIL) 
    53835844XUWS0   ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)  ;Value thrown 
    5384         ((M-1) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)  ;Tag 
     5845XUWPCN1 ((M-1) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)  ;Tag 
    53855846        (JUMP-EQUAL-XCT-NEXT M-1 A-V-TRUE XTHRW7)         ;Tag of T means all the way 
    53865847       ((A-CATCH-TAG) M-1)                                ; so don't check first 
     
    53885849                XTHRW7)                                   ;Tag of 0 also special 
    53895850;DROPS THROUGH 
    5390 ;DROPS IN 
     5851 
     5852;DROPS IN, or jumps back from XTHC5. 
    53915853;Before actually going and munging anything, follow the open-call-block chain 
    53925854;and find out whether the catch tag we're looking for actually exists. 
     
    53955857;  M-B  Virtual address of next active call block (typeless) 
    53965858;  M-C  Pdl buffer address of next call block (only low 10 bits valid) 
     5859;  M-D  Typeless virtual address of outermost active frame we are popping 
     5860;       that has the %%LP-CLS-TRAP-ON-EXIT bit set; or zero, if there is none. 
    53975861;  M-1  arg into / result out of XTHCG 
     5862XTHC0   ((M-D) A-ZERO) 
    53985863        (CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS) 
    53995864       ((M-K) M-AP) 
     
    54105875        ((M-B) SUB M-B A-ZR) 
    54115876XTHC4   ((M-ZR) (LISP-BYTE %%LP-CLS-DELTA-TO-OPEN-BLOCK) M-1) 
     5877        (CALL-IF-BIT-SET (LISP-BYTE %%LP-CLS-TRAP-ON-EXIT) M-1 XTHC-TRAP-LATER) 
    54125878        ((M-A) SUB M-A A-ZR) 
    54135879        (JUMP-EQUAL-XCT-NEXT M-A A-B XTHC1) 
     
    54185884        (CALL-XCT-NEXT XTHCG) 
    54195885       ((M-1) ADD M-A (A-CONSTANT 1))                   ;GET FIRST ARG 
    5420         (JUMP-EQUAL M-1 A-CATCH-TAG XTHRW7)             ;FOUND THE ONE WE'RE LOOKING FOR, 
     5886        (JUMP-EQUAL M-1 A-CATCH-TAG XTHC5)              ;FOUND THE ONE WE'RE LOOKING FOR, 
    54215887                                                        ;IT'S NOW SAFE TO GO THROW FOR REAL. 
    5422         (JUMP-EQUAL M-1 A-V-NIL XTHRW7)                 ;FOUND CATCH-ALL, THATS OK TOO. 
     5888        (JUMP-EQUAL M-1 A-V-NIL XTHC5)                  ;FOUND CATCH-ALL, THATS OK TOO. 
    54235889XTHC3   (CALL-XCT-NEXT XTHCG)                           ;GET CALL STATE Q 
    54245890       ((M-1) ADD M-A (A-CONSTANT (EVAL %LP-CALL-STATE))) 
    54255891        (JUMP XTHC4) 
     5892 
     5893XTHC5   (JUMP-EQUAL M-D A-ZERO XTHRW7) 
     5894        ((M-A) A-CATCH-TAG) 
     5895        ((M-B) A-CATCH-COUNT) 
     5896        ((M-C) A-CATCH-ACTION) 
     5897        ((M-E) A-CATCH-MARK) 
     5898        ((M-D) DPB M-D Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE))) 
     5899        (CALL TRAP) 
     5900    (ERROR-TABLE THROW-EXIT-TRAP) 
     5901        ;Restart after clearing the trap-on-exit bit 
     5902        ;of all the frames we are exiting. 
     5903        ((A-CATCH-TAG) M-A) 
     5904        ((A-CATCH-COUNT) M-B) 
     5905        ((A-CATCH-ACTION) M-C) 
     5906        ((A-CATCH-MARK) M-E) 
     5907        (JUMP XTHC0) 
     5908 
     5909;Keep track of the lowest stack frame that has the %%LP-CLS-TRAP-ON-EXIT bit set. 
     5910XTHC-TRAP-LATER 
     5911        (POPJ-XCT-NEXT) 
     5912        ((M-D) M-A) 
    54265913 
    54275914XTHC-ERROR 
     
    54335920                                        ;It knows the tag is in M-A, the value is in M-T, 
    54345921                                        ;the count is in M-B, and the action is in M-C. 
    5435                                         ;It restarts at *THROW (should use *UNWIND-STACK) 
    54365922 
    54375923;GET A WORD WHOSE UNTYPED VIRTUAL ADDRESS IS IN M-1.  FOR SPEED, ATTEMPTS 
     
    55296015                                                ; EXECUTION, CALL FUNCTION INSTEAD. 
    55306016XTHRW6D ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMEX1))) 
     6017        ((M-S) A-ZERO) 
    55316018        (CALL XRNVR)                            ;FIRST VALUE IS VALUE THROWN (STILL IN M-T) 
    55326019        ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMEX1))) 
     6020        ((M-S) A-ZERO) 
    55336021        (CALL-XCT-NEXT XRNVR)                   ;SECOND VALUE IS TAG 
    55346022       ((M-T) A-CATCH-TAG) 
    55356023        ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC QMEX1))) 
     6024        ((M-S) A-ZERO) 
    55366025        (CALL-XCT-NEXT XRNVR)                   ;THIRD VALUE IS COUNT 
    55376026       ((M-T) A-CATCH-COUNT) 
     
    56656154XAPDLR1 (CALL TRAP) 
    56666155    (ERROR-TABLE STACK-FRAME-TOO-LARGE) 
    5667  
     6156    (ERROR-TABLE ARG-POPPED 0 M-1) 
     6157 
     6158;This makes a list of specified length, full of NILs, on the stack.  Because it 
     6159;pushes on the stack it must be done at "top level" in the function body, rather 
     6160;than as an argument to a function, unless a SHRINK-PDL-SAVE-TOP instruction is 
     6161;emitted at a suitable place. 
    56686162XMSL (MISC-INST-ENTRY %MAKE-STACK-LIST) 
    56696163        (CALL XAPDLR)                           ;M-1 GETS LIST LENGTH, CHECK FOR ROOM 
     
    56796173       ((M-T) Q-POINTER M-K (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST))) 
    56806174 
     6175;Like %MAKE-STACK-LIST but expects the contents of 
     6176;the list to be on the stack already, 
     6177;followed by a word containing the length, which we discard. 
     6178;We fix the cdr codes and return a pointer. 
     6179XMESL (MISC-INST-ENTRY %MAKE-EXPLICIT-STACK-LIST) 
     6180        ((M-A) Q-POINTER C-PDL-BUFFER-POINTER-POP) 
     6181        (JUMP-EQUAL M-A A-ZERO XFALSE) 
     6182        ;Compute pointer to beginning of list. 
     6183        (CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS) 
     6184       ((M-K PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER A-A) 
     6185        ;B gets CDR-NEXT. 
     6186        ((M-B) DPB (M-CONSTANT -1) Q-CDR-CODE) 
     6187        (JUMP-EQUAL M-A (A-CONSTANT 1) XMESL2) 
     6188;Give all but last element of list CDR-NEXT. 
     6189XMESL1 
     6190        ((C-PDL-BUFFER-INDEX) Q-TYPED-POINTER C-PDL-BUFFER-INDEX A-B) 
     6191        ((M-A) SUB M-A (A-CONSTANT 1)) 
     6192        ((PDL-BUFFER-INDEX) ADD PDL-BUFFER-INDEX (A-CONSTANT 1)) 
     6193        (JUMP-GREATER-THAN M-A (A-CONSTANT 1) XMESL1) 
     6194XMESL2 
     6195;Give last element CDR-NIL. 
     6196        (POPJ-AFTER-NEXT 
     6197         (C-PDL-BUFFER-INDEX) Q-TYPED-POINTER C-PDL-BUFFER-INDEX 
     6198                              (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-NIL))) 
     6199        ((M-T) Q-POINTER M-K (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST))) 
     6200 
     6201;A lexical closure is a pointer with type DTP-CLOSURE or DTP-STACK-CLOSURE 
     6202;to a couple of lists on the stack which look like 
     6203;(function ,(LOCF LEXICAL-ENVIRONMENT) ((,(%STACK-FRAME-POINTER) . ,LEXICAL-ENVIRONMENT))) 
     6204;This uses six slots.  We expect the index of the first one within the local block. 
     6205;We set up the third slot (to point to the fourth, cdr-nil), 
     6206;the fourth slot (to point to the fifth, cdr-nil), 
     6207;and the fifth (our own stack frame, cdr-normal). 
     6208;Then we return a pointer to the first slot, with DTP-STACK-CLOSURE. 
     6209XMLC (MISC-INST-ENTRY %MAKE-LEXICAL-CLOSURE) 
     6210        ((PDL-BUFFER-INDEX) ADD M-AP (A-CONSTANT (EVAL %LP-ENTRY-STATE))) 
     6211        ((M-B) (LISP-BYTE %%LP-ENS-MACRO-LOCAL-BLOCK-ORIGIN) C-PDL-BUFFER-INDEX) 
     6212        ((M-B) ADD C-PDL-BUFFER-POINTER-POP A-B) 
     6213;Put in M-T the memory address of the first slot. 
     6214        ((M-K) ADD M-AP A-B) 
     6215        ((PDL-BUFFER-INDEX) ADD M-K (A-CONSTANT 2)) 
     6216        (CALL CONVERT-PDL-BUFFER-ADDRESS) 
     6217        ((M-T) DPB M-K Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-STACK-CLOSURE))) 
     6218;Set up the third slot. 
     6219        ((M-K) M+A+1 M-T (A-CONSTANT 2)) 
     6220        ((C-PDL-BUFFER-INDEX) DPB M-K Q-POINTER  
     6221                              (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-LIST) 
     6222                                                (BYTE-VALUE Q-CDR-CODE CDR-NIL)))) 
     6223;Set up the fourth slot. 
     6224        ((PDL-BUFFER-INDEX) M+1 PDL-BUFFER-INDEX) 
     6225        ((M-K) M+1 M-K) 
     6226        ((C-PDL-BUFFER-INDEX) DPB M-K Q-POINTER  
     6227                              (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-LIST) 
     6228                                                (BYTE-VALUE Q-CDR-CODE CDR-NIL)))) 
     6229;Set up the fifth slot. 
     6230        ((PDL-BUFFER-INDEX) M+1 PDL-BUFFER-INDEX) 
     6231        (CALL-XCT-NEXT CONVERT-PDL-BUFFER-ADDRESS) 
     6232       ((M-K) M-AP) 
     6233        ((C-PDL-BUFFER-INDEX) DPB M-K Q-POINTER  
     6234                              (A-CONSTANT (PLUS (BYTE-VALUE Q-DATA-TYPE DTP-LIST) 
     6235                                                (BYTE-VALUE Q-CDR-CODE CDR-NORMAL)))) 
     6236;Set up the sixth slot. 
     6237        ((PDL-BUFFER-INDEX) M+1 PDL-BUFFER-INDEX) 
     6238        (POPJ-AFTER-NEXT 
     6239         (M-K) A-LEXICAL-ENVIRONMENT) 
     6240        ((C-PDL-BUFFER-INDEX) DPB M-K Q-TYPED-POINTER  
     6241                              (A-CONSTANT (BYTE-VALUE Q-CDR-CODE CDR-ERROR))) 
     6242 
    56816243;(%SPREAD LIST)D-NEXT sends the elements of the list which is 
    56826244;on the top of the stack to D-NEXT.  (%SPREAD LIST)D-LAST is similar 
    56836245;but sends the last one to D-LAST (i.e. activates an open-call). 
    56846246;(%SPREAD LIST)D-PDL is identical to (%SPREAD LIST)D-NEXT 
     6247(ERROR-TABLE DEFAULT-ARG-LOCATIONS %SPREAD M-D) 
     6248 
    56856249XSPREAD (MISC-INST-ENTRY %SPREAD) 
    56866250        ((M-GARBAGE) MICRO-STACK-DATA-POP)      ;DON'T STORE IN DESTINATION 
    56876251        ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)        ;LIST TO BE SPREAD 
    56886252        ((M-C) M-INST-DEST) 
     6253        ((M-D) M-T)                                     ;SAVE ORIGINAL ARG FOR ERROR MSG. 
    56896254MC-SPREAD-0                                             ;ENTRY FOR MICROCOMPILED CODE 
    56906255        ((PDL-BUFFER-INDEX) M-A-1 PDL-BUFFER-POINTER A-AP)      ;CURRENT FRAME SIZE (MOD 2000) 
     
    58376402        ((M-K) PDL-BUFFER-POINTER)              ;LOC OF BLOCK AS PDL INDEX 
    58386403        ((M-E) M-D) 
    5839 LMVRB1  ((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL)   ;RESERVE SLOTS, FILL WITH NIL 
     6404LMVRB1  ((C-PDL-BUFFER-POINTER-PUSH)            ;RESERVE SLOTS, FILL WITH NIL 
     6405                DPB (M-CONSTANT -1) Q-CDR-CODE A-V-NIL) ;WITH CDR-NEXT 
    58406406        (JUMP-GREATER-THAN-XCT-NEXT M-E (A-CONSTANT 1) LMVRB1) 
    58416407       ((M-E) SUB M-E (A-CONSTANT 1)) 
     
    59416507        ((M-S) PDL-BUFFER-INDEX)                ;Must be in both M-S and PDL-BUFFER-INDEX 
    59426508        (CALL-NOT-EQUAL M-S A-IPMARK ILLOP)     ;Frame not where it should be.  M-R lied? 
    5943         ((M-A) C-PDL-BUFFER-INDEX)              ;Function to call 
     6509       ((M-A) C-PDL-BUFFER-INDEX)               ;M-A := FUNCTION TO CALL 
    59446510        (DISPATCH Q-DATA-TYPE M-A D-QMRCL)      ;Does MLLV if necc 
    59456511       (CALL MLLV) 
     
    61486714;*** WE STILL HAVE A PROBLEM WITH M-ERROR-SUBSTATUS NOT BEING PRESERVED 
    61496715 
    6150 QLENTR  ((PDL-BUFFER-INDEX) SUB M-S A-AP)       ;ASSURE ROOM IN PDL-BUFFER 
     6716QLENTR  (CALL-IF-BIT-SET-XCT-NEXT (LISP-BYTE %%METER-FUNCTION-ENTRY-EXIT-ENABLE) 
     6717                M-METER-ENABLES METER-FUNCTION-ENTRY) 
     6718        ((PDL-BUFFER-INDEX) SUB M-S A-AP)       ;ASSURE ROOM IN PDL-BUFFER 
    61516719        ((M-PDL-BUFFER-ACTIVE-QS) ADD PDL-BUFFER-INDEX A-PDL-BUFFER-ACTIVE-QS) 
    61526720        (CALL-GREATER-THAN-XCT-NEXT M-PDL-BUFFER-ACTIVE-QS  
     
    61886756        (JUMP-XCT-NEXT QFL2) 
    61896757       ((M-E) SUB M-E (A-CONSTANT 1)) 
     6758 
     6759METER-FUNCTION-ENTRY 
     6760        ((A-METER-EVENT) (A-CONSTANT (EVAL %METER-FUNCTION-ENTRY-EVENT))) 
     6761        ((C-PDL-BUFFER-POINTER-PUSH) M-A) 
     6762        (JUMP-XCT-NEXT METER-MICRO-WRITE-HEADER) 
     6763       ((A-METER-LENGTH) (A-CONSTANT 1))        ;Number of meters pushed 
    61906764 
    61916765SET-TOO-FEW-ARGS 
     
    65637137;QBEQQ  (JUMP-NOT-EQUAL M-C A-ZERO QBEQC1) 
    65647138;       (JUMP QBEQQ1) 
    6565  
     7139 
    65667140;;FRAME BIND. BIND S-V S FROM FRAME FAST ENTERED USING S.V. MAP 
    65677141FRMBN1  ((VMA-START-READ) ADD M-A (A-CONSTANT (EVAL %FEFHI-SV-BITMAP))) 
     
    66037177        ((WRITE-MEMORY-DATA-START-WRITE) SELECTIVE-DEPOSIT 
    66047178                READ-MEMORY-DATA Q-ALL-BUT-TYPED-POINTER A-B) 
    6605         (CHECK-PAGE-WRITE) 
    6606         (JUMP-IF-BIT-SET Q-FLAG-BIT M-B BBLKP2) ;Jump if last binding in block 
     7179        (CHECK-PAGE-WRITE-BIND) 
     7180BBLKP3  (JUMP-IF-BIT-SET Q-FLAG-BIT M-B BBLKP2) ;Jump if last binding in block 
    66077181        (JUMP-NOT-EQUAL M-ZR A-ZERO BBLKP1)     ;Loop if BBLKP 
    66087182        (POPJ-IF-BIT-CLEAR-XCT-NEXT M-DEFERRED-SEQUENCE-BREAK-FLAG)     ;Exit if QUNBND 
     
    66667240;THE FOLLOWING IS A TEMPORARY KLUDGE UNTIL THE COMPILER BUG IS FIXED. 12/19/78 MOON, PER RMS 
    66677241        ((M-B) (BYTE-FIELD 4 0) M-B) 
     7242XPOPIP-2 
    66687243        ((PDL-BUFFER-POINTER M-B) SUB PDL-BUFFER-POINTER A-B) 
    66697244XPOPIP-1 
     
    66797254 
    66807255XSHRINK-PDL-SAVE-TOP (MISC-INST-ENTRY SHRINK-PDL-SAVE-TOP) 
    6681         ((M-2) Q-POINTER C-PDL-BUFFER-POINTER-POP)              ;AMT TO DECREMENT PP BY 
    6682         (POPJ-AFTER-NEXT 
    6683          (M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)        ;THING TO RETURN 
    6684        ((PDL-BUFFER-POINTER) SUB PDL-BUFFER-POINTER A-2) 
     7256        ((M-B) Q-POINTER C-PDL-BUFFER-POINTER-POP)      ;AMT TO DECREMENT PP BY 
     7257        (JUMP-XCT-NEXT XPOPIP-2) 
     7258       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;THING TO RETURN 
    66857259 
    66867260XSPECIAL-PDL-INDEX (MISC-INST-ENTRY SPECIAL-PDL-INDEX) 
     
    67227296;   NOTE- ALWAYS RETURNS 0 IN FIELDS OTHER THAN POINTER AND DATA TYPE 
    67237297 
    6724 QTADDD (MISC-INST-ENTRY CADDDR) 
     7298(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAR M-T) 
     7299 
     7300QTA   (MISC-INST-ENTRY M-CAR) 
    67257301        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    6726 QMADDD  (CALL QMD)              ;These also MC-LINKAGE entries 
    6727 QMADD   (CALL QMD) 
    6728 QMAD    (CALL QMD) 
    67297302QMA 
    67307303   (ERROR-TABLE RESTART CAR) 
     
    67477320   (ERROR-TABLE ARGTYP CONS M-T T CAR CAR) 
    67487321 
    6749 QTDDDD (MISC-INST-ENTRY CDDDDR) 
     7322 
     7323 
     7324(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDR M-T) 
     7325 
     7326QTD   (MISC-INST-ENTRY M-CDR) 
    67507327        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    6751 QMDDDD  (CALL QMD)              ;These also MC-LINKAGE entries. 
    6752 QMDDD   (CALL QMD) 
    6753 QMDD    (CALL QMD) 
    67547328QMD    
    67557329   (ERROR-TABLE RESTART CDR) 
     
    67917365       ((M-T) DPB M-T Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LOCATIVE))) 
    67927366 
    6793 QTAAAA (MISC-INST-ENTRY CAAAAR) 
     7367;; Multiple CAR/CDR functions. 
     7368 
     7369;; QMA, QMD, etc. take arg in M-T and return value in M-T. 
     7370;; XCAAR, etc. pop arg off stack and return value in M-T. 
     7371;; QTAD, etc., exist only for certain functions. 
     7372;; They pop arg off stack like XCADR, etc., but do not set M-A. 
     7373 
     7374(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADDDR M-A) 
     7375 
     7376XCADDDR (MISC-INST-ENTRY CADDDR) 
     7377        ((M-A) C-PDL-BUFFER-POINTER) 
    67947378        ((M-T) C-PDL-BUFFER-POINTER-POP) 
     7379QMADDD  (CALL QMD)              ;These also MC-LINKAGE entries 
     7380QMADD   (CALL QMD) 
     7381QMAD    (CALL QMD) 
     7382        (JUMP QMA) 
     7383 
     7384(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAAAAR M-A) 
     7385 
     7386XCAAAAR (MISC-INST-ENTRY CAAAAR) 
     7387        ((M-T) C-PDL-BUFFER-POINTER-POP) 
     7388        ((M-A) M-T) 
    67957389QMAAAA  (CALL QMA)                      ;These also MC-LINKAGEs 
    67967390QMAAA   (CALL QMA) 
     
    67987392        (JUMP QMA) 
    67997393 
    6800 QTAAAD (MISC-INST-ENTRY CAAADR) 
     7394(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDDDR M-A) 
     7395 
     7396XCDDDDR (MISC-INST-ENTRY CDDDDR) 
     7397        ((M-A) C-PDL-BUFFER-POINTER) 
    68017398        ((M-T) C-PDL-BUFFER-POINTER-POP) 
     7399QMDDDD  (CALL QMD)              ;These also MC-LINKAGE entries. 
     7400QMDDD   (CALL QMD) 
     7401QMDD    (CALL QMD) 
     7402        (JUMP QMD) 
     7403 
     7404(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAAADR M-A) 
     7405 
     7406XCAAADR (MISC-INST-ENTRY CAAADR) 
     7407        (CALL-XCT-NEXT QMD) 
     7408       ((M-T) C-PDL-BUFFER-POINTER) 
     7409    (ERROR-TABLE ARG-POPPED 0 PP) 
     7410        (JUMP-XCT-NEXT QMAAA) 
     7411       ((M-A) C-PDL-BUFFER-POINTER-POP) 
     7412 
    68027413QMAAAD  (CALL QMD)                      ;MC-LINKAGE 
    68037414        (JUMP QMAAA) 
    68047415 
    6805 QTDDDA (MISC-INST-ENTRY CDDDAR) 
    6806         ((M-T) C-PDL-BUFFER-POINTER-POP) 
     7416(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDDAR M-A) 
     7417 
     7418XCDDDAR (MISC-INST-ENTRY CDDDAR) 
     7419        (CALL-XCT-NEXT QMA) 
     7420       ((M-T) C-PDL-BUFFER-POINTER) 
     7421    (ERROR-TABLE ARG-POPPED 0 PP) 
     7422        (JUMP-XCT-NEXT QMDDD) 
     7423       ((M-A) C-PDL-BUFFER-POINTER-POP) 
     7424 
    68077425QMDDDA  (CALL QMA)                      ;MC-LINKAGE 
    68087426        (JUMP QMDDD) 
    68097427 
    6810 QTAADD (MISC-INST-ENTRY CAADDR) 
     7428(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAADDR M-A) 
     7429 
     7430XCAADDR (MISC-INST-ENTRY CAADDR) 
    68117431        ((M-T) C-PDL-BUFFER-POINTER-POP) 
     7432        ((M-A) M-T) 
    68127433QMAADD  (CALL QMD)                      ;MC-LINKAGE 
    68137434QMAAD   (CALL QMD) 
    68147435        (JUMP QMAA) 
    68157436 
    6816 QTAADA (MISC-INST-ENTRY CAADAR) 
    6817         ((M-T) C-PDL-BUFFER-POINTER-POP) 
     7437(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAADAR M-A) 
     7438 
     7439XCAADAR (MISC-INST-ENTRY CAADAR) 
     7440        (CALL-XCT-NEXT QMA) 
     7441       ((M-T) C-PDL-BUFFER-POINTER) 
     7442    (ERROR-TABLE ARG-POPPED 0 PP) 
     7443        (JUMP-XCT-NEXT QMAAD) 
     7444       ((M-A) C-PDL-BUFFER-POINTER-POP) 
     7445 
    68187446QMAADA  (CALL QMA)                      ;MC-LINKAGE 
    68197447        (JUMP QMAAD) 
    68207448 
    6821 QTDDAA (MISC-INST-ENTRY CDDAAR) 
     7449(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDAAR M-A) 
     7450 
     7451XCDDAAR (MISC-INST-ENTRY CDDAAR) 
    68227452        ((M-T) C-PDL-BUFFER-POINTER-POP) 
     7453        ((M-A) M-T) 
    68237454QMDDAA  (CALL QMA)                      ;MC-LINKAGE 
    68247455QMDDA   (CALL QMA) 
    68257456        (JUMP QMDD) 
    68267457 
    6827 QTDDAD (MISC-INST-ENTRY CDDADR)  
    6828         ((M-T) C-PDL-BUFFER-POINTER-POP) 
     7458(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDADR M-A) 
     7459 
     7460XCDDADR (MISC-INST-ENTRY CDDADR)         
     7461        (CALL-XCT-NEXT QMD) 
     7462       ((M-T) C-PDL-BUFFER-POINTER) 
     7463    (ERROR-TABLE ARG-POPPED 0 PP) 
     7464        (JUMP-XCT-NEXT QMDDA) 
     7465       ((M-A) C-PDL-BUFFER-POINTER-POP) 
     7466 
    68297467QMDDAD  (CALL QMD)                      ;MC-LINKAGE 
    68307468        (JUMP QMDDA) 
    68317469 
    6832 QTADAA (MISC-INST-ENTRY CADAAR) 
     7470(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADAAR M-A) 
     7471 
     7472XCADAAR (MISC-INST-ENTRY CADAAR) 
    68337473        ((M-T) C-PDL-BUFFER-POINTER-POP) 
     7474        ((M-A) M-T) 
    68347475QMADAA  (CALL QMA)                      ;MC-LINKAGE 
    68357476QMADA   (CALL QMA) 
    68367477        (JUMP QMAD) 
    68377478 
    6838 QTADAD (MISC-INST-ENTRY CADADR) 
    6839         ((M-T) C-PDL-BUFFER-POINTER-POP) 
     7479(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADADR M-A) 
     7480 
     7481XCADADR (MISC-INST-ENTRY CADADR) 
     7482        (CALL-XCT-NEXT QMD) 
     7483       ((M-T) C-PDL-BUFFER-POINTER) 
     7484    (ERROR-TABLE ARG-POPPED 0 PP) 
     7485        (JUMP-XCT-NEXT QMADA) 
     7486       ((M-A) C-PDL-BUFFER-POINTER-POP) 
     7487 
    68407488QMADAD  (CALL QMD)                      ;MC-LINKAGE 
    68417489        (JUMP QMADA) 
    68427490 
    6843 QTADDA (MISC-INST-ENTRY CADDAR) 
    6844         ((M-T) C-PDL-BUFFER-POINTER-POP) 
     7491(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADDAR M-A) 
     7492 
     7493XCADDAR (MISC-INST-ENTRY CADDAR) 
     7494        (CALL-XCT-NEXT QMA) 
     7495       ((M-T) C-PDL-BUFFER-POINTER) 
     7496    (ERROR-TABLE ARG-POPPED 0 PP) 
     7497        (JUMP-XCT-NEXT QMADD) 
     7498       ((M-A) C-PDL-BUFFER-POINTER-POP) 
     7499 
    68457500QMADDA  (CALL QMA)                      ;MC-LINKAGE 
    68467501        (JUMP QMADD) 
    68477502 
    6848 QTDADA (MISC-INST-ENTRY CDADAR) 
     7503(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDADAR M-A) 
     7504 
     7505XCDADAR (MISC-INST-ENTRY CDADAR) 
    68497506        ((M-T) C-PDL-BUFFER-POINTER-POP) 
     7507        ((M-A) M-T) 
    68507508QMDADA  (CALL QMA)                      ;MC-LINKAGE 
    68517509QMDAD   (CALL QMD) 
    68527510        (JUMP QMDA) 
    68537511 
    6854 QTDADD (MISC-INST-ENTRY CDADDR) 
    6855         ((M-T) C-PDL-BUFFER-POINTER-POP) 
     7512(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDADDR M-A) 
     7513 
     7514XCDADDR (MISC-INST-ENTRY CDADDR) 
     7515        (CALL-XCT-NEXT QMD) 
     7516       ((M-T) C-PDL-BUFFER-POINTER) 
     7517    (ERROR-TABLE ARG-POPPED 0 PP) 
     7518        (CALL-XCT-NEXT QMD) 
     7519       ((M-A) C-PDL-BUFFER-POINTER-POP) 
     7520        (JUMP QMDA) 
     7521 
    68567522QMDADD  (CALL QMD)                      ;MC-LINKAGE 
    68577523        (JUMP QMDAD) 
    68587524 
    6859 QTDAAA (MISC-INST-ENTRY CDAAAR) 
     7525(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDAAAR M-A) 
     7526 
     7527XCDAAAR (MISC-INST-ENTRY CDAAAR) 
    68607528        ((M-T) C-PDL-BUFFER-POINTER-POP) 
     7529        ((M-A) M-T) 
    68617530QMDAAA  (CALL QMA)                      ;MC-LINKAGE 
    68627531QMDAA   (CALL QMA) 
     
    68647533        (JUMP QMD) 
    68657534 
    6866 QTDAAD (MISC-INST-ENTRY CDAADR) 
    6867         ((M-T) C-PDL-BUFFER-POINTER-POP) 
     7535(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDAADR M-A) 
     7536 
     7537XCDAADR (MISC-INST-ENTRY CDAADR) 
     7538        (CALL-XCT-NEXT QMD) 
     7539       ((M-T) C-PDL-BUFFER-POINTER) 
     7540    (ERROR-TABLE ARG-POPPED 0 PP) 
     7541        (JUMP-XCT-NEXT QMDAA) 
     7542       ((M-A) C-PDL-BUFFER-POINTER-POP) 
     7543 
    68687544QMDAAD  (CALL QMD)                      ;MC-LINKAGE 
    68697545        (JUMP QMDAA) 
    68707546 
    68717547 
    6872 QTAAA (MISC-INST-ENTRY CAAAR) 
     7548;For CAAAR ... CDDDR, the arg is in M-A whenever an error occurs. 
     7549 
     7550(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAAAR M-A) 
     7551 
     7552XCAAAR (MISC-INST-ENTRY CAAAR) 
     7553        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    68737554        (JUMP-XCT-NEXT QMAAA) 
    6874        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    6875  
    6876 QTAAD (MISC-INST-ENTRY CAADR) 
     7555       ((M-A) M-T) 
     7556 
     7557(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAADR M-A) 
     7558 
     7559XCAADR (MISC-INST-ENTRY CAADR) 
     7560        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    68777561        (JUMP-XCT-NEXT QMAAD) 
    6878        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    6879  
    6880 QTADA (MISC-INST-ENTRY CADAR) 
     7562       ((M-A) M-T) 
     7563 
     7564(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADAR M-A) 
     7565 
     7566XCADAR (MISC-INST-ENTRY CADAR) 
     7567        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    68817568        (JUMP-XCT-NEXT QMADA) 
    6882        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    6883  
    6884 QTADD (MISC-INST-ENTRY CADDR) 
     7569       ((M-A) M-T) 
     7570 
     7571(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADDR M-A) 
     7572 
     7573XCADDR (MISC-INST-ENTRY CADDR) 
     7574        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    68857575        (JUMP-XCT-NEXT QMADD) 
    6886        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    6887  
    6888 QTDAA (MISC-INST-ENTRY CDAAR) 
     7576       ((M-A) M-T) 
     7577 
     7578(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDAAR M-A) 
     7579 
     7580XCDAAR (MISC-INST-ENTRY CDAAR) 
     7581        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    68897582        (JUMP-XCT-NEXT QMDAA) 
    6890        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    6891  
    6892 QTDAD (MISC-INST-ENTRY CDADR) 
     7583       ((M-A) M-T) 
     7584 
     7585(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDADR M-A) 
     7586 
     7587XCDADR (MISC-INST-ENTRY CDADR) 
     7588        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    68937589        (JUMP-XCT-NEXT QMDAD) 
    6894        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    6895  
    6896 QTDDA (MISC-INST-ENTRY CDDAR) 
     7590       ((M-A) M-T) 
     7591 
     7592(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDAR M-A) 
     7593 
     7594XCDDAR (MISC-INST-ENTRY CDDAR) 
     7595        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    68977596        (JUMP-XCT-NEXT QMDDA) 
    6898        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    6899  
    6900 QTDDD (MISC-INST-ENTRY CDDDR) 
     7597       ((M-A) M-T) 
     7598 
     7599(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDDR M-A) 
     7600 
     7601XCDDDR (MISC-INST-ENTRY CDDDR) 
     7602        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    69017603        (JUMP-XCT-NEXT QMDDD) 
    6902        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    6903  
    6904 QTAA  (MISC-INST-ENTRY M-CAAR) 
    6905         (JUMP-XCT-NEXT QMAA) 
    6906        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    6907  
    6908 QTAD  (MISC-INST-ENTRY M-CADR) 
    6909         (JUMP-XCT-NEXT QMAD) 
    6910        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    6911  
    6912 QTDA  (MISC-INST-ENTRY M-CDAR) 
    6913         (JUMP-XCT-NEXT QMDA) 
    6914        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    6915  
    6916 QTDD  (MISC-INST-ENTRY M-CDDR) 
    6917         (JUMP-XCT-NEXT QMDD) 
    6918        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    6919  
    6920 QTA   (MISC-INST-ENTRY M-CAR) 
     7604       ((M-A) M-T) 
     7605 
     7606;For CAAR ... CDDR, the arg is in M-A unless an ARG-POPPED says it is elsewhere. 
     7607 
     7608(ERROR-TABLE DEFAULT-ARG-LOCATIONS CAAR M-A) 
     7609 
     7610XCAAR  (MISC-INST-ENTRY M-CAAR) 
     7611        (CALL-XCT-NEXT QMA) 
     7612       ((M-T) C-PDL-BUFFER-POINTER) 
     7613    (ERROR-TABLE ARG-POPPED 0 PP) 
    69217614        (JUMP-XCT-NEXT QMA) 
    6922        ((M-T) C-PDL-BUFFER-POINTER-POP) 
    6923  
    6924 QTD   (MISC-INST-ENTRY M-CDR) 
     7615       ((M-A) C-PDL-BUFFER-POINTER-POP) 
     7616 
     7617(ERROR-TABLE DEFAULT-ARG-LOCATIONS CADR M-A) 
     7618 
     7619XCADR  (MISC-INST-ENTRY M-CADR) 
     7620        (CALL-XCT-NEXT QMD) 
     7621       ((M-T) C-PDL-BUFFER-POINTER) 
     7622    (ERROR-TABLE ARG-POPPED 0 PP) 
     7623        (JUMP-XCT-NEXT QMA) 
     7624       ((M-A) C-PDL-BUFFER-POINTER-POP) 
     7625 
     7626(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDAR M-A) 
     7627 
     7628XCDAR  (MISC-INST-ENTRY M-CDAR) 
     7629        (CALL-XCT-NEXT QMA) 
     7630       ((M-T) C-PDL-BUFFER-POINTER) 
     7631    (ERROR-TABLE ARG-POPPED 0 PP) 
    69257632        (JUMP-XCT-NEXT QMD) 
    6926        ((M-T) C-PDL-BUFFER-POINTER-POP) 
     7633       ((M-A) C-PDL-BUFFER-POINTER-POP) 
     7634 
     7635(ERROR-TABLE DEFAULT-ARG-LOCATIONS CDDR M-A) 
     7636 
     7637XCDDR  (MISC-INST-ENTRY M-CDDR) 
     7638        (CALL-XCT-NEXT QMD) 
     7639       ((M-T) C-PDL-BUFFER-POINTER) 
     7640    (ERROR-TABLE ARG-POPPED 0 PP) 
     7641        (JUMP-XCT-NEXT QMD) 
     7642       ((M-A) C-PDL-BUFFER-POINTER-POP) 
     7643 
     7644QTAD    (CALL QTD) 
     7645        (JUMP QMA) 
     7646 
     7647QTDD    (CALL QTD) 
     7648        (JUMP QMD) 
     7649 
     7650(ERROR-TABLE DEFAULT-ARG-LOCATIONS NTH PP M-T) 
     7651(ERROR-TABLE DEFAULT-ARG-LOCATIONS NTHCDR PP M-T) 
    69277652 
    69287653XNTH (MISC-INST-ENTRY NTH) 
     
    69317656XNTHCDR (MISC-INST-ENTRY NTHCDR) 
    69327657        ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP)        ;List 
     7658                (ERROR-TABLE RESTART XNTHCDR0) 
    69337659        (DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM) 
    6934             (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP 0) 
    6935         (CALL-IF-BIT-SET BOXED-SIGN-BIT C-PDL-BUFFER-POINTER TRAP) 
    6936             (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP 0) 
     7660            (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP 0 XNTHCDR0) 
     7661        (CALL-IF-BIT-SET-XCT-NEXT BOXED-SIGN-BIT C-PDL-BUFFER-POINTER TRAP) 
     7662       ((M-B) Q-TYPED-POINTER C-PDL-BUFFER-POINTER) 
     7663            (ERROR-TABLE ARGTYP POSITIVE-FIXNUM PP 0 XNTHCDR0) 
    69377664        ((M-1) Q-POINTER C-PDL-BUFFER-POINTER-POP)              ;Count 
    6938         (POPJ-EQUAL M-1 A-ZERO) 
     7665        (POPJ-EQUAL-XCT-NEXT M-1 A-ZERO) 
     7666       ((M-A) M-T) 
    69397667XNTHCDR-1 
    69407668        (CALL-NOT-EQUAL M-T A-V-NIL QCDR) 
    69417669            (ERROR-TABLE CALLS-SUB NTHCDR) 
     7670            (ERROR-TABLE ARG-POPPED 0 M-B M-A) 
    69427671        (JUMP-GREATER-THAN-XCT-NEXT M-1 (A-CONSTANT 1) XNTHCDR-1) 
    69437672       ((M-1) SUB M-1 (A-CONSTANT 1)) 
     
    69467675;;; RPLACA AND RPLACD 
    69477676 
     7677  (ERROR-TABLE DEFAULT-ARG-LOCATIONS RPLACA M-S M-T) 
    69487678  (MISC-INST-ENTRY RPLACA) 
    69497679XRPLCA  ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) 
     
    69517681   (ERROR-TABLE RESTART RPLACA) 
    69527682QRAR1   (DISPATCH (I-ARG RPLACA-INVOKE-OP) Q-DATA-TYPE M-S QRACDT) 
     7683   (ERROR-TABLE ARGTYP CONS M-S 0 RPLACA) 
    69537684 
    69547685QRASYM  (CALL-EQUAL M-S A-V-NIL TRAP)           ;RPLACA ING NIL ALWAYS ERROR 
     
    69667697       ((M-T) M-S) 
    69677698 
    6968    (MISC-INST-ENTRY RPLACD) 
     7699  (ERROR-TABLE DEFAULT-ARG-LOCATIONS RPLACD M-S M-T) 
     7700  (MISC-INST-ENTRY RPLACD) 
    69697701;MUSTN'T CLOBBER M-C OR M-R BECAUSE CALLED BY MULTIPLE-VALUE-LIST 
    69707702;NOW CLOBBERS M-S, M-T, M-I, M-A 
     
    69737705   (ERROR-TABLE RESTART RPLACD) 
    69747706QRDR1   (DISPATCH (I-ARG RPLACD-INVOKE-OP) Q-DATA-TYPE M-S QRDCDT) 
     7707   (ERROR-TABLE ARGTYP CONS M-S 0 RPLACD) 
    69757708 
    69767709QRDRSY  (DISPATCH M-CDR-SYM-MODE RPLACD-SYM-DISPATCH) 
     
    69957728                READ-MEMORY-DATA Q-ALL-BUT-TYPED-POINTER A-T) 
    69967729        (CHECK-PAGE-WRITE)                      ;NO SEQ BRK, CALLED BY MVR (???) 
    6997         (POPJ-AFTER-NEXT GC-WRITE-TEST) 
     7730QRDR2   (POPJ-AFTER-NEXT GC-WRITE-TEST) 
    69987731       ((M-T) M-S) 
    69997732 
     7733RPLACD-NEXT-NIL  
     7734        (JUMP-EQUAL M-T A-V-NIL QRDR2)          ;RPLACD WITH NIL AND CDR ALREADY NIL, NO-OP 
    70007735RPLACD-CDR-NEXT  
    7001 RPLACD-NEXT-NIL  
    70027736;THIS CODE CAN SEQUENCE BREAK!!! BEWARE!!! 
    70037737        ((C-PDL-BUFFER-POINTER-PUSH) M-S)               ;SAVE THIS SO WE CAN RETURN IT 
    70047738        ((C-PDL-BUFFER-POINTER-PUSH) VMA)               ;ADDR OF CELL TO BE FORWARDED 
    70057739        ((MD) VMA)                                      ;ADDRESS THE MAP 
    7006         (DISPATCH MAP-STATUS-CODE MEMORY-MAP-DATA D-ASSURE-MAP-VALID) 
     7740        (DISPATCH MAP-STATUS-CODE MEMORY-MAP-DATA D-GET-MAP-BITS) ;Ensure validity of meta bits 
    70077741        ((M-TEM) (LISP-BYTE %%REGION-REPRESENTATION-TYPE) MEMORY-MAP-DATA) 
    70087742        (CALL-NOT-EQUAL M-TEM (A-CONSTANT (EVAL %REGION-REPRESENTATION-TYPE-LIST)) TRAP) 
    70097743    (ERROR-TABLE RPLACD-WRONG-REPRESENTATION-TYPE M-S) 
     7744    (ERROR-TABLE ARG-POPPED 0 (PP 1) M-T) 
    70107745        ((C-PDL-BUFFER-POINTER-PUSH) M-I)               ;CAR OF NEW CELL 
    70117746        ((C-PDL-BUFFER-POINTER-PUSH) M-T)               ;CDR OF NEW CELL 
     
    70207755        (POPJ-AFTER-NEXT GC-WRITE-TEST) 
    70217756       ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;RETURN THE ORIGINAL FIRST ARG 
     7757 
     7758;;; EQUAL 
     7759 
     7760XEQUAL  (MISC-INST-ENTRY EQUAL) 
     7761        ((M-T) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) 
     7762        ((M-B) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) 
     7763XEQUAL-0 
     7764        (JUMP-EQUAL M-T A-B XTRUE) 
     7765        ((M-1) Q-DATA-TYPE M-T) 
     7766        ((M-2) Q-DATA-TYPE M-B) 
     7767        (JUMP-NOT-EQUAL M-1 A-2 XFALSE) 
     7768        (CALL XEQUAL-1) 
     7769        (JUMP-EQUAL M-1 (A-CONSTANT (EVAL DTP-ARRAY-POINTER)) XEQUAL-ARRAY) 
     7770        (DISPATCH Q-DATA-TYPE M-T SKIP-IF-NO-ATOM) 
     7771        (JUMP XFALSE) 
     7772 
     7773        ;; Now we are a list     
     7774        ((C-PDL-BUFFER-POINTER-PUSH) M-T) 
     7775        (CALL-XCT-NEXT QCAR3) 
     7776       ((C-PDL-BUFFER-POINTER-PUSH) M-B) 
     7777        ((M-B) M-T) 
     7778        (CALL-XCT-NEXT QCAR3) 
     7779       ((M-T) C-PDL-BUFFER-POINTER) 
     7780        ;; If the micro stack is filling up, make new stack frame. 
     7781        (JUMP-GREATER-THAN MICRO-STACK-PNTR-AND-DATA (A-CONSTANT 10._24.) 
     7782                           XEQUAL-SLOW-RECURSE) 
     7783        ;; Otherwise, test for EQUALity of the two cars. 
     7784        (CALL XEQUAL-0) 
     7785 
     7786XEQUAL-CDR 
     7787        (JUMP-EQUAL M-T A-V-NIL XEQUAL-DIFFERENT-CARS) 
     7788        ;; If the cars match, tail-recursively check the two cdrs. 
     7789        (CALL-XCT-NEXT QCDR) 
     7790       ((M-T) C-PDL-BUFFER-POINTER-POP) 
     7791        ((M-B) M-T) 
     7792        (CALL-XCT-NEXT QCDR) 
     7793       ((M-T) C-PDL-BUFFER-POINTER-POP) 
     7794        (JUMP XEQUAL-0) 
     7795 
     7796XEQUAL-DIFFERENT-CARS 
     7797        (POPJ-AFTER-NEXT (PDL-BUFFER-POINTER) SUB PDL-BUFFER-POINTER (A-CONSTANT 2)) 
     7798       (NO-OP) 
     7799 
     7800XEQUAL-SLOW-RECURSE 
     7801        (CALL P3ZERO) 
     7802        ((ARG-CALL REF-SUPPORT-VECTOR) (I-ARG SVCEQL)) 
     7803        ((C-PDL-BUFFER-POINTER-PUSH) READ-MEMORY-DATA) 
     7804        ((C-PDL-BUFFER-POINTER-PUSH) M-T) 
     7805        ((C-PDL-BUFFER-POINTER-PUSH) M-B) 
     7806        ((ARG-CALL MMCALL) (I-ARG 2)) 
     7807        (JUMP XEQUAL-CDR) 
     7808 
     7809        ;;Numbers are EQUAL if = 
     7810XEQUAL-1 
     7811        (DISPATCH-XCT-NEXT Q-DATA-TYPE M-T POPJ-IF-NOT-NUMBER) 
     7812       ((M-A) (A-CONSTANT ARITH-2ARG-EQUAL)) 
     7813        ((M-GARBAGE) MICRO-STACK-DATA-POP) 
     7814        ((C-PDL-BUFFER-POINTER-PUSH) M-B) 
     7815        (DISPATCH-XCT-NEXT Q-DATA-TYPE M-B D-NUMARG1) 
     7816       (NO-OP) 
     7817        (JUMP XFALSE)                           ;Non-EQ fixnums 
     7818 
     7819XEQUAL-ARRAY 
     7820        ((VMA-START-READ) M-T) 
     7821        (CHECK-PAGE-READ) 
     7822        (DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA) 
     7823        ((M-1) (LISP-BYTE %%ARRAY-TYPE-FIELD) READ-MEMORY-DATA) 
     7824        (JUMP-EQUAL M-1 (A-CONSTANT (EVAL (LSH ART-STRING ARRAY-TYPE-SHIFT))) XEQUAL-STRING) 
     7825        (JUMP-NOT-EQUAL M-1 (A-CONSTANT (EVAL (LSH ART-FAT-STRING ARRAY-TYPE-SHIFT))) XFALSE) 
     7826XEQUAL-STRING 
     7827        ((VMA-START-READ) M-B) 
     7828        (CHECK-PAGE-READ) 
     7829        (DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA) 
     7830        ((M-2) (LISP-BYTE %%ARRAY-TYPE-FIELD) READ-MEMORY-DATA) 
     7831        (JUMP-EQUAL M-2 (A-CONSTANT (EVAL (LSH ART-STRING ARRAY-TYPE-SHIFT))) XEQUAL-STRING-1) 
     7832        (JUMP-NOT-EQUAL M-2 (A-CONSTANT (EVAL (LSH ART-FAT-STRING ARRAY-TYPE-SHIFT))) XFALSE) 
     7833XEQUAL-STRING-1 
     7834        ((C-PDL-BUFFER-POINTER-PUSH) A-T) 
     7835        ((C-PDL-BUFFER-POINTER-PUSH) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) ) 
     7836        ((C-PDL-BUFFER-POINTER-PUSH) A-B) 
     7837        ((C-PDL-BUFFER-POINTER-PUSH) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
     7838        ((C-PDL-BUFFER-POINTER-PUSH) A-V-NIL) 
     7839        (JUMP XSTRING-EQUAL)                    ;No XCT-NEXT here 
    70227840 
    70237841;;; ARRAYS 
     
    70537871;UPON RETURN FROM THE ARRAY-TYPE-REF-DISPATCH. 
    70547872 
     7873                (ERROR-TABLE RESTART BEGIN-QARYR)       ;For error handler 
    70557874QARYR   (CALL GAHD1)                            ;REFERENCE ARRAY 
    70567875        (CALL-NOT-EQUAL M-D A-R TRAP) 
     
    70587877        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP) 
    70597878                        Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM) 
    7060    (ERROR-TABLE ARGTYP FIXNUM PP NIL) 
     7879   (ERROR-TABLE ARGTYP FIXNUM PP NIL NIL AREF) 
    70617880        ((M-Q) Q-POINTER C-PDL-BUFFER-POINTER-POP) 
    70627881        (JUMP-NOT-EQUAL (A-CONSTANT 1) M-D QARY-MULTI)  ;MULTI DIM ARRAY 
     
    71057924        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP) 
    71067925                        Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM) 
    7107    (ERROR-TABLE ARGTYP FIXNUM PP NIL) 
     7926   (ERROR-TABLE ARGTYP FIXNUM PP NIL NIL AREF) 
    71087927        ((M-1) Q-POINTER C-PDL-BUFFER-POINTER-POP) 
    71097928        ((M-Q) ADD Q-R A-1)                     ;ADD NEXT SUBSCRIPT 
    71107929        (JUMP-EQUAL (A-CONSTANT 1) M-D QARY-M1) ;JUMP IF THROUGH, FINAL SUBSC IN M-Q 
    71117930        (JUMP QARY-MULTI-1) 
     7931                (ERROR-TABLE RESTART END-QARYR) 
    71127932 
    71137933GAHD4   (JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-STACK-GROUP)) GAHD1)    ;SG OK 
     
    71427962        (CALL GAHDRA) 
    71437963  (ERROR-TABLE CALLS-SUB ARRAY-LENGTH) 
     7964  (ERROR-TABLE ARG-POPPED 0 M-A) 
    71447965XAIXL1  (POPJ-IF-BIT-CLEAR-XCT-NEXT (LISP-BYTE %%ARRAY-DISPLACED-BIT) M-B) 
    71457966       ((M-T) DPB M-S Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
     
    71517972XAAIXL (MISC-INST-ENTRY ARRAY-ACTIVE-LENGTH) 
    71527973        (CALL GAHDRA) 
    7153    (ERROR-TABLE CALLS-SUB ARRAY-ACTIVE-LENGTH) 
     7974  (ERROR-TABLE CALLS-SUB ARRAY-ACTIVE-LENGTH) 
     7975  (ERROR-TABLE ARG-POPPED 0 M-A) 
    71547976        (JUMP-IF-BIT-CLEAR (LISP-BYTE %%ARRAY-LEADER-BIT) M-B XAIXL1) 
    71557977        ((VMA-START-READ) SUB M-A (A-CONSTANT 2))       ;Get fill pointer from leader 
    71567978        (CHECK-PAGE-READ) 
    71577979        ((M-TEM) Q-DATA-TYPE READ-MEMORY-DATA)          ;Fixnum there? 
    7158         (JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-FIX)) XAIXL2) ;Yes, it's the fill ptr 
     7980        (JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-FIX)) XAIXL2) ;Yes, it's the fill ptr 
    71597981        (JUMP XAIXL1)                                   ;No, don't use garbage as fill ptr 
    71607982 
     
    72278049        (JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-ARRAY-POINTER)) QDACM2) ;DOUBLE INDIRECT 
    72288050        (JUMP-XCT-NEXT QDACM1)                          ;JUST DISPLACED 
    7229        ((M-E) READ-MEMORY-DATA) 
     8051       ((M-E) Q-POINTER READ-MEMORY-DATA) 
    72308052 
    72318053QBARY   ((M-J) (BYTE-FIELD 2 0) M-Q)            ;BYTE ARRAY 
     
    72798101                (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
    72808102 
     8103QB16SRY ((A-TEM1) (BYTE-FIELD 27 1) M-Q)        ;HALFWORD FIXNUM ARRAY 
     8104        ((VMA-START-READ) ADD A-TEM1 M-E) 
     8105        (CHECK-PAGE-READ) 
     8106        (JUMP-IF-BIT-CLEAR-XCT-NEXT (BYTE-FIELD 1 0) M-Q A-ZERO QB16SRY-1) 
     8107       ((M-T) (BYTE-FIELD 16. 0) READ-MEMORY-DATA 
     8108                (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
     8109        ((M-T) (BYTE-FIELD 16. 16.) READ-MEMORY-DATA 
     8110                (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
     8111QB16SRY-1 
     8112        (POPJ-AFTER-NEXT POPJ-IF-BIT-CLEAR (BYTE-FIELD 1 15.) M-T) 
     8113       ((M-T) DPB (M-CONSTANT -1) (BYTE-FIELD 8 16.) A-T)       ;NEGATIVE--EXTEND SIGN 
     8114 
    72818115QQARY   ((VMA-START-READ) ADD A-Q M-E)          ;Q ARRAY 
    72828116        (CHECK-PAGE-READ) 
     
    72848118       ((M-T) Q-TYPED-POINTER READ-MEMORY-DATA) 
    72858119 
    7286 QFARY   ((M-TEM) ADD M-Q A-Q) 
     8120QFARY   ((M-TEM) ADD M-Q A-Q)                   ;FLOAT 
    72878121        ((VMA-START-READ) ADD M-E A-TEM) 
    72888122        (CHECK-PAGE-READ) 
     
    72978131        (CALL-XCT-NEXT FLOPACK) 
    72988132       ((M-1) READ-MEMORY-DATA) 
    7299         ((M-S) C-PDL-BUFFER-POINTER-POP) 
     8133QFARY1  ((M-S) C-PDL-BUFFER-POINTER-POP) 
    73008134        ((M-K) C-PDL-BUFFER-POINTER-POP) 
    73018135        ((M-I) C-PDL-BUFFER-POINTER-POP) 
    73028136        (POPJ-AFTER-NEXT (M-E) C-PDL-BUFFER-POINTER-POP) 
    73038137       ((M-B) C-PDL-BUFFER-POINTER-POP) 
     8138 
     8139QFFARY  ((VMA-START-READ) ADD M-Q A-E)          ;FPS-FLOAT 
     8140        (CHECK-PAGE-READ) 
     8141        ((C-PDL-BUFFER-POINTER-PUSH) M-B) 
     8142        ((C-PDL-BUFFER-POINTER-PUSH) M-E) 
     8143        ((C-PDL-BUFFER-POINTER-PUSH) M-I) 
     8144        ((C-PDL-BUFFER-POINTER-PUSH) M-K) 
     8145        ((C-PDL-BUFFER-POINTER-PUSH) M-S) 
     8146        ((M-TEM) (BYTE-FIELD 16. 16.) READ-MEMORY-DATA)         ;Swap halves 
     8147        ((M-TEM) DPB READ-MEMORY-DATA (BYTE-FIELD 16. 16.) A-TEM) 
     8148        ((M-1) DPB M-TEM (BYTE-FIELD 23. 7) (A-CONSTANT 1_30.)) ;Positive fraction 
     8149        ((M-I) (BYTE-FIELD 8 23.) M-TEM)        ;Excess-200 exponent 
     8150        (CALL-EQUAL-XCT-NEXT M-I A-ZERO FLZERO) ;0.0 is a special case 
     8151       ((M-I) ADD M-I (A-CONSTANT 1600))        ;Excess-2000 exponent 
     8152        (CALL-IF-BIT-SET (BYTE-FIELD 1 31.) M-TEM FNEG1) ;If negative, negate 
     8153        (JUMP-XCT-NEXT QFARY1)        
     8154       (CALL FLOPACK) 
    73048155 
    73058156   (MISC-INST-ENTRY GET-LOCATIVE-POINTER-INTO-ARRAY) 
     
    73328183 
    73338184     (MISC-INST-ENTRY G-L-P)            ;(G-L-P <ARRAY-POINTER-TO-ART-Q-LIST-ARRAY>) 
    7334 XGLPAR  (CALL-XCT-NEXT GAHD1)           ; RETURNS LIST POINTER TO ARRAY CONTENTS 
    7335        ((M-A) Q-TYPED-POINTER C-PDL-BUFFER-POINTER-POP) ;IF FILL-POINTER 0, RETURN NIL 
    7336   (ERROR-TABLE CALLS-SUB G-L-P) 
     8185XGLPAR  (CALL GAHDRA)                   ; RETURNS LIST POINTER TO ARRAY CONTENTS 
     8186    (ERROR-TABLE CALLS-SUB G-L-P)       ;IF FILL-POINTER 0, RETURN NIL 
     8187    (ERROR-TABLE ARG-POPPED 0 M-A) 
    73378188        (JUMP-IF-BIT-CLEAR M-B (LISP-BYTE %%ARRAY-LEADER-BIT) XGLPA2) ;JUMP ON NO LEADER 
    73388189        ((VMA-START-READ) SUB M-A (A-CONSTANT 2))       ;NO TRANSPORT SINCE JUST TOUCHED HDR 
     
    73418192        (JUMP-EQUAL M-TEM (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) XFALSE) 
    73428193XGLPA2  ((M-R) (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-LIST))) 
    7343         (JUMP-XCT-NEXT XGLPA1)  ;RETURN POINTER TO ELEMENT NUMBER 0 
     8194        (JUMP-XCT-NEXT XGLPA1)          ;RETURN POINTER TO ELEMENT NUMBER 0 
    73448195       ((M-Q) A-ZERO) 
    73458196 
    7346 ;Storing into arrays.  M-T has data to store, M-Q subscript, M-E etc. have GAHDR data 
     8197;Storing into arrays. 
     8198 
     8199(ERROR-TABLE DEFAULT-ARG-LOCATIONS XSTORE M-T) 
    73478200 
    73488201XXSTOR (MISC-INST-ENTRY XSTORE) 
     
    73518204       ((M-A) A-QLARYH) 
    73528205   (ERROR-TABLE CALLS-SUB STORE) 
     8206   (ERROR-TABLE ARG-POPPED 0 PP) 
    73538207        ((M-Q) DPB M-ZERO Q-ALL-BUT-POINTER A-QLARYL) 
    73548208        (CALL-IF-BIT-SET M-B (LISP-BYTE %%ARRAY-DISPLACED-BIT) DSP-ARRAY-SETUP) 
     8209   (ERROR-TABLE ARG-POPPED 0 PP) 
    73558210        (CALL-GREATER-OR-EQUAL M-Q A-S TRAP)    ;INDEX OUT OF BOUNDS 
    73568211   (ERROR-TABLE SUBSCRIPT-OOB M-Q M-S) 
     8212   (ERROR-TABLE ARG-POPPED 0 PP) 
    73578213        (DISPATCH-XCT-NEXT (LISP-BYTE %%ARRAY-TYPE-FIELD)  
    73588214                M-B ARRAY-TYPE-STORE-DISPATCH) 
     
    73608216       ((M-T) C-PDL-BUFFER-POINTER-POP) 
    73618217 
     8218;Store routines for various types of arrays, reached via ARRAY-TYPE-STORE-DISPATCH. 
     8219;M-T has data to store, M-Q subscript, M-E etc. have GAHDR data. 
    73628220 
    73638221;NOTE REFLECTING ABOUT 40 HACK NOT NECESSARY FOR DPB 
     
    74268284        (CHECK-PAGE-WRITE) 
    74278285        (POPJ) 
     8286 
     8287;FPS-FLOAT has less precision than Lisp machine float, so round. 
     8288QSFFARY ((M-J) M-I)                             ;Save M-I 
     8289        ((C-PDL-BUFFER-POINTER-PUSH) M-T)       ;Value being stored 
     8290        (CALL GET-FLONUM) 
     8291        ;Transfer sign bit to M-TEM and get magnitude of fraction 
     8292        (CALL-LESS-THAN-XCT-NEXT M-1 A-ZERO FNEG1) 
     8293       ((M-TEM) SELECTIVE-DEPOSIT M-1 (BYTE-FIELD 1 31.) A-ZERO) 
     8294        ;Round off fraction 
     8295        ((M-4) (BYTE-FIELD 7 0) M-1)            ;Discarded bits of fraction 
     8296        (CALL-EQUAL M-4 (A-CONSTANT 1_6) QSFFRY2)       ;Stable rounding 
     8297        ((M-1) ADD M-1 (A-CONSTANT 1_6)) 
     8298        (CALL-IF-BIT-SET (BYTE-FIELD 1 31.) M-1 QSFFRY3)        ;Renormalize 
     8299QSFFRY0 ((M-I) SUB M-I (A-CONSTANT 1600))       ;Get excess-200 exponent 
     8300        (JUMP-LESS-OR-EQUAL M-I A-ZERO QSFFRY1) ;Underflow or zero => zero 
     8301        ;Insert relevant fraction bits 
     8302        ((M-TEM) (BYTE-FIELD 23. 7) M-1 A-TEM) 
     8303        (JUMP-LESS-THAN-XCT-NEXT M-I (A-CONSTANT 400) QSFFRY1) 
     8304       ((M-TEM) DPB M-I (BYTE-FIELD 8 23.) A-TEM) 
     8305        ((M-TEM) DPB (M-CONSTANT -1) (BYTE-FIELD 31. 0) A-TEM)  ;Overflow => infinity 
     8306QSFFRY1 ((M-1) (BYTE-FIELD 16. 16.) M-TEM)      ;Swap halves 
     8307        ((WRITE-MEMORY-DATA) DPB M-TEM (BYTE-FIELD 16. 16.) A-1)         
     8308        ((VMA-START-WRITE) ADD M-E A-Q) 
     8309        (CHECK-PAGE-WRITE) 
     8310        (POPJ-AFTER-NEXT (M-I) M-J) 
     8311       (NO-OP) 
     8312 
     8313QSFFRY2 (POPJ-AFTER-NEXT POPJ-IF-BIT-SET (BYTE-FIELD 1 7) M-1) 
     8314        (JUMP QSFFRY0)                          ;If lsb 0, suppress adding 1 
     8315 
     8316QSFFRY3 (POPJ-AFTER-NEXT (M-1) (BYTE-FIELD 30. 1) M-1)  ;Shift fraction right 1 
     8317       ((M-I) ADD M-I (A-CONSTANT 1))           ;And increment exponent 
    74288318                                
     8319   (ERROR-TABLE DEFAULT-ARG-LOCATIONS ARRAY-PUSH PP M-T) 
    74298320   (MISC-INST-ENTRY ARRAY-PUSH) 
    74308321XFARY   ((M-T) C-PDL-BUFFER-POINTER-POP) 
    74318322        (CALL-XCT-NEXT GAHDR) 
    7432        ((M-A) C-PDL-BUFFER-POINTER-POP) 
     8323       ((M-A) C-PDL-BUFFER-POINTER) 
    74338324   (ERROR-TABLE CALLS-SUB ARRAY-PUSH) 
    74348325        (CALL-IF-BIT-CLEAR (LISP-BYTE %%ARRAY-LEADER-BIT) M-B TRAP) 
     
    74458336        (CALL-IF-BIT-SET (LISP-BYTE %%ARRAY-DISPLACED-BIT) M-B  
    74468337                         DSP-ARRAY-SETUP) 
    7447         (JUMP-GREATER-OR-EQUAL M-Q A-S XFALSE)  ;INDEX OUT OF BOUNDS, RETURN NIL, DON'T STORE 
     8338        (JUMP-GREATER-OR-EQUAL M-Q A-S POP-THEN-XFALSE) ;INDEX OUT OF BOUNDS, RETURN NIL, 
     8339                                                        ; DON'T STORE 
    74488340        ((VMA) SUB M-A (A-CONSTANT 2))          ;KNOW WILL WIN NOW, MUNG 
    74498341        ((WRITE-MEMORY-DATA-START-WRITE) ADD A-FARY-TEM M-ZERO ALU-CARRY-IN-ONE) 
     
    74528344                        ARRAY-TYPE-FILL-DISPATCH) 
    74538345   (ERROR-TABLE BAD-ARRAY-TYPE M-B) 
     8346        ; ((M-T) A-FARY-TEM) and discard top of stack. 
    74548347        (POPJ-AFTER-NEXT        ;RETURN ELEMENT NUMBER STORED INTO. 
    7455          (M-T) A-FARY-TEM) 
     8348         (M-T) SETA A-FARY-TEM C-PDL-BUFFER-POINTER-POP) 
    74568349       ((M-T) IOR (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX)) M-T) 
    74578350 
     
    74748367   (MISC-INST-ENTRY STORE-ARRAY-LEADER) 
    74758368XSALDR  (CALL XFLAD1)           ;STORE IN ARRAY LEADER 
     8369  (ERROR-TABLE CALLS-SUB STORE-ARRAY-LEADER) 
    74768370;NEEDS TRANSPORTER HACKERY HERE IF ONE-Q-FORWARD S IN ARRAY-LEADERS ARE TO BE SUPPORTED. 
    74778371        ((M-T WRITE-MEMORY-DATA-START-WRITE)  
     
    74898383       ((M-T) Q-TYPED-POINTER READ-MEMORY-DATA) 
    74908384 
     8385;Pop index and array off stack, and return in VMA the address 
     8386;of the slot in the leader specified by the index. 
    74918387XFLAD1  (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP) 
    74928388                  Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM) ;COMPUTE ADDRESS 
    74938389   (ERROR-TABLE ARGTYP FIXNUM PP 1) 
     8390   (ERROR-TABLE ARG-POPPED 0 PP PP) 
    74948391        ((M-Q) Q-POINTER C-PDL-BUFFER-POINTER-POP)              ;OR ARRAY LEADER ELEMENT 
    74958392        (CALL-XCT-NEXT GAHDR) 
    7496        ((M-A) C-PDL-BUFFER-POINTER-POP) 
     8393       ((M-A) C-PDL-BUFFER-POINTER) 
     8394   (ERROR-TABLE ARG-POPPED 0 M-Q) 
    74978395        (CALL-IF-BIT-CLEAR (LISP-BYTE %%ARRAY-LEADER-BIT) M-B TRAP)     ;NO LEADER 
    74988396   (ERROR-TABLE ARRAY-HAS-NO-LEADER M-A) 
    74998397   (ERROR-TABLE RESTART XFLAD1-A) 
     8398   (ERROR-TABLE ARG-POPPED 0 M-Q) 
    75008399        ((VMA-START-READ) SUB M-A (A-CONSTANT 1))       ;GET LENGTH OF ARRAY LEADER 
    75018400        (CHECK-PAGE-READ)       ;NO TRANSPORT SINCE JUST TOUCHED HEADER 
     
    75038402        (CALL-GREATER-OR-EQUAL M-Q A-TEM1 TRAP)         ;SUBSCRIPT OUT OF BOUNDS 
    75048403   (ERROR-TABLE SUBSCRIPT-OOB M-Q RMD XFLAD1-A) 
     8404   (ERROR-TABLE ARG-POPPED 0 M-Q) 
     8405        (C-PDL-BUFFER-POINTER-POP) 
    75058406        (POPJ-AFTER-NEXT (A-TEM1) ADD M-Q (A-CONSTANT 2)) 
    75068407       ((VMA) SUB M-A A-TEM1) 
     
    75098410        (CALL GAHDRA) 
    75108411  (ERROR-TABLE CALLS-SUB ARRAY-HAS-LEADER-P) 
     8412  ;; The following is ok because the arg is, unchanged, in M-A 
     8413  ;; at the time when GAHRDA might get an error, 
     8414  ;; and we don't need to worry about it after GAHDRA returns. 
     8415  (ERROR-TABLE ARG-POPPED 0 M-A) 
    75118416        (JUMP-IF-BIT-CLEAR (LISP-BYTE %%ARRAY-LEADER-BIT) M-B XFALSE) 
    75128417        (JUMP XTRUE) 
    75138418 
     8419;;;??? This is very hard. 
    75148420XAR1   (MISC-INST-ENTRY AR-1) 
    75158421        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP) 
     
    76338539       ((M-1) Q-POINTER M-1) 
    76348540 
     8541(ERROR-TABLE DEFAULT-ARG-LOCATIONS COPY-ARRAY-CONTENTS-AND-LEADER M-C M-T) 
     8542 
    76358543XCARCL (MISC-INST-ENTRY COPY-ARRAY-CONTENTS-AND-LEADER) 
    76368544        ((M-T) C-PDL-BUFFER-POINTER-POP)                ;TO 
     
    76608568;(COPY-ARRAY-PORTION FROM-ARRAY FROM-START FROM-END TO-ARRAY TO-START TO-END) 
    76618569;IF THE TO-LENGTH IS LONGER IT FILLS WITH 0 OR NIL 
     8570;;;??? This one is hard to remember the args for. 
    76628571XCAP (MISC-INST-ENTRY COPY-ARRAY-PORTION) 
    76638572        ((M-R) Q-POINTER C-PDL-BUFFER-POINTER-POP)      ;TO-END 
     
    76928601       ((M-A) M-T) 
    76938602  (ERROR-TABLE CALLS-SUB COPY-ARRAY-CONTENTS) 
     8603  (ERROR-TABLE ARG-POPPED 0 M-C M-T) 
    76948604        ((M-A) M-C)                                     ;FROM-ARRAY 
    76958605        ((M-R) M-S)                                     ;TO LENGTH 
     
    76998609       ((M-K) M-B)                                      ;TO ARRAY HEADER 
    77008610  (ERROR-TABLE CALLS-SUB COPY-ARRAY-CONTENTS) 
     8611  (ERROR-TABLE ARG-POPPED 0 M-A M-T) 
    77018612XCARC1  (JUMP-GREATER-OR-EQUAL M-I A-R XTRUE)           ;TO ARRAY DONE, RETURN 
    77028613        (JUMP-GREATER-OR-EQUAL M-Q A-S XCARC3)          ;JUMP IF FROM ARRAY EXHAUSTED 
     
    77048615                (LISP-BYTE %%ARRAY-TYPE-FIELD) M-B ARRAY-TYPE-REF-DISPATCH) 
    77058616   (ERROR-TABLE BAD-ARRAY-TYPE M-B) 
    7706 XCARC4 ((C-PDL-BUFFER-POINTER-PUSH) M-Q) 
    7707         ((C-PDL-BUFFER-POINTER-PUSH) M-E) 
     8617XCARC4 ((C-PDL-BUFFER-POINTER-PUSH) Q-POINTER M-Q 
     8618                        (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
     8619        ((M-D) M-E) 
    77088620        ((M-Q) M-I) 
    77098621        ((MICRO-STACK-DATA-PUSH) (A-CONSTANT (I-MEM-LOC XCARC5))) 
     
    77128624       ((M-E) M-C) 
    77138625XCARC5  ((M-I) ADD M-I (A-CONSTANT 1)) 
    7714         ((M-E) C-PDL-BUFFER-POINTER-POP) 
     8626        ((M-Q) Q-POINTER C-PDL-BUFFER-POINTER-POP) 
     8627        ((M-Q) ADD M-Q (A-CONSTANT 1)) 
    77158628        (JUMP-XCT-NEXT XCARC1) 
    7716        ((M-Q) ADD C-PDL-BUFFER-POINTER-POP (A-CONSTANT 1)) 
     8629       ((M-E) M-D) 
    77178630 
    77188631;COMPUTE FILLER VALUE IN M-T, REENTER AT XCARC4 
     
    77398652       ((M-Q) A-ZERO) 
    77408653        (JUMP DSP-ARRAY-SETUP) 
     8654 
     8655;(%BLT from-address to-address n-words increment) 
     8656;Increment is usually 1, less often -1 for backwards blt. 
     8657XBLT (MISC-INST-ENTRY %BLT) 
     8658        ((M-D) Q-POINTER C-PDL-BUFFER-POINTER-POP) 
     8659        ((M-C) Q-POINTER C-PDL-BUFFER-POINTER-POP) 
     8660        ((M-B) Q-POINTER C-PDL-BUFFER-POINTER-POP) 
     8661        ((M-A) Q-POINTER C-PDL-BUFFER-POINTER-POP) 
     8662        ((M-B) SUB M-B A-D) 
     8663        ((M-A) SUB M-A A-D) 
     8664XBLT1   (JUMP-EQUAL M-C (A-CONSTANT 0) XFALSE) 
     8665        ((VMA-START-READ M-A) ADD M-A A-D) 
     8666        (CHECK-PAGE-READ) 
     8667        ((VMA-START-WRITE M-B) ADD M-B A-D) 
     8668        (CHECK-PAGE-WRITE) 
     8669        (JUMP-XCT-NEXT XBLT1) 
     8670       ((M-C) SUB M-C (A-CONSTANT 1)) 
    77418671 
    77428672XNUMBP (MISC-INST-ENTRY NUMBERP) 
     
    77458675       ((M-T) A-V-NIL) 
    77468676        (JUMP XTRUE) 
     8677 
     8678XFIXP (MISC-INST-ENTRY FIXP) 
     8679        ((M-T) C-PDL-BUFFER-POINTER-POP) 
     8680XTFIXP  ((M-TEM) Q-DATA-TYPE M-T) 
     8681        (JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-FIX)) XTRUE) 
     8682        ((M-4) (A-CONSTANT (EVAL %HEADER-TYPE-BIGNUM))) 
     8683XFXFLP  (JUMP-NOT-EQUAL M-TEM (A-CONSTANT (EVAL DTP-EXTENDED-NUMBER)) XFALSE) 
     8684        ((VMA-START-READ) M-T) 
     8685        (CHECK-PAGE-READ) 
     8686        ((M-T) A-V-TRUE) 
     8687        (DISPATCH TRANSPORT-HEADER READ-MEMORY-DATA) 
     8688        (POPJ-AFTER-NEXT (M-TEM) (LISP-BYTE %%HEADER-TYPE-FIELD) READ-MEMORY-DATA) 
     8689       (CALL-NOT-EQUAL M-TEM A-4 XFALSE) 
     8690 
     8691XFLTP (MISC-INST-ENTRY FLOATP) 
     8692        ((M-T) C-PDL-BUFFER-POINTER-POP) 
     8693XTFLTP  ((M-TEM) Q-DATA-TYPE M-T) 
     8694        (JUMP-EQUAL M-TEM (A-CONSTANT (EVAL DTP-SMALL-FLONUM)) XTRUE) 
     8695        (JUMP-XCT-NEXT XFXFLP) 
     8696       ((M-4) (A-CONSTANT (EVAL %HEADER-TYPE-FLONUM))) 
    77478697 
    77488698XDATTP (MISC-INST-ENTRY %DATA-TYPE) 
     
    77778727       (NO-OP) 
    77788728 
     8729(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-LDB-OFFSET PP M-C M-B) 
     8730 
    77798731XOPLDB(MISC-INST-ENTRY %P-LDB-OFFSET) 
    77808732        (JUMP-XCT-NEXT XOPLD1)                  ;JOIN XLDB, BUT FIRST 
    77818733       (CALL XOMR0)                             ;REFERENCE THE LOCATION 
    77828734 
     8735(ERROR-TABLE DEFAULT-ARG-LOCATIONS %LOGLDB PP M-1) 
     8736 
    77838737XLLDB (MISC-INST-ENTRY %LOGLDB)                 ;LDB FOR FIXNUMS 
    77848738        (JUMP-XCT-NEXT XLLDB1) 
    77858739       ((M-1) Q-POINTER C-PDL-BUFFER-POINTER-POP) 
     8740 
     8741(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-LDB PP VMA) 
    77868742 
    77878743;%P-LDB treats target Q just as 32 bits.  Data type is not interpreted. 
     
    78178773        (DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG)  ;Only the second operand is 
    78188774            (ERROR-TABLE ARGTYP NUMBER PP 1 XLDB)   ;processed via NUMARG.  Thus LDB is 
     8775            (ERROR-TABLE ARG-POPPED 0 PP PP) 
    78198776       ((M-A) (A-CONSTANT ARITH-1ARG-LDB))          ;considered to be a one operand op. 
     8777                (ERROR-TABLE RESTART XLDB0) 
    78208778        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)   ;Arg1, byte pointer.  Must be fixnum. 
    78218779                        Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM) 
    7822             (ERROR-TABLE ARGTYP FIXNUM PP 0) 
     8780            (ERROR-TABLE ARGTYP FIXNUM PP 0 XLDB0) 
     8781            (ERROR-TABLE ARG-POPPED 0 PP (FIXPACK M-1)) 
    78238782;Fixnum case.  Data to LDB out of (arg2) sign extended in M-1. 
    78248783        ((M-K) (BYTE-FIELD 6 0) C-PDL-BUFFER-POINTER)    ;Get number of bits 
     
    78278786                                           ; but if we didnt, it would cause lossage) 
    78288787        (CALL-GREATER-THAN M-K (A-CONSTANT 23.) TRAP) 
    7829     (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0) 
     8788    (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0 XLDB0) 
     8789    (ERROR-TABLE ARG-POPPED 0 PP (FIXPACK M-1)) 
    78308790        ((M-J) SUB M-K (A-CONSTANT 1))     ;Byte length minus one field 
    78318791        ((M-E) (BYTE-FIELD (DIFFERENCE 23. 6) 6) 
     
    78458805 
    78468806BIGNUM-LDB      ;M-Q has bignum, M-C has bignum header, M-I has length of bignum. 
     8807                (ERROR-TABLE RESTART BIGNUM-LDB) 
    78478808        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)   ;Arg1, byte pointer.  Must be fixnum. 
    78488809                        Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM) 
    7849             (ERROR-TABLE ARGTYP FIXNUM PP 0) 
     8810            (ERROR-TABLE ARGTYP FIXNUM PP 0 BIGNUM-LDB) 
     8811            (ERROR-TABLE ARG-POPPED 0 PP M-Q) 
    78508812        ((M-K) (BYTE-FIELD 6 0) C-PDL-BUFFER-POINTER)    ;Get number of bits 
    78518813        (CALL-GREATER-THAN M-K (A-CONSTANT 23.) TRAP) 
    7852             (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0) 
     8814            (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0 BIGNUM-LDB) 
     8815            (ERROR-TABLE ARG-POPPED 0 PP M-Q) 
    78538816        ((M-E) (BYTE-FIELD (DIFFERENCE 23. 6) 6) 
    78548817                         C-PDL-BUFFER-POINTER)  ;Number of places over 
     
    79578920       ((M-1) BYTE-INST M-1 A-ZERO)             ;RIGHT ADJUST BITS IN M-1 FOR NEXT TIME. 
    79588921 
     8922(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-DPB-OFFSET PP PP M-C M-B) 
     8923 
    79598924XOPDPB(MISC-INST-ENTRY %P-DPB-OFFSET) 
    79608925        (JUMP-XCT-NEXT XOPDP1)                  ;JOIN XDPB, BUT FIRST 
    79618926       (CALL XOMR0)                             ;REFERENCE THE DATA AND SET VMA 
     8927 
     8928(ERROR-TABLE DEFAULT-ARG-LOCATIONS %LOGDPB M-1 (+ (LSH M-E 6) M-K) M-2) 
    79628929 
    79638930XLDPB (MISC-INST-ENTRY %LOGDPB)    ;DPB FOR FIXNUMS ONLY, CAN STORE INTO SIGN BIT 
     
    79718938          (M-T) DPB M-2 Q-POINTER (A-CONSTANT (BYTE-VALUE Q-DATA-TYPE DTP-FIX))) 
    79728939       (NO-OP) 
     8940 
     8941(ERROR-TABLE DEFAULT-ARG-LOCATIONS %P-DPB PP PP VMA) 
    79738942 
    79748943XPDPB (MISC-INST-ENTRY %P-DPB) 
     
    79918960; DPB never changes the sign of quantity DPB'ed into, it extends 
    79928961; the sign arbitrarily far to the left past the byte. 
    7993 XDPB (MISC-INST-ENTRY DPB) (ERROR-TABLE RESTART DPB) 
     8962XDPB (MISC-INST-ENTRY DPB) (ERROR-TABLE RESTART XDPB) 
    79948963        ((PDL-BUFFER-INDEX) SUB PDL-BUFFER-POINTER (A-CONSTANT 2))      ;ADDRESS ARG1 
    79958964        (DISPATCH Q-DATA-TYPE C-PDL-BUFFER-INDEX TRAP-UNLESS-FIXNUM)    ;MAKE SURE NOT BIGNUM 
    7996     (ERROR-TABLE ARGTYP FIXNUM (PP -2) 0) 
     8965    (ERROR-TABLE ARGTYP FIXNUM (PP -2) 0 XDPB) 
     8966    (ERROR-TABLE ARG-POPPED 0 PP PP PP) 
    79978967        (DISPATCH Q-DATA-TYPE C-PDL-BUFFER-POINTER D-NUMARG) ;ONLY THE THIRD OPERAND IS  
    79988968            (ERROR-TABLE ARGTYP NUMBER PP T XDPB)  ;PROCESSED VIA NUMARG. THUS DPB IS A 
     8969            (ERROR-TABLE ARG-POPPED 0 PP PP PP) 
    79998970       ((M-A) (A-CONSTANT ARITH-1ARG-DPB))         ;ONE OPERAND OP. 
    80008971;FIXNUM CASE.  DATA TO DPB INTO (ARG3) SIGN EXTENDED IN M-1. 
     8972                (ERROR-TABLE RESTART XDPB0) 
    80018973        (DISPATCH (I-ARG DATA-TYPE-INVOKE-OP)            ;ARG2, BYTE POINTER 
    80028974                        Q-DATA-TYPE C-PDL-BUFFER-POINTER TRAP-UNLESS-FIXNUM) 
    8003    (ERROR-TABLE ARGTYP FIXNUM PP 1) 
     8975    (ERROR-TABLE ARGTYP FIXNUM PP 1 XDPB0) 
     8976    (ERROR-TABLE ARG-POPPED 0 PP PP M-1) 
    80048977        ((M-K) (BYTE-FIELD 6 0) C-PDL-BUFFER-POINTER) ;GET NUMBER OF BITS 
    80058978        (JUMP-EQUAL M-K A-ZERO XDPB-ZERO) 
    80068979        (CALL-GREATER-THAN M-K (A-CONSTANT 23.) TRAP) 
    8007             (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0) 
     8980    (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0 XDPB0) 
     8981    (ERROR-TABLE ARG-POPPED 0 PP PP M-1) 
    80088982        ((M-E) (BYTE-FIELD (DIFFERENCE 23. 6) 6) 
    80098983                        C-PDL-BUFFER-POINTER-POP) ;GET NUMBER OF PLACES OVER 
    8010 ASHDPB  ((M-J) SUB M-K (A-CONSTANT 1)) 
    8011         ((M-2) ADD M-K A-E) 
    8012         (JUMP-GREATER-THAN M-2 (A-CONSTANT 31.) XDPB2A) 
    8013         ((OA-REG-LOW) DPB M-J OAL-BYTL-1 A-E)           ;Will fit in machine 
    8014         ((M-1) DPB C-PDL-BUFFER-POINTER-POP A-1)        ; word so go ahead 
    8015         (JUMP RETURN-M-1) 
     8984ASHDPB  ((M-2) ADD M-K A-E)                     ;M-2 maximum number of bits in result 
     8985        (JUMP-GREATER-THAN M-2 (A-CONSTANT 32.) XDPB2A) ;Multi-word => use bignum code  
     8986        (JUMP-LESS-THAN-XCT-NEXT M-1 A-ZERO ASHDPB-NEG) 
     8987       ((M-J) SUB M-K (A-CONSTANT 1))           ;Single-word => use hardware DPB 
     8988        ((OA-REG-LOW) DPB M-J OAL-BYTL-1 A-E) 
     8989        ((M-1) DPB C-PDL-BUFFER-POINTER-POP A-1) 
     8990        (JUMP-GREATER-OR-EQUAL M-1 A-ZERO RETURN-M-1)   ;Result in M-1 if sign didn't change 
     8991        ((M-C) A-ZERO)                          ;Else it's a 2-word bignum 
     8992        (JUMP-XCT-NEXT OVERFLOW-BIGNUM-CREATE) 
     8993       ((M-2) A-ZERO) 
     8994 
     8995ASHDPB-NEG                                      ;Single-word DPB into negative number 
     8996        ((OA-REG-LOW) DPB M-J OAL-BYTL-1 A-E) 
     8997        ((M-1) DPB C-PDL-BUFFER-POINTER-POP A-1) 
     8998        (JUMP-LESS-THAN M-1 A-ZERO RETURN-M-1)  ;Result in M-1 if sign didn't change 
     8999        ((M-1) SUB M-ZERO A-1)                  ;Else it's a 2-word bignum 
     9000        (JUMP-NOT-EQUAL-XCT-NEXT M-1 A-ZERO OVERFLOW-BIGNUM-CREATE-NEGATIVE) 
     9001       ((M-2) A-ZERO) 
     9002        (JUMP-XCT-NEXT OVERFLOW-BIGNUM-CREATE-NEGATIVE) 
     9003       ((M-2) (A-CONSTANT 1)) 
    80169004 
    80179005;Get here on DPB ing into fixnum at position beyond 31. bits.  Fake up bignum 
     
    80369024        (CALL-GREATER-THAN M-K (A-CONSTANT 23.) TRAP) 
    80379025            (ERROR-TABLE ARGTYP FIXNUM-FIELD PP 0) 
     9026            (ERROR-TABLE ARG-POPPED PP PP M-T) 
    80389027        (CALL-IF-BIT-SET BIGNUM-HEADER-SIGN M-C BIGNEG) ;GET 2'S COMPLEMENT REPRESENTATION 
    80399028        ((M-E) (BYTE-FIELD (DIFFERENCE 23. 6) 6) 
     
    80469035       ((M-E) SUB M-E (A-CONSTANT 31.)) 
    80479036        (CALL TRAP) 
    8048            (ERROR-TABLE BIGNUM-NOT-BIG-ENUF-DPB)        ;SHOULDN'T HAPPEN 
     9037           (ERROR-TABLE BIGNUM-NOT-BIG-ENOUGH-DPB)      ;SHOULDN'T HAPPEN 
    80499038 
    80509039BIGDPB1 ((VMA-START-READ) ADD M-T A-D)    ;FETCH WORD OF BIGNUM