diff --git a/code/exports.lisp b/code/exports.lisp index 39350644d9a2965744ee252b61039e191d60ec43..0a9bb1da44a4bd9428d3673cf66219b21f081b66 100644 --- a/code/exports.lisp +++ b/code/exports.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.296 2010/04/18 16:47:37 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/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 diff --git a/code/extfmts.lisp b/code/extfmts.lisp index 5b5af4d5cf1a8be1a5619fbed88c46807701a827..753b3a780f56a29806fc8a55b5c275461947141c 100644 --- a/code/extfmts.lisp +++ b/code/extfmts.lisp @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/extfmts.lisp,v 1.33 2010/07/05 22:45:50 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/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 *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)) -(defvar *external-format-aliases* (make-hash-table)) +(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