;;; -*- Mode: Common-Lisp; Package: User; Base: 8.; Patch-File: T -*-

;;; Reason: Fixed copy-object to not create an invalid structure in memory without
;;; an "without-interrupts".

;;;                           RESTRICTED RIGHTS LEGEND
;;;
;;; Use, duplication, or disclosure by the Government is subject to
;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;; Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;   TEXAS INSTRUMENTS INCORPORATED      
;;;   P.O. BOX 2909, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Written 10/02/89 10:46:32 by FISH,
;;; while running on DaVinci from band LOD2
;;; With SYSTEM 6.14, VIRTUAL-MEMORY 6.1, EH 6.4, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0,
;;;  BASIC-PATHNAME 6.1, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.2, NETWORK-NAMESPACE 6.0,
;;;  DISK-IO 6.1, DISK-LABEL 6.0, BASIC-FILE 6.2, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0,
;;;  COMPILER 6.10, TV 6.15, DATALINK 6.0, CHAOSNET 6.0, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.1,
;;;  SYSLOG 6.1, STREAMER-TAPE 6.4, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.5,
;;;  DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.1, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.1,
;;;  IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.2, TELNET 6.0, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.2, TI-CLOS 6.20, CLEH 6.5, IP 3.47,
;;;  Experimental CLX 6.2, CLUE 6.10, X11M 6.13, Experimental BUG 11.15, Experimental SEYMOUR3 2.0,
;;;  Experimental SLAP 3.15,  microcode 465, Band Name: rel6 7/25 seymour

#!C
; From file STORAGE-INTERNALS.LISP#> KERNEL; Hotel:
#8R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; STORAGE-INTERNALS.#"


(DEFUN Copy-Object (object &optional (area default-cons-area))
  "Copy any kind of object that occupies memory, except stack groups.
The copy has the same contents as the original.  Fixnums and other immediate
types are simply returned as supplied."
  (TYPECASE object
    ((OR fixnum character symbol short-float microcode-function locative)
     object)
    (cons (let ((default-cons-area area))
	    (COPY-LIST object)))
    (closure (let ((default-cons-area area))
	       (COPY-CLOSURE object)))
    (stack-group (FERROR nil "It is not possible to copy a stack group"))
    (t
     (IF (AND (ARRAYP object)
	      (= (%STRUCTURE-TOTAL-SIZE (FOLLOW-STRUCTURE-FORWARDING object)) 1))
	 (MAKE-ARRAY 0 :type (ARRAY-TYPE object) :area area)
	 ;; else
	 (LET* ((real-object (FOLLOW-STRUCTURE-FORWARDING object))
		(leader (%FIND-STRUCTURE-LEADER real-object))
		(total (%STRUCTURE-TOTAL-SIZE leader))
		(boxed (%STRUCTURE-BOXED-SIZE leader))
		new)   
	   (WITHOUT-INTERRUPTS
	     (setf new (%ALLOCATE-AND-INITIALIZE (%DATA-TYPE real-object)
					       (%P-DATA-TYPE leader)
					       (%P-POINTER leader)
					       0
					       area
					       total))
	     (%BLT-TYPED leader new boxed 1)
	     (%BLT (%MAKE-POINTER-OFFSET Dtp-Locative leader boxed)
		   (%MAKE-POINTER-OFFSET Dtp-Locative new boxed)
		   (- total boxed) 1))
	   (%MAKE-POINTER-OFFSET (%DATA-TYPE real-object) new
				 (%POINTER-DIFFERENCE real-object leader)))))))
))