;;; -*- Mode:LISP; Package:SYMBOL; Readtable:CL; Base:10 -*-



(export '(boundp
	  fboundp
	  fmakunbound
	  get
	  get-properties
	  getf
	  make-symbol
	  makunbound
	  remf
	  remprop
	  set
	  symbol-function
	  symbol-name
	  symbol-package
	  symbol-plist
	  symbol-value
 ))
	  
	  
(defconstant *symbol-size* 5)

(defconstant *symbol-pname*    0)
(defconstant *symbol-value*    1)
(defconstant *symbol-function* 2)
(defconstant *symbol-package*  3)
(defconstant *symbol-plist*    4)

;;; Isn't Common LISP wonderful, NIL is a symbol and a LIST

;; T if object is DTP-SYMBOL
(defsubst %symbol? (object)
  (hw:field= gr:*T*
	     object vinc::%%data-type))

;; T if object is DTP-SYMBOL or DTP-NIL
(defsubst symbol? (object)
  (hw:32logbitp (hw:ldb object vinc::%%data-type 0)
		(hw:unboxed-constant
		  #.(lisp:logior (lisp:ash 1 $$dtp-nil)
				 (lisp:ash 1 $$dtp-symbol)))))

;;; Print Name

;;; 1.  Pnames are not allowed to be altered, just read.
;;; 2.  PNAME of NIL is funny because of how we make CAR and CDR
;;;     of NIL fast.

(defun %symbol-pname (symbol)
  ;; Won't work on NIL.
  (contents-offset symbol *symbol-pname*))

(defun symbol-name (symbol)
  (cond ((%symbol? symbol) (make-pointer $$dtp-array (%symbol-pname symbol)))
	((null symbol)     "NIL")
	(t (li:error "Wasn't a symbol to symbol name." symbol))))

;;; Value Cell

;;; 1. SYMBOL-VALUE is the real symbol value
;;; 2. %SET does not check to see if the symbol is constant.
;;;    SET probably should
;;; 3. Therefore, we do not defsetf symbol-value to %set
;;; 4. Same thing goes for %make-unbound
;;; 5. Implement SETQ as a call to SET.

(defun %symbol-value (symbol)
  (contents-offset symbol *symbol-value*))

(defun symbol-value (symbol)
  (if (symbol? symbol)
      (contents-offset symbol *symbol-value*)
      (li:error "SYMBOL-VALUE not called on a symbol")))

(defun %%set (symbol value)
  (cond ((eq symbol 'T)
	 (trap::illop "Veritas aeterae: don't set T"))
	((eq symbol 'NIL)
	 (trap::illop "Nihil ex nilhil: don't set NIL"))
	((%symbol? symbol)
	 (store-contents-offset symbol *symbol-value* value))
	(t (li:error "SET not called on a symbol")))
  ;; @@@ return to this when we are sure it is safe to go back in the water ... 
;   (store-contents-offset symbol *symbol-value* value)
  )

(defun %set (symbol value)
  (cond ((eq symbol 'T)
	 (trap::illop "Veritas aeterae: don't set T"))
	((eq symbol 'NIL)
	 (trap::illop "Nihil ex nilhil: don't set NIL"))
	((%symbol? symbol)
	 (store-contents-offset symbol *symbol-value* value))
	(t (li:error "SET not called on a symbol")))
  ;; @@@ return to this when we are sure it is safe to go back in the water ... 
;  (if (%symbol? symbol)
;      (store-contents-offset symbol *symbol-value* value)
;    (li:error "SET not called on a symbol"))
  )

(defun set (symbol value)
  (cond ((eq symbol 'T)
	 (trap::illop "Veritas aeterae: don't set T"))
	((eq symbol 'NIL)
	 (trap::illop "Nihil ex nilhil: don't set NIL"))
	((%symbol? symbol)
	 (store-contents-offset symbol *symbol-value* value))
	(t (li:error "SET not called on a symbol"))))

(defun %make-unbound (symbol)
  (%set symbol (make-pointer $$dtp-unbound symbol))
  symbol)

(defsubst cell-bound? (cell)
  (hw:vma-start-read-will-write-vma-unboxed-md-boxed cell)
  (not (vinc:data-type= (hw:read-md)
			(hw:unboxed-constant #.(lisp:ash $$dtp-unbound
							 (byte-position vinc:%%data-type))))))

(defun boundp (symbol)
  (if (symbol? symbol)
      (cell-bound? (hw:24+ *symbol-value* symbol)) 		;*** 24+ is not really sufficient
      (li:error "Boundp not called on a symbol")))

(defun makunbound (symbol)
  (set symbol (make-pointer $$dtp-unbound symbol))
  symbol)

;;; Function Cell

;;; 1. SYMBOL-FUNCTION is the common lisp function
;;; 2. When bashing the function cell of a symbol, it is important
;;;    to unlink any FEF it may be pointing at.

(defun %symbol-function (symbol)  ;;;@@@ Turn into a macro for speed. --wkf
  (contents-offset symbol *symbol-function*))

(defun symbol-function (symbol)
  (if (symbol? symbol)
      (%symbol-function symbol)
      (li:tail-error "SYMBOL-FUNCTION not called on a symbol")))

(defun %set-symbol-function (symbol value)  ;;@@@ Turn into a macro for speed. --wkf
  "Returns value."
  (cons:%store-contents-offset symbol *symbol-function* value))

(defun set-symbol-function (symbol value)
  (if (symbol? symbol)
      (if (%fboundp symbol)
	  (let ((old-function (%symbol-function symbol)))
	    (if (eq old-function value)
		value
	      (progn (%set-symbol-function symbol value)
		     (k2:kill-old-function old-function))))
	(%set-symbol-function symbol value))
    (li:tail-error "~A is not a symbol in SET-SYMBOL-FUNCTION" symbol)))

(defun %fmakunbound (symbol)
  (%set-symbol-function symbol (make-pointer $$dtp-unbound symbol))
  symbol)

(defun fmakunbound (symbol)
  (set-symbol-function symbol (make-pointer $$dtp-unbound symbol))
  symbol)

(defun %fboundp (symbol)
  (cell-bound? (hw:24+ *symbol-function* symbol)))

(defun fboundp (symbol)
  (if (symbol? symbol)
      (cell-bound? (hw:24+ *symbol-function* symbol))
      (li:error "FBOUNDP not called on a symbol")))

(defsetf symbol-function set-symbol-function)

;;; Package cells

;;; 1. No restrictions on SYMBOL-PACKAGE

(defun symbol-package (symbol)
  (if (symbol? symbol)
      (contents-offset symbol *symbol-package*)
      (li:error "SYMBOL-PACKAGE not called on a symbol")))

(defun set-symbol-package (symbol value)
  (if (symbol? symbol)
      (progn (store-contents-offset symbol *symbol-package* value)
	     value)
      (li:error "SET-SYMBOL-PACKAGE not called on a symbol")))

(defsetf symbol-package set-symbol-package)


;;; Property List

(defun symbol-plist (symbol)
  (if (symbol? symbol)
      (contents-offset symbol *symbol-plist*)
      (li:error "SYMBOL-PLIST not called on a symbol")))

(defun set-symbol-plist (symbol value)
  (if (symbol? symbol)
      (progn (store-contents-offset symbol *symbol-plist* value)
	     value)
      (li:error "SET-SYMBOL-PLIST not called on a symbol")))

(defsetf symbol-plist set-symbol-plist)


(defun get (symbol property &optional default)
  (do ((plist (symbol-plist symbol) (cons:cddr plist)))
      ((null plist) default)
    (when (eq property (cons:car plist))
      (return (cons:cadr plist)))))

(defun getf (list property &optional default)
  (do ((plist list (cons:cddr plist)))
      ((null plist) default)
    (when (eq property (cons:car plist))
      (return (cons:cadr plist)))))

(defun %putf (plist property data)
  (if (null plist)
      (cons:cons property (cons:cons data nil))
    (do () (())
      (if (eq property (cons:car plist))
	  (progn
	    (cons:rplaca (cons:cdr plist) data)
	    (return plist))
	(let ((new-plist (cons:cddr plist)))
	  (if new-plist
	      (setq plist new-plist)
	    (progn
	      (cons:rplacd (cons:cdr plist) (cons:cons property (cons:cons data nil)))
	      (return plist))))))))


(defun %put (symbol property data &optional default)
  (store-contents-offset symbol *symbol-plist* (%putf (symbol-plist symbol) property data))
  data)


(select-processor
  (:lambda )
  (:k
    (defsetf get  (symbol property &optional default) (value)
      `(%put ,symbol ,property ,value))))

(defun remprop (symbol property)
  (incf gr:*allow-sequence-break*)
  (multiple-value-bind (new-plist found-it)
      (%remprop (symbol-plist symbol) property)
    (setf (symbol-plist symbol) new-plist)
    (decf gr:*allow-sequence-break*)
    found-it))

(defun %remprop (plist property)
  (if (eq (cons:car plist) property)
      (values (cons:cddr plist) t)
    (do ((plist (cons:cdr plist) (cons:cddr plist)))
	((null plist) nil)
      (when (eq property (cons:cadr plist))
	(cons:rplacd plist (cons:cddr plist))
	(values plist t)))))

(defmacro remf (plist property)
  `(setf ,plist (%remprop ,plist ,property)))

(defun get-properties (plist properties)
  (do* ((plist plist (cons:cddr plist))
	(this-p (cons:car plist) (cons:car plist)))
       ((null plist) nil)
    (do* ((properties properties (cons:cdr properties))
	  (property (cons:car properties) (cons:car properties)))
	 ((null properties))
      (when (eq this-p property)
	(return-from get-properties (values property (cons:cadr plist) plist))))))


;;; Making symbols

(defun %make-symbol (pname)
  (let ((symbol
	  (allocate-structure *symbol-size* 0
			      $$dtp-symbol
			      (make-header $$dtp-symbol-header pname))))
    ;; PNAME is set up by allocate structure
    ;; We know that the symbol is not constant because we just made it.
    (%make-unbound symbol)
    (%fmakunbound symbol)
    ;; These two not strictly necessary as structures are filled with NIL
    ;; when created.
    (setf (symbol-plist symbol)   nil)
    (setf (symbol-package symbol) nil)
    symbol))
	  
(defun make-symbol (pname)
  (if (array:stringp pname)
      (%make-symbol pname)
    (li:error "~a is not a string" pname)))