;;; Implementation of syms

(defgeneric make-symbol (sym-name)
  (:documentation "
DO:     Make a new symbol
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_mk_sym.htm>
"))

(defgeneric symbol-name (sym)
  (:documentation "
RETURN: the name of the symbol.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_symb_2.htm>
"))


(defgeneric symbol-plist (symbol)
(:documentation "
RETURN: The plist of the symbol.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_symb_4.htm>
"))

(defgeneric symbol-value (symbol)
(:documentation "
RETURN: The value of the symbol.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_symb_5.htm>
"))

(defgeneric symbol-function (symbol)
(:documentation "
RETURN: The function of the symbol.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_symb_1.htm>
"))

(defclass symbol ()
  ((name
    :initarg :name
    :reader symbol-name)
   (pack
    :initarg :pack
    :reader symbol-package
    :accessor sym-pack)
   (plist
    :initarg :plist
    :initform nil
    :accessor symbol-plist)
   (value
    :initarg :value
    :accessor symbol-value)
   (function
    :initarg :function
    :accessor symbol-function)
   (constantp
    :initarg :constantp
    :initform nil
    :accessor symbol-constantp))
  (:default-initargs
   :pack nil)
  (:documentation "
The symbol class.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/t_symbol.htm>
"))

(defgeneric symbolp (object)
  (:method ((object t))      nil)
  (:method ((object symbol)) t)
  (:documentation "
RETURN: Whether the object is a symbol.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_symbol.htm>
"))


(defgeneric boundp (object)
  (:method ((object t))
    (error 'type-error :datum object :expected-type 'symbol))
  (:method ((object symbol))
    (slot-boundp object 'value))
  (:documentation "
RETURN: Whether the symbol is bound to a value.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_boundp.htm>
"))

(defgeneric fboundp (object)
  (:method ((object t))
    (error 'type-error :datum object :expected-type 'symbol))
  (:method ((object symbol))
    (slot-boundp object 'function))
  (:documentation "
RETURN: Whether the symbol is fbound to a function.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_fbound.htm>
"))


(defclass keyword (symbol)
  ()
  (:documentation "
The keyword class.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/t_kwd.htm>
"))


(defgeneric keywordp (object)
  (:method ((object t))       nil)
  (:method ((object keyword)) t)
  (:documentation "
RETURN: Whether the object is a keyword.
URL:    <http://www.lispworks.com/documentation/HyperSpec/Body/f_kwdp.htm>
"))


(defmethod make-symbol (sym-name)
  (make-instance 'symbol :name (copy-seq sym-name)))

(defmethod make-load-form ((sym symbol) &optional environment)
  (declare (ignore environment))
  `(intern ,(symbol-name sym) ,(package-name (symbol-package sym))))


(defun constituentp (ch first-character-p &optional (readtable *readtable*))
  (multiple-value-bind (macro-character-p non-terminating-p) (get-macro-character ch readtable)
    (or (not macro-character-p)
        (and (not first-character-p)
             non-terminating-p))))

(defun specialp (ch &optional (readtable *readtable*))
  (declare (ignore readtable))
  (find ch #(#\Space #\: #\| #\\
             #\Newline #\Tab #\Linefeed #\Return #\Page)))

(defun parses-as-a-number-p (string &key (start 0) (end nil) (base *read-base*))
  ;; integer  ::= [sign] digit+
  ;; integer  ::= [sign] decimal-digit+ decimal-point
  ;; ratio    ::= [sign] {decimal-digit}+ '/' {decimal-digit}+
  ;; float    ::= [sign] {decimal-digit}* decimal-point {decimal-digit}+ exponent
  ;; float    ::= [sign] {decimal-digit}* decimal-point {decimal-digit}+
  ;; float    ::= [sign] {decimal-digit}+ exponent
  ;; float    ::= [sign] {decimal-digit}+ decimal-point {decimal-digit}* exponent
  ;; exponent ::=  exponent-marker [sign] {digit}+
  ;; We may ignore ratio starting with #\# since that's excluded by constituentp.
  ;; ratio    ::= [#b|#o|#x|#{decimal-digit}+r] [sign] digit+ '/' digit+
  (loop
    :with end =  (or end (length string))
    :with i = start
    :with state = :opt-sign
    :for ch = (and (< i end) (aref string i))
    :while (< i end)
    :do (ecase state
          (:opt-sign (case ch ((#\+ #\-) (incf i)))
                     (setf state :unknown0))
          (:unknown0  (if (<= base 10)
                          (cond
                            ((digit-char-p ch base) (incf i) (setf state :unknown1))
                            ((digit-char-p ch 10)   (incf i) (setf state :decimal))
                            (t (case ch
                                 ((#\.) (incf i) (setf state :float0))
                                 (otherwise (return nil)))))
                          (cond
                            ((digit-char-p ch 10)   (incf i) (setf state :unknown1))
                            ((digit-char-p ch base) (incf i) (setf state :integer))
                            (t (case ch
                                 ((#\.) (incf i) (setf state :float0))
                                 (otherwise (return nil)))))))
          (:unknown1  (if (<= base 10)
                          (cond
                            ((digit-char-p ch base) (incf i) (setf state :unknown1))
                            ((digit-char-p ch 10)   (incf i) (setf state :decimal))
                            (t (case ch
                                 ((#\/) (incf i) (setf state :ratio0))
                                 ((#\.) (incf i) (setf state :dot))
                                 ((#\D #\d #\E #\e #\F #\f #\L #\l #\S #\s)
                                  (incf i) (setf state :float-expo/opt-sign))
                                 (otherwise (return nil)))))
                          (cond
                            ((digit-char-p ch 10)   (incf i) (setf state :unknown1))
                            ((digit-char-p ch base) (incf i) (setf state :integer))
                            (t (case ch
                                 ((#\/) (incf i) (setf state :ratio0))
                                 ((#\.) (incf i) (setf state :dot))
                                 ((#\D #\d #\E #\e #\F #\f #\L #\l #\S #\s)
                                  (incf i) (setf state :float-expo/opt-sign))
                                 (otherwise (return nil)))))))
          (:integer   (if (digit-char-p ch base)
                          (incf i)
                          (return nil)))
          (:decimal   (if (digit-char-p ch 10)
                          (incf i)
                          (case ch
                            ((#\/) (incf i) (setf state :ratio0))
                            ((#\.) (incf i) (setf state :dot))
                            ((#\D #\d #\E #\e #\F #\f #\L #\l #\S #\s)
                             (incf i) (setf state :float-expo/opt-sign))
                            (otherwise (return nil)))))
          (:dot      (if (digit-char-p ch 10)
                         (progn (incf i) (setf state :float))
                         (case ch
                           ((#\D #\d #\E #\e #\F #\f #\L #\l #\S #\s)
                            (incf i) (setf state :float-expo/opt-sign))
                           (otherwise (return nil)))))
          (:ratio0   (if (digit-char-p ch 10)
                         (progn (incf i) (setf state :ratio))
                         (return nil)))
          (:ratio    (if (digit-char-p ch 10)
                         (incf i)
                         (return nil)))
          (:float0   (if (digit-char-p ch 10)
                         (progn (incf i) (setf state :float))
                         (return nil)))
          (:float    (if (digit-char-p ch 10)
                         (incf i)
                         (case ch
                           ((#\D #\d #\E #\e #\F #\f #\L #\l #\S #\s)
                            (incf i) (setf state :float-expo/opt-sign))
                           (otherwise (return nil)))))
          (:float-expo/opt-sign (case ch ((#\+ #\-) (incf i)))
                                (setf state :float-expo0))
          (:float-expo0 (if (digit-char-p ch 10)
                            (progn (incf i) (setf state :float-expo))
                            (return nil)))
          (:float-expo  (if (digit-char-p ch 10)
                            (incf i)
                            (return nil))))
    :finally (return (case state
                       ((:unknown1 :integer :dot :ratio :float :float-expo) t)
                       (otherwise nil)))))


(defun needs-escape-p (symbol-name)
  "Whether the symbol name needs to be escaped."
  (cond
    ((string= "" symbol-name) t)
    ((or *print-readably* *print-escape*)
     (or (notevery (let ((first-character-p t))
                     (lambda (ch)
                       (prog1 (and (not (specialp ch))
                                   (constituentp ch first-character-p))
                         (setf first-character-p nil))))
                   symbol-name)
         ;; Parses as a number integer, decimal, ratio or float.
         (parses-as-a-number-p symbol-name :base *print-base*)))
    (t
     nil)))

(defun mixed-case-p (string)
  "Whether the string contains both lower case and upper case letters."
  (and (some (lambda (ch) (and (alpha-char-p ch) (upper-case-p ch))) string)
       (some (lambda (ch) (and (alpha-char-p ch) (lower-case-p ch))) string)))

(defun prepare-symbol-name (sname)
  (cond
    ((needs-escape-p sname)
     (with-output-to-string (*standard-output*)
       (loop
         :for ch :across sname
         :initially (princ "|")
         :do (if (char= #\| ch) (princ "\\|") (princ ch))
         :finally (princ "|"))))
    (t
     (let ((transform
            (if *print-escape*
                (ecase (readtable-case *readtable*)
                  (:upcase     (lambda (ch)
                                 (if (both-case-p ch)
                                     (if (lower-case-p ch)
                                         (format nil "\\~C" ch)
                                         ch)
                                     ch)))
                  (:downcase   (lambda (ch)
                                 (if (both-case-p ch)
                                     (if (upper-case-p ch)
                                         (format nil "\\~C" ch)
                                         ch))))
                  (:preserve   (function identity))
                  (:invert     (function identity)))
                (ecase (readtable-case *readtable*)
                  (:upcase     (let ((start-word t))
                                 (lambda (ch)
                                   (prog1 (if (both-case-p ch)
                                              (if (upper-case-p ch)
                                                  (ecase *print-case*
                                                    (:upcase     ch)
                                                    (:downcase   (char-downcase ch))
                                                    (:capitalize (if start-word
                                                                     (char-upcase ch)
                                                                     (char-downcase ch))))
                                                  ch)
                                              ch)
                                     (if (alphanumericp ch)
                                         (setf start-word nil)
                                         (setf start-word t))))))
                  (:downcase   (let ((start-word t))
                                 (lambda (ch)
                                   (prog1 (if (both-case-p ch)
                                              (if (lower-case-p ch)
                                                  (ecase *print-case*
                                                    (:upcase     (char-upcase ch))
                                                    (:downcase   ch)
                                                    (:capitalize (if start-word
                                                                     (char-upcase ch)
                                                                     (char-downcase ch))))
                                                  ch)
                                              ch)
                                     (if (alphanumericp ch)
                                         (setf start-word nil)
                                         (setf start-word t))))))
                  (:preserve   (function identity))
                  (:invert     (if (mixed-case-p sname)
                                   (function identity)
                                   (lambda (ch)
                                     (cond
                                       ((not (both-case-p ch)) ch)
                                       ((upper-case-p ch)      (char-downcase ch))
                                       ((lower-case-p ch)      (char-upcase ch))
                                       (t                      ch)))))))))
       (with-output-to-string (*standard-output*)
         (loop
           :for ch :across sname
           :do (princ (funcall transform ch))))))))


(defmethod print-object ((sym symbol) stream)
  (let ((*print-readably* t))
    (flet ((print-it ()
             (let ((pack (symbol-package sym)))
               (cond ((null pack)
                      (format stream "~:[~;#:~]~A"
                              (or *print-readably* (and *print-escape* *print-gensym*))
                              (prepare-symbol-name (symbol-name sym))))
                     ((eql pack *keyword-package*)
                      (format stream ":~A"
                              (prepare-symbol-name (symbol-name sym))))
                     ((or (eq pack *package*)
                          (eq sym (find-symbol (symbol-name sym) *package*)))
                      (format stream "~A" (prepare-symbol-name (symbol-name sym))))
                     (t
                      (format stream "~A~:[::~;:~]~A"
                              (prepare-symbol-name (package-name pack))
                              (externalp sym pack)
                              (prepare-symbol-name (symbol-name sym))))))))
      (if *print-readably*
          (print-it)
          (progn
            (format stream "#<~S " 'symbol)
            (print-it)
            (format stream ">")))))
  sym)


(defmethod make-constant (symbol value)
  (declare (ignorable value))
  (setf (symbol-value symbol) value
        (symbol-constantp symbol) t)
  symbol)

ViewGit