1;;; -*- *cold-load:t; 1Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:10. -*-

;;;                           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
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151

;;; Copyright (C) 198*61-1989 Texas Instruments Incorporated. All rights reserved.*

;;; Symbol manipulation functions

;;;Record of changes:
;;;  4/11/89 jlm	Moved PUTPROP to TICL package
;;;			Changed many (PUTPROP calls to (SETF (GET ...
;;;		   
;;;  7/20/88 clm - added optional argument to MAKE-SYMBOL-IN-AREA to allow user to 
;;;                control where the pname is stored.  This is useful in the case
;;;                of not allowing any pointers to get out of a designated area.
;;;                This changed was requested by the MP project, and it should be
;;;                completely transparent to other users.

(defun make-symbol (pname &optional permanent-p)
  1"Create a symbol with name PNAME.
The symbol starts out with no value, definition or properties.
PERMANENT-P forces areas to those normally used for symbols."*
  (check-arg pname stringp "a string")
  (and permanent-p (not (= (%area-number pname) p-n-string))
       (let ((%inhibit-read-only t)
	     (default-cons-area p-n-string))
	 (setq pname (string-append pname))))
  (let ((symb (%allocate-and-initialize dtp-symbol	;Type to return.
			     dtp-symbol-header	;Type of header.
			     pname		;Pointer field of header.
			     nil		;Value for second word.
			     (and permanent-p nr-sym)	;Area.
			     length-of-atom-head)))	;Length.
    (makunbound symb)			;Was initialized to NIL
    (fmakunbound symb)
    symb))

(defun make-symbol-in-area (pname area &optional (string-area p-n-string))
  "Create a symbol with name PNAME.
The symbol starts out with no value, definition or properties.
AREA is the area for allocating the new symbol, defaults to that
normally used for symbols.
STRING-AREA is the area use for allocating strings, defaults to that
normally used for strings."
  (check-arg pname stringp "a string")
  (if (not (= (%area-number pname) string-area))   ;;7/20/88 clm
      (let ((%inhibit-read-only t)
	    (default-cons-area string-area))
	(setq pname (string-append pname))))
  (let* ((area (if (symbolp area) (symbol-value area) area))
	 (symb (%allocate-and-initialize dtp-symbol	;Type to return.
			     dtp-symbol-header	;Type of header.
			     pname		;Pointer field of header.
			     nil		;Value for second word.
			     area		;Area.
			     length-of-atom-head)))	;Length.
    (makunbound symb)			;Was initialized to NIL
    (fmakunbound symb)
    symb))

(defun makunbound (symbol)
  1"Cause SYMBOL to have no value.  It will be an error to evaluate it."*
  (when (member symbol '(t nil) :test #'eq)      ;I guess it's worth checking
    (ferror () "Don't makunbound ~S please" symbol)) 
  ;; Value cell could be forwarded somewhere, e.g. into microcode memory
  (do ((loc (value-cell-location symbol) (%p-contents-as-locative loc)))
      ((/= (%p-data-type loc) dtp-one-q-forward) 
       (without-interrupts
;; TGC	 (%p-store-pointer loc symbol)
;;	 (%p-store-data-type loc dtp-null)
	 (%p-store-data-type-and-pointer loc dtp-null symbol))))
  symbol)

(defun fmakunbound (symbol)
  1"Cause SYMBOL to have no function definition.  It will be an error to call it."*
  (without-interrupts
;; TGC (%p-store-pointer (function-cell-location symbol) symbol)
;;     (%p-store-data-type (function-cell-location symbol) dtp-null)
    (%p-store-data-type-and-pointer (function-cell-location symbol) dtp-null symbol))
  symbol)


;;; SETF of DOCUMENTATION expands into this.
;;; 8/7/86 if only two arguments are passed assume second argument
;;;        is doc-string and doc-type is 'function. PMH#1083
(defun set-documentation (symbol doc-type &optional (value doc-type value-supplied))
  (unless value-supplied 
     (setf doc-type 'function))
  (setf (get (locf (get symbol 'documentation-property))
	     (if (string-equal doc-type 'flavor)		;allow flavor to map to defflavor
		 'defflavor doc-type)) value))

(deff zlc:copysymbol 'copy-symbol)
(defun copy-symbol (symbol &optional copyprops &aux newsym)
  1"Return a new uninterned symbol with the same pname as SYMBOL.
If COPYPROPS is non-NIL, the value, function definition and properties
of SYMBOL are all copied into the new symbol."*
  (setq newsym (make-symbol (symbol-name symbol) ))
  (when copyprops
    (if (boundp symbol)
	(rplaca (value-cell-location newsym) (car (value-cell-location symbol))))
    (if (fboundp symbol)
	(rplaca (function-cell-location newsym) (car (function-cell-location symbol))))
    (rplaca (property-cell-location newsym)
	    (copy-list (car (property-cell-location symbol)))))
  newsym)

(defvar *gensym-prefix* "G"
  1"Character or string used as prefix of names made by GENSYM."*)
(defvar *gensym-counter* 0 "Counter used for next GENSYM'd symbol.")
(forward-value-cell '*gensym-counter '*gensym-counter*)
(forward-value-cell '*gensym-prefix '*gensym-prefix*)

;;;PHD 4/7/87 Changed default value for permanent-p
(defun gensym (&optional arg (permanent-p nil) &aux pname)
1  "Return a new uninterned symbol with a generated name.
When PERMANENT-P is T, the pname string is consed in a permanent area."*
  (cond ((null arg))
	((numberp arg)
	 (setq *gensym-counter* (1- arg)))
	((symbolp arg)
	 (setq *gensym-prefix* (symbol-name arg)))
	((stringp arg)
	 (setq *gensym-prefix* arg)))
  (and (> (setq *gensym-counter* (1+ *gensym-counter*)) 9999.)
       (setq *gensym-counter* 0))
  (let ((default-cons-area (if permanent-p p-n-string default-cons-area))
	(%inhibit-read-only t)
	index)
    (setq pname (string-append *gensym-prefix* "    "))
    (setq index (- (length pname) 4))
    (setf (aref pname index) (+ #o60 (truncate *gensym-counter* #o1750))) 
    (setf (aref pname (+ index #o1)) (+ #o60 (rem (truncate *gensym-counter* #o144) #o12))) 
    (setf (aref pname (+ index #o2)) (+ #o60 (rem (truncate *gensym-counter* #o12) #o12))) 
    (setf (aref pname (+ index #o3)) (+ #o60 (rem *gensym-counter* #o12))) )
  (make-symbol pname permanent-p))

(defvar *gentemp-counter* 0)

;;PHD 1/7/87 replace call to format by prin1-to-string.
(defun gentemp (&optional (prefix "T") (pkg *package*))
  1"Return a unique symbol in package PKG.  Its name starts with PREFIX.
We try appending various numerals to PREFIX until we get a name
that is not interned in PKG; then we intern it and return the
newly created symbol.  Therefore, no two calls to GENTEMP in the
same Lisp world ever return the same value."*
  (loop 
    (incf *gentemp-counter*)
    (let* ((*print-base* 10.)
	   (*nopoint t)
	   (*print-radix* nil)
	   (string (string-append prefix (prin1-to-string *gentemp-counter*))))
      (unless (find-symbol string pkg)
	(return (intern string pkg))))))

(defun declare (&quote &rest declarations)
  1"The body is made up of declarations,
which are in effect throughout the construct at the head of whose body the DECLARE appears.
The use of DECLARE at top level is obsolete; use PROCLAIM instead."*
  declarations
  'declare)

;;; Property List support

(defun get-location (symbol property)
  (if (typep symbol 'instance)
      (send symbol :get-location property)
    (do ((l (symbol-plist symbol) (cddr l)))
        ((null l)
	 ;;(putprop symbol nil property) 		; jlm 4/11/89
         (setf (get symbol property) nil)
         (get-location symbol property))
       (and (eq (car l) property)
            (return (car-location (cdr l)))))))

(defun zlc:setplist (symbol l)
  1"Set the property list of SYMBOL to be L (a list of alternating properties and values).
SYMBOL may be an instance that handles the :SETPLIST operation, instead of a symbol."*
  (typecase symbol
    (symbol (rplaca (property-cell-location symbol) l))
    (instance (send symbol :setplist l)))
  l)


(deff zlc:plist 'symbol-plist)
(defun symbol-plist (symbol)
  1"Return the contents of the property list of SYMBOL.
SYMBOL may be a symbol, an instance supporting the :PROPERTY-LIST operation,
or a locative or cons cell whose cdr is the property list."*
  (typecase symbol
    (symbol (car (property-cell-location symbol)))
    (instance (send symbol :property-list))
    (t (cdr symbol))))


1;Note: this used to be done with an explicit SETQ so that it would happen
;inside the cold-load generator rather than as part of LISP-CRASH-LIST.
;However, now it should happen inside the cold load generator anyway.*
(defvar area-for-property-lists property-list-area
  1"Area for consing property lists of interned symbols in."*)

(proclaim '(inline getf)) 
(defun getf (place indicator &optional default)
  1"Searches the property list stored in PLACE for an indicator EQ to INDICATOR.
If one is found, then the corresponding value is returned;
otherwise DEFAULT is returned."*
  (get (locf place) indicator default))

(defun get (symbol-or-plist property &optional default)
  1"Returns the value of SYMBOL-OR-PLIST's PROPERTY property.
If there is no property, DEFAULT is returned.
SYMBOL-OR-PLIST may be a symbol or a disembodied property list -
a list or locative whose cdr stores the properties.
It may also be an instance; then its :GET method is used.
 (if DEFAULT is non-NIL, its :GET-LOCATION-OR-NIL method is used, for now)."*
  (if default
      (get symbol-or-plist property default)
    ;; 2-arg case is open coded!
    (get symbol-or-plist property)))

(defun get-properties-internal (location list-of-properties)
  (let ((tem (getl location list-of-properties)))
    (if tem (values (car tem) (cadr tem) tem))))

(defun ticl:putprop (symbol-or-plist value property)				; jlm 4/11/89
  1"Make the value of SYMBOL-OR-PLIST's PROPERTY property be VALUE.
SYMBOL-OR-PLIST may be a symbol or a disembodied property list -
a list or locative whose cdr stores the properties.
It may also be an instance; then its :PUTPROP method is used.
VALUE is returned."*
  (etypecase symbol-or-plist
    (instance (send symbol-or-plist :putprop value property))
    ((or symbol locative cons) 
     (without-interrupts
       (let* ((plist-loc (if (symbolp symbol-or-plist) 
			     (property-cell-location symbol-or-plist) 
			     symbol-or-plist))
	      (valloc (get-location-or-nil plist-loc property)))  ;; a locative to (old-value ...)
	 (if valloc (rplaca valloc value)   ;; if there is already a property, replace its value
	     (rplacd plist-loc              ;; else push a new property and value
		     (list*-in-area 
		       (if (= (%area-number symbol-or-plist) nr-sym)
			   property-list-area
			   background-cons-area)
		       property value (contents plist-loc))))
	 value)))))

;Implements SETF of GET.
(defun setprop (symbol-or-plist property value)
  (etypecase symbol-or-plist
    (instance (send symbol-or-plist :putprop value property))
    ((or symbol locative cons) 
     (without-interrupts
       (let* ((plist-loc (if (symbolp symbol-or-plist) 
			     (property-cell-location symbol-or-plist) 
			     symbol-or-plist))
	      (valloc (get-location-or-nil plist-loc property)))  ;; a locative to (old-value ...)
	 (if valloc (rplaca valloc value)   ;; if there is already a property, replace its value
	     (rplacd plist-loc              ;; else push a new property and value
		     (list*-in-area 
		       (if (= (%area-number symbol-or-plist) nr-sym)
			   property-list-area
			   background-cons-area)
		       property value (contents plist-loc))))
	 value)))))

(defun defprop (&quote symbol value property)
  1"Make the value of SYMBOL's PROPERTY property be VALUE."*
  ;;(putprop symbol value property)	; jlm 4/11/89
  (setf (get symbol property) value)
  symbol)

(defun remprop (symbol-or-plist property &aux plloc)
  1"Remove a property.  Returns NIL if not present, or a list whose CAR is the property.
SYMBOL-OR-PLIST may be a symbol or a disembodied property list -
a list or locative whose cdr stores the properties.
It may also be an instance; then it is sent a :REMPROP message."*
  (check-type symbol-or-plist (or symbol cons locative instance) "a symbol, list, locative or instance")
  (if (typep symbol-or-plist 'instance)
      (send symbol-or-plist :remprop property)
      (setq plloc (cond ((symbolp symbol-or-plist)
			 (property-cell-location symbol-or-plist))
			(t symbol-or-plist)))
      (without-interrupts 
	(do ((pl (cdr plloc) (cddr pl))
	     (ppl plloc (cdr pl)))
	    ((null pl) nil)
	  (when (eq (car pl) property)
	    (rplacd ppl (cddr pl))
	    (return (cdr pl)))))))

(defun property-list-handler (op plist &rest args)
  (case op
    (:get
     (get plist (first args) (second args)))
    (:get-location-or-nil
     (get-location-or-nil plist (first args)))
    (:get-location
      (locf (get plist (first args))))
    (:getl
     (getl plist (car args)))
    (:putprop
     ;;(putprop plist (first args) (second args)) 	; jlm 4/11/89
     (setf (get plist (second args)) (first args)))
    (:remprop
     (remprop plist (car args)))
    (:push-property
     (push (first args) (get plist (second args))))
    (:plist
     (contents plist))
    ((:plist-location :property-list-location)
     plist)
    (:setplist
     (setf (contents plist) (first args)))
    (:set
     (case (first args)
       (:get
	;;(putprop plist (car (last args)) (second args))	; jlm 4/11/89
	(setf (get plist (second args)) (car (last args))))
       (:plist (setf (contents plist) (second args)))
       (:which-operations '(:get :plist))
       (t (ferror nil "Don't know how to :SET ~S" (first args)))))
    (:which-operations '(:get :get-location :get-location-or-nil :getl :putprop :remprop
			 :push-property :plist :plist-location :property-list-location :set
			 :setplist :which-operations))
    (t (ferror nil "Don't know how to ~S a plist" op))) )

(defun documentation (symbol &optional (doc-type 'function))
  "Try to return the documentation string for SYMBOL, else return NIL.
Standard values of DOC-TYPE are: FUNCTION, VARIABLE, TYPE, STRUCTURE and SETF,
but you can put on and retrieve documentation for any DOC-TYPE.
Documentation strings are installed by SETFing a call to DOCUMENTATION."
  (cond ((and (eq doc-type 'value)
	      (get symbol :documentation)))
	((and (symbolp symbol)
	      (let ((doc-prop (get symbol 'documentation-property)))
		(get (locf doc-prop) (if (string-equal doc-type 'flavor)
					 ;; PMH: allow 'flavor to map to 'defflavor
					 'defflavor doc-type)))))
	((eq doc-type 'type)
	 (and (get symbol 'type-expander)
	      (documentation (get symbol 'type-expander) 'function)))
	((eq doc-type 'function)
	 (typecase symbol
	   (symbol
	    (and (fboundp symbol)
		 (documentation (fdefinition (unencapsulate-function-spec symbol)))))
	   (cons
	    (if (functionp symbol t)
		(if (eq (car symbol) 'macro)
		    (documentation (cdr symbol))
		    (multiple-value-bind (nil nil doc)
			(parse-body (cdr (lambda-exp-args-and-body symbol)) nil t)
		      doc))
		(and (fdefinedp symbol)
		     (documentation (fdefinition (unencapsulate-function-spec symbol))))))
	   (compiled-function
	    (let ((di (get-debug-info-struct symbol)))
	      (if (get-debug-info-field di :combined-method-derivation)
		  ;; its a fef for a combined method, so do special handling
		  (combined-method-documentation symbol)
		  (get-debug-info-field di :documentation))))))))

;Old name.
(deff function-documentation 'documentation)



(defvar *force-defvar-init* nil
1  "Bound true by ZMACS while evaluating a buffer, in order to force DEFVAR initialization."*)

(defun defvar-ok-to-set-p (symbol &optional documentation always-set)
  ;; Record a declaration of a variable and return true if its value should be initialized.
  (when (if (fboundp 'record-source-file-name)
	    (record-source-file-name symbol 'defvar)
	  t)
    (setf (get symbol 'special)
	  (or (and (boundp 'fdefine-file-pathname) fdefine-file-pathname)
	      t))
    (when (or documentation ; avoid storing null documentation
	      (documentation symbol 'variable))
      (setf (documentation symbol 'variable) documentation))
    (or always-set
	(not (boundp symbol))
	(and (boundp 'fs:this-is-a-patch-file) fs:this-is-a-patch-file)
	*force-defvar-init*)))

(defun defvar-1 (&quote symbol &optional (value :unbound) documentation)
  (when (and (consp symbol) (eq (car symbol) 'quote))
    (setq symbol (cadr symbol)))
  (when (defvar-ok-to-set-p symbol documentation nil)
    (remprop symbol 'compiler:system-constant)
    (unless (eq value :unbound)
      (set symbol (*eval value))))
  symbol)

(defun defconst-1 (&quote symbol &eval value &optional documentation constantp)
  (when (and (consp symbol) (eq (car symbol) 'quote))
    (setq symbol (cadr symbol)))
  (when (defvar-ok-to-set-p symbol documentation t)
    (set symbol value)
    (if constantp
	(setf (get symbol 'compiler:system-constant) t)
      (remprop symbol 'compiler:system-constant))
    )
  symbol)

;;PHD 1/7/87 Added set function.
(defun set (symbol value)
  "SYNTAX: (SET symbol value)
 Sets the value of SYMBOL to the value of VALUE. SYMBOL must evaluate to a symbol
 other than t , nil , a keyword or a constant. SET cannot be used to change the 
 value of local variables in compiled code."
  (unless (variable-p symbol)
    (if (symbolp symbol)
	(ferror nil "attempted to SET the ~a ~s"
		(if (keywordp symbol) "KEYWORD" "CONSTANT") symbol)
	(ferror nil "a non-symbol ~s is the target of a SET" symbol)))
  (set symbol value))