From: David Vázquez Date: Sat, 4 May 2013 11:13:09 +0000 (+0100) Subject: Rename some functions X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=5fd5a3d813ed29bb766f6ce90b7b5d15f639783d;p=jscl.git Rename some functions --- diff --git a/src/print.lisp b/src/print.lisp index 1718b82..310754e 100644 --- a/src/print.lisp +++ b/src/print.lisp @@ -18,7 +18,9 @@ ;;; Printer -(defun special-symbol-name (s &key uppercase) +;;; Return T if the string S contains characters which need to be +;;; escaped to print the symbol name, NIL otherwise. +(defun escape-symbol-name-p (s &optional uppercase) (let ((dots-only t)) (dotimes (i (length s)) (let ((ch (char s i))) @@ -28,10 +30,10 @@ (and uppercase (not (char= ch (char (string-upcase (string ch)) 0)))) (char= ch #\\) (char= ch #\|)) - (return-from special-symbol-name t)))) + (return-from escape-symbol-name-p t)))) dots-only)) -(defun potential-number (s) +(defun potential-number-p (s) (let ((i 0) (n (length s)) (ch nil)) @@ -39,16 +41,16 @@ (setf ch (and (< i n) (char s (1- (incf i))))))) (next) (cond - ((null ch) (return-from potential-number)) + ((null ch) (return-from potential-number-p)) ((digit-char-p ch)) ((char= ch #\.)) ((char= ch #\+) (next)) ((char= ch #\-) (next)) - (t (return-from potential-number))) + (t (return-from potential-number-p))) (when ch (while (and ch (digit-char-p ch)) (next)) (when (null ch) - (return-from potential-number t))) + (return-from potential-number-p t))) (when (char= ch #\.) (next) (when ch @@ -59,19 +61,22 @@ (char= ch #\L) (char= ch #\l)) (next) (cond - ((null ch) (return-from potential-number)) + ((null ch) (return-from potential-number-p)) ((digit-char-p ch)) ((char= ch #\+) (next)) ((char= ch #\-) (next)) - (t (return-from potential-number))) + (t (return-from potential-number-p))) (unless (and ch (digit-char-p ch)) - (return-from potential-number)) + (return-from potential-number-p)) (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"))))) +(defun escape-token-p (string &optional uppercase) + (or (potential-number-p string) + (escape-symbol-name-p string uppercase))) + +(defun escape-token (s &optional uppercase) + (if (escape-token-p s uppercase) (let ((result "|")) (dotimes (i (length s)) (let ((ch (char s i))) @@ -82,61 +87,59 @@ (concat result "|")) s)) + (defvar *print-escape* t) (defun write-to-string (form) (cond - ((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 "#") - (concat "#")))) - ((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 "#")) - (t - (concat "#")))) + ((null form) "NIL") + ((symbolp form) + (multiple-value-bind (found-symbol status) + (find-symbol (symbol-name form)) + (if (eq found-symbol form) + (escape-token (symbol-name form) (not (eq *package* *js-package*))) + (let ((package (symbol-package form)) + (name (symbol-name form))) + (concat (cond + ((null package) "#") + ((eq package (find-package "KEYWORD")) "") + (t (escape-token (package-name package)))) + ":" + (if (or (null package) (eq :external (second (multiple-value-list (find-symbol name package))))) + "" ":") + (escape-token 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 "#") + (concat "#")))) + ((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 "#")) + (t + (concat "#")))) (defun prin1-to-string (form) (let ((*print-escape* t)) diff --git a/src/read.lisp b/src/read.lisp index 190ec79..7b7518b 100644 --- a/src/read.lisp +++ b/src/read.lisp @@ -148,7 +148,7 @@ (list 'function (ls-read stream))) (#\( (list-to-vector (%read-list stream))) (#\: (make-symbol - (unescape + (unescape-token (string-upcase-noescaped (read-escaped-until stream #'terminalp))))) (#\\ @@ -172,7 +172,7 @@ (:jscl (ls-read stream eof-error-p eof-value))))))) -(defun unescape (x) +(defun unescape-token (x) (let ((result "")) (dotimes (i (length x)) (unless (char= (char x i) #\\) @@ -224,7 +224,7 @@ (setq name (subseq string index)))) ;; Canonalize symbol name and package (setq name (if (equal package "JS") - (setq name (unescape name)) + (setq name (unescape-token name)) (setq name (string-upcase-noescaped name)))) (setq package (find-package package)) (if (or internalp