- cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl][issue-375-mkstemp-return-filename] 3 commits: Simplify mkdtemp and fix error in mkstemp
by Raymond Toy (＠rtoy) 02 Feb '25

02 Feb '25

Raymond Toy pushed to branch issue-375-mkstemp-return-filename at cmucl / cmucl Commits: 544a6787 by Raymond Toy at 2025-02-01T15:59:09-08:00 Simplify mkdtemp and fix error in mkstemp Since mkdtemp returns a pointer to the resulting directory name, we can convert that to the desired lisp string. In mkstemp, we were converting the resulting buffer to a string but we had `:end (1- length)`. It should be `:end length` to get all the characters. - - - - - 0111bb50 by Raymond Toy at 2025-02-01T16:34:20-08:00 Add tests with template with non-ascii char Add a test for mkstemp and mkdtemp where the template name contains a non-ascii char (lower case alpha) to test the we convert the returned name to a Lisp string correctly. - - - - - 6e0378ea by Raymond Toy at 2025-02-01T16:35:27-08:00 Need to convert the return result of mkdtemp Forgot that we need to encode the result to a proper UTF-16 Lisp string. - - - - - 2 changed files: - src/code/unix.lisp - tests/unix.lisp Changes: ===================================== src/code/unix.lisp ===================================== @@ -2930,7 +2930,7 @@ ;; Convert the array of octets in BUFFER back to ;; a Lisp string. (stream:octets-to-string buffer - :end (1- length) + :end length :external-format format)) (sys:vector-sap buffer)))) @@ -2965,6 +2965,4 @@ ;; resulting name. Otherwise, return NIL and the errno. (if (null-alien result) (values nil (unix-errno)) - (values (stream:octets-to-string buffer - :end (1- length) - :external-format format)))))) + (%file->name (cast result c-call:c-string)))))) ===================================== tests/unix.lisp ===================================== @@ -17,6 +17,26 @@ (when fd (unix:unix-unlink name))))) +(define-test mkstemp.name-returned.2 + (:tag :issues) + (let ((unix::*filename-encoding* :utf-8) + fd name) + (unwind-protect + (progn + ;; Temp name starts with a lower case alpha character. + (let* ((template (concatenate 'string (string #\u+3b1) + "test-XXXXXX")) + (x-posn (position #\X template))) + (multiple-value-setq (fd name) + (unix::unix-mkstemp template)) + (assert-true fd) + (assert-false (search "XXXXXX" name) + name) + (assert-true (string= name template :end1 x-posn :end2 x-posn) + name))) + (when fd + (unix:unix-unlink name))))) + (define-test mkstemp.bad-path (:tag :issues) (multiple-value-bind (fd errno) @@ -52,6 +72,25 @@ (when name (unix:unix-rmdir name))))) +(define-test mkdtemp.name-returned.2 + (:tag :issues) + (let ((unix::*filename-encoding* :utf-8) + name) + (unwind-protect + (progn + ;; Temp name starts with a lower case alpha character. + (let* ((template (concatenate 'string (string #\u+3b1) + "dir-XXXXXX")) + (x-posn (position #\X template))) + (setf name (unix::unix-mkdtemp template)) + ;; Verify that the dir name no longer has X's. + (assert-true (stringp name)) + (assert-false (search "XXXXXX" name)) + (assert-true (string= name template :end1 x-posn :end2 x-posn) + name x-posn))) + (when name + (unix:unix-rmdir name))))) + (define-test mkdtemp.bad-path (:tag :issues) (multiple-value-bind (result errno) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/15501db4886ad26a943e1c… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/15501db4886ad26a943e1c… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-375-mkstemp-return-filename] Update bad template tests for Darwin
by Raymond Toy (＠rtoy) 01 Feb '25

01 Feb '25

Raymond Toy pushed to branch issue-375-mkstemp-return-filename at cmucl / cmucl Commits: 15501db4 by Raymond Toy at 2025-02-01T09:11:11-08:00 Update bad template tests for Darwin Darwin seems to require at least one X in the template, unlike Linux which requires 6. Update the test for bad templates for both mkstemp and mkdtemp to have no X's in the template. - - - - - 1 changed file: - tests/unix.lisp Changes: ===================================== tests/unix.lisp ===================================== @@ -30,9 +30,13 @@ (define-test mkstemp.bad-template (:tag :issues) (multiple-value-bind (fd errno) - (unix::unix-mkstemp "test-XXXXX") + (unix::unix-mkstemp "test-") ;; The template doesn't have enough X's so the FD should be NIL, ;; and a positive Unix errno value should be returned. + ;; + ;; Note that Darwin allows any number of X's in the template but + ;; Linux requires exactly 6. Just test with no X's to handle all + ;; OSes. (assert-false fd) (assert-true (and (integerp errno) (plusp errno))))) @@ -58,7 +62,8 @@ (define-test mkdtemp.bad-template (:tag :issues) (multiple-value-bind (result errno) - (unix::unix-mkdtemp "dir-XXXXX") + (unix::unix-mkdtemp "dir-") + ;; No X's in template, like for mkstemp.bad-template test. (assert-false result) (assert-true (and (integerp errno) (plusp errno))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/15501db4886ad26a943e1c0… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/15501db4886ad26a943e1c0… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-375-mkstemp-return-filename
by Raymond Toy (＠rtoy) 01 Feb '25

01 Feb '25

Raymond Toy pushed new branch issue-375-mkstemp-return-filename at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-375-mkstemp-return-… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Update release notes to add issue 367
by Raymond Toy (＠rtoy) 31 Jan '25

31 Jan '25

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 739de261 by Raymond Toy at 2025-01-31T06:57:45-08:00 Update release notes to add issue 367 - - - - - 1 changed file: - src/general-info/release-21f.md Changes: ===================================== src/general-info/release-21f.md ===================================== @@ -113,6 +113,7 @@ public domain. * ~~#361~~ Add herald item to mention where to report issues * ~~#362~~ Simplify "library:" search-list * ~~#364~~ Add interface to `mkdtemp` and `mkstemp` + * ~~#367~~ Add stream:string-count-octets to count octets in a string * ~~#369~~ Improve docstring for `unix::unix-setlocale` * Other changes: * Improvements to the PCL implementation of CLOS: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/739de26192809e9f9a159ab… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/739de26192809e9f9a159ab… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #367: Add method to count number of octets to encode a string
by Raymond Toy (＠rtoy) 31 Jan '25

31 Jan '25

Raymond Toy pushed to branch master at cmucl / cmucl Commits: fd391099 by Raymond Toy at 2025-01-31T14:39:40+00:00 Fix #367: Add method to count number of octets to encode a string - - - - - 12e15d8b by Raymond Toy at 2025-01-31T14:39:40+00:00 Merge branch 'issue-367-count-octets-for-encoding' into 'master' Fix #367: Add method to count number of octets to encode a string Closes #367 See merge request cmucl/cmucl!264 - - - - - 18 changed files: - .gitlab-ci.yml - + src/bootfiles/21e/boot-2024-08.lisp - src/code/exports.lisp - src/code/extfmts.lisp - src/i18n/locale/cmucl.pot - src/pcl/simple-streams/external-formats/ascii.lisp - src/pcl/simple-streams/external-formats/euc-kr.lisp - src/pcl/simple-streams/external-formats/iso8859-1.lisp - src/pcl/simple-streams/external-formats/iso8859-2.lisp - src/pcl/simple-streams/external-formats/mac-roman.lisp - src/pcl/simple-streams/external-formats/utf-16-be.lisp - src/pcl/simple-streams/external-formats/utf-16-le.lisp - src/pcl/simple-streams/external-formats/utf-16.lisp - src/pcl/simple-streams/external-formats/utf-32-be.lisp - src/pcl/simple-streams/external-formats/utf-32-le.lisp - src/pcl/simple-streams/external-formats/utf-32.lisp - src/pcl/simple-streams/external-formats/utf-8.lisp - + tests/external-formats.lisp Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1,7 +1,7 @@ variables: download_url: "https://common-lisp.net/project/cmucl/downloads/snapshots/2024/08" version: "2024-08-x86" - bootstrap: "" + bootstrap: "-B boot-2024-08" stages: ===================================== src/bootfiles/21e/boot-2024-08.lisp ===================================== @@ -0,0 +1,10 @@ +;; Bootstrap file for the ef-octet-count changes. Just need to change +;; the value of +ef-max+ + +(in-package "STREAM") + +(handler-bind + ((error (lambda (c) + (declare (ignore c)) + (invoke-restart 'continue)))) + (defconstant +ef-max+ 14)) ===================================== src/code/exports.lisp ===================================== @@ -1456,7 +1456,8 @@ (name '("STRING-TO-OCTETS" "OCTETS-TO-STRING" "*DEFAULT-EXTERNAL-FORMAT*" "STRING-ENCODE" "STRING-DECODE" "SET-SYSTEM-EXTERNAL-FORMAT" - "LIST-ALL-EXTERNAL-FORMATS" "DESCRIBE-EXTERNAL-FORMAT")) + "LIST-ALL-EXTERNAL-FORMATS" "DESCRIBE-EXTERNAL-FORMAT" + "STRING-OCTET-COUNT")) (intern name "STREAM")) (defpackage "EXTENSIONS" ===================================== src/code/extfmts.lisp ===================================== @@ -19,7 +19,8 @@ string-encode string-decode set-system-external-format +replacement-character-code+ list-all-external-formats - describe-external-format)) + describe-external-format + string-octet-count)) (defvar *default-external-format* :utf-8 @@ -52,6 +53,7 @@ flush ; flush state copy-state ; copy state osc ; octets to string, counted + oc ; number of octets to encode string max) ;; Unicode replacement character U+FFFD @@ -96,6 +98,11 @@ (copy-state nil :type (or null function) :read-only t) (cache nil :type (or null simple-vector)) ;; + ;; Function to count the number of octets needed to encode a + ;; codepoint. Basically like code-to-octets, except we return the + ;; number of octets needed instead of the octets themselves. + (octet-count #'%efni :type (or null function) :read-only t) + ;; ;; Minimum number of octets needed to form a codepoint (min 1 :type kernel:index :read-only t) ;; @@ -126,7 +133,8 @@ (setf (gethash (ef-name ef) *external-formats*) ef)) (declaim (inline ef-octets-to-code ef-code-to-octets ef-flush-state ef-copy-state - ef-cache ef-min-octets ef-max-octets)) + ef-cache ef-min-octets ef-max-octets + ef-octet-count)) (defun ef-octets-to-code (ef) (efx-octets-to-code (ef-efx ef))) @@ -143,6 +151,9 @@ (defun ef-cache (ef) (efx-cache (ef-efx ef))) +(defun ef-octet-count (ef) + (efx-octet-count (ef-efx ef))) + (defun ef-min-octets (ef) (efx-min (ef-efx ef))) @@ -166,7 +177,7 @@ ;;; DEFINE-EXTERNAL-FORMAT -- Public ;;; ;;; name (&key base min max size documentation) (&rest slots) octets-to-code -;;; code-to-octets flush-state copy-state +;;; code-to-octets flush-state copy-state octet-count ;;; ;;; Define a new external format. If base is specified, then an ;;; external format is defined that is based on a previously defined @@ -228,6 +239,15 @@ ;;; This should probably be a deep copy so that if the original ;;; state is modified, the copy is not. ;;; +;;; octet-count (code state error &rest vars) +;;; Defines a form to determine the number of octets needed to +;;; encode the given CODE using the external format. This is +;;; essentially the same as CODE-TO-OCTETS, except the encoding is +;;; not saved anywhere. ERROR is the same as in CODE-TO-OCTETS. +;;; +;;; This should return one value: the number of octets needed to +;;; encode the given code. +;;; ;;; Note: external-formats work on code-points, not ;;; characters, so that the entire 31 bit ISO-10646 range can be ;;; used internally regardless of the size of a character recognized @@ -238,7 +258,7 @@ (defmacro define-external-format (name (&key base min max size (documentation "")) (&rest slots) &optional octets-to-code code-to-octets - flush-state copy-state) + flush-state copy-state octet-count) (let* ((tmp (gensym)) (min (or min size 1)) (max (or max size 6)) @@ -282,7 +302,17 @@ (declare (ignorable ,state)) (let (,@',slotb ,@(loop for var in vars collect `(,var (gensym)))) - ,body)))) + ,body))) + (octet-count ((code state error &rest vars) body) + `(lambda (,',tmp ,state ,error) + (declare (ignorable ,state ,error) + (optimize (ext:inhibit-warnings 3))) + (let (,@',slotb + (,code ',code) + ,@(loop for var in vars collect `(,var (gensym)))) + `(let ((,',code (the lisp:codepoint ,,',tmp))) + (declare (ignorable ,',code)) + ,,body))))) (%intern-ef (make-external-format ,name ,(if base `(ef-efx (find-external-format ,(ef-name base))) @@ -291,7 +321,8 @@ :flush-state ,flush-state :copy-state ,copy-state :cache (make-array +ef-max+ - :initial-element nil) + :initial-element nil) + :octet-count ,octet-count :min ,(min min max) :max ,(max min max))) nil @@ -688,7 +719,20 @@ character and illegal outputs are replaced by a question mark.") (intl:gettext "Cannot output codepoint #x~X to ISO8859-1 stream") ,code 1)) #x3F) - ,code)))) + ,code))) + () + () + (octet-count (code state error) + `(if (> ,code 255) + (if ,error + (locally + ;; No warnings about fdefinition + (declare (optimize (ext:inhibit-warnings 3))) + (funcall ,error + (intl:gettext "Cannot output codepoint #x~X to ISO8859-1 stream") + ,code 1)) + 1) + 1))) ;;; OCTETS-TO-CODEPOINT, CODEPOINT-TO-OCTETS -- Semi-Public ;;; @@ -709,6 +753,10 @@ character and illegal outputs are replaced by a question mark.") (let ((ef (find-external-format external-format))) (funcall (ef-code-to-octets ef) code state output error))) +(defmacro count-codepoint-octets (external-format code state &optional error) + (let ((ef (find-external-format external-format))) + (funcall (ef-octet-count ef) code state error))) + (defvar *ef-base* +ef-max+) @@ -878,6 +926,42 @@ character and illegal outputs are replaced by a question mark.") (when f (funcall f state)))) +(defmacro octet-count (external-format char state &optional error) + (let ((nchar (gensym)) + (nstate (gensym)) + (count-it (gensym)) + (ch (gensym))) + `(let ((,nchar ,char) + (,nstate ,state)) + (when (null ,nstate) (setq ,nstate (setf ,state (cons nil nil)))) + (if (lisp::surrogatep (char-code ,nchar) :high) + (setf (car ,nstate) ,nchar) + (flet ((,count-it (,ch) + (count-codepoint-octets ,external-format ,ch (cdr ,nstate) ,error))) + (if (car ,nstate) + (prog1 + (,count-it (if (lisp::surrogatep (char-code ,nchar) :low) + (surrogates-to-codepoint (car ,nstate) ,nchar) + (if ,error + (locally + (declare (optimize (ext:inhibit-warnings 3))) + (funcall ,error + (intl:gettext "Cannot convert invalide surrogate #~x~X to character") + ,nchar)) + +replacement-character-code+))) + (setf (car ,nstate) nil)) + ;; A lone trailing (low surrogate gets replaced with + ;; the replacement character. + (,count-it (if (lisp::surrogatep (char-code ,nchar) :low) + (if ,error + (locally + (declare (optimize (ext:inhibit-warnings 3))) + (funcall ,error + (intl:gettext "Cannot convert lone trailing surrogate #x~X to character") + ,nchar)) + +replacement-character-code+) + (char-code ,nchar))))))))) + (def-ef-macro ef-string-to-octets (extfmt lisp::lisp +ef-max+ +ef-so+) `(lambda (string start end buffer buffer-start buffer-end error bufferp &aux (ptr buffer-start) (state nil) (last-octet buffer-start)) @@ -1071,6 +1155,31 @@ character and illegal outputs are replaced by a question mark.") (values (if stringp string (lisp::shrink-vector string pos)) (- pos s-start) last-octet new-state)))) +(def-ef-macro ef-string-octet-count (extfmt lisp::lisp +ef-max+ +ef-oc+) + `(lambda (string start end error &aux (total 0) (state nil)) + (dotimes (i (- end start) total) + (incf total + (octet-count ,extfmt (schar string (+ start i)) state error))))) + +(defun string-octet-count (string &key (start 0) end (external-format :default) error) + "Compute the number of octets needed to convert String using the + specified External-format. The string is bound by Start (defaulting + to 0) and End (defaulting to the end of the string)." + (let ((composing-format-p + ;; Determine is the external format is a composing format + ;; which we determine by seeing that the name of the format + ;; is a cons. Probably not the best way. + (consp (ef-name (find-external-format external-format))))) + ;; We currently don't know how to get just the number of octets + ;; when a composing external format is used. As a workaround, use + ;; STRING-TO-OCTETS to find the number of octets. + (if composing-format-p + (nth-value 1 + (string-to-octets string :start start :end end + :external-format external-format)) + (lisp::with-array-data ((string string) (start start) (end end)) + (funcall (ef-string-octet-count external-format) + string start end error))))) (def-ef-macro ef-encode (extfmt lisp::lisp +ef-max+ +ef-en+) `(lambda (string start end result error &aux (ptr 0) (state nil)) @@ -1186,10 +1295,11 @@ character and illegal outputs are replaced by a question mark.") (#.+ef-so+ (%ef-string-to-octets ef)) (#.+ef-en+ (%ef-encode ef)) (#.+ef-de+ (%ef-decode ef)) - (#.+ef-osc+ (%ef-octets-to-string-counted ef)))) + (#.+ef-osc+ (%ef-octets-to-string-counted ef)) + (#.+ef-oc+ (%ef-octet-count ef)))) `(setf (aref (ef-cache (find-external-format ,(ef-name ef))) ,slot) ,(subst (ef-name ef) ef - (function-lambda-expression (aref (ef-cache ef) slot)))))) + (function-lambda-expression (aref (ef-cache ef) slot))))))) ;;; Builtin external formats. @@ -1307,7 +1417,17 @@ replacement character.") ((< ,code #x800) (utf8 ,code 1)) ((< ,code #x10000) (utf8 ,code 2)) ((< ,code #x110000) (utf8 ,code 3)) - (t (error "How did this happen? Codepoint U+~X is illegal" ,code)))))) + (t (error "How did this happen? Codepoint U+~X is illegal" ,code))))) + () + () + (octet-count (code state error) + `(locally + (declare (optimize (ext:inhibit-warnings 3))) + (cond ((< ,code #x80) 1) + ((< ,code #x800) 2) + ((< ,code #x10000) 3) + ((< ,code #x110000) 4) + (t (error "How did this happen? Codepoint U+~X is illegal" ,code)))))) (define-external-format :ascii (:size 1 :documentation "US ASCII 7-bit encoding. Illegal input sequences are replaced with @@ -1333,4 +1453,14 @@ replaced with a question mark.") (declare (optimize (ext:inhibit-warnings 3))) (funcall ,error "Cannot output codepoint #x~X to ASCII stream" ,code)) #x3F) - ,code)))) + ,code))) + () + () + (octet-count (code state error) + `(if (> ,code #x7f) + (if ,error + (locally + (declare (optimize (ext:inhibit-warnings 3))) + (funcall ,error "Cannot output codepoint #x~X to ASCII stream" ,code)) + 1) + 1))) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -9300,6 +9300,13 @@ msgid "" " external format." msgstr "" +#: src/code/extfmts.lisp +msgid "" +"Compute the number of octets needed to convert String using the\n" +" specified External-format. The string is bound by Start (defaulting\n" +" to 0) and End (defaulting to the end of the string)." +msgstr "" + #: src/code/extfmts.lisp msgid "" "Encode the given String using External-Format and return a new\n" ===================================== src/pcl/simple-streams/external-formats/ascii.lisp ===================================== @@ -33,5 +33,15 @@ replaced with a question mark.") (declare (optimize (ext:inhibit-warnings 3))) (funcall ,error "Cannot output codepoint #x~X to ASCII stream" ,code)) #x3F) - ,code)))) + ,code))) + () + () + (octet-count (code state error) + `(if (> ,code #x7f) + (if ,error + (locally + (declare (optimize (ext:inhibit-warnings 3))) + (funcall ,error "Cannot output codepoint #x~X to ASCII stream" ,code)) + 1) + 1))) ===================================== src/pcl/simple-streams/external-formats/euc-kr.lisp ===================================== @@ -1007,4 +1007,16 @@ character and illegal outputs are replaced by a question mark.") (t (if ,error (funcall ,error "Cannot output codepoint #x~X to EUC-KR format." ,code) - (,output #X3f)))))))) + (,output #X3f))))))) + () + () + (octet-count (code state error present) + `(if (<= ,code #x7f) + 1 + (let ((,present (get-inverse ,itable ,code))) + (cond (,present + 2) + (t + (if ,error + (funcall ,error "Cannot output codepoint #x~X to EUC-KR format." ,code) + 1))))))) ===================================== src/pcl/simple-streams/external-formats/iso8859-1.lisp ===================================== @@ -31,4 +31,17 @@ character and illegal outputs are replaced by a question mark.") (funcall ,error "Cannot output codepoint #x~X to ISO8859-1 stream" ,code 1)) #x3F) - ,code)))) + ,code))) + () + () + (octet-count (code state error) + `(if (> ,code 255) + (if ,error + (locally + ;; No warnings about fdefinition + (declare (optimize (ext:inhibit-warnings 3))) + (funcall ,error + (intl:gettext "Cannot output codepoint #x~X to ISO8859-1 stream") + ,code 1)) + 1) + 1))) ===================================== src/pcl/simple-streams/external-formats/iso8859-2.lisp ===================================== @@ -47,4 +47,19 @@ character and illegal outputs are replaced by a question mark.") (declare (optimize (ext:inhibit-warnings 3))) (funcall ,error "Cannot output codepoint #x~X to ISO8859-2 stream" ,code)) - #x3F))))))) + #x3F)))))) + () + () + (octet-count (code state error present) + `(if (< ,code 160) + 1 + (let ((,present (get-inverse ,itable ,code))) + (if ,present + 1 + (if ,error + (locally + ;; No warnings about fdefinition + (declare (optimize (ext:inhibit-warnings 3))) + (funcall ,error "Cannot output codepoint #x~X to ISO8859-2 stream" + ,code)) + 1)))))) ===================================== src/pcl/simple-streams/external-formats/mac-roman.lisp ===================================== @@ -49,4 +49,19 @@ character and illegal outputs are replaced by a question mark.") (declare (optimize (ext:inhibit-warnings 3))) (funcall ,error "Cannot output codepoint #x~X to MAC-ROMAN stream" ,code)) - #x3F))))))) + #x3F)))))) + () + () + (octet-count (code state error present) + `(if (< ,code 128) + 1 + (let ((,present (get-inverse ,itable ,code))) + (if ,present + 1 + (if ,error + (locally + ;; No warnings about fdefinition + (declare (optimize (ext:inhibit-warnings 3))) + (funcall ,error "Cannot output codepoint #x~X to MAC-ROMAN stream" + ,code)) + 1)))))) ===================================== src/pcl/simple-streams/external-formats/utf-16-be.lisp ===================================== @@ -110,4 +110,12 @@ Unicode replacement character.") (copy-state (state) ;; The state is either NIL or a codepoint, so nothing really ;; special is needed to copy it. - `(progn ,state))) + `(progn ,state)) + (octet-count (code state error) + `(cond ((< ,code #x10000) + 2) + ((< ,code #x110000) + 4) + (t + ;; Replacement character is 2 octets + 2)))) ===================================== src/pcl/simple-streams/external-formats/utf-16-le.lisp ===================================== @@ -111,4 +111,12 @@ Unicode replacement character.") (copy-state (state) ;; The state is either NIL or a codepoint, so nothing really ;; special is needed. - `(progn ,state))) + `(progn ,state)) + (octet-count (code state error) + `(cond ((< ,code #x10000) + 2) + ((< ,code #x110000) + 4) + (t + ;; Replacement character is 2 octets + 2)))) ===================================== src/pcl/simple-streams/external-formats/utf-16.lisp ===================================== @@ -156,4 +156,18 @@ Unicode replacement character.") ,c)))))) (copy-state (state) ;; The state is list. Copy it - `(copy-list ,state))) + `(copy-list ,state)) + (octet-count (code state error) + `(let ((bom-count 0)) + (unless ,state + ;; Output BOM + (setf bom-count 2) + (setf ,state t)) + (+ bom-count + (cond ((< ,code #x10000) + 2) + ((< ,code #x110000) + 4) + (t + ;; Replacement character is 2 octets + 2)))))) ===================================== src/pcl/simple-streams/external-formats/utf-32-be.lisp ===================================== @@ -61,4 +61,18 @@ Unicode replacement character.") ,code)) +replacement-character-code+))) (t - (out ,code)))))) + (out ,code))))) + () + () + (octet-count (code state error) + `(cond ((lisp::surrogatep ,code) + (if ,error + (locally + ;; No warnings about fdefinition + (declare (optimize (ext:inhibit-warnings 3))) + (funcall ,error "Surrogate code #x~4,'0X is illegal for UTF32 output" + ,code)) + ;; Replacement character is 2 octets + 2)) + (t + 4)))) ===================================== src/pcl/simple-streams/external-formats/utf-32-le.lisp ===================================== @@ -62,4 +62,18 @@ Unicode replacement character.") ,code)) +replacement-character-code+))) (t - (out ,code)))))) + (out ,code))))) + () + () + (octet-count (code state error) + `(cond ((lisp::surrogatep ,code) + (if ,error + (locally + ;; No warnings about fdefinition + (declare (optimize (ext:inhibit-warnings 3))) + (funcall ,error "Surrogate code #x~4,'0X is illegal for UTF32 output" + ,code)) + ;; Replacement character is 2 octets + 2)) + (t + 4)))) ===================================== src/pcl/simple-streams/external-formats/utf-32.lisp ===================================== @@ -114,4 +114,20 @@ Unicode replacement character.") nil (copy-state (state) ;; The state is either NIL or T, so we can just return that. - `(progn ,state))) + `(progn ,state)) + (octet-count (code state error) + `(let ((bom-count 0)) + (unless ,state + (setf bom-count 4) + (setf ,state t)) + (cond ((lisp::surrogatep ,code) + (if ,error + (locally + ;; No warnings about fdefinition + (declare (optimize (ext:inhibit-warnings 3))) + (funcall ,error "Surrogate code #x~4,'0X is illegal for UTF32 output" + ,code)) + ;; Replacement character is 2 octets + (+ 2 bom-count))) + (t + (+ 4 bom-count)))))) ===================================== src/pcl/simple-streams/external-formats/utf-8.lisp ===================================== @@ -127,4 +127,14 @@ replacement character.") ((< ,code #x800) (utf8 ,code 1)) ((< ,code #x10000) (utf8 ,code 2)) ((< ,code #x110000) (utf8 ,code 3)) - (t (error "How did this happen? Codepoint U+~X is illegal" ,code)))))) + (t (error "How did this happen? Codepoint U+~X is illegal" ,code))))) + () + () + (octet-count (code state error) + `(locally + (declare (optimize (ext:inhibit-warnings 3))) + (cond ((< ,code #x80) 1) + ((< ,code #x800) 2) + ((< ,code #x10000) 3) + ((< ,code #x110000) 4) + (t (error "How did this happen? Codepoint U+~X is illegal" ,code)))))) ===================================== tests/external-formats.lisp ===================================== @@ -0,0 +1,135 @@ +;;; Tests for external formats + +(defpackage :external-formats-tests + (:use :cl :lisp-unit)) + +(in-package "EXTERNAL-FORMATS-TESTS") + +(defparameter *test-iso8859-1* + (let ((rs (kernel::make-random-object :state (kernel::init-random-state 27182828)))) + (lisp::codepoints-string + (loop for k from 0 below 1000 + collect (random 256 rs)))) + "Random test string with ISO8859-1 characters") + +(defparameter *test-unicode* + (let ((rs (kernel::make-random-object :state (kernel::init-random-state 27182828)))) + (lisp::codepoints-string + (loop for k from 0 below 1000 + collect (random 20000 rs)))) + "Random test string with codepoints below 20000") + + + +(defmacro test-octet-count (string format) + "Test that STRING-OCTET-COUNT returns the correct number of octets" + ;; We expect STRING-OCTET-COUNT returns the same number of octets + ;; that are produced by STRING-TO-OCTETS. + `(multiple-value-bind (octets count converted) + (stream:string-to-octets ,string :external-format ,format) + ;; While we're at it, make sure that the length of the octet + ;; buffer matches returned count. And make sure we converted all + ;; the characters in the string. + (assert-equal (length octets) count) + (assert-equal (length ,string) converted) + ;; Finally, make sure that STRING-OCTET-COUNT returns the same + ;; number of octets from STRING-TO-OCTETS. + (assert-equal (length octets) + (stream::string-octet-count ,string :external-format ,format)))) + +(define-test octet-count.iso8859-1 + (:tag :octet-count) + (test-octet-count *test-iso8859-1* :iso8859-1)) + +(define-test octet-count.ascii + (:tag :octet-count) + (test-octet-count *test-iso8859-1* :ascii)) + +(define-test octet-count.ascii.error + (:tag :octet-count) + (assert-error 'simple-error + (stream::string-octet-count *test-iso8859-1* + :external-format :ascii + :error 'error))) + +(define-test octet-count.utf-8 + (:tag :octet-count) + (test-octet-count *test-unicode* :utf-8)) + +(define-test octet-count.utf-16 + (:tag :octet-count) + (test-octet-count *test-unicode* :utf-16)) + +(define-test octet-count.utf-16-be + (:tag :octet-count) + (test-octet-count *test-unicode* :utf-16-be)) + +(define-test octet-count.utf-16-le + (:tag :octet-count) + (test-octet-count *test-unicode* :utf-16-le)) + +(define-test octet-count.utf-32 + (:tag :octet-count) + (test-octet-count *test-unicode* :utf-32)) + +(define-test octet-count.utf-32-le + (:tag :octet-count) + (test-octet-count *test-unicode* :utf-32-le)) + +(define-test octet-count.utf-32-le + (:tag :octet-count) + (test-octet-count *test-unicode* :utf-32-le)) + +(define-test octet-count.euc-kr + (:tag :octet-count) + (test-octet-count *test-unicode* :euc-kr)) + +(define-test octet-count.iso8859-2 + (:tag :octet-count) + (test-octet-count *test-iso8859-1* :iso8859-2)) + +(define-test octet-count.iso8859-3 + (:tag :octet-count) + (test-octet-count *test-iso8859-1* :iso8859-3)) + +(define-test octet-count.iso8859-4 + (:tag :octet-count) + (test-octet-count *test-iso8859-1* :iso8859-4)) + +(define-test octet-count.iso8859-5 + (:tag :octet-count) + (test-octet-count *test-iso8859-1* :iso8859-5)) + +(define-test octet-count.iso8859-6 + (:tag :octet-count) + (test-octet-count *test-iso8859-1* :iso8859-6)) + +(define-test octet-count.iso8859-7 + (:tag :octet-count) + (test-octet-count *test-iso8859-1* :iso8859-7)) + +(define-test octet-count.iso8859-8 + (:tag :octet-count) + (test-octet-count *test-iso8859-1* :iso8859-8)) + +(define-test octet-count.iso8859-10 + (:tag :octet-count) + (test-octet-count *test-iso8859-1* :iso8859-10)) + +(define-test octet-count.iso8859-13 + (:tag :octet-count) + (test-octet-count *test-iso8859-1* :iso8859-13)) + +(define-test octet-count.iso8859-14 + (:tag :octet-count) + (test-octet-count *test-iso8859-1* :iso8859-14)) + +(define-test octet-count.iso8859-15 + (:tag :octet-count) + (test-octet-count *test-iso8859-1* :iso8859-15)) + +(define-test octet-count.mac-roman + (:tag :octet-count) + (test-octet-count *test-iso8859-1* :mac-roman)) + + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/bf461224aaa80f802a5f40… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/bf461224aaa80f802a5f40… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-365-add-strerror] 2 commits: Building unix-errno.lisp is independent of of the -b option
by Raymond Toy (＠rtoy) 31 Jan '25

31 Jan '25

Raymond Toy pushed to branch issue-365-add-strerror at cmucl / cmucl Commits: 0628c87a by Raymond Toy at 2025-01-30T17:19:07-08:00 Building unix-errno.lisp is independent of of the -b option Previously, we were setting `GEN_ERROR` if `$BASE` was not set (via the `-b` option). This is incorrect. The choice is independent of the value of the `$BASE` setting. Add a separate test for this. - - - - - fe12bd37 by Raymond Toy at 2025-01-30T17:22:00-08:00 Make code for setting of GEN_ERROR the same as in build.sh - - - - - 2 changed files: - bin/build.sh - bin/cross-build-world.sh Changes: ===================================== bin/build.sh ===================================== @@ -156,8 +156,6 @@ buildit () BUILDWORLD="$TOOLDIR/build-world.sh" BUILD_POT="yes" UPDATE_TRANS= -# Set to "yes" if we auto-generate code/unix-errno.lisp. -GEN_ERRNO= while getopts "123PRGo:b:v:uB:C:Ui:w:O:?" arg do @@ -198,7 +196,6 @@ if [ -z "$BASE" ]; then i86pc) BASE=sol-x86 ;; esac ;; Linux) - GEN_ERRNO=yes BASE=linux ;; # Add support for FreeBSD and NetBSD? Otherwise default to just build. *) BASE=build ;; @@ -207,6 +204,19 @@ fi echo base = $BASE +# Determine if we need to generate unix-errno.lisp + +# Set to "yes" if we auto-generate code/unix-errno.lisp. +GEN_ERRNO= + +case `uname -s` in + # Add more cases as we support more OSes + Linux) + GEN_ERRNO=yes + ;; +esac + + bootfiles_dir=$SRCDIR/bootfiles/$version if [ -n "$bootfiles" ]; then for file in $bootfiles; do ===================================== bin/cross-build-world.sh ===================================== @@ -14,8 +14,6 @@ usage() { MAKE=make INTERACTIVE=nil BREAK="" -# Set to "yes" if we auto-generate code/unix-errno.lisp. -GEN_ERRNO= while getopts "cirlXB:G:" arg do @@ -61,15 +59,14 @@ CROSS="`echo $2 | sed 's:/*$::'`" SCRIPT="$3" LISP="${4:-lisp}" +# Determine if we need to generate unix-errno.lisp +# Set to "yes" if we auto-generate code/unix-errno.lisp. +GEN_ERRNO= case `uname -s` in - Darwin) - ;; - SunOS) - ;; + # Add more cases as we support more OSes Linux) GEN_ERRNO=yes ;; - *) ;; esac if [ -z "$BOOTSTRAP" ]; then View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/3cccf95a5ccbe09b22b6fb… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/3cccf95a5ccbe09b22b6fb… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-365-add-strerror] Fix typo: Missing closing ";;"
by Raymond Toy (＠rtoy) 31 Jan '25

31 Jan '25

Raymond Toy pushed to branch issue-365-add-strerror at cmucl / cmucl Commits: 3cccf95a by Raymond Toy at 2025-01-30T16:04:32-08:00 Fix typo: Missing closing ";;" - - - - - 1 changed file: - bin/cross-build-world.sh Changes: ===================================== bin/cross-build-world.sh ===================================== @@ -68,6 +68,7 @@ case `uname -s` in ;; Linux) GEN_ERRNO=yes + ;; *) ;; esac View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/3cccf95a5ccbe09b22b6fbf… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/3cccf95a5ccbe09b22b6fbf… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-365-add-strerror] Generate unix-errno.lisp if needed.
by Raymond Toy (＠rtoy) 30 Jan '25

30 Jan '25

Raymond Toy pushed to branch issue-365-add-strerror at cmucl / cmucl Commits: 5b3ab0d6 by Raymond Toy at 2025-01-30T15:02:45-08:00 Generate unix-errno.lisp if needed. For Linux, we need to generate code/unix-errno.lisp before doing the cross-compile. (Or should we just not compile unix-errno.lisp since we probably don't need it to create the cross-compiled result?) - - - - - 1 changed file: - bin/cross-build-world.sh Changes: ===================================== bin/cross-build-world.sh ===================================== @@ -14,6 +14,8 @@ usage() { MAKE=make INTERACTIVE=nil BREAK="" +# Set to "yes" if we auto-generate code/unix-errno.lisp. +GEN_ERRNO= while getopts "cirlXB:G:" arg do @@ -59,6 +61,16 @@ CROSS="`echo $2 | sed 's:/*$::'`" SCRIPT="$3" LISP="${4:-lisp}" +case `uname -s` in + Darwin) + ;; + SunOS) + ;; + Linux) + GEN_ERRNO=yes + *) ;; +esac + if [ -z "$BOOTSTRAP" ]; then CROSSBOOT="$TARGET/cross-bootstrap.lisp" else @@ -84,6 +96,11 @@ then sed "s:^src:$CROSS:g" | xargs mkdir fi +if [ "$GEN_ERRNO" = "yes" ]; then + # Generate code/unix-errno.lisp + $MAKE -C $TARGET/lisp ../code/unix-errno.lisp +fi + echo cross boot = $CROSSBOOT $LISP "$@" -noinit -nositeinit <<EOF (in-package :cl-user) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/5b3ab0d6bebc791ab3649d1… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/5b3ab0d6bebc791ab3649d1… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-365-add-strerror] 2 commits: Only create unix-errno.lisp if we support it
by Raymond Toy (＠rtoy) 30 Jan '25

30 Jan '25

Raymond Toy pushed to branch issue-365-add-strerror at cmucl / cmucl Commits: e8c92624 by Raymond Toy at 2025-01-30T07:56:23-08:00 Only create unix-errno.lisp if we support it No point in trying to generate unix-errno.lisp if we haven't added support for generating it. - - - - - c2e1a2f2 by Raymond Toy at 2025-01-30T07:57:34-08:00 Need to use list for building unix-errno.lisp - - - - - 2 changed files: - bin/build.sh - src/tools/worldbuild.lisp Changes: ===================================== bin/build.sh ===================================== @@ -129,8 +129,10 @@ buildit () if [ "$ENABLE" = "yes" ]; then $TOOLDIR/clean-target.sh $CLEAN_FLAGS $TARGET || { echo "Failed: $TOOLDIR/clean-target.sh"; exit 1; } - # Generate code/unix-errno.lisp - $MAKE -C $TARGET/lisp ../code/unix-errno.lisp + if [ "$GEN_ERRNO" = "yes" ]; then + # Generate code/unix-errno.lisp + $MAKE -C $TARGET/lisp ../code/unix-errno.lisp + fi time $BUILDWORLD $TARGET $OLDLISP $BOOT || { echo "Failed: $BUILDWORLD"; exit 1; } if [ "$REBUILD_LISP" = "yes" ]; then $TOOLDIR/rebuild-lisp.sh $TARGET @@ -154,6 +156,8 @@ buildit () BUILDWORLD="$TOOLDIR/build-world.sh" BUILD_POT="yes" UPDATE_TRANS= +# Set to "yes" if we auto-generate code/unix-errno.lisp. +GEN_ERRNO= while getopts "123PRGo:b:v:uB:C:Ui:w:O:?" arg do @@ -193,7 +197,9 @@ if [ -z "$BASE" ]; then sun4*) BASE=sparc ;; i86pc) BASE=sol-x86 ;; esac ;; - Linux) BASE=linux ;; + Linux) + GEN_ERRNO=yes + BASE=linux ;; # Add support for FreeBSD and NetBSD? Otherwise default to just build. *) BASE=build ;; esac ===================================== src/tools/worldbuild.lisp ===================================== @@ -139,7 +139,7 @@ ,@(when (or (c:backend-featurep :linux)) ;; This is currently only available for some OSes. Ideally, ;; it should be available for all OSes. - "target:code/unix-errno") + '("target:code/unix-errno")) ,@(when (c:backend-featurep :mach) '("target:code/mach" "target:code/mach-os")) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/e3504ec0293902fde75fd9… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/e3504ec0293902fde75fd9… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-365-add-strerror] 6 commits: Autogenerate def-unix-errors in code/unix-errno.lisp
by Raymond Toy (＠rtoy) 30 Jan '25

30 Jan '25

Raymond Toy pushed to branch issue-365-add-strerror at cmucl / cmucl Commits: 967de6a7 by Raymond Toy at 2025-01-30T06:58:14-08:00 Autogenerate def-unix-errors in code/unix-errno.lisp Add the file create-errno.c that generates prints out appropriate `def-unix-error` forms. Add a make rule in GNUMakefile to build `create-errno`. This means we had to comment out the rules for internals.h/internals.inc because we need to run make to create unix-errno.lisp before doing the build. Update Config.x86_linux with a make rule to create code/unix-errno.lisp via create-errno. - - - - - d122b95f by Raymond Toy at 2025-01-30T07:01:45-08:00 Add rule to create code/unix-errno.lisp Just copied from Config.x86_linux. - - - - - 07a998ee by Raymond Toy at 2025-01-30T07:31:19-08:00 Add CMUCL-style file header to unix-errno.lisp Make the generated file look like a typical source file. And add a note not to edit the file because it's autogenerated. - - - - - 034c685d by Raymond Toy at 2025-01-30T07:42:59-08:00 Preserve def-unix-error for other OSes than Linux (for now) Since on Linux we currently auto-generate the errno definitions, we don't need to define them here. For other OSes, we leave the definitions here until they are also auto-generated. - - - - - 55db6026 by Raymond Toy at 2025-01-30T07:44:09-08:00 Create code/unix-errno.lisp before compiling the world We need to generate code/unix-errno.lisp before compiling the world. Call make to do that. - - - - - e3504ec0 by Raymond Toy at 2025-01-30T07:44:59-08:00 Compile and load code/unix-errno.lisp This is only done for Linux for now since we only generate this file on Linux. - - - - - 8 changed files: - bin/build.sh - src/code/unix.lisp - src/lisp/Config.x86_linux - src/lisp/Config.x86_linux_clang - src/lisp/GNUmakefile - + src/lisp/create-errno.c - src/tools/worldbuild.lisp - src/tools/worldcom.lisp Changes: ===================================== bin/build.sh ===================================== @@ -129,6 +129,8 @@ buildit () if [ "$ENABLE" = "yes" ]; then $TOOLDIR/clean-target.sh $CLEAN_FLAGS $TARGET || { echo "Failed: $TOOLDIR/clean-target.sh"; exit 1; } + # Generate code/unix-errno.lisp + $MAKE -C $TARGET/lisp ../code/unix-errno.lisp time $BUILDWORLD $TARGET $OLDLISP $BOOT || { echo "Failed: $BUILDWORLD"; exit 1; } if [ "$REBUILD_LISP" = "yes" ]; then $TOOLDIR/rebuild-lisp.sh $TARGET ===================================== src/code/unix.lisp ===================================== @@ -1742,13 +1742,16 @@ (defparameter *compiler-unix-errors* nil) -(defmacro def-unix-error (name number description) +(defmacro def-unix-error (name number &optional description) + "Define a constant named Name corresponding to the Unix errno value + Number. A description of the errno is optional in Description." `(progn (eval-when (compile eval) (push (cons ,number ,description) *compiler-unix-errors*)) (defconstant ,name ,number ,description) (export ',name))) +#-linux (defmacro emit-unix-errors () (let* ((max (apply #'max (mapcar #'car *compiler-unix-errors*))) (array (make-array (1+ max) :initial-element nil))) @@ -1760,6 +1763,10 @@ ) ;eval-when +;;; For Linux, the def-unix-error forms are auto-generated and are not +;;; defined here. +#-linux +(progn ;;; ;;; From <errno.h> ;;; @@ -1945,101 +1952,11 @@ (def-unix-error EINPROGRESS 150 _N"Operation now in progress") (def-unix-error ESTALE 151 _N"Stale NFS file handle") ) -#+linux -(progn -(def-unix-error EDEADLK 35 _N"Resource deadlock would occur") -(def-unix-error ENAMETOOLONG 36 _N"File name too long") -(def-unix-error ENOLCK 37 _N"No record locks available") -(def-unix-error ENOSYS 38 _N"Function not implemented") -(def-unix-error ENOTEMPTY 39 _N"Directory not empty") -(def-unix-error ELOOP 40 _N"Too many symbolic links encountered") -(def-unix-error EWOULDBLOCK 11 _N"Operation would block") -(def-unix-error ENOMSG 42 _N"No message of desired type") -(def-unix-error EIDRM 43 _N"Identifier removed") -(def-unix-error ECHRNG 44 _N"Channel number out of range") -(def-unix-error EL2NSYNC 45 _N"Level 2 not synchronized") -(def-unix-error EL3HLT 46 _N"Level 3 halted") -(def-unix-error EL3RST 47 _N"Level 3 reset") -(def-unix-error ELNRNG 48 _N"Link number out of range") -(def-unix-error EUNATCH 49 _N"Protocol driver not attached") -(def-unix-error ENOCSI 50 _N"No CSI structure available") -(def-unix-error EL2HLT 51 _N"Level 2 halted") -(def-unix-error EBADE 52 _N"Invalid exchange") -(def-unix-error EBADR 53 _N"Invalid request descriptor") -(def-unix-error EXFULL 54 _N"Exchange full") -(def-unix-error ENOANO 55 _N"No anode") -(def-unix-error EBADRQC 56 _N"Invalid request code") -(def-unix-error EBADSLT 57 _N"Invalid slot") -(def-unix-error EDEADLOCK EDEADLK _N"File locking deadlock error") -(def-unix-error EBFONT 59 _N"Bad font file format") -(def-unix-error ENOSTR 60 _N"Device not a stream") -(def-unix-error ENODATA 61 _N"No data available") -(def-unix-error ETIME 62 _N"Timer expired") -(def-unix-error ENOSR 63 _N"Out of streams resources") -(def-unix-error ENONET 64 _N"Machine is not on the network") -(def-unix-error ENOPKG 65 _N"Package not installed") -(def-unix-error EREMOTE 66 _N"Object is remote") -(def-unix-error ENOLINK 67 _N"Link has been severed") -(def-unix-error EADV 68 _N"Advertise error") -(def-unix-error ESRMNT 69 _N"Srmount error") -(def-unix-error ECOMM 70 _N"Communication error on send") -(def-unix-error EPROTO 71 _N"Protocol error") -(def-unix-error EMULTIHOP 72 _N"Multihop attempted") -(def-unix-error EDOTDOT 73 _N"RFS specific error") -(def-unix-error EBADMSG 74 _N"Not a data message") -(def-unix-error EOVERFLOW 75 _N"Value too large for defined data type") -(def-unix-error ENOTUNIQ 76 _N"Name not unique on network") -(def-unix-error EBADFD 77 _N"File descriptor in bad state") -(def-unix-error EREMCHG 78 _N"Remote address changed") -(def-unix-error ELIBACC 79 _N"Can not access a needed shared library") -(def-unix-error ELIBBAD 80 _N"Accessing a corrupted shared library") -(def-unix-error ELIBSCN 81 _N".lib section in a.out corrupted") -(def-unix-error ELIBMAX 82 _N"Attempting to link in too many shared libraries") -(def-unix-error ELIBEXEC 83 _N"Cannot exec a shared library directly") -(def-unix-error EILSEQ 84 _N"Illegal byte sequence") -(def-unix-error ERESTART 85 _N"Interrupted system call should be restarted _N") -(def-unix-error ESTRPIPE 86 _N"Streams pipe error") -(def-unix-error EUSERS 87 _N"Too many users") -(def-unix-error ENOTSOCK 88 _N"Socket operation on non-socket") -(def-unix-error EDESTADDRREQ 89 _N"Destination address required") -(def-unix-error EMSGSIZE 90 _N"Message too long") -(def-unix-error EPROTOTYPE 91 _N"Protocol wrong type for socket") -(def-unix-error ENOPROTOOPT 92 _N"Protocol not available") -(def-unix-error EPROTONOSUPPORT 93 _N"Protocol not supported") -(def-unix-error ESOCKTNOSUPPORT 94 _N"Socket type not supported") -(def-unix-error EOPNOTSUPP 95 _N"Operation not supported on transport endpoint") -(def-unix-error EPFNOSUPPORT 96 _N"Protocol family not supported") -(def-unix-error EAFNOSUPPORT 97 _N"Address family not supported by protocol") -(def-unix-error EADDRINUSE 98 _N"Address already in use") -(def-unix-error EADDRNOTAVAIL 99 _N"Cannot assign requested address") -(def-unix-error ENETDOWN 100 _N"Network is down") -(def-unix-error ENETUNREACH 101 _N"Network is unreachable") -(def-unix-error ENETRESET 102 _N"Network dropped connection because of reset") -(def-unix-error ECONNABORTED 103 _N"Software caused connection abort") -(def-unix-error ECONNRESET 104 _N"Connection reset by peer") -(def-unix-error ENOBUFS 105 _N"No buffer space available") -(def-unix-error EISCONN 106 _N"Transport endpoint is already connected") -(def-unix-error ENOTCONN 107 _N"Transport endpoint is not connected") -(def-unix-error ESHUTDOWN 108 _N"Cannot send after transport endpoint shutdown") -(def-unix-error ETOOMANYREFS 109 _N"Too many references: cannot splice") -(def-unix-error ETIMEDOUT 110 _N"Connection timed out") -(def-unix-error ECONNREFUSED 111 _N"Connection refused") -(def-unix-error EHOSTDOWN 112 _N"Host is down") -(def-unix-error EHOSTUNREACH 113 _N"No route to host") -(def-unix-error EALREADY 114 _N"Operation already in progress") -(def-unix-error EINPROGRESS 115 _N"Operation now in progress") -(def-unix-error ESTALE 116 _N"Stale NFS file handle") -(def-unix-error EUCLEAN 117 _N"Structure needs cleaning") -(def-unix-error ENOTNAM 118 _N"Not a XENIX named type file") -(def-unix-error ENAVAIL 119 _N"No XENIX semaphores available") -(def-unix-error EISNAM 120 _N"Is a named type file") -(def-unix-error EREMOTEIO 121 _N"Remote I/O error") -(def-unix-error EDQUOT 122 _N"Quota exceeded") -) ;;; ;;; And now for something completely different ... (emit-unix-errors) +) (def-alien-routine ("os_get_errno" unix-get-errno) int) (def-alien-routine ("os_set_errno" unix-set-errno) int (newvalue int)) ===================================== src/lisp/Config.x86_linux ===================================== @@ -14,3 +14,6 @@ OS_LINK_FLAGS = -m32 -rdynamic -Xlinker --export-dynamic -Xlinker -Map -Xlinker OS_LINK_FLAGS += -Wl,-z,noexecstack EXEC_FINAL_OBJ = exec-final.o + +../code/unix-errno.lisp : create-errno + ./create-errno /usr/include/asm-generic/errno* | uniq > $@ ===================================== src/lisp/Config.x86_linux_clang ===================================== @@ -19,3 +19,6 @@ OS_LINK_FLAGS = -m32 -rdynamic -Xlinker --export-dynamic -Xlinker -Map -Xlinker OS_LINK_FLAGS += -Wl,-z,noexecstack EXEC_FINAL_OBJ = exec-final.o + +../code/unix-errno.lisp : create-errno + ./create-errno /usr/include/asm-generic/errno* | uniq > $@ ===================================== src/lisp/GNUmakefile ===================================== @@ -66,9 +66,9 @@ endif version: echo 0 > version -internals.h internals.inc: - @echo "You must run genesis to create internals.h!" - @false +#internals.h internals.inc: +# @echo "You must run genesis to create internals.h!" +# @false clean: $(RM) Depends *.o lisp lisp.nm core lisp.a @@ -139,3 +139,7 @@ translations-update: done; done +# Compile program that creates the unix-error.lisp file. Actual +# generation of the file is OS-dependent. +create-errno : create-errno.c + $(CC) -o $@ $^ ===================================== src/lisp/create-errno.c ===================================== @@ -0,0 +1,91 @@ +#include <regex.h> +#include <stdio.h> +#include <stdlib.h> +#include <string.h> + +struct Err { + char *name; + int num; +#if 0 + char *descr; +#endif +} err[256]; + +int nerr = 0; + +regex_t reg; + +void match(const char *line) { + regmatch_t match[3]; + regoff_t len; + + if (regexec(&reg, line, 3, match, 0) == REG_NOMATCH) + return; + + len = match[1].rm_eo - match[1].rm_so; + err[nerr].name = malloc(len + 1); + sprintf(err[nerr].name, "%.*s", len, line + match[1].rm_so); + + err[nerr].num = atoi(line + match[2].rm_so); + +#if 0 + err[nerr].descr = strerror(err[nerr].num); +#endif + + nerr++; +} + +int cmp(const void *a, const void *b) { + return ((struct Err *)a)->num - ((struct Err *)b)->num; +} + +int main(int argc, char **argv) +{ + int i; + FILE *fp; + char line[1024]; + + regcomp(&reg, "^#define[ \t]*(E[A-Z0-9]+)[ \t]*([0-9]+)", REG_EXTENDED); + + for (i = 1; i < argc; i++) { + if ((fp = fopen(argv[i], "r")) == NULL) { + perror("fopen"); + exit(1); + } + while (fgets(line, sizeof(line), fp) != NULL) + match(line); + fclose(fp); + } + + qsort(err, nerr, sizeof(*err), cmp); + + /* + * Print out CMUCL-style file header + */ + puts(";;; -*- Package: UNIX -*-\n\ +;;;\n\ +;;; **********************************************************************\n\ +;;; This code was written as part of the CMU Common Lisp project at\n\ +;;; Carnegie Mellon University, and has been placed in the public domain.\n\ +;;;\n\ +(ext:file-comment\n\ + \"$Header: src/code/unix-errno.lisp $\")\n\ +;;;\n\ +;;; **********************************************************************\n\ +;;;\n\ +;;; This file contains the values of the UNIX errno values.\n\ +;;;\n \ +;;; DO NOT EDIT! This is auto-generated from create-errno.\n\ +;;;\n"); + + puts("(in-package \"UNIX\")\n"); + for (i = 0; i < nerr; i++) { +#if 0 + printf("(def-unix-error %s %d \"%s\")\n", err[i].name, err[i].num, err[i].descr); +#else + printf("(def-unix-error %s %d)\n", err[i].name, err[i].num); +#endif + } + + return 0; +} ===================================== src/tools/worldbuild.lisp ===================================== @@ -136,6 +136,10 @@ "target:code/c-call" "target:code/sap" "target:code/unix" + ,@(when (or (c:backend-featurep :linux)) + ;; This is currently only available for some OSes. Ideally, + ;; it should be available for all OSes. + "target:code/unix-errno") ,@(when (c:backend-featurep :mach) '("target:code/mach" "target:code/mach-os")) ===================================== src/tools/worldcom.lisp ===================================== @@ -163,6 +163,10 @@ (comf "target:code/mipsstrops") (comf "target:code/unix" :proceed t) +(when (or (c:backend-featurep :linux)) + ;; This is currently only available for some OSes. Ideally, it + ;; should be available for all OSes. + (comf "target:code/unix-errno" :proceed t)) (when (c:backend-featurep :mach) (comf "target:code/mach") View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/3c324a95caff5e9533c562… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/3c324a95caff5e9533c562… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0