Extracted from lisp-reader package stuff.

Pascal J. Bourguignon [2013-12-15 02:09]
Extracted from lisp-reader package stuff.
Filename
symbol.lisp
diff --git a/symbol.lisp b/symbol.lisp
new file mode 100644
index 0000000..98c966a
--- /dev/null
+++ b/symbol.lisp
@@ -0,0 +1,353 @@
+;;; 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