diff --git a/code/exports.lisp b/code/exports.lisp index 6eeec56574915eabb6ef34b4edeec6711022984c..45bd80e705ab5d2a9f12696a2cf7cb3ee075052d 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.260 2007/08/17 14:09:20 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.261 2007/10/25 15:17:07 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1211,6 +1211,13 @@ (intern "CHAR" "LISP") +;; Make these STREAM symbols available +(dolist + (name + '("STRING-TO-OCTETS" "OCTETS-TO-STRING" "*DEFAULT-EXTERNAL-FORMAT*" + "ENCODE-STRING" "DECODE-STRING")) + (intern name "STREAM")) + (defpackage "EXTENSIONS" (:nicknames "EXTENSIONS") (:import-from "LISP" "GET-SETF-METHOD") @@ -1401,7 +1408,12 @@ "PARSE-MACRO" "AUGMENT-ENVIRONMENT") #+double-double - (:export "DOUBLE-DOUBLE-FLOAT" "DD-PI")) + (:export "DOUBLE-DOUBLE-FLOAT" "DD-PI") + (:import-from "STREAM" + "STRING-TO-OCTETS" "OCTETS-TO-STRING" "*DEFAULT-EXTERNAL-FORMAT*" + "ENCODE-STRING" "DECODE-STRING") + (:export "STRING-TO-OCTETS" "OCTETS-TO-STRING" "*DEFAULT-EXTERNAL-FORMAT*" + "ENCODE-STRING" "DECODE-STRING")) (defpackage "STREAM" (:import-from "SYSTEM" "LISP-STREAM") @@ -1458,7 +1470,10 @@ "WITH-OPEN-FILE" "WITH-OPEN-STREAM" "FORMAT" "PPRINT" "PRIN1" "PRIN1-TO-STRING" "PRINC" "PRINC-TO-STRING" "PRINT" "READ" "READ-DELIMITED-LIST" "READ-FROM-STRING" "WRITE" "WRITE-LINE" - "WRITE-TO-STRING" "READ-PRESERVING-WHITESPACE")) + "WRITE-TO-STRING" "READ-PRESERVING-WHITESPACE" + + "STRING-TO-OCTETS" "OCTETS-TO-STRING" "*DEFAULT-EXTERNAL-FORMAT*" + "ENCODE-STRING" "DECODE-STRING")) (defpackage "LOOP") (dolist diff --git a/code/extfmts.lisp b/code/extfmts.lisp new file mode 100644 index 0000000000000000000000000000000000000000..5c23b9c11b3b4c3558c1aff0b56963d74f6d4b84 --- /dev/null +++ b/code/extfmts.lisp @@ -0,0 +1,271 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*- +;;; +;;; ********************************************************************** +;;; This code was written by Paul Foley and has been placed in the public +;;; domain. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/extfmts.lisp,v 1.1 2007/10/25 15:17:07 rtoy Exp $") +;;; +;;; ********************************************************************** +;;; +;;; Implementation of external-formats + +(in-package "STREAM") + +(export '(string-to-octets octets-to-string *default-external-format* + encode-string decode-string)) + +(defvar *default-external-format* :iso8859-1) + +(defvar *external-formats* (make-hash-table)) +(defvar *external-format-aliases* (make-hash-table)) + +(define-condition external-format-not-implemented (error) + () + (:report + (lambda (condition stream) + (declare (ignore condition)) + (format stream "Attempting unimplemented external-format I/O.")))) + +(defun %efni (a b c d) + (declare (ignore a b c d)) + (error 'external-format-not-implemented)) + +(defstruct (external-format + (:conc-name ef-) + (:print-function %print-external-format) + (:constructor make-external-format (name + &optional slots slotd + octets-to-code + code-to-octets))) + (name (ext:required-argument) :type keyword :read-only t) + (slots #() :type simple-vector :read-only t) + (slotd nil :type list :read-only t) + (octets-to-code #'%efni :type function :read-only t) + (code-to-octets #'%efni :type function :read-only t)) + +(defun %print-external-format (ef stream depth) + (declare (ignore depth)) + (print-unreadable-object (ef stream :type t :identity t) + (princ (ef-name ef) stream))) + +(defmacro define-external-format (name octets-to-code code-to-octets) + (let ((tmp (gensym))) + `(macrolet ((octets-to-code ((state input unput) &body body) + `(lambda (,',tmp ,state ,input ,unput) + (declare (type (function () (unsigned-byte 8)) ,input) + (type (function (lisp::index) t) ,unput) + (ignore ,',tmp) + (ignorable ,state ,unput) + (values (unsigned-byte 31) lisp::index t)) + ,@body)) + (code-to-octets ((code state output) &body body) + `(lambda (,',tmp ,code ,state ,output) + (declare (type (unsigned-byte 31) ,code) + (type (function ((unsigned-byte 8)) t) ,output) + (ignore ,',tmp) + (ignorable ,state ,output) + (values t)) + ,@body))) + (setf (gethash ,name *external-formats*) + (make-external-format ,name #() '() + ,octets-to-code ,code-to-octets))))) + +(defun load-external-format-aliases () + (let ((*package* (find-package "KEYWORD"))) + (with-open-file (stm "library:ext-formats/aliases" :if-does-not-exist nil) + (when stm + (do ((alias (read stm nil stm) (read stm nil stm)) + (value (read stm nil stm) (read stm nil stm))) + ((or (eq alias stm) (eq value stm)) + (unless (eq alias stm) + (warn "External-format aliases file ends early."))) + (if (and (keywordp alias) (keywordp value)) + (setf (gethash alias *external-format-aliases*) value) + (warn "Bad entry in external-format aliases file: ~S => ~S." + alias value))))))) + +(defun find-external-format (name &optional (error-p t)) + (when (external-format-p name) + (return-from find-external-format name)) + + (when (eq name :default) + (setq name *default-external-format*)) + + #+(or) + (unless (ext:search-list-defined-p "ef:") + (setf (ext:search-list "ef:") '("library:ef/"))) + + (when (zerop (hash-table-count *external-format-aliases*)) + (setf (gethash :latin1 *external-format-aliases*) :iso8859-1) + (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1) + (setf (gethash :iso-8859-1 *external-format-aliases*) :iso8859-1) + (load-external-format-aliases)) + + (do ((tmp (gethash name *external-format-aliases*) + (gethash tmp *external-format-aliases*)) + (cnt 0 (1+ cnt))) + ((or (null tmp) (= cnt 50)) + (unless (null tmp) + (error "External-format aliasing depth exceeded."))) + (setq name tmp)) + + (or (gethash name *external-formats*) + (and (let ((*package* (find-package "STREAM"))) + (load (format nil "library:ext-formats/~(~A~)" name) :if-does-not-exist nil)) + (gethash name *external-formats*)) + (if error-p (error "External format ~S not found." name) nil))) + + +(define-condition void-external-format (error) + () + (:report + (lambda (condition stream) + (declare (ignore condition)) + (format stream "Attempting I/O through void external-format.")))) + +(define-external-format :void + (octets-to-code (state input unput) + (declare (ignore input)) + (error 'void-external-format)) + (code-to-octets (code state output) + (declare (ignore code)) + (error 'void-external-format))) + +(define-external-format :iso8859-1 + (octets-to-code (state input unput) + (declare (optimize (speed 3) (space 0) (safety 0) (debug 0))) + (values (funcall input) 1 nil)) + (code-to-octets (code state output) + (declare (optimize (speed 3) (space 0) (safety 0) (debug 0))) + (funcall output (if (> code 255) #x3F code)) + nil)) + + +(defmacro octets-to-codepoint (external-format state count input unput) + (let ((tmp1 (gensym)) (tmp2 (gensym)) (tmp3 (gensym))) + `(multiple-value-bind (,tmp1 ,tmp2 ,tmp3) + (funcall (ef-octets-to-code ,external-format) ,external-format + ,state ,input ,unput) + (declare (type (unsigned-byte 31) ,tmp1) (type lisp::index ,tmp2)) + (setf ,state ,tmp3 ,count ,tmp2) + ,tmp1))) + +(defmacro codepoint-to-octets (external-format code state output) + `(progn + (setf ,state (funcall (ef-code-to-octets ,external-format) + ,external-format ,code ,state ,output)) + nil)) + + + +(defmacro octets-to-char (external-format state count input unput) + `(let ((code (octets-to-codepoint ,external-format + ,state ,count ,input ,unput))) + (declare (type (unsigned-byte 31) code)) + (if (< code #x100) (code-char code) #\?))) + +(defmacro char-to-octets (external-format char state output) + `(codepoint-to-octets ,external-format (char-code ,char) ,state ,output)) + +(defun string-to-octets (string &key (start 0) end (external-format :default)) + (declare (type string string) + (type lisp::index start) + (type (or null lisp::index) end) + #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#) + (let ((ef (find-external-format external-format)) + (buffer (make-array (length string) :element-type '(unsigned-byte 8))) + (ptr 0) + (state nil)) + (declare (type external-format ef) + (type (simple-array (unsigned-byte 8) (*)) buffer) + (type lisp::index ptr)) + (flet ((out (b) + (when (= ptr (length buffer)) + (setq buffer (adjust-array buffer (* 2 ptr)))) + (setf (aref buffer (1- (incf ptr))) b))) + (dotimes (i (- (or end (length string)) start)) + (declare (type lisp::index i)) + (char-to-octets ef (char string (+ start i)) state #'out)) + (lisp::shrink-vector buffer ptr)))) + +(defun octets-to-string (octets &key (start 0) end (external-format :default)) + (declare (type (simple-array (unsigned-byte 8) (*)) octets) + (type lisp::index start) + (type (or null lisp::index) end) + #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#) + (let ((ef (find-external-format external-format)) + (end (1- (or end (length octets)))) + (string (make-string (length octets))) + (ptr (1- start)) + (pos -1) + (count 0) + (state nil)) + (declare (type external-format ef) + (type lisp::index end count) + (type (integer -1 (#.array-dimension-limit)) pos ptr) + (type simple-base-string string)) + (flet ((input () + (aref octets (incf ptr))) + (unput (n) + (decf ptr (the lisp::index n)))) + (loop until (>= ptr end) + ;; increasing size of string shouldn't ever be necessary, unless + ;; someone implements an encoding smaller than the source string... + do (setf (schar string (incf pos)) + (octets-to-char ef state count #'input #'unput)))) + (lisp::shrink-vector string (1+ pos)))) + + + +(defun encode-string (string external-format &optional (start 0) end) + (declare (type string string) + (type lisp::index start) + (type (or null lisp::index) end) + #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#) + (let ((ef (find-external-format external-format)) + (result (make-string (length string))) + (ptr 0) + (state nil)) + (declare (type external-format ef) + (type simple-base-string result) + (type lisp::index ptr)) + (flet ((out (b) + (when (= ptr (length result)) + (setq result (adjust-array result (* 2 ptr)))) + (setf (char result (1- (incf ptr))) (code-char b)))) + (dotimes (i (- (or end (length string)) start)) + (declare (type lisp::index i)) + (char-to-octets ef (char string (+ start i)) state #'out)) + (lisp::shrink-vector result ptr)))) + +(defun decode-string (string external-format &optional (start 0) end) + (declare (type string string) + (type lisp::index start) + (type (or null lisp::index) end) + #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#) + (let ((ef (find-external-format external-format)) + (end (1- (or end (length string)))) + (result (make-string (length string))) + (ptr (1- start)) + (pos -1) + (count 0) + (state nil)) + (declare (type external-format ef) + (type lisp::index end count) + (type (integer -1 (#.array-dimension-limit)) pos ptr) + (type simple-base-string result)) + (flet ((input () + (char-code (char string (incf ptr)))) + (unput (n) + (decf ptr (the lisp::index n)))) + (loop until (>= ptr end) + ;; increasing size of result shouldn't ever be necessary, unless + ;; someone implements an encoding smaller than the source string... + do (setf (schar result (incf pos)) + (octets-to-char ef state count #'input #'unput)))) + (lisp::shrink-vector result (1+ pos)))) + + +(provide :external-formats) diff --git a/pcl/simple-streams/external-formats/iso8859-1.lisp b/pcl/simple-streams/external-formats/iso8859-1.lisp new file mode 100644 index 0000000000000000000000000000000000000000..378a062d5dfa03dadbbe95f904be1fd515021876 --- /dev/null +++ b/pcl/simple-streams/external-formats/iso8859-1.lisp @@ -0,0 +1,22 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*- +;;; +;;; ********************************************************************** +;;; This code was written by Paul Foley and has been placed in the public +;;; domain. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/external-formats/iso8859-1.lisp,v 1.1 2007/10/25 15:17:07 rtoy Exp $") +;;; +;;; ********************************************************************** + +;; This is actually implemented internally. It appears here only for +;; reference, and will never get loaded. + +(define-external-format :iso8859-1 + (octets-to-code (state input unput) + (declare (optimize (speed 3) (space 0) (safety 0) (debug 0))) + (values (funcall input) 1 nil)) + (code-to-octets (code state output) + (declare (optimize (speed 3) (space 0) (safety 0) (debug 0))) + (funcall output (if (> code 255) #x3F code)) + nil)) diff --git a/pcl/simple-streams/external-formats/utf-8.lisp b/pcl/simple-streams/external-formats/utf-8.lisp index 76465e3fedc1c55c948a4a54ec37deb3e8b4eb66..5af6212810cf5673ad5bc665381539ce69d2958e 100644 --- a/pcl/simple-streams/external-formats/utf-8.lisp +++ b/pcl/simple-streams/external-formats/utf-8.lisp @@ -5,54 +5,44 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/external-formats/utf-8.lisp,v 1.1 2003/06/26 13:27:43 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/external-formats/utf-8.lisp,v 1.2 2007/10/25 15:17:07 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; ;;; A UTF-8 external format for simple-streams +(in-package "STREAM") (define-external-format :utf-8 - (octets-to-char (state input unput) - (declare (optimize (speed 3) (space 0) (safety 0) (debug 0))) - ;; return (values character octets-used state) - (let ((code (funcall input))) - (cond ((< code #x80) - (values (code-char code) 1 nil)) - ((= (logand code #b11000000) #b10000000) - (error "UTF-8 desync")) ; incf count, retry with next octet - ((= (logand code #b11100000) #b11000000) - (let ((next (funcall input))) - (if (= (logand next #b11000000) #b10000000) - (let ((code (dpb (ldb (byte 6 0) code) (byte 6 6) - (ldb (byte 6 0) next)))) - (if (< code #x100) - (values (code-char code) 2 nil) - (values #\? 2 nil))) - (progn - (warn "UTF-8: short read") - (funcall unput 1) - (values #\? 1 nil))))) - ((= (logand code #b11110000) #b11100000) - (dotimes (i 2) (funcall input)) - (values #\? 3 nil)) - ((= (logand code #b11111000) #b11110000) - (dotimes (i 3) (funcall input)) - (values #\? 4 nil)) - ((= (logand code #b11111100) #b11111000) - (dotimes (i 4) (funcall input)) - (values #\? 5 nil)) - ((= (logand code #b11111110) #b11111100) - (dotimes (i 5) (funcall input)) - (values #\? 6 nil)) - (t - (error "Illegal UTF-8 character"))))) - (char-to-octets (char state output) + (octets-to-code (state input unput) (declare (optimize (speed 3) (space 0) (safety 0) (debug 0))) - ;; return state - (let ((code (char-code char))) - (if (< code #x80) - (funcall output code) - (progn - (funcall output (logior #b11000000 (ldb (byte 2 6) code))) - (funcall output (logior #b10000000 (ldb (byte 6 0) code)))))) + (flet ((utf8 (c i) + (let ((n (ash (ldb (byte (- 6 i) 0) c) (* 6 i)))) + (dotimes (j i (values n (1+ i) nil)) + (setf (ldb (byte 6 (* 6 (- i j 1))) n) + (ldb (byte 6 0) (funcall input))))))) + (let ((c (funcall input))) + (cond ((< c #b10000000) (values c 1 nil)) + ((< c #b11000000) (error "UTF-8 desync")) + ((< c #b11100000) (utf8 c 1)) + ((< c #b11110000) (utf8 c 2)) + ((< c #b11111000) (utf8 c 3)) + ((< c #b11111100) (utf8 c 4)) + ((< c #b11111110) (utf8 c 5)) + (t (error "Invalid UTF-8 character")))))) + (code-to-octets (code state output) + (declare (optimize (speed 3) (space 0) (safety 0) (debug 0))) + (flet ((utf8 (n i) + (let* ((j (- 6 i)) + (p (* 6 i)) + (init (logand #xFF (ash #b01111110 j)))) + (funcall output (logior init (ldb (byte j p) n))) + (dotimes (i i) + (decf p 6) + (funcall output (logior 128 (ldb (byte 6 p) n))))))) + (cond ((< code #x80) (funcall output code)) + ((< code #x800) (utf8 code 1)) + ((< code #x10000) (utf8 code 2)) + ((< code #x200000) (utf8 code 3)) + ((< code #x4000000) (utf8 code 4)) + (t (utf8 code 5)))) nil)) diff --git a/pcl/simple-streams/external-formats/void.lisp b/pcl/simple-streams/external-formats/void.lisp new file mode 100644 index 0000000000000000000000000000000000000000..6cca06046fb797d3c1266ca5439eed971e276a48 --- /dev/null +++ b/pcl/simple-streams/external-formats/void.lisp @@ -0,0 +1,21 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*- +;;; +;;; ********************************************************************** +;;; This code was written by Paul Foley and has been placed in the public +;;; domain. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/external-formats/void.lisp,v 1.1 2007/10/25 15:17:07 rtoy Exp $") +;;; +;;; ********************************************************************** + +;; This is actually implemented internally. It appears here only for +;; reference, and will never get loaded. + +(define-external-format :void + (octets-to-code (state input unput) + (declare (ignore input)) + (error 'void-external-format)) + (code-to-octets (code state output) + (declare (ignore code)) + (error 'void-external-format))) diff --git a/pcl/simple-streams/internal.lisp b/pcl/simple-streams/internal.lisp index 682d22bcea9e7d7bd133f8ed0d608fd80017074c..f90c3f9644fd6879cad5f141ae32f3ccb03b7b6c 100644 --- a/pcl/simple-streams/internal.lisp +++ b/pcl/simple-streams/internal.lisp @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/internal.lisp,v 1.5 2003/06/27 15:12:47 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/internal.lisp,v 1.6 2007/10/25 15:17:07 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -89,172 +89,9 @@ -(defvar *default-external-format* :iso8859-1) - -(defvar *external-formats* (make-hash-table)) -(defvar *external-format-aliases* (make-hash-table)) - -(defstruct (external-format - (:conc-name ef-) - (:print-function %print-external-format) - (:constructor make-external-format (name octets-to-char - char-to-octets))) - (name (ext:required-argument) :type keyword :read-only t) - (octets-to-char (ext:required-argument) :type function :read-only t) - (char-to-octets (ext:required-argument) :type function :read-only t)) - -(defun %print-external-format (ef stream depth) - (declare (ignore depth)) - (print-unreadable-object (ef stream :type t :identity t) - (princ (ef-name ef) stream))) - -(defmacro define-external-format (name octets-to-char char-to-octets) - `(macrolet ((octets-to-char ((state input unput) &body body) - `(lambda (,state ,input ,unput) - (declare (type (function () (unsigned-byte 8)) ,input) - (type (function (lisp::index) t) ,unput) - (ignorable ,state ,input ,unput) - (values character lisp::index t)) - ,@body)) - (char-to-octets ((char state output) &body body) - `(lambda (,char ,state ,output) - (declare (type character ,char) - (type (function ((unsigned-byte 8)) t) ,output) - (ignorable state ,output) - (values t)) - ,@body))) - (setf (gethash ,name *external-formats*) - (make-external-format ,name ,octets-to-char ,char-to-octets)))) - -(defun load-external-format-aliases () - (let ((*package* (find-package "KEYWORD"))) - (with-open-file (stm "ef:aliases" :if-does-not-exist nil) - (when stm - (do ((alias (read stm nil stm) (read stm nil stm)) - (value (read stm nil stm) (read stm nil stm))) - ((or (eq alias stm) (eq value stm)) - (unless (eq alias stm) - (warn "External-format aliases file ends early."))) - (if (and (keywordp alias) (keywordp value)) - (setf (gethash alias *external-format-aliases*) value) - (warn "Bad entry in external-format aliases file: ~S => ~S." - alias value))))))) - -(defun find-external-format (name &optional (error-p t)) - (when (external-format-p name) - (return-from find-external-format name)) - - (when (eq name :default) - (setq name *default-external-format*)) - - (unless (ext:search-list-defined-p "ef:") - (setf (ext:search-list "ef:") '("library:ef/"))) - - (when (zerop (hash-table-count *external-format-aliases*)) - (setf (gethash :latin1 *external-format-aliases*) :iso8859-1) - (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1) - (setf (gethash :iso-8859-1 *external-format-aliases*) :iso8859-1) - (load-external-format-aliases)) - - (do ((tmp (gethash name *external-format-aliases*) - (gethash tmp *external-format-aliases*)) - (cnt 0 (1+ cnt))) - ((or (null tmp) (= cnt 50)) - (unless (null tmp) - (error "External-format aliasing depth exceeded."))) - (setq name tmp)) - - (or (gethash name *external-formats*) - (and (let ((*package* (find-package "STREAM"))) - (load (format nil "ef:~(~A~)" name) :if-does-not-exist nil)) - (gethash name *external-formats*)) - (if error-p (error "External format ~S not found." name) nil))) - -(define-condition void-external-format (error) - () - (:report - (lambda (condition stream) - (declare (ignore condition)) - (format stream "Attempting I/O through void external-format.")))) - -(define-external-format :void - (octets-to-char (state input unput) - (declare (ignore state input unput)) - (error 'void-external-format)) - (char-to-octets (char state output) - (declare (ignore char state output)) - (error 'void-external-format))) - -(define-external-format :iso8859-1 - (octets-to-char (state input unput) - (declare (optimize (speed 3) (space 0) (safety 0) (debug 0))) - (values (code-char (funcall input)) 1 state)) - (char-to-octets (char state output) - (declare (optimize (speed 3) (space 0) (safety 0) (debug 0))) - (let ((code (char-code char))) - #-(or) - (funcall output code) - #+(or) - (if (< code 256) - (funcall output code) - (funcall output (char-code #\?)))) - state)) - -(defmacro octets-to-char (external-format state count input unput) - (let ((tmp1 (gensym)) (tmp2 (gensym)) (tmp3 (gensym))) - `(multiple-value-bind (,tmp1 ,tmp2 ,tmp3) - (funcall (ef-octets-to-char ,external-format) ,state ,input ,unput) - (setf ,state ,tmp3 ,count ,tmp2) - ,tmp1))) - -(defmacro char-to-octets (external-format char state output) - `(progn - (setf ,state (funcall (ef-char-to-octets ,external-format) - ,char ,state ,output)) - nil)) - -(defun string-to-octets (string &key (start 0) end (external-format :default)) - (declare (type string string) - (type lisp::index start) - (type (or null lisp::index) end)) - (let ((ef (find-external-format external-format)) - (buffer (make-array (length string) :element-type '(unsigned-byte 8))) - (ptr 0) - (state nil)) - (flet ((out (b) - (setf (aref buffer ptr) b) - (when (= (incf ptr) (length buffer)) - (setq buffer (adjust-array buffer (* 2 ptr)))))) - (dotimes (i (- (or end (length string)) start)) - (declare (type lisp::index i)) - (char-to-octets ef (char string (+ start i)) state #'out)) - (lisp::shrink-vector buffer ptr)))) - -(defun octets-to-string (octets &key (start 0) end (external-format :default)) - (declare (type vector octets) - (type lisp::index start) - (type (or null lisp::index) end)) - (let ((ef (find-external-format external-format)) - (end (1- (or end (length octets)))) - (string (make-string (length octets))) - (ptr (1- start)) - (pos -1) - (count 0) - (state nil)) - (flet ((input () - (aref octets (incf ptr))) - (unput (n) - (decf ptr n))) - (loop until (>= ptr end) - do (setf (schar string (incf pos)) - (octets-to-char ef state count #'input #'unput)))) - (lisp::shrink-vector string (1+ pos)))) - - - #-(or big-endian little-endian) (eval-when (:compile-toplevel) - (push (c::backend-byte-order c::*backend*) *features*)) + (push (c::backend-byte-order c::*target-backend*) *features*)) (defun vector-elt-width (vector) ;; Return octet-width of vector elements diff --git a/tools/make-main-dist.sh b/tools/make-main-dist.sh index 581b8f500ec44ba6c04a122ad8e6647bd096eee0..d989012feaafc69c9234f9abe1566744812f256a 100755 --- a/tools/make-main-dist.sh +++ b/tools/make-main-dist.sh @@ -75,6 +75,7 @@ install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/doc/cmucl install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/subsystems +install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/ext-formats install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/man/man1 install ${GROUP} ${OWNER} -m 0755 $TARGET/lisp/lisp $DESTDIR/bin/ if [ "$EXECUTABLE" = "true" ] @@ -94,11 +95,18 @@ install ${GROUP} ${OWNER} -m 0644 $TARGET/lisp/lisp.nm $TARGET/lisp/lisp.map \ $TARGET/lisp/internals.h $TARGET/lisp/internals.inc $DESTDIR/lib/cmucl/ install ${GROUP} ${OWNER} -m 0755 src/tools/sample-wrapper $DESTDIR/lib/cmucl/ -for f in gray-streams gray-compat simple-streams iodefs +for f in gray-streams gray-compat simple-streams iodefs external-formats do install ${GROUP} ${OWNER} -m 0644 $TARGET/pcl/$f-library.$FASL $DESTDIR/lib/cmucl/lib/subsystems/ done +set -x +for f in src/pcl/simple-streams/external-formats/*.lisp +do + install ${GROUP} ${OWNER} -m 0644 $f $DESTDIR/lib/cmucl/lib/ext-formats/ +done + +set +x install ${GROUP} ${OWNER} -m 0644 src/general-info/cmucl.1 \ $DESTDIR/man/man1/ install ${GROUP} ${OWNER} -m 0644 src/general-info/lisp.1 \ diff --git a/tools/pclcom.lisp b/tools/pclcom.lisp index cbc114264b094fb64797a520f742baac968a873b..b414e95b30ee65b37299d9394caccedcdbb81806 100644 --- a/tools/pclcom.lisp +++ b/tools/pclcom.lisp @@ -3,7 +3,7 @@ ;;; ********************************************************************** ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/pclcom.lisp,v 1.32 2003/09/08 16:07:04 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/pclcom.lisp,v 1.33 2007/10/25 15:17:07 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -128,7 +128,12 @@ "pcl:simple-streams/file" "pcl:simple-streams/string" "pcl:simple-streams/terminal" - "pcl:simple-streams/socket") + "pcl:simple-streams/socket";) + "pcl:simple-streams/iodefs" + "pcl:simple-streams/gray-compat") + +(cat-if-anything-changed + "pcl:external-formats-library") (cat-if-anything-changed "pcl:iodefs-library" diff --git a/tools/worldcom.lisp b/tools/worldcom.lisp index 7fabd62bb77cab5a26832c5356de014ed266d2ae..1d5a182d0959affa01be861d76e65ce546b19822 100644 --- a/tools/worldcom.lisp +++ b/tools/worldcom.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.98 2007/08/02 16:11:17 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.99 2007/10/25 15:17:07 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -292,6 +292,8 @@ (comf "target:code/remote") (comf "target:code/cmu-site") +(comf "target:code/extfmts") + (when (c:backend-featurep :mp) (comf "target:code/multi-proc")) diff --git a/tools/worldload.lisp b/tools/worldload.lisp index 0e55efbec3f5212a5c28192c0ecc58c61da4aa9c..7f99a26549f5c5f78c7664a9ccb388d6d4b229a3 100644 --- a/tools/worldload.lisp +++ b/tools/worldload.lisp @@ -6,7 +6,7 @@ ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.107 2007/08/02 16:11:17 rtoy Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.108 2007/10/25 15:17:07 rtoy Exp $ ;;; ;;; ********************************************************************** ;;; @@ -118,6 +118,7 @@ #-(or gengc runtime) (maybe-byte-load "code:room") (maybe-byte-load "code:stream-vector-io") +(maybe-byte-load "code:extfmts") (maybe-byte-load "code:env-access") ;;; Overwrite some cold-loaded stuff with byte-compiled versions, if any.