;;; This is a -*-Lisp-*- file.

;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************

;;; Symbol manipulating functions for Spice Lisp.

;;; Written by Scott Fahlman.
;;; Hacked on and maintained by Skef Wholey.

;;; Many of these are trivial interpreter entries to functions
;;; open-coded by the compiler.

;;; **********************************************************************


(defun set (variable new-value)
  "VARIABLE must evaluate to a symbol.  This symbol's special value cell is
  set to the specified new value."
  (set variable new-value))

(defun fset (variable new-definition)
  "VARIABLE must evaluate to a symbol.  This symbol's definition cell is
  set to the specified new definition."
  (fset variable new-definition))

(defun makunbound (variable)
  "VARIABLE must evaluate to a symbol.  This symbol is made unbound,
  removing any value it may currently have."
  (makunbound variable))

(defun fmakunbound (variable)
  "VARIABLE must evaluate to a symbol.  This symbol is made undefined,
  removing any definition it may currently have."
  (fmakunbound variable))

(defun symbol-value (variable)
  "VARIABLE must evaluate to a symbol.  This symbol's current special
  value is returned."
  (symbol-value variable))

(defun symbol-function (variable)
  "VARIABLE must evaluate to a symbol.  This symbol's current definition
  is returned."
  (symbol-function variable))

(defun boundp (variable)
  "VARIABLE must evaluate to a symbol.  Return () if this symbol is
  unbound, T if it has a value."
  (boundp variable))

(defun fboundp (variable)
  "VARIABLE must evaluate to a symbol.  Return () if this symbol is
  undefined, T if it has a definition."
  (fboundp variable))

(defun symbol-plist (variable)
  "VARIABLE must evaluate to a symbol.  Return its property list."
  (symbol-plist variable))

(defun symbol-name (variable)
  "VARIABLE must evaluate to a symbol.  Return its print name."
  (%sp-get-pname variable))

;;; *** Flush this someday. ***
(defun symbol-print-name (variable)
  "Obsolete version of Symbol-Name.  This will go away soon."
  (%sp-get-pname variable))

(defun samepnamep (sym1 sym2)
  "Returns T if the print names of Sym1 and Sym2 are equal."
  (equal (symbol-name sym1) (symbol-name sym2)))

(defun symbol-package (variable)
  "VARIABLE must evaluate to a symbol.  Return its package."
  (symbol-package variable))

(defun make-symbol (string)
  "Make and return a new symbol with the STRING as its print name."
  (make-symbol string))

(defun get (symbol indicator &optional (default nil))
  "Look on the property list of SYMBOL for the specified INDICATOR.  If this
  is found, return the associated value, else return DEFAULT."
  (do ((pl (symbol-plist symbol) (cddr pl)))
      ((atom pl) default)
    (cond ((atom (cdr pl))
	   (error "~S has an odd number of items in its property list."
		   symbol))
	  ((eq (car pl) indicator)
	   (return (cadr pl))))))

(defun %put (symbol indicator value)
  "The VALUE is added as a property of SYMBOL under the specified INDICATOR.
  Returns VALUE."
  (do ((pl (symbol-plist symbol) (cddr pl)))
      ((atom pl)
       (%set-plist symbol (list* indicator value (symbol-plist symbol)))
       value)
    (cond ((atom (cdr pl))
	   (error "~S has an odd number of items in its property list."
		  symbol))
	  ((eq (car pl) indicator)
	   (rplaca (cdr pl) value)
	   (return value)))))

(defun remprop (symbol indicator)
  "Look on property list of SYMBOL for property with specified
  INDICATOR.  If found, splice this indicator and its value out of
  the plist, and return the tail of the original list starting with
  INDICATOR.  If not found, return () with no side effects."
  (do ((pl (symbol-plist symbol) (cddr pl))
       (prev nil pl))
      ((atom pl) nil)
    (cond ((atom (cdr pl))
	   (error "~S has an odd number of items in its property list."
		  symbol))
	  ((eq (car pl) indicator)
	   (cond (prev (rplacd (cdr prev) (cddr pl)))
		 (t (%set-plist symbol (cddr pl))))
	   (return pl)))))

(defun getf (place indicator &optional (default ()))
  "Searches the property list stored in Place for an indicator EQ to Indicator.
  If one is found, the corresponding value is returned, else the Default is
  returned."
  (do ((plist place (cddr plist)))
      ((null plist) default)
    (cond ((atom (cdr plist))
	   (error "~S is a malformed property list."
		  place))
	  ((eq (car plist) indicator)
	   (return (cadr plist))))))


(defun get-properties (place indicator-list)
  "Like GETF, except that Indicator-List is a list of indicators which will
  be looked for in the property list stored in Place.  Three values are
  returned, see manual for details."
  (do ((plist place (cddr plist)))
      ((null plist) (values nil nil nil))
    (cond ((atom (cdr plist))
	   (error "~S is a malformed proprty list."
		  place))
	  ((memq (car plist) indicator-list)
	   (return (values (car plist) (cadr plist) plist))))))

(defun samenamep (sym1 sym2)
  "Returns T if the two symbols have equal print names.  Case is
  distinguished by this predicate."
  (string= (symbol-name sym1) (symbol-name sym2)))

(defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol)
  "Make and return a new uninterned symbol with the same print name
  as SYMBOL.  If COPY-PROPS is null, the new symbol has no properties.
  Else, it has a copy of SYMBOL's property list."
  (setq new-symbol (make-symbol (symbol-name symbol)))
  (if copy-props
      (%set-plist new-symbol (copy-seq (symbol-plist symbol))))
  new-symbol)


;;; The following implement GENSYM in a fairly kludgy way.  Once more of
;;; the system is working, we can improve this.

(defvar gensym-prefix "G"
  "Default prefix string for GENSYM symbols.")

(defvar gensym-counter 0
  "Counter for generating unique GENSYM symbols.")

;;; Turns an integer into a six-character string.

(defun integer-to-string (n)
  (do ((string (make-string 6))
       (index 5 (1- index)))
      ((minusp index) string)
    (setf (char string index) (digit-char (rem n 10.)))
    (setq n (truncate n 10.))))

(defun gensym (&optional (x nil xp))
  "Creates a new uninterned symbol whose name is a prefix string
  (defaults to \"G\"), followed by a decimal number.  The number is
  incremented by each call to GENSYM.  X, if supplied and an integer,
  resets the counter.  If X is a string, it becomes the new prefix."
  (if xp (typecase x
	   (string (setq gensym-prefix (coerce x 'simple-string)))
	   (integer (setq gensym-counter x))
	   (t (error "~S is an illegal argument to GENSYM." x))))
  (let ((temp (integer-to-string gensym-counter)))
    (declare (simple-string temp))
    (setq gensym-counter (1+ gensym-counter))
    (make-symbol (concatenate 'simple-string
			      (the simple-string gensym-prefix) temp))))

(defun gentemp (&optional (prefix t) (package *package*))
  "Creates a new symbol interned in package Package with the given Prefix."
  (do ((new-pname (concatenate 'simple-string (string prefix)
			       (integer-to-string gensym-counter))
		  (concatenate 'simple-string (string prefix)
			       (integer-to-string gensym-counter))))
      ((multiple-value-bind (symbol there-p)
			   (find-symbol new-pname package)
	 symbol
	 (not there-p))
       (intern new-pname package))
    (setq gensym-counter (1+ gensym-counter))))

(declare (special *keyword-package*))

(defun keywordp (symbol)
  "Returns T if the Symbol belongs to the Keyword package, Nil otherwise."
  (eq (symbol-package symbol) *keyword-package*))