CMUCL commit: src/code (exports.lisp extfmts.lisp)
Raymond Toy
rtoy at common-lisp.net
Sun Jul 11 00:50:58 CEST 2010
Date: Saturday, July 10, 2010 @ 18:50:58
Author: rtoy
Path: /project/cmucl/cvsroot/src/code
Modified: exports.lisp extfmts.lisp
extfmts.lisp:
o Add a simple function it list all external formats.
o Add some docstrings.
o Correctly indent some s-exps.
exports.lisp:
o Update package definitions to export new LIST-ALL-EXTERNAL-FORMATS.
--------------+
exports.lisp | 14 ++++++++-----
extfmts.lisp | 58 +++++++++++++++++++++++++++++++++++++++++++++++----------
2 files changed, 57 insertions(+), 15 deletions(-)
Index: src/code/exports.lisp
diff -u src/code/exports.lisp:1.296 src/code/exports.lisp:1.297
--- src/code/exports.lisp:1.296 Sun Apr 18 12:47:37 2010
+++ src/code/exports.lisp Sat Jul 10 18:50:58 2010
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/exports.lisp,v 1.296 2010-04-18 16:47:37 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/code/exports.lisp,v 1.297 2010-07-10 22:50:58 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -1252,7 +1252,8 @@
(dolist
(name
'("STRING-TO-OCTETS" "OCTETS-TO-STRING" "*DEFAULT-EXTERNAL-FORMAT*"
- "STRING-ENCODE" "STRING-DECODE" "SET-SYSTEM-EXTERNAL-FORMAT"))
+ "STRING-ENCODE" "STRING-DECODE" "SET-SYSTEM-EXTERNAL-FORMAT"
+ "LIST-ALL-EXTERNAL-FORMATS"))
(intern name "STREAM"))
(defpackage "EXTENSIONS"
@@ -1434,7 +1435,6 @@
"GET-PEER-HOST-AND-PORT" "GET-SOCKET-HOST-AND-PORT"
"OPEN-NETWORK-STREAM" "ACCEPT-NETWORK-STREAM")
-
;; CLX extensions
(:export "OPEN-CLX-DISPLAY" "WITH-CLX-EVENT-HANDLING" "ENABLE-CLX-EVENT-HANDLING"
"DISABLE-CLX-EVENT-HANDLING" "OBJECT-SET-EVENT-HANDLER"
@@ -1483,8 +1483,11 @@
(:import-from "STREAM"
"STRING-TO-OCTETS" "OCTETS-TO-STRING" "*DEFAULT-EXTERNAL-FORMAT*"
"STRING-ENCODE" "STRING-DECODE"
- "SET-SYSTEM-EXTERNAL-FORMAT")
+ "SET-SYSTEM-EXTERNAL-FORMAT"
+ "LIST-ALL-EXTERNAL-FORMATS")
+ ;; Unicode
(:export "STRING-TO-OCTETS" "OCTETS-TO-STRING" "*DEFAULT-EXTERNAL-FORMAT*"
+ "LIST-ALL-EXTERNAL-FORMATS"
"STRING-ENCODE" "STRING-DECODE"
"SET-SYSTEM-EXTERNAL-FORMAT"))
@@ -1551,7 +1554,8 @@
"STRING-TO-OCTETS" "OCTETS-TO-STRING" "*DEFAULT-EXTERNAL-FORMAT*"
"STRING-ENCODE" "STRING-DECODE"
"SET-SYSTEM-EXTERNAL-FORMAT"
- "+REPLACEMENT-CHARACTER-CODE+"))
+ "+REPLACEMENT-CHARACTER-CODE+"
+ "LIST-ALL-EXTERNAL-FORMATS"))
(defpackage "LOOP")
(dolist
Index: src/code/extfmts.lisp
diff -u src/code/extfmts.lisp:1.33 src/code/extfmts.lisp:1.34
--- src/code/extfmts.lisp:1.33 Mon Jul 5 18:45:50 2010
+++ src/code/extfmts.lisp Sat Jul 10 18:50:58 2010
@@ -5,7 +5,7 @@
;;; domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/extfmts.lisp,v 1.33 2010-07-05 22:45:50 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/code/extfmts.lisp,v 1.34 2010-07-10 22:50:58 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -17,12 +17,22 @@
(export '(string-to-octets octets-to-string *default-external-format*
string-encode string-decode set-system-external-format
- +replacement-character-code+))
+ +replacement-character-code+
+ list-all-external-formats))
-(defvar *default-external-format* :iso8859-1)
-
-(defvar *external-formats* (make-hash-table :test 'equal))
-(defvar *external-format-aliases* (make-hash-table))
+(defvar *default-external-format*
+ :iso8859-1
+ "The default external format to use if no other external format is
+ specified")
+
+(defvar *external-formats*
+ (make-hash-table :test 'equal)
+ "Hash table of all the external formats that have been loaded")
+
+(defvar *external-format-aliases*
+ (make-hash-table)
+ "Hash table mapping an external format alias to the actual external
+ format implementation")
(vm::defenum (:prefix "+EF-" :suffix "+" :start 1)
str ; string length
@@ -357,6 +367,34 @@
(warn (intl:gettext "Bad entry in external-format aliases file: ~S => ~S.")
alias value)))))))
+(defun list-all-external-formats ()
+ "List the available external formats. A list is returned where each
+ element is list of the external format and a list of aliases for the
+ format. No distinction is made between external formats and
+ composing external formats."
+ ;; Look for all lisp files in the ext-formats directory. These are
+ ;; the available formats.
+ (let ((ef (make-hash-table))
+ result)
+ (map nil #'(lambda (p)
+ (setf (gethash (intern (string-upcase (pathname-name p)) :keyword) ef)
+ nil))
+ (directory "ext-formats:*.lisp"))
+
+ ;; Look through aliases and update formats with a list of aliases.
+ (load-external-format-aliases)
+ (maphash #'(lambda (k v)
+ (push k (gethash v ef)))
+ *external-format-aliases*)
+
+ (maphash #'(lambda (k v)
+ (push (if v
+ (list k v)
+ (list k))
+ result))
+ ef)
+ (sort result #'string< :key #'first)))
+
(defun %find-external-format (name)
;; avoid loading files, etc., early in the boot sequence
(when (or (eq name :iso8859-1)
@@ -605,9 +643,9 @@
;; the compiler messages.
#|(*default-external-format* :iso8859-1)|#)
(compile nil `(lambda (%slots%)
- (declare (ignorable %slots%))
- (block ,',blknm
- ,,body))))))
+ (declare (ignorable %slots%))
+ (block ,',blknm
+ ,,body))))))
(ef-slots ,tmp1))))
(declaim (inline ,name))
(defun ,name (,tmp1)
@@ -635,7 +673,7 @@
(prog1 (the character (car ,nstate))
(setf (car ,nstate) nil ,count 0))
(let ((code (octets-to-codepoint ,external-format
- (cdr ,nstate) ,count ,input ,unput ,error)))
+ (cdr ,nstate) ,count ,input ,unput ,error)))
(declare (type lisp:codepoint code))
;;@@ on non-Unicode builds, limit to 8-bit chars
;;@@ if unicode-bootstrap, can't use #\u+fffd
More information about the cmucl-commit
mailing list