;;; -*- Mode:LISP; Package:LAMBDA; Base:8; Readtable:ZL -*-
;;;	** (c) Copyright 1980 Massachusetts Institute of Technology **
;;;     ** (c) Enhancements Copyright 1984,1985,1986 - Lisp Machine, Inc.
;;;    macros for QF, LAM: version of console program




;SPECIAL VARIABLES FOR ARRAY STUFF

(DECLARE (SPECIAL QF-ARRAY-HEADER QF-ARRAY-DISPLACED-P QF-ARRAY-HAS-LEADER-P 
  QF-ARRAY-NUMBER-DIMS QF-ARRAY-HEADER-ADDRESS QF-ARRAY-DATA-ORIGIN QF-ARRAY-LENGTH))

;FUNCTIONS TO EXAMINE AND DEPOSIT FIELDS OF A Q

;BUILD A Q, GIVEN THE CONTENTS OF ITS FIELDS.
;THE CDR-CODE DEFAULTS TO CDR-ERROR.
(DEFMACRO QF-MAKE-Q (POINTER DATA-TYPE &OPTIONAL CDR-CODE)
     (COND (CDR-CODE
	    `(QF-SMASH-CDR-CODE (QF-SMASH-DATA-TYPE ,POINTER ,DATA-TYPE) ,CDR-CODE))
	   (T `(QF-SMASH-DATA-TYPE ,POINTER ,DATA-TYPE))))

;; Many of these are set up to values that depend on
;; how big the pointer field is in the machine being debugged.
(DEFVAR %%QF-POINTER)
(DEFVAR %%QF-DATA-TYPE)
(DEFVAR %%QF-TYPED-POINTER)
(DEFVAR %%QF-CDR-CODE)
(DEFVAR %QF-POINTER-MASK)
(DEFVAR %%QF-BOXED-SIGN-BIT)
(DEFVAR %%QF-PHT1-VIRTUAL-PAGE-NUMBER)
(DEFVAR %QF-PAGE-NUMBER-MASK)
(DEFVAR %QF-POINTER-SANS-BOXED-SIGN-BIT-MASK)
(DEFVAR %QF-TYPED-POINTER-MASK)
(defvar %QF-PHT-DUMMY-VIRTUAL-ADDRESS)

(defprop %pht-swap-status-normal t special)
(defprop %pht-swap-status-prepage t special)
(defprop %pht-swap-status-age-trap t special)
(defprop %%region-map-bits t special)
(defprop %%REGION-REPRESENTATION-TYPE t special)
(defprop %%REGION-SPACE-TYPE t special)
(defprop %%REGION-OLDSPACE-META-BIT t special)
(defprop  %%REGION-EXTRA-PDL-META-BIT t special)
(defprop  %%REGION-REPRESENTATION-TYPE t special)
(defprop %%SPECPDL-BLOCK-START-FLAG t special)
(defprop  %%LP-CLS-ATTENTION  t special)
(defprop  %%LP-CLS-SELF-MAP-PROVIDED t special)
(defprop  %PHT-MAP-STATUS-READ-ONLY  t special)
(defprop  SG-SPECIAL-PDL  t special)
(defprop  SG-SPECIAL-PDL-POINTER t special)
(defprop  SG-SAVED-M-FLAGS  t special)
(defprop  %%LP-CLS-ATTENTION  t special)
(defprop  %%LP-CLS-SELF-MAP-PROVIDED t special)
(defprop %%FEFH-PC-IN-WORDS  t special)
(defprop  %%ADI-PREVIOUS-ADI-FLAG t special)
(defprop  %%LP-ENS-MACRO-LOCAL-BLOCK-ORIGIN t special)
(defprop  %%FEFHI-MS-LOCAL-BLOCK-LENGTH  t special)
(defprop  %FEFHI-MISC  t special)


(DEFVAR QF-NIL :UNBOUND
  "Bignum representing NIL on debugged machine.
Must be set up again when cache is cleared.")

(DEFSUBST QF-DATA-TYPE (Q) (LDB %%QF-DATA-TYPE Q))

(DEFSUBST QF-POINTER (Q) (LOGAND %QF-POINTER-MASK Q))	;Can't use LDB, byte too wide

(DEFSUBST QF-MASK-PAGE-NUMBER (Q) (LOGAND %QF-PAGE-NUMBER-MASK Q))

(DEFSUBST QF-POINTER-SANS-BOXED-SIGN-BIT (Q) (LOGAND %QF-POINTER-SANS-BOXED-SIGN-BIT-MASK Q))

(DEFSUBST QF-BOXED-SIGN-BIT (Q) (LDB %%QF-BOXED-SIGN-BIT Q))

(DEFSUBST QF-CDR-CODE (Q) (LDB %%QF-CDR-CODE Q))

(DEFSUBST QF-TYPED-POINTER (Q) (LOGAND %QF-TYPED-POINTER-MASK Q))

;SMASH VAL INTO POINTER AND DATA-TYPE OF Q
(DEFUN QF-SMASH-TYPED-POINTER (Q VAL)
  (+ (QF-TYPED-POINTER VAL)
     (- Q (QF-TYPED-POINTER Q))))

(DEFSUBST QF-SMASH-CDR-CODE (Q VAL) (DPB VAL %%QF-CDR-CODE Q))

(DEFSUBST QF-SMASH-POINTER (Q VAL) (DPB VAL %%QF-POINTER Q))

(DEFSUBST QF-SMASH-DATA-TYPE (Q VAL) (DPB VAL %%QF-DATA-TYPE Q))

;;;; ANALOGUES OF %P-POINTER, %P-STORE-POINTER, ETC.

(DEFMACRO QF-P-POINTER (LOC) `(QF-POINTER (QF-MEM-READ ,LOC)))

(DEFMACRO QF-P-DATA-TYPE (LOC) `(QF-DATA-TYPE (QF-MEM-READ ,LOC)))

(DEFMACRO QF-P-CDR-CODE (LOC) `(QF-CDR-CODE (QF-MEM-READ ,LOC)))

(DEFMACRO QF-P-CONTENTS (LOC) `(QF-TYPED-POINTER (QF-MEM-READ ,LOC)))

(DEFMACRO QF-P-STORE-POINTER (LOC VAL)
     `(LET ((ADDR* ,LOC))
	   (QF-MEM-WRITE ADDR*
			 (QF-SMASH-POINTER (QF-MEM-READ ADDR*)
					   ,VAL))))

(DEFMACRO QF-P-STORE-CONTENTS (LOC VAL)
     `(LET ((ADDR* ,LOC))
	   (QF-MEM-WRITE ADDR*
			 (QF-SMASH-TYPED-POINTER (QF-MEM-READ ADDR*)
						 ,VAL))))

(DEFMACRO QF-P-STORE-DATA-TYPE (LOC VAL)
     `(LET ((ADDR* ,LOC))
	   (QF-MEM-WRITE ADDR*
			 (QF-SMASH-DATA-TYPE (QF-MEM-READ ADDR*)
					     ,VAL))))

(DEFMACRO QF-P-STORE-CDR-CODE (LOC VAL)
     `(LET ((ADDR* ,LOC))
	   (QF-MEM-WRITE ADDR*
			 (QF-SMASH-CDR-CODE (QF-MEM-READ ADDR*)
					    ,VAL))))

(DEFMACRO QF-TRANSPORT-HEADER (HEADER-ADDRESS)
  `(DO-FOREVER
     (LET ((CONTENTS (QF-MEM-READ ,HEADER-ADDRESS)))
       (UNLESS (OR (= (QF-DATA-TYPE CONTENTS) DTP-HEADER-FORWARD)
		   (= (QF-DATA-TYPE CONTENTS) DTP-GC-FORWARD))
	 (RETURN NIL))
       (SETQ ,HEADER-ADDRESS (QF-POINTER CONTENTS)))))

(DEFSUBST QF-NULL (X) (= X QF-NIL))

(DEFMACRO SELECTN (ITEM . BODY)
  `((LAMBDA (*SELECTN-ITEM*)
      (COND . ,(MAPCAR
		'#(LAMBDA (CLAUSE)
		    (COND ((EQ (CAR CLAUSE) 'OTHERWISE)
			   `(T . ,(CDR CLAUSE)))
			  ((ATOM (CAR CLAUSE))
			   `((= *SELECTN-ITEM* ,(CAR CLAUSE)) . ,(CDR CLAUSE)))
			  (T `((OR . ,(MAPCAR '(LAMBDA (ITEM) `(= *SELECTN-ITEM* ,ITEM))
					      (CAR CLAUSE))) . ,(CDR CLAUSE)))))
		BODY)))
    ,ITEM))