;;; -*- Mode: Common-Lisp; Package: sys; Base: 10.; Patch-File: T -*-

;;; Reason: Modified make-callable-constructor to ignore duplicate inits on slots. CLp62 [10799]

;;;                           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 02/13/90 13:46:32 by berger,
;;; while running on Pasteur from band LOD2
;;; With SYSTEM 6.29, VIRTUAL-MEMORY 6.3, EH 6.6, MAKE-SYSTEM 6.2, MICRONET 6.0, LOCAL-FILE 6.1,
;;;  BASIC-PATHNAME 6.3, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.7, NETWORK-NAMESPACE 6.1,
;;;  DISK-IO 6.2, DISK-LABEL 6.0, BASIC-FILE 6.7, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0,
;;;  COMPILER 6.14, TV 6.23, DATALINK 6.0, CHAOSNET 6.5, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.2,
;;;  SYSLOG 6.2, STREAMER-TAPE 6.5, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.12,
;;;  DEBUG-TOOLS 6.4, NETWORK-SUPPORT 6.1, NETWORK-SERVICE 6.2, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.2,
;;;  IMAGEN 6.1, SUGGESTIONS 6.1, MAIL-DAEMON 6.5, MAIL-READER 6.7, TELNET 6.1, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.4, PROFILE 6.2, VISIDOC 6.7, TI-CLOS 6.37, CLEH 6.5, IP 3.57,
;;;  Experimental CLX 6.8, CLUE 6.50, X11M 6.20, Experimental BUG 11.18,  microcode 648,
;;;  Band Name: rel6.0 1/23

#!C
; From file STRUCTURE.LISP#> KERNEL; sys:
#10R 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; STRUCTURE.#"


(defun make-callable-constructor (cons-name)
  (using-defstruct-special-variables)
  ;;figure out the element type
  (let ((slot-defaults (collect-slot-defaults slot-alist))
	(code (defstruct-type-description-accessor-code type-description))
	keys val (missing (gensym)))
    ;;take care of the defstruct keywords
    (dolist (key (defstruct-type-description-defstruct-keywords type-description))
      (unless (get key keys) ;; already specified in the arguments of the macro
	(when (setf val (get-defstruct-property-value name key))
	  (push val keys) (push key keys))))
    (push `(defun ,cons-name (&rest inits)
	     (declare (function-parent ,name))
	     (do ((inits inits (cddr inits))
		  (structure ,(apply (defstruct-type-description-bare-constructor
					 type-description)
				       name size
				       subtype (name-offset) keys
				       ))
		  (allow-other-keys-p nil)
		  (allow-other-keys nil)
		  (processed-inits ()) ; DAB 02-13-90
		  ,@(if slot-defaults '(slot-done) nil))
		 ((null inits)
		  ,@(and (and (not (defstruct-type-description-named-p type-description) )
			     (<= 1 (defstruct-type-description-overhead type-description)))
			(mapcan #'(lambda (x)
				    ;;Filter out dummy slots used for structure names.
				    (if (defstruct-slot-description-name-slot-p (cdr x))
					(list (set-slot code 'structure
							(defstruct-slot-description-number (cdr x))
							(defstruct-slot-description-init-code (cdr x))))
					nil))
				slot-alist))
		  ,@(if slot-defaults
			(do ((defaults slot-defaults (cdr defaults)) (produced-code '(structure)))
			    ((null defaults ) produced-code)
			  (push
			    `(unless (member ,(caar defaults) slot-done :test #'eq)
			       ,(if (check-for-byte-slots slot-alist)
				    (if (null (cdddar defaults))
					(set-slot code 'structure (caddar defaults ) (cadar defaults))
					(set-slot code 'structure (caddar defaults )(cadar defaults)
						  (cdddar defaults )))
				    (set-slot code 'structure (caddar defaults ) (cadar defaults))
				    ))
			    produced-code))
			'(structure)))
	       (let ((slot-number
		       (cdr (assoc (car inits)
				  ',(mapcan
				      #'(lambda (x)
					  ;;Filter out dummy slots used for structure names.
					  (if (defstruct-slot-description-name-slot-p (cdr x))
					      nil
					      (list (cons (intern (symbol-name (car x)) 'keyword)
							  (cons (defstruct-slot-description-number (cdr x))
								(defstruct-slot-description-ppss (cdr x)))))))
				      slot-alist)
				  :test #'eq))))
		 (unless (member (car inits) processed-inits)  ; DAB 02-13-90 Ignore duplicate inits, use first CLp62[10799]
		   (if slot-number
		       (progn 
			 ,(if (check-for-byte-slots slot-alist)
			      (set-slot code 'structure '(car slot-number) '(second inits) '(cdr slot-number))
			      #| `(if (null (cdr (slot-number)))
			   (setf ,(funcall code '(car slot-number) 'structure) (second inits))
			   (progn
			     (when (null ,(funcall code '(car slot-number) 'structure))
			       (setf ,(funcall code '(car slot-number) 'structure) 0))
			     (setf (ldb (cdr slot-number ) ,(funcall code '(car slot-number) 'structure))
				   (second inits)))) |#
			      (set-slot code 'structure '(car slot-number) '(second inits) ))
			 #| `(setf ,(funcall code '(car slot-number) 'structure) (second inits))) |#
			 ,@(if slot-defaults `((push (car inits) slot-done)) nil))
		       (or allow-other-keys
			   (and (eq (car inits) :allow-other-keys)
				(progn (unless  allow-other-keys-p
					 (setf allow-other-keys (cadr inits))
					 (setf allow-other-keys-p t))
				       t))
			   (and (null allow-other-keys-p)
				(let ((p (getf inits  :allow-other-keys ',missing)))
				  (when (neq p ',missing)
				    (setf  allow-other-keys-p t)
				    (setf allow-other-keys p))))
			   (error "unknown slot keyword ~S for structure ~S" (car inits) ',name)))
		   )				; DAB 02-13-90 unless
		 )))
	  returns)))
))