root/trunk/lisp/lcadr/lqfmac.lisp @ 204

;;; -*- Mode:Lisp; Package:CADR; Base:8 -*-
;;;     ** (c) Copyright 1980 Massachusetts Institute of Technology **
;;; ***CAUTION!! This file runs only on LISPM.  The MACLISP version is LMCONS;QFMAC***
;;;    macros for QF, CC: version of console program that runs on machine


;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))))

(DEFMACRO QF-DATA-TYPE (Q) `(LDB 3005 ,Q))

(DEFMACRO QF-POINTER (Q) `(LET ((**FOO** ,Q))
                               (LOGIOR (LSH (LDB 1414 **FOO**) 14) (LDB 0014 **FOO**))))

(DEFMACRO QF-CDR-CODE (Q) `(LDB 3602 ,Q))

(DEFMACRO QF-FLAG-BIT (Q) `(LDB 3501 ,Q))

(DEFMACRO QF-TYPED-POINTER (Q) `(LOGAND 3777777777 ,Q))

;SMASH VAL INTO POINTER AND DATA-TYPE OF Q
(DEFMACRO QF-SMASH-TYPED-POINTER (Q VAL) `(DPB ,VAL 0035 ,Q))

(DEFMACRO QF-SMASH-CDR-CODE (Q VAL) `(DPB ,VAL 3602 ,Q))

(DEFMACRO QF-SMASH-FLAG-BIT (Q VAL) `(DPB ,VAL 3501 ,Q))

(DEFMACRO QF-SMASH-POINTER (Q VAL) `(DPB ,VAL 0030 ,Q))

(DEFMACRO QF-SMASH-DATA-TYPE (Q VAL) `(DPB ,VAL 3005 ,Q))

(DECLARE (SPECIAL QF-NIL))
(SETQ QF-NIL (QF-MAKE-Q 0 DTP-SYMBOL))          ;******* NIL KNOWN TO BE AT ZERO *******

;;;; 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-FLAG-BIT (LOC) `(QF-FLAG-BIT (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 (QF-SMASH-POINTER (QF-MEM-READ ADDR*)
                                           ,VAL)
                         ADDR*)))

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

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

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

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

(DEFMACRO 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))


;Really wants to be a bignum LSH.  On LISPM, LSH doesnt win for bignums, ASH does.
; In MACLISP, LSH wins sufficiently.
(DEFMACRO CC-SHIFT (QUAN AMT)
  `(#Q ASH #M LSH ,QUAN ,AMT))