;;; 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)