r413 - in trunk/lisp: cold io sys sys2
rswindells at common-lisp.net
rswindells at common-lisp.net
Wed May 22 23:03:22 UTC 2013
Author: rswindells
Date: Wed May 22 16:03:22 2013
New Revision: 413
Log:
Remove Q-FLAG-BIT.
Modified:
trunk/lisp/cold/defmic.lisp
trunk/lisp/cold/global.lisp
trunk/lisp/cold/qcom.lisp
trunk/lisp/cold/qdefs.lisp
trunk/lisp/io/unibus.lisp
trunk/lisp/sys/qfasl.lisp
trunk/lisp/sys/qfctns.lisp
trunk/lisp/sys/qlf.lisp
trunk/lisp/sys/qmisc.lisp
trunk/lisp/sys/qrand.lisp
trunk/lisp/sys2/qfasd.lisp
Modified: trunk/lisp/cold/defmic.lisp
==============================================================================
--- trunk/lisp/cold/defmic.lisp Wed May 22 15:54:41 2013 (r412)
+++ trunk/lisp/cold/defmic.lisp Wed May 22 16:03:22 2013 (r413)
@@ -155,12 +155,12 @@
(DEFMIC LIST* 437 (FIRST &REST ELEMENTS) T T) ;"(&REST ELEMENTS LAST)"
(DEFMIC LIST-IN-AREA 440 (AREA &REST ELEMENTS) T T)
(DEFMIC LIST*-IN-AREA 441 (AREA FIRST &REST ELEMENTS) T T) ;"(AREA &REST ELEMENTS LAST)"
-(DEFMIC %P-FLAG-BIT 442 (POINTER) T)
+;442 FREE
(DEFMIC %P-CDR-CODE 443 (POINTER) T)
(DEFMIC %P-DATA-TYPE 444 (POINTER) T)
(DEFMIC %P-POINTER 445 (POINTER) T)
(DEFMIC %PAGE-TRACE 446 (TABLE) T)
-(DEFMIC %P-STORE-FLAG-BIT 447 (POINTER FLAG-BIT) T)
+;447 FREE
(DEFMIC %P-STORE-CDR-CODE 450 (POINTER CDR-CODE) T)
(DEFMIC %P-STORE-DATA-TYPE 451 (POINTER DATA-TYPE) T)
(DEFMIC %P-STORE-POINTER 452 (POINTER POINTER) T)
@@ -320,9 +320,6 @@
(DEFMIC %AOS-TRIANGLE 706 (X1 Y1 X2 Y2 X3 Y3 INCREMENT SHEET) T)
(DEFMIC %SET-MOUSE-SCREEN 707 (SHEET) T)
(DEFMIC %OPEN-MOUSE-CURSOR 710 () T)
-(defmic %ether-wakeup 711 (reset-p) t)
-(defmic %checksum-pup 712 (art-16b-pup start length) t)
-(defmic %decode-pup 713 (art-byte-pup start length state super-image-p) t)
; FROM HERE TO 777 FREE
Modified: trunk/lisp/cold/global.lisp
==============================================================================
--- trunk/lisp/cold/global.lisp Wed May 22 15:54:41 2013 (r412)
+++ trunk/lisp/cold/global.lisp Wed May 22 16:03:22 2013 (r413)
@@ -33,7 +33,6 @@
%%Q-ALL-BUT-TYPED-POINTER
%%Q-CDR-CODE
%%Q-DATA-TYPE
- %%Q-FLAG-BIT
%%Q-HIGH-HALF
%%Q-LOW-HALF
%%Q-POINTER
@@ -75,7 +74,6 @@
%P-DEPOSIT-FIELD-OFFSET
%P-DPB
%P-DPB-OFFSET
- %P-FLAG-BIT
%P-LDB
%P-LDB-OFFSET
%P-MASK-FIELD
@@ -85,7 +83,6 @@
%P-STORE-CONTENTS
%P-STORE-CONTENTS-OFFSET
%P-STORE-DATA-TYPE
- %P-STORE-FLAG-BIT
%P-STORE-POINTER
%P-STORE-TAG-AND-POINTER
%POINTER
@@ -720,7 +717,6 @@
MIN
MINUS
MINUSP
- MONITOR-VARIABLE
MULTIPLE-VALUE
MULTIPLE-VALUE-BIND
MULTIPLE-VALUE-CALL
@@ -1058,7 +1054,6 @@
UNDELETEF
UNION
UNLESS
- UNMONITOR-VARIABLE
UNSPECIAL
UNTRACE
UNWIND-PROTECT
Modified: trunk/lisp/cold/qcom.lisp
==============================================================================
--- trunk/lisp/cold/qcom.lisp Wed May 22 15:54:41 2013 (r412)
+++ trunk/lisp/cold/qcom.lisp Wed May 22 16:03:22 2013 (r413)
@@ -180,7 +180,8 @@
; Byte pointers at the parts of a Q or other thing, and their values.
; Q-FIELD-VALUES does NOT itself go into the cold load.
-(SETQ Q-FIELD-VALUES '(%%Q-CDR-CODE 3602 %%Q-FLAG-BIT 3501
+(SETQ Q-FIELD-VALUES '(%%Q-CDR-CODE 3602
+ ;%%Q-FLAG-BIT 3501
%%Q-DATA-TYPE 3005 %%Q-POINTER 0030 %%Q-POINTER-WITHIN-PAGE 0007
%%Q-TYPED-POINTER 0035 %%Q-ALL-BUT-TYPED-POINTER 3503
%%Q-ALL-BUT-POINTER 3010 %%Q-ALL-BUT-CDR-CODE 0036
@@ -195,7 +196,7 @@
(ASSIGN-ALTERNATE Q-FIELD-VALUES)
(SETQ Q-FIELDS (GET-ALTERNATE Q-FIELD-VALUES))
-(SETQ %Q-FLAG-BIT (DPB -1 %%Q-FLAG-BIT 0)) ;USED BY QLF IN COLD MODE
+;(SETQ %Q-FLAG-BIT (DPB -1 %%Q-FLAG-BIT 0)) ;USED BY QLF IN COLD MODE
;;; Stuff in the REGION-BITS array, some of these bits also appear in the
;;; map in the same orientation.
@@ -365,11 +366,20 @@
ADI-ST-MAKE-LIST ADI-ST-INDIRECT))
(SETQ ADI-FIELD-VALUES '(%%ADI-TYPE 2403 %%ADI-RET-STORING-OPTION 2103
+ %%ADI-PREVIOUS-ADI-FLAG 3601 ;Overlaps cdr-code
%%ADI-RET-SWAP-SV 2001 %%ADI-RET-NUM-VALS-EXPECTING 0006
%%ADI-RPC-MICRO-STACK-LEVEL 0006))
(ASSIGN-ALTERNATE ADI-FIELD-VALUES)
(SETQ ADI-FIELDS (GET-ALTERNATE ADI-FIELD-VALUES))
+;;; These overlap the cdr-code field, which is not used in the special pdl.
+(SETQ SPECPDL-FIELD-VALUES '(
+ %%SPECPDL-BLOCK-START-FLAG 3601 ;Flag is set on first binding of each block of bindings
+ %%SPECPDL-CLOSURE-BINDING 3701 ;Flag is set on bindings made "before" entering function
+ ))
+(ASSIGN-ALTERNATE SPECPDL-FIELD-VALUES)
+(SETQ SPECPDL-FIELDS (GET-ALTERNATE SPECPDL-FIELD-VALUES))
+
; LINEAR-PDL-QS and LINEAR-PDL-FIELDS, and their elements, go in the real machine.
(SETQ LINEAR-PDL-QS '(%LP-FEF %LP-ENTRY-STATE %LP-EXIT-STATE %LP-CALL-STATE))
;THESE ARE ASSIGNED VALUES STARTING WITH 0 AND INCREMENTING BY -1
@@ -578,7 +588,6 @@
; DEFINITIONS OF FIELDS IN PAGE HASH TABLE
;WORD 1
- %%PHT1-SCAVENGER-WS-FLAG %%Q-FLAG-BIT ;IF SET, PAGE IN SCAVENGER WORKING SET.
%%PHT1-VIRTUAL-PAGE-NUMBER 1020 ;ALIGNED SAME AS VMA
%PHT-DUMMY-VIRTUAL-ADDRESS 177777 ;ALL ONES MEANS THIS IS DUMMY ENTRY
;WHICH JUST REMEMBERS A FREE CORE PAGE
@@ -597,6 +606,7 @@
; OR NOMINALLY READ-WRITE-FIRST.
%%PHT1-VALID-BIT 0601 ;1 IF THIS HASH TABLE SLOT IS OCCUPIED.
+ %%PHT1-SCAVENGER-WS-FLAG 0701 ;IF SET, PAGE IN SCAVENGER WORKING SET.
;PHT WORD 2. THIS IS IDENTICAL TO THE LEVEL-2 MAP
%%PHT2-META-BITS 1606 ;SEE %%REGION-MAP-BITS
@@ -932,6 +942,32 @@
(ASSIGN-VALUES-INIT-DELTA UNIBUS-CHANNEL-QS 0 1 1)
+;;; Extra bits in the %UNIBUS-CHANNEL-CSR-BITS word.
+;;; Only the bottom 16 bits actually have to do with the device's CSR register
+;;; (which is only 16 bits long).
+(SETQ UNIBUS-CSR-BIT-VALUES '(
+ %%UNIBUS-CSR-OUTPUT 2001 ;This is an output device.
+ %%UNIBUS-CSR-TIMESTAMPED 2101 ;Store timestamp with each input char;
+ ; for output, delay till timestamp is reached.
+ %%UNIBUS-CSR-TWO-DATA-REGISTERS 2201 ;Device has two 16-bit data registers;
+ ; assume lower unibus addr has low bits.
+ %%UNIBUS-CSR-SB-ENABLE 2301 ;Enable sequence break (input only).
+ %%UNIBUS-CSR-SET-BITS-P 2401 ;** %UNIBUS-CHANNEL-CSR-SET-BITS is
+ ; significant.
+ %%UNIBUS-CSR-CLEAR-BITS-P 2501 ;** %UNIBUS-CHANNEL-CSR-CLEAR-BITS is
+ ; significant.
+ ))
+(ASSIGN-ALTERNATE UNIBUS-CSR-BIT-VALUES)
+
+(SETQ UNIBUS-CSR-BITS '(
+ %%UNIBUS-CSR-OUTPUT
+ %%UNIBUS-CSR-TIMESTAMPED
+ %%UNIBUS-CSR-TWO-DATA-REGISTERS
+ %%UNIBUS-CSR-SB-ENABLE
+ %%UNIBUS-CSR-SET-BITS-P
+ %%UNIBUS-CSR-CLEAR-BITS-P
+ ))
+
;;; Definitions for Chaos net hardware and microcode
;;; Command/Status register fields
Modified: trunk/lisp/cold/qdefs.lisp
==============================================================================
--- trunk/lisp/cold/qdefs.lisp Wed May 22 15:54:41 2013 (r412)
+++ trunk/lisp/cold/qdefs.lisp Wed May 22 16:03:22 2013 (r413)
@@ -22,8 +22,10 @@
SG-STATE-FIELDS SG-INST-DISPATCHES
SYSTEM-COMMUNICATION-AREA-QS PAGE-HASH-TABLE-FIELDS
Q-FIELDS Q-AREA-SWAP-BITS MICRO-STACK-FIELDS M-FLAGS-FIELDS M-ERROR-SUBSTATUS-FIELDS
+ SPECPDL-FIELDS
LINEAR-PDL-FIELDS LINEAR-PDL-QS HARDWARE-MEMORY-SIZES
DISK-RQ-LEADER-QS DISK-RQ-HWDS DISK-HARDWARE-SYMBOLS UNIBUS-CHANNEL-QS
+ UNIBUS-CSR-BITS
CHAOS-BUFFER-LEADER-QS CHAOS-HARDWARE-SYMBOLS
ETHER-BUFFER-LEADER-QS ETHER-HARDWARE-SYMBOLS ETHER-REGISTER-OFFSETS
INSTANCE-DESCRIPTOR-OFFSETS
@@ -55,6 +57,7 @@
Q-FIELDS Q-AREA-SWAP-BITS MICRO-STACK-FIELDS M-FLAGS-FIELDS M-ERROR-SUBSTATUS-FIELDS
LINEAR-PDL-FIELDS LINEAR-PDL-QS HARDWARE-MEMORY-SIZES
DISK-RQ-LEADER-QS DISK-RQ-HWDS DISK-HARDWARE-SYMBOLS UNIBUS-CHANNEL-QS
+ UNIBUS-CSR-BITS
CHAOS-BUFFER-LEADER-QS CHAOS-HARDWARE-SYMBOLS
ETHER-BUFFER-LEADER-QS ETHER-HARDWARE-SYMBOLS ETHER-REGISTER-OFFSETS
INSTANCE-DESCRIPTOR-OFFSETS
Modified: trunk/lisp/io/unibus.lisp
==============================================================================
--- trunk/lisp/io/unibus.lisp Wed May 22 15:54:41 2013 (r412)
+++ trunk/lisp/io/unibus.lisp Wed May 22 16:03:22 2013 (r413)
@@ -44,7 +44,7 @@
(%P-DPB-OFFSET (VIRTUAL-UNIBUS-ADDRESS DATA-ADDRESS) %%Q-POINTER
CHAN %UNIBUS-CHANNEL-DATA-ADDRESS)
(AND (= N-DATA-WORDS 2)
- (%P-DPB-OFFSET 1 %%Q-FLAG-BIT CHAN %UNIBUS-CHANNEL-DATA-ADDRESS))
+ (%P-DPB-OFFSET 1 %%UNIBUS-CSR-TWO-DATA-REGISTERS CHAN %UNIBUS-CHANNEL-DATA-ADDRESS))
(COND (OUTPUT-TURNOFF-UNIBUS-ADDRESS
(%P-DPB-OFFSET (VIRTUAL-UNIBUS-ADDRESS OUTPUT-TURNOFF-UNIBUS-ADDRESS) %%Q-POINTER
CHAN %UNIBUS-CHANNEL-OUTPUT-TURNOFF-ADDRESS)
Modified: trunk/lisp/sys/qfasl.lisp
==============================================================================
--- trunk/lisp/sys/qfasl.lisp Wed May 22 15:54:41 2013 (r412)
+++ trunk/lisp/sys/qfasl.lisp Wed May 22 16:03:22 2013 (r413)
@@ -588,7 +588,7 @@
(SETQ OBJ (%MAKE-POINTER-OFFSET DTP-LOCATIVE OBJ OFFSET)))
(%P-STORE-CONTENTS-OFFSET OBJ FEF I) ;STORE IT
(%P-DPB-OFFSET (LSH TEM -6) %%Q-CDR-CODE FEF I) ;MUNG CDR CODE
- (%P-DPB-OFFSET (LSH TEM -5) %%Q-FLAG-BIT FEF I) ;MUNG FLAG BIT
+; (%P-DPB-OFFSET (LSH TEM -5) %%Q-FLAG-BIT FEF I) ;MUNG FLAG BIT
(AND (BIT-TEST 20 TEM) ;MAKE INTO EXTERNAL VALUE CELL POINTER
(%P-DPB-OFFSET DTP-EXTERNAL-VALUE-CELL-POINTER
%%Q-DATA-TYPE FEF I))
Modified: trunk/lisp/sys/qfctns.lisp
==============================================================================
--- trunk/lisp/sys/qfctns.lisp Wed May 22 15:54:41 2013 (r412)
+++ trunk/lisp/sys/qfctns.lisp Wed May 22 16:03:22 2013 (r413)
@@ -1739,7 +1739,7 @@
(%P-LDB-OFFSET %%ARRAY-NUMBER-DIMENSIONS ARRAY 0)))
(AND (= (%P-LDB-OFFSET %%ARRAY-DISPLACED-BIT ARRAY 0) 1)
(= (%P-LDB-OFFSET %%Q-DATA-TYPE ARRAY OFFSET) DTP-ARRAY-POINTER)
- (= (%P-LDB-OFFSET %%Q-FLAG-BIT ARRAY OFFSET) 1)))
+ (= (%P-LDB-OFFSET %%ARRAY-INDEX-LENGTH-IF-SHORT ARRAY 0) 3)))
(DEFUN ARRAY ("E X TYPE &EVAL &REST DIMLIST)
(APPLY (FUNCTION *ARRAY) (CONS X (CONS TYPE DIMLIST))))
Modified: trunk/lisp/sys/qlf.lisp
==============================================================================
--- trunk/lisp/sys/qlf.lisp Wed May 22 15:54:41 2013 (r412)
+++ trunk/lisp/sys/qlf.lisp Wed May 22 16:03:22 2013 (r413)
@@ -109,7 +109,7 @@
%ARG-DESC-FEF-QUOTE-HAIR %ARG-DESC-FEF-BIND-HAIR
%ARG-DESC-QUOTED-REST %ARG-DESC-EVALED-REST
LAP-OUTPUT-BLOCK LAP-OUTPUT-BLOCK-LENGTH LAP-STORE-POINTER LAP-MACRO-FLAG
- %Q-FLAG-BIT %HEADER-TYPE-FEF %%HEADER-TYPE-FIELD ALLVARS FREEVARS
+ %HEADER-TYPE-FEF %%HEADER-TYPE-FIELD ALLVARS FREEVARS
%FEF-NAME-PRESENT %%FEFHI-MS-DEBUG-INFO-PRESENT QLP-DEBUG-INFO-PRESENT QCMP-OUTPUT))
(DECLARE (SPECIAL DTP-FEF-POINTER DTP-FIX DTP-SYMBOL DTP-LOCATIVE
@@ -239,13 +239,12 @@
;On pass 2, output a Q, specified by components.
;S-EXP is the contents of the Q.
-;FLAG is %Q-FLAG-BIT, to turn on that bit, if desired.
;INVZ-P is non-NIL to modify the data type of the Q:
; QZEVCP for an external value cell pointer, or
; QZLOC for a locative.
;OFFSET is added to the Q. It is useful for making pointers to
; value cells or function cells of symbols.
-(DEFUN LAP-Q-OUT (FLAG INVZ-P OFFSET S-EXP)
+(DEFUN LAP-Q-OUT (IGNORE INVZ-P OFFSET S-EXP)
(COND (LAP-LASTQ-MODIFIER (LAP-MODIFY-LASTQ LAP-LASTQ-MODIFIER)))
(COND ((OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE))
;Don't call FASD with the temporary area in effect
@@ -263,12 +262,12 @@
(SETQ LAP-STORE-POINTER (1+ LAP-STORE-POINTER))))
(SETQ LAP-LASTQ-MODIFIER
(+ 300 ;NXTCDR
- (+ (COND (FLAG 40) (T 0))
+; (COND (FLAG 40) (T 0))
(+ (COND ((NULL INVZ-P) 0)
((EQ INVZ-P 'QZEVCP) 20)
((EQ INVZ-P 'QZLOC) 400)
(T (BARF INVZ-P 'LAP-Q-OUT 'BARF)))
- (COND (OFFSET OFFSET) (T 0)) )))))
+ (COND (OFFSET OFFSET) (T 0)) ))))
(DEFUN LAP-MODIFY-LASTQ (CODE)
(COND ((OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE))
@@ -277,7 +276,6 @@
(LET ((OFFSET (LOGAND CODE 17))
(IDX (1- LAP-STORE-POINTER)))
(%P-DPB-OFFSET (LSH CODE -6) %%Q-CDR-CODE LAP-OUTPUT-BLOCK IDX)
- (%P-DPB-OFFSET (LSH CODE -5) %%Q-FLAG-BIT LAP-OUTPUT-BLOCK IDX)
(COND ((NOT (ZEROP OFFSET))
(%P-STORE-CONTENTS-OFFSET
(%MAKE-POINTER-OFFSET
@@ -650,7 +648,7 @@
((NULL SVS)
(LAP-STORE-NXTNIL-CDR-CODE)
ADR)
- (LAP-Q-OUT (AND (<= NUMARGS 0) '%Q-FLAG-BIT)
+ (LAP-Q-OUT NIL
'QZEVCP
1
(CAR SVS))))
Modified: trunk/lisp/sys/qmisc.lisp
==============================================================================
--- trunk/lisp/sys/qmisc.lisp Wed May 22 15:54:41 2013 (r412)
+++ trunk/lisp/sys/qmisc.lisp Wed May 22 16:03:22 2013 (r413)
@@ -1818,59 +1818,10 @@
(SETQ DIMLIST (CDR DIMLIST))))
(%P-STORE-CONTENTS-OFFSET DISPLACED-P ARRAY NDIMS)
(%P-STORE-CONTENTS-OFFSET INDEX-LENGTH ARRAY (1+ NDIMS))
- (COND (INDEX-OFFSET
- (%P-DPB-OFFSET 1 %%Q-FLAG-BIT ARRAY NDIMS) ;FLAG SIGNALS INDEX OFFSET
- (%P-STORE-CONTENTS-OFFSET INDEX-OFFSET ARRAY (+ NDIMS 2))))
+ (WHEN INDEX-OFFSET
+ (%P-STORE-CONTENTS-OFFSET INDEX-OFFSET ARRAY (+ NDIMS 2)))
ARRAY)
-(LOCAL-DECLARE
- ((SPECIAL SYM VARIABLES-BEING-MONITORED))
-(SETQ VARIABLES-BEING-MONITORED NIL)
-(DEFUN MONITOR-VARIABLE (SYM &OPTIONAL CURRENT-VALUE-CELL-ONLY-P MONITOR-FUNCTION)
- "Calls a given function just after a given symbol is SETQed (by
-compiled code or otherwise). Does not trigger on BINDing of the symbol.
-Can apply either to all SETQs, or only those which would alter the
-symbol's currently active value cell. The function is given both
-the old and new values as arguments. The default monitoring function
-just prints the symbol and the old and new values. Dont try to use this
-with variables that are forwarded to A memory (ie INHIBIT-SCHEDULING-FLAG).
-With CURRENT-VALUE-CELL-ONLY-P, it will work OK for DTP-EXTERNAL-VALUE-CELL
-type variables."
- (PROG (ADR OLD-VALUE NEW-ARRAY)
- (COND ((NULL MONITOR-FUNCTION)
- (SETQ MONITOR-FUNCTION
- (CLOSURE '(SYM)
- 'DEFAULT-VARIABLE-MONITOR-FUNCTION))))
- (SETQ ADR (VALUE-CELL-LOCATION SYM)
- OLD-VALUE (COND ((BOUNDP SYM)
- (CAR ADR)))
- NEW-ARRAY (MAKE-ARRAY 2 ':TYPE ART-Q-LIST))
- (AS-1 OLD-VALUE NEW-ARRAY 0) ;MOVE CURRENT VALUE TO NEW PLACE
- (AS-1 MONITOR-FUNCTION NEW-ARRAY 1)
- (%P-DPB-OFFSET 1 %%Q-FLAG-BIT NEW-ARRAY 1) ;The FLAG-BIT in the value
- ; cell triggers the hack.
- (%P-STORE-CONTENTS ADR
- (%MAKE-POINTER (COND (CURRENT-VALUE-CELL-ONLY-P
- DTP-EXTERNAL-VALUE-CELL-POINTER)
- (T DTP-ONE-Q-FORWARD))
- (1+ (%POINTER NEW-ARRAY))))
- (SETQ VARIABLES-BEING-MONITORED (CONS SYM VARIABLES-BEING-MONITORED))
- (RETURN T)))
-
-(DEFUN UNMONITOR-VARIABLE (&OPTIONAL SYM)
- (COND ((NULL SYM)
- (MAPC #'UNMONITOR-VARIABLE VARIABLES-BEING-MONITORED))
- ((MEMQ SYM VARIABLES-BEING-MONITORED)
- (SETQ VARIABLES-BEING-MONITORED (DELQ SYM VARIABLES-BEING-MONITORED))
- (%P-DPB-OFFSET DTP-FIX 3005 (PRINT-NAME-CELL-LOCATION SYM) 1) ;SMASH FORWARDING PNTR
- (%P-STORE-CONTENTS (VALUE-CELL-LOCATION SYM)
- (COND ((BOUNDP SYM)
- (SYMEVAL SYM)))))))
-
-(DEFUN DEFAULT-VARIABLE-MONITOR-FUNCTION (OLD NEW)
- (FORMAT T "~%Changing ~S from ~S to ~S" SYM OLD NEW))
-)
-
(DEFUN IGNORE (&REST IGNORE) NIL)
;;; Read a number out of a string (starting at FROM, in the given RADIX).
Modified: trunk/lisp/sys/qrand.lisp
==============================================================================
--- trunk/lisp/sys/qrand.lisp Wed May 22 15:54:41 2013 (r412)
+++ trunk/lisp/sys/qrand.lisp Wed May 22 16:03:22 2013 (r413)
@@ -370,9 +370,8 @@
(%P-STORE-CONTENTS-OFFSET DISPLACED-TO ARRAY IDX)
(%P-STORE-CONTENTS-OFFSET INDEX-LENGTH ARRAY (1+ IDX))
(COND (DISPLACED-INDEX-OFFSET
- ;; Index offset feature is in use. Set the magic bit to say so,
- ;; and store the index offset in the next Q.
- (%P-DPB-OFFSET 1 %%Q-FLAG-BIT ARRAY IDX)
+ ;; Index offset feature is in use.
+ ;; Store the index offset in the next Q.
(%P-STORE-CONTENTS-OFFSET DISPLACED-INDEX-OFFSET ARRAY (+ IDX 2)))))))
;; The leader's initial values were specified.
(DO ((I 0 (1+ I))
Modified: trunk/lisp/sys2/qfasd.lisp
==============================================================================
--- trunk/lisp/sys2/qfasd.lisp Wed May 22 15:54:41 2013 (r412)
+++ trunk/lisp/sys2/qfasd.lisp Wed May 22 16:03:22 2013 (r413)
@@ -291,8 +291,7 @@
(DEFUN FASD-FEF-Q (FEF I &AUX DATTP PTR PTR1 OFFSET (TYPE 0))
(SETQ DATTP (%P-LDB-OFFSET %%Q-DATA-TYPE FEF I))
- (SETQ TYPE (+ (LSH (%P-LDB-OFFSET %%Q-CDR-CODE FEF I) 6)
- (LSH (%P-LDB-OFFSET %%Q-FLAG-BIT FEF I) 5)))
+ (SETQ TYPE (LSH (%P-LDB-OFFSET %%Q-CDR-CODE FEF I) 6))
(COND ((OR (= DATTP DTP-EXTERNAL-VALUE-CELL-POINTER)
(= DATTP DTP-LOCATIVE))
(SETQ PTR1 (%P-CONTENTS-AS-LOCATIVE-OFFSET FEF I))
More information about the mit-cadr-cvs
mailing list