Ignore:
Timestamp:
Oct 15, 2006, 11:50:41 PM (13 years ago)
Author:
gb
Message:

EXTERNAL-FORMATs are immutable, interned.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/level-1/l1-sysio.lisp

    r5335 r5352  
    9797is :UNIX.")
    9898
    99 (defstruct external-format
    100   (character-encoding :default)
    101   (line-termination :default))
     99(defstruct (external-format (:constructor %make-external-format)
     100                            (:copier nil))
     101  (character-encoding :default :read-only t)
     102  (line-termination :default :read-only t))
     103
     104(defmethod print-object ((ef external-format) stream)
     105  (print-unreadable-object (ef stream :type t :identity t)
     106    (format stream "~s/~s" (external-format-character-encoding ef) (external-format-line-termination ef))))
     107
     108
     109
     110(defvar *external-formats* (make-hash-table :test #'equal))
     111
     112(defun make-external-format (&key (domain t)
     113                                  (character-encoding :default)
     114                                  (line-termination :default))
     115  (if (eq line-termination :default)
     116    (setq line-termination *default-line-termination*))
     117  (unless (assq line-termination *canonical-line-termination-conventions*)
     118                    (error "~S is not a known line-termination format." line-termination))
     119  (if (eq character-encoding :default)
     120    (setq character-encoding
     121          (default-character-encoding domain)))
     122  (unless (lookup-character-encoding character-encoding)
     123    (error "~S is not the name of a known characer encoding."
     124           character-encoding))
     125  (let* ((pair (cons character-encoding line-termination)))
     126    (declare (dynamic-extent pair))   
     127    (or (gethash pair *external-formats*)
     128        (setf (gethash (cons character-encoding line-termination) *external-formats*)
     129              (%make-external-format :character-encoding character-encoding
     130                                     :line-termination line-termination)))))
     131
    102132
    103133
     
    106136         (unless (plistp external-format)
    107137           (error "External-format ~s is not a property list." external-format))
    108          (normalize-external-format domain (apply #'make-external-format external-format)))
     138         (normalize-external-format domain (apply #'make-external-format :domain domain  external-format)))
    109139        ((typep external-format 'external-format)
    110          (let* ((character-encoding (external-format-character-encoding external-format))
    111                 (line-termination (external-format-line-termination external-format)))
    112            (when (or (eq character-encoding :default)
    113                      (eq line-termination :default))
    114              (setq external-format (copy-external-format external-format))
    115              (if (eq line-termination :default)
    116                (setf (external-format-line-termination external-format)
    117                      (setq line-termination *default-line-termination*)))
    118              (unless (assq line-termination *canonical-line-termination-conventions*)
    119                (error "~S is not a known line-termination format." line-termination))
    120              (if (eq character-encoding :default)
    121                (setf (external-format-character-encoding external-format)
    122                      (setq character-encoding
    123                            (default-character-encoding domain))))
    124              (unless (lookup-character-encoding character-encoding)
    125                (error "~S is not the name of a known characer encoding."
    126                       character-encoding)))
    127            external-format))
     140         external-format)
    128141        ((eq external-format :default)
    129142         (normalize-external-format domain nil))
Note: See TracChangeset for help on using the changeset viewer.