LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031543. :SYSTEM-TYPE :LOGICAL :VERSION 4. :TYPE "LISP" :NAME "STORAGE-MACROS" :DIRECTORY ("REL3-SOURCE" "KERNEL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758657597. :AUTHOR "REL3" :LENGTH-IN-BYTES 12151. :LENGTH-IN-BLOCKS 12. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                       ;;; -*- cold-load:t; Mode:Common-Lisp; Package:SI; Base:8; -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;; Copyright (C) 1984,1987 Texas Instruments Incorporated. All rights reserved.;** (c) Copyright 1980 Massachusetts Institute of Technology **;;; Edit History;;;                   Patch;;;   Date    Author  Number   Description;;;--------------------------------------------------------------------;;; 01-31-86    ab      --     Common Lisp conversion for VM2.;;;                              Most of these functions all formerly lived in QMISC.;;; 07-25-86    ab      --     Added 3 new macros for return-storage.;;; 08-13-86    ab             Moved Copy-Value here from INTERNALS-MACROS;;;                              & %Pointer-Plus from STORAGE-INTERNALS.;;;                            Combined with LOCATIVES-INTERNALS file.;;;                              Also moved a few things here from ;;;                              LOW-LEVEL-INTERNALS.;;;                              Integrated system patch 2-19 (25-bit-unsigned bug);;; 10-15-86    ab             Added a few INLINEs.;;; 10-27-86    ab             Changes for TGC support:;;;                              o Added %p-<field>-offset & %p-store-<field>-offset;;;                                functions as inlines.;;; 02-04-87    ab             Added new pointer-comparison routines.  Also new;;;                            get- and set-16b-array-word-pointer-and-type routines.;;; 02-10-87    ab             Added %p-store-data-type-and-pointer routine.;;;;;; Macros;;;(DEFMACRO Safe-Return-Storage (object)  `(RETURN-STORAGE (PROG1 ,object (SETQ ,object nil))))(DEFMACRO Safe-Return-Array (object)  `(RETURN-STORAGE (PROG1 ,object (SETQ ,object nil))))(DEFMACRO Safe-Return-Array-Element (object)  `(PROG1 ,object (SETF ,object nil)));;;;;; Q-Field Structure Accessors;;;;;; Next six new with TGC (PROCLAIM '(inline %p-pointer-offset))(DEFUN %p-pointer-offset (pointer offset)  "Extracts the pointer field of the contents of the locationOFFSET words beyond the POINTER after following structure forwarding."  (%P-POINTER    (%MAKE-POINTER-OFFSET DTP-Locative  (FOLLOW-STRUCTURE-FORWARDING pointer)  offset)))(PROCLAIM '(inline %p-data-type-offset))(DEFUN %p-data-type-offset (pointer offset)  "Extracts the data-type field of the contents of the locationOFFSET words beyond the POINTER after following structure forwarding."  (%P-DATA-TYPE    (%MAKE-POINTER-OFFSET DTP-Locative  (FOLLOW-STRUCTURE-FORWARDING pointer)  offset)))(PROCLAIM '(inline %p-cdr-code-offset))(DEFUN %p-cdr-code-offset (pointer offset)  "Extracts the cdr-code field of the contents of the locationOFFSET words beyond the POINTER after following structure forwarding."  (%P-CDR-CODE    (%MAKE-POINTER-OFFSET DTP-Locative  (FOLLOW-STRUCTURE-FORWARDING pointer)  offset)))(PROCLAIM '(inline %p-store-pointer-offset))(DEFUN %p-store-pointer-offset (pointer-to-store pointer offset)  "Stores POINTER-TO-STORE into the pointer field of the contents of thelocation OFFSET words beyond POINTER after following structure forwarding."  (%P-STORE-POINTER    (%MAKE-POINTER-OFFSET DTP-Locative  (FOLLOW-STRUCTURE-FORWARDING pointer)  offset)    pointer-to-store))(PROCLAIM '(inline %p-store-data-type-offset))(DEFUN %p-store-data-type-offset (data-type-to-store pointer offset)  "Stores DATA-TYPE-TO-STORE into the data-type field of the contents of the location OFFSET words beyond POINTER after following structure forwarding."  (%P-STORE-DATA-TYPE    (%MAKE-POINTER-OFFSET DTP-Locative  (FOLLOW-STRUCTURE-FORWARDING pointer)  offset)    data-type-to-store))(PROCLAIM '(inline %p-store-cdr-code-offset))(DEFUN %p-store-cdr-code-offset (cdr-code-to-store pointer offset)  "Store CDR-CODE-TO-STORE into the cdr-code field of the contents of the location OFFSET words beyond POINTER after following structure forwarding."  (%P-STORE-CDR-CODE    (%MAKE-POINTER-OFFSET DTP-Locative  (FOLLOW-STRUCTURE-FORWARDING pointer)  offset)    cdr-code-to-store))(PROCLAIM '(inline %p-store-data-type-and-pointer))(DEFUN %p-store-data-type-and-pointer (pointer data-type-to-store pointer-to-store)  "Store DATA-TYPE-TO-STORE and POINTER-TO-STORE in the data type and pointerfields of the word at POINTER."  (WITHOUT-INTERRUPTS     (LET ((cc (%p-cdr-code pointer)))      (%p-store-tag-and-pointer pointer(DPB cc     (BYTE (BYTE-SIZE %%Q-Cdr-Code)   (BYTE-SIZE %%Q-Data-Type))     data-type-to-store)pointer-to-store)))  );;;;;; Pointer Arithmetic/Comparison routines;;;(PROCLAIM '(inline %pointer-plus))(DEFUN %Pointer-Plus (ptr1 ptr2)  (%MAKE-POINTER-OFFSET DTP-Fix ptr1 ptr2))(PROCLAIM '(inline %pointer=))(DEFUN %pointer= (ptr1 ptr2)  "Returns T when PTR1 and PTR2 have the same pointer."  (= (%pointer ptr1) (%pointer ptr2)))(PROCLAIM '(inline %pointer/=))(DEFUN %pointer/= (ptr1 ptr2)  "Returns T when PTR1 and PTR2 do not have the same pointer."  (/= (%pointer ptr1) (%pointer ptr2)));;;; Algorithm for pointer comparison:;; ---------------------------------;;;; If two pointers, PTR1 and PTR2, have the same sign, we can just use the regular;; lisp arithmetic function to perform the comparison.;;;; If the two pointers have different signs, one must be negative.  The one that is;; negative is always "bigger" than the one that is not.;;;; (LOGXOR ptr1 ptr2) will have a 1 in the sign bit (ie, will be negative) if;; EXACTLY one argument is negative.  So (NOT (MINUSP (LOGXOR ptr1 ptr2))) = T;; means the two ptrs have the same sign.;;(PROCLAIM '(inline %pointer<))(DEFUN %pointer< (ptr1 ptr2)  (SETQ ptr1 (%POINTER ptr1) ptr2 (%POINTER ptr2))  (COND ((NOT (MINUSP (LOGXOR ptr1 ptr2))) (< ptr1 ptr2))       ((MINUSP ptr2) t)(t nil)))(PROCLAIM '(inline %pointer>))(DEFUN %pointer> (ptr1 ptr2)  (SETQ ptr1 (%POINTER ptr1) ptr2 (%POINTER ptr2))  (COND ((NOT (MINUSP (LOGXOR ptr1 ptr2))) (> ptr1 ptr2))       ((MINUSP ptr1) t)(t nil)))(PROCLAIM '(inline %pointer<=))(DEFUN %pointer<= (ptr1 ptr2)  (COND ((NOT (MINUSP (LOGXOR (SETQ ptr1 (%POINTER ptr1))      (SETQ ptr2 (%POINTER ptr2))))) (<= ptr1 ptr2))((MINUSP ptr2) t)(t nil)))(PROCLAIM '(inline %pointer>=))(DEFUN %pointer>= (ptr1 ptr2)  (COND ((NOT (MINUSP (LOGXOR (SETQ ptr1 (%POINTER ptr1))      (SETQ ptr2 (%POINTER ptr2))))) (>= ptr1 ptr2))((MINUSP ptr1) t)(t nil)));;;; Test routines.  If you think you're smart enough to write these routines;;;; more efficiently, just be sure to test them with the stuff below!!;;(DEFVAR *tst-ptr-fns-list*;;`(0 4 200.;;   ,(FLOOR most-positive-fixnum 2);;   ,(- most-positive-fixnum 200.);;   ,(1- most-positive-fixnum);;   ,most-positive-fixnum;;   ,most-negative-fixnum;;   ,(1+ most-negative-fixnum);;   ,(+ most-negative-fixnum 200.);;   ,(%pointer-plus most-negative-fixnum (FLOOR most-positive-fixnum 2));;   -200 -4 -1));;(DEFVAR *tst-fns-list* '((= %POINTER=) (/= %pointer/=);; (> %POINTER>) (< %POINTER<) (>= %POINTER>=) (<= %POINTER<=)));;(DEFUN test-ptr-arith-fns (&aux (total-count 0)(error-count 0));;  (LOOP FOR fn-pair IN *tst-fns-list* DO;;(LOOP FOR num1 IN *tst-ptr-fns-list*;;      DO (LOOP FOR num2 IN *tst-ptr-fns-list*;;       FOR non-ptr-res-1 = (FUNCALL (FIRST fn-pair);;    (convert-to-unsigned num1);;    (convert-to-unsigned num2));;       FOR ptr-res-1 = (FUNCALL (SECOND fn-pair);;(convert-to-signed num1);;(convert-to-signed num2));;       FOR non-ptr-res-2 = (FUNCALL (FIRST fn-pair);;    (convert-to-unsigned num2);;    (convert-to-unsigned num1));;       FOR ptr-res-2 = (FUNCALL (SECOND fn-pair);;(convert-to-signed num2);;(convert-to-signed num1));;       DO;;       (INCF total-count 2);;       (UNLESS (EQ non-ptr-res-1 ptr-res-1);; (INCF error-count);; (FORMAT t "~% (~a ~a ~a)  =  ~a" (SECOND fn-pair) num1 num2 ptr-res-1));;       (UNLESS (EQ non-ptr-res-2 ptr-res-2);; (INCF error-count);; (FORMAT t "~% (~a ~a ~a)  =  ~a" (SECOND fn-pair) num2 num1 ptr-res-2))));;FINALLY (RETURN (VALUES error-count total-count))));;;;;; Miscellaneous Inlines;;;(PROCLAIM '(inline copy-value))(DEFUN copy-value (to-cell from-cell)  "Copy whatever value is in FROM-CELL into TO-CELL."  (%BLT-TYPED from-cell to-cell 1 0));; This must be DEFSUBST so it can be SETF-able.(DEFSUBST contents (locative)  "Return the contents of the cell LOCATIVE points to.Thus (CONTENTS (LOCF <expression>)) is equivalent to <expression>."  (CDR locative))(PROCLAIM '(inline data-type))(Defun Data-Type (x)  "Return the name for the data type of X."  ;; q-data-types is an array stored in a function cell location (see qcom)  (q-data-types (%data-type x)))(PROCLAIM '(inline high))(DEFUN high (word)  (LDB %%Q-HIGH-HALF word))(PROCLAIM '(inline low))(DEFUN low (word)  (LDB %%Q-LOW-HALF word));; Next two may be locally DECLARE'd INLINE, so have in environment early.(Defun Convert-to-Unsigned (n)  "Convert fixnum, regarded as unsigned number, into number (maybe big) with same value.When the argument is negative (regarded as signed), it is expanded into a bignum."  (if (minusp n) (+ n (ash (dpb 1 %%Q-Boxed-Sign-Bit 0) 1)) n))(deff 25-bit-unsigned 'Convert-to-Unsigned)(deff 24-Bit-Unsigned 'Convert-to-Unsigned)(defun Convert-to-Signed (n)  "Convert N to a fixnum which, regarded as unsigned, has same value as N.Thus, a number just too big to be a signed fixnumbecomes a fixnum which, if regarded as signed, would be negative."  (cond ((= (%data-type n) DTP-Fix) n)(t (logior (ldb (1- %%Q-Pointer) n)   (rot (ldb (byte 1 (1- %%Q-Pointer)) n) -1)))))(deff make-25-bit-unsigned 'Convert-to-Signed)(deff Make-24-Bit-Unsigned 'Convert-to-Signed)(PROCLAIM '(inline get-16b-array-word))(DEFUN get-16b-array-word (16b-array word-offset)  (DPB (AREF 16b-array (1+ (* 2 word-offset)))       %%Q-High-Half       (AREF 16b-array (* 2 word-offset))))(PROCLAIM '(inline set-16b-array-word))(DEFUN set-16b-array-word (16b-array word-offset value)  (SETF (AREF 16b-array (1+ (* 2 word-offset)))(LDB %%Q-HIGH-HALF value))  (SETF (AREF 16b-array (* 2 word-offset))(LDB %%Q-LOW-HALF value)))(DEFSETF get-16b-array-word set-16b-array-word)(PROCLAIM '(inline get-16b-array-halfwords))(DEFUN get-16b-array-halfwords (16b-array word-offset)  (VALUES (AREF 16b-array (1+ (* 2 word-offset)))  (AREF 16b-array (* 2 word-offset))))(PROCLAIM '(inline set-16b-array-halfwords))(DEFUN set-16b-array-halfwords (16b-array word-offset hi-value low-value)  (SETF (AREF 16b-array (1+ (* 2 word-offset)))hi-value)  (SETF (AREF 16b-array (* 2 word-offset))low-value))(DEFUN get-16b-array-word-pointer-and-type (16b-array word-offset)  (LET ((hi (AREF 16b-array (1+ (* 2 word-offset)))))    (VALUES (%LOGDPB hi     (BYTE (- (BYTE-SIZE %%Q-Pointer)      (BYTE-SIZE %%Q-High-Half))   (BYTE-POSITION %%Q-High-Half))          (AREF 16b-array (* 2 word-offset)))    (LDB (BYTE (BYTE-SIZE %%Q-Data-Type)       (- (BYTE-SIZE %%Q-Pointer)  (BYTE-SIZE %%Q-Low-Half))) hi))))(DEFUN set-16b-array-word-pointer-and-type (16b-array word-offset pointer type)  (SETF (AREF 16b-array (1+ (* 2 word-offset)))(DPB type     (BYTE (BYTE-SIZE %%Q-Data-Type)   (- (BYTE-SIZE %%Q-Pointer)      (BYTE-SIZE %%Q-Low-Half)))     (LDB (BYTE (- (BYTE-SIZE %%Q-Pointer)   (BYTE-SIZE %%Q-High-Half))(BYTE-POSITION %%Q-High-Half))  pointer)))  (SETF (AREF 16b-array (* 2 word-offset))(LDB %%Q-Low-Half pointer)))at occupies memory, except stack groups.The copy has the same contents as the original.  Fixnums and other immediatetypes are simply re