;;; Printer
+(defun special-symbol-name (s &key uppercase)
+ (let ((dots-only t))
+ (dotimes (i (length s))
+ (let ((ch (char s i)))
+ (setf dots-only (and dots-only (char= ch #\.)))
+ (when (or (terminalp ch)
+ (char= ch #\:)
+ (and uppercase (not (char= ch (char (string-upcase (string ch)) 0))))
+ (char= ch #\\)
+ (char= ch #\|))
+ (return-from special-symbol-name t))))
+ dots-only))
+
+(defun potential-number (s)
+ (let ((i 0)
+ (n (length s))
+ (ch nil))
+ (flet ((next ()
+ (setf ch (and (< i n) (char s (1- (incf i)))))))
+ (next)
+ (cond
+ ((null ch) (return-from potential-number))
+ ((digit-char-p ch))
+ ((char= ch #\.))
+ ((char= ch #\+) (next))
+ ((char= ch #\-) (next))
+ (t (return-from potential-number)))
+ (when ch
+ (while (and ch (digit-char-p ch)) (next))
+ (when (null ch)
+ (return-from potential-number t)))
+ (when (char= ch #\.)
+ (next)
+ (when ch
+ (while (and ch (digit-char-p ch)) (next))))
+ (when (or (char= ch #\E) (char= ch #\e)
+ (char= ch #\D) (char= ch #\d)
+ (char= ch #\F) (char= ch #\f)
+ (char= ch #\L) (char= ch #\l))
+ (next)
+ (cond
+ ((null ch) (return-from potential-number))
+ ((digit-char-p ch))
+ ((char= ch #\+) (next))
+ ((char= ch #\-) (next))
+ (t (return-from potential-number)))
+ (unless (and ch (digit-char-p ch))
+ (return-from potential-number))
+ (while (and ch (digit-char-p ch)) (next)))
+ (null ch))))
+
+(defun special-escape (s package)
+ (if (or (potential-number s)
+ (special-symbol-name s :uppercase (not (eq package (find-package "JS")))))
+ (let ((result "|"))
+ (dotimes (i (length s))
+ (let ((ch (char s i)))
+ (when (or (char= ch #\|)
+ (char= ch #\\))
+ (setf result (concat result "\\")))
+ (setf result (concat result (string ch)))))
+ (concat result "|"))
+ s))
+
(defvar *print-escape* t)
(defun write-to-string (form)
(cond
- ((symbolp form)
- (multiple-value-bind (symbol foundp)
- (find-symbol (symbol-name form) *package*)
- (if (and foundp (eq symbol form))
- (symbol-name form)
- (let ((package (symbol-package form))
- (name (symbol-name form)))
- (concat (cond
- ((null package) "#")
- ((eq package (find-package "KEYWORD")) "")
- (t (package-name package)))
- ":" name)))))
- ((integerp form) (integer-to-string form))
- ((floatp form) (float-to-string form))
- ((characterp form)
- (concat "#\\"
- (case form
- (#\newline "newline")
- (#\space "space")
- (otherwise (string form)))))
- ((stringp form) (if *print-escape*
- (concat "\"" (escape-string form) "\"")
- form))
- ((functionp form)
- (let ((name (oget form "fname")))
- (if name
- (concat "#<FUNCTION " name ">")
- (concat "#<FUNCTION>"))))
- ((listp form)
- (concat "("
- (join-trailing (mapcar #'write-to-string (butlast form)) " ")
- (let ((last (last form)))
- (if (null (cdr last))
- (write-to-string (car last))
- (concat (write-to-string (car last)) " . " (write-to-string (cdr last)))))
- ")"))
- ((arrayp form)
- (concat "#" (if (zerop (length form))
- "()"
- (write-to-string (vector-to-list form)))))
- ((packagep form)
- (concat "#<PACKAGE " (package-name form) ">"))
- (t
- (concat "#<javascript object>"))))
+ ((null form) "NIL")
+ ((symbolp form)
+ (multiple-value-bind (found-symbol status)
+ (find-symbol (symbol-name form))
+ (if (eq found-symbol form)
+ (special-escape (symbol-name form) *package*)
+ (let ((package (symbol-package form))
+ (name (symbol-name form)))
+ (concat (cond
+ ((null package) "#")
+ ((eq package (find-package "KEYWORD")) "")
+ (t (package-name package)))
+ ":"
+ (if (eq (cadr (multiple-value-list
+ (find-symbol name)))
+ :internal)
+ ":"
+ "")
+ (special-escape name package))))))
+ ((integerp form) (integer-to-string form))
+ ((floatp form) (float-to-string form))
+ ((characterp form)
+ (concat "#\\"
+ (case form
+ (#\newline "newline")
+ (#\space "space")
+ (otherwise (string form)))))
+ ((stringp form) (if *print-escape*
+ (concat "\"" (escape-string form) "\"")
+ form))
+ ((functionp form)
+ (let ((name (oget form "fname")))
+ (if name
+ (concat "#<FUNCTION " name ">")
+ (concat "#<FUNCTION>"))))
+ ((listp form)
+ (concat "("
+ (join-trailing (mapcar #'write-to-string (butlast form)) " ")
+ (let ((last (last form)))
+ (if (null (cdr last))
+ (write-to-string (car last))
+ (concat (write-to-string (car last)) " . " (write-to-string (cdr last)))))
+ ")"))
+ ((arrayp form)
+ (concat "#" (if (zerop (length form))
+ "()"
+ (write-to-string (vector-to-list form)))))
+ ((packagep form)
+ (concat "#<PACKAGE " (package-name form) ">"))
+ (t
+ (concat "#<javascript object>"))))
(defun prin1-to-string (form)
(let ((*print-escape* t))
(defun format (destination fmt &rest args)
(let ((len (length fmt))
- (i 0)
- (res "")
- (arguments args))
+ (i 0)
+ (res "")
+ (arguments args))
(while (< i len)
(let ((c (char fmt i)))
- (if (char= c #\~)
- (let ((next (char fmt (incf i))))
- (cond
- ((char= next #\~)
- (concatf res "~"))
- ((char= next #\%)
- (concatf res *newline*))
- (t
- (concatf res (format-special next (car arguments)))
- (pop arguments))))
- (setq res (concat res (char-to-string c))))
- (incf i)))
+ (if (char= c #\~)
+ (let ((next (char fmt (incf i))))
+ (cond
+ ((char= next #\~)
+ (concatf res "~"))
+ ((char= next #\%)
+ (concatf res *newline*))
+ (t
+ (concatf res (format-special next (car arguments)))
+ (pop arguments))))
+ (setq res (concat res (char-to-string c))))
+ (incf i)))
(if destination
- (progn
- (write-string res)
- nil)
- res)))
-
+ (progn
+ (write-string res)
+ nil)
+ res)))
(defun format-special (chr arg)
(case chr
projects / jscl.git / blobdiff