Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found
Select Git revision
  • 134-expt-1-c-2-2-signals-an-error-incorrectly
  • 135-unix-namestring-returns-instead-of
  • 159-don-t-use-tmp-as-the-path-for-temp-files-in-the-tests
  • 19c-alpha-osf
  • 20f-branch
  • 21c-branch
  • 21d-branch
  • RELEASE-20C-BRANCH
  • branch-21e
  • clx-update-2021-09-19
  • dynamic-stack-alloc
  • file-attribute
  • fixup-template-headings
  • issue-100-ldb-base-char-printing
  • issue-101-add-test
  • issue-101-clang-trapping-math
  • issue-103-remove-random-mt19937-update
  • issue-105-add-build-logs
  • issue-107-use-uint8_t
  • issue-108-update-asdf
  • issue-111-fixes-for-motifd-clm
  • issue-113-prefer-cmucl-modules
  • issue-119-ci-osx-install-fails
  • issue-120-move-misc-first
  • issue-120-software-type-in-c
  • issue-121-fill-pointer-misc
  • issue-122-dynamically-allocate-altstack
  • issue-122-gnu-source
  • issue-125-unix-stat-wrong
  • issue-127-getpwuid-segfault
  • issue-128-quit-exit-code
  • issue-130-file-author-in-c
  • issue-131-move-unix-uname
  • issue-132-ansi-test-rename-files
  • issue-134-expt-bug
  • issue-135-unix-namestring-dot
  • issue-136-ansi-test-ensure-directories-exist.8
  • issue-139-add-alias-local-external-format
  • issue-139-default-external-format-utf8
  • issue-139-filename-encoding-utf8
  • issue-139-set-filename-encoding-to-utf8
  • issue-139-set-terminal-to-utf8
  • issue-139-terminal-format-is-locale
  • issue-139-use-lang-to-set-external-format
  • issue-139a-default-external-format-utf8
  • issue-140-stream-element-type-two-way-stream
  • issue-141-locale
  • issue-142-random-0-wrong-error
  • issue-143-ansi-compliance-failure-listen-extra-argument
  • issue-146-ci-passes-incorrectly
  • issue-147-stream-line-column-impl
  • issue-149-add-setlocale
  • issue-150-add-aliases-cp949-euckr
  • issue-154-piglatin-translation-doesnt-work-anymore
  • issue-155-wrap-help-strings
  • issue-156-add-two-arg-ge-le
  • issue-156-add-vops-for-ge-le
  • issue-156-define-cmpsd-pmovmskb
  • issue-156-nan-comparisons
  • issue-156-take-2-nan-comparison
  • issue-157-directory-no-magic-wildcarding
  • issue-157-directory-returns-all-files
  • issue-158-darwin-pathnames
  • issue-158-darwin-pathnames-utf8
  • issue-159-use-local-tmp-dir
  • issue-162-filename-encoding-no-encoding
  • issue-163-add-command-line-version
  • issue-166-integer-decode-float-min-float
  • issue-167-exponent-bounds-off-by-one
  • issue-168-no-negated-forms-for-jmp
  • issue-169-pprint-define-vop
  • issue-170-clean-up-x86-float-compare
  • issue-171-readable-unspecific-pathnames
  • issue-172-pathname-match-p-return-type
  • issue-173-pprint-def-assem-routine
  • issue-175-simplify-float-compare-vops
  • issue-176-site-name-is-nil
  • issue-177-pprint-deftransform
  • issue-179-get-system-info-in-c
  • issue-180-get-page-size-in-c
  • issue-185-x86-shorter-insts
  • issue-187-imul-disassembly
  • issue-189-move-get-system-info
  • issue-192-disassemble-prints-radix-marker
  • issue-193-nil-unspecific-equivalent
  • issue-195-relocatable-stacks-by-default
  • issue-195b-relocatable-stacks-by-default
  • issue-216-enough-namestring-relative-dir
  • issue-228-update-ansi-tests
  • issue-234-make-ascii-format-builtin
  • issue-240-add-hashtable-for-destructive-set-ops
  • issue-240-add-hashtable-set-exclusive-or
  • issue-240-clean-up-hashtable-for-sets-impl
  • issue-240-clean-up-hashtable-impl
  • issue-240-intersection-with-hash-table
  • issue-240-set-diff-with-hash-table
  • issue-240-subsetp-with-hash-table
  • issue-240-union-with-hash-table
  • issue-241-bug-in-compiler-pcl
  • issue-242-c-call-char-result-wrong
  • 20d
  • 20e
  • 20f
  • 21a
  • 21b
  • 21c
  • 21d
  • 21e
  • GIT-CONVERSION
  • LINKAGE_TABLE
  • PRE_LINKAGE_TABLE
  • RELEASE_18a
  • RELEASE_18b
  • RELEASE_18c
  • RELEASE_18d
  • RELEASE_19f
  • RELEASE_20a
  • RELEASE_20b
  • UNICODE-BASE
  • amd64-dd-start
  • amd64-merge-start
  • begin-x87-removal
  • cold-pcl-base
  • cross-sol-x86-2010-12-20
  • cross-sol-x86-base
  • cross-sol-x86-merged
  • cross-sparc-branch-base
  • double-double-array-base
  • double-double-array-checkpoint
  • double-double-base
  • double-double-init-%make-sparc
  • double-double-init-checkpoint-1
  • double-double-init-ppc
  • double-double-init-sparc
  • double-double-init-sparc-2
  • double-double-init-x86
  • double-double-irrat-end
  • double-double-irrat-start
  • double-double-reader-base
  • double-double-reader-checkpoint-1
  • double-double-sparc-checkpoint-1
  • dynamic-extent-base
  • intl-2-branch-base
  • intl-branch-2010-03-18-1300
  • intl-branch-base
  • intl-branch-working-2010-02-11-1000
  • intl-branch-working-2010-02-19-1000
  • label-2009-03-16
  • label-2009-03-25
  • last-x87-snapshot
  • lisp-executable-base
  • merge-sse2-packed
  • merge-with-19f
  • merged-unicode-utf16-extfmt-2009-06-11
  • mod-arith-base
  • movable-linkage-space-alloc-fixed
  • old_rt
  • portable-clx-base
  • portable-clx-import-2009-06-16
  • post-merge-intl-branch
  • ppc_gencgc_snap_2005-05-14
  • ppc_gencgc_snap_2005-12-17
  • ppc_gencgc_snap_2006-01-06
  • pre-merge-intl-branch
  • pre-telent-clx
  • prm-before-macosx-merge-tag
  • release-18e
  • release-18e-base
  • release-18e-pre1
  • release-18e-pre2
  • release-19a
  • release-19a-base
  • release-19a-pre1
  • release-19a-pre2
  • release-19a-pre3
  • release-19b-base
  • release-19b-pre1
  • release-19b-pre2
  • release-19c
  • release-19c-base
  • release-19c-pre1
  • release-19d
  • release-19d-base
  • release-19d-pre1
  • release-19d-pre2
  • release-19e
  • release-19e-base
  • release-19e-pre1
  • release-19e-pre2
  • release-19f-base
  • release-19f-pre1
  • release-20a-base
  • release-20a-pre1
  • release-20b-pre1
  • release-20b-pre2
  • release-20c
  • release-20c-base
  • release-20e
  • release-20e-base
  • remove_negative_zero_not_zero
200 results

Target

Select target project
  • cmucl/cmucl
  • pfominykh/cmucl
  • yitzchak/cmucl
  • rkreuter/cmucl
  • cshapiro/cmucl
5 results
Select Git revision
  • 134-expt-1-c-2-2-signals-an-error-incorrectly
  • 135-unix-namestring-returns-instead-of
  • 159-don-t-use-tmp-as-the-path-for-temp-files-in-the-tests
  • 19c-alpha-osf
  • 20f-branch
  • 21c-branch
  • 21d-branch
  • RELEASE-20C-BRANCH
  • branch-21e
  • clx-update-2021-09-19
  • dynamic-stack-alloc
  • file-attribute
  • fixup-template-headings
  • issue-100-ldb-base-char-printing
  • issue-101-add-test
  • issue-101-clang-trapping-math
  • issue-103-remove-random-mt19937-update
  • issue-105-add-build-logs
  • issue-107-use-uint8_t
  • issue-108-update-asdf
  • issue-111-fixes-for-motifd-clm
  • issue-113-prefer-cmucl-modules
  • issue-119-ci-osx-install-fails
  • issue-120-move-misc-first
  • issue-120-software-type-in-c
  • issue-121-fill-pointer-misc
  • issue-122-dynamically-allocate-altstack
  • issue-122-gnu-source
  • issue-125-unix-stat-wrong
  • issue-127-getpwuid-segfault
  • issue-128-quit-exit-code
  • issue-130-file-author-in-c
  • issue-131-move-unix-uname
  • issue-132-ansi-test-rename-files
  • issue-134-expt-bug
  • issue-135-unix-namestring-dot
  • issue-136-ansi-test-ensure-directories-exist.8
  • issue-139-add-alias-local-external-format
  • issue-139-default-external-format-utf8
  • issue-139-filename-encoding-utf8
  • issue-139-set-filename-encoding-to-utf8
  • issue-139-set-terminal-to-utf8
  • issue-139-terminal-format-is-locale
  • issue-139-use-lang-to-set-external-format
  • issue-139a-default-external-format-utf8
  • issue-140-stream-element-type-two-way-stream
  • issue-141-locale
  • issue-142-random-0-wrong-error
  • issue-143-ansi-compliance-failure-listen-extra-argument
  • issue-146-ci-passes-incorrectly
  • issue-147-stream-line-column-impl
  • issue-149-add-setlocale
  • issue-150-add-aliases-cp949-euckr
  • issue-154-piglatin-translation-doesnt-work-anymore
  • issue-155-wrap-help-strings
  • issue-156-add-two-arg-ge-le
  • issue-156-add-vops-for-ge-le
  • issue-156-define-cmpsd-pmovmskb
  • issue-156-nan-comparisons
  • issue-156-take-2-nan-comparison
  • issue-157-directory-no-magic-wildcarding
  • issue-157-directory-returns-all-files
  • issue-158-darwin-pathnames
  • issue-158-darwin-pathnames-utf8
  • issue-159-use-local-tmp-dir
  • issue-162-filename-encoding-no-encoding
  • issue-163-add-command-line-version
  • issue-166-integer-decode-float-min-float
  • issue-167-exponent-bounds-off-by-one
  • issue-168-no-negated-forms-for-jmp
  • issue-169-pprint-define-vop
  • issue-170-clean-up-x86-float-compare
  • issue-171-readable-unspecific-pathnames
  • issue-172-pathname-match-p-return-type
  • issue-173-pprint-def-assem-routine
  • issue-175-simplify-float-compare-vops
  • issue-176-site-name-is-nil
  • issue-177-pprint-deftransform
  • issue-179-get-system-info-in-c
  • issue-180-get-page-size-in-c
  • issue-185-x86-shorter-insts
  • issue-187-imul-disassembly
  • issue-189-move-get-system-info
  • issue-192-disassemble-prints-radix-marker
  • issue-193-nil-unspecific-equivalent
  • issue-195-relocatable-stacks-by-default
  • issue-195b-relocatable-stacks-by-default
  • issue-216-enough-namestring-relative-dir
  • issue-228-update-ansi-tests
  • issue-234-make-ascii-format-builtin
  • issue-240-add-hashtable-for-destructive-set-ops
  • issue-240-add-hashtable-set-exclusive-or
  • issue-240-clean-up-hashtable-for-sets-impl
  • issue-240-clean-up-hashtable-impl
  • issue-240-intersection-with-hash-table
  • issue-240-set-diff-with-hash-table
  • issue-240-subsetp-with-hash-table
  • issue-240-union-with-hash-table
  • issue-241-bug-in-compiler-pcl
  • issue-242-c-call-char-result-wrong
  • 20d
  • 20e
  • 20f
  • 21a
  • 21b
  • 21c
  • 21d
  • 21e
  • GIT-CONVERSION
  • LINKAGE_TABLE
  • PRE_LINKAGE_TABLE
  • RELEASE_18a
  • RELEASE_18b
  • RELEASE_18c
  • RELEASE_18d
  • RELEASE_19f
  • RELEASE_20a
  • RELEASE_20b
  • UNICODE-BASE
  • amd64-dd-start
  • amd64-merge-start
  • begin-x87-removal
  • cold-pcl-base
  • cross-sol-x86-2010-12-20
  • cross-sol-x86-base
  • cross-sol-x86-merged
  • cross-sparc-branch-base
  • double-double-array-base
  • double-double-array-checkpoint
  • double-double-base
  • double-double-init-%make-sparc
  • double-double-init-checkpoint-1
  • double-double-init-ppc
  • double-double-init-sparc
  • double-double-init-sparc-2
  • double-double-init-x86
  • double-double-irrat-end
  • double-double-irrat-start
  • double-double-reader-base
  • double-double-reader-checkpoint-1
  • double-double-sparc-checkpoint-1
  • dynamic-extent-base
  • intl-2-branch-base
  • intl-branch-2010-03-18-1300
  • intl-branch-base
  • intl-branch-working-2010-02-11-1000
  • intl-branch-working-2010-02-19-1000
  • label-2009-03-16
  • label-2009-03-25
  • last-x87-snapshot
  • lisp-executable-base
  • merge-sse2-packed
  • merge-with-19f
  • merged-unicode-utf16-extfmt-2009-06-11
  • mod-arith-base
  • movable-linkage-space-alloc-fixed
  • old_rt
  • portable-clx-base
  • portable-clx-import-2009-06-16
  • post-merge-intl-branch
  • ppc_gencgc_snap_2005-05-14
  • ppc_gencgc_snap_2005-12-17
  • ppc_gencgc_snap_2006-01-06
  • pre-merge-intl-branch
  • pre-telent-clx
  • prm-before-macosx-merge-tag
  • release-18e
  • release-18e-base
  • release-18e-pre1
  • release-18e-pre2
  • release-19a
  • release-19a-base
  • release-19a-pre1
  • release-19a-pre2
  • release-19a-pre3
  • release-19b-base
  • release-19b-pre1
  • release-19b-pre2
  • release-19c
  • release-19c-base
  • release-19c-pre1
  • release-19d
  • release-19d-base
  • release-19d-pre1
  • release-19d-pre2
  • release-19e
  • release-19e-base
  • release-19e-pre1
  • release-19e-pre2
  • release-19f-base
  • release-19f-pre1
  • release-20a-base
  • release-20a-pre1
  • release-20b-pre1
  • release-20b-pre2
  • release-20c
  • release-20c-base
  • release-20e
  • release-20e-base
  • remove_negative_zero_not_zero
200 results
Show changes

Commits on Source 64

Showing
with 516 additions and 220 deletions
variables:
download_url: "https://common-lisp.net/project/cmucl/downloads/snapshots/2021/07"
version: "2021-07-x86"
bootstrap: ""
bootstrap: "-B boot-2021-07-1 -B boot-2021-07-2"
stages:
- install
......
......@@ -39,7 +39,7 @@ ENABLE2="yes"
ENABLE3="yes"
ENABLE4="yes"
version=21c
version=21d
SRCDIR=src
BINDIR=bin
TOOLDIR=$BINDIR
......
;; Bootstrap file
;;
;; Use "bin/build.sh -B boot-2021-07-1" to build this.
;;
;; We want to export the symbols from the KERNEL package which also
;; exists in the C package, so we unintern the conflicting symbols from
;; the C package.
(in-package "KERNEL")
(ext:without-package-locks
(handler-bind
((error (lambda (c)
(declare (ignore c))
(invoke-restart 'lisp::unintern-conflicting-symbols))))
(export '(DOUBLE-FLOAT-INT-EXPONENT
SINGLE-FLOAT-INT-EXPONENT))))
;; Bootstrap file for x86 to choose the non-negated forms of the
;; condition flag for conditional jumps.
;;
;; Use bin/build.sh -B boot-2021-07-2 to build this.
#+x86
(in-package :x86)
#+x86
(ext:without-package-locks
(handler-bind
((error
(lambda (c)
(declare (ignore c))
(invoke-restart 'continue))))
(defconstant conditions
'((:o . 0)
(:no . 1)
(:b . 2) (:nae . 2) (:c . 2)
(:ae . 3) (:nb . 3) (:nc . 3)
(:e . 4) (:eq . 4) (:z . 4)
(:ne . 5) (:nz . 5)
(:be . 6) (:na . 6)
(:a . 7) (:nbe . 7)
(:s . 8)
(:ns . 9)
(:p . 10) (:pe . 10)
(:np . 11) (:po . 11)
(:l . 12) (:nge . 12)
(:ge . 13) (:nl . 13)
(:le . 14) (:ng . 14)
(:g . 15) (:nle . 15)))))
......@@ -339,16 +339,54 @@
(defun help-switch-demon (switch)
(declare (ignore switch))
(format t (intl:gettext "~&Usage: ~A <options>~2%") *command-line-utility-name*)
(flet
((get-words (s)
(declare (string s))
;; Return a list of all the words from S. A word is defined
;; as any sequence of characters separated from others by
;; whitespace consisting of space, newline, tab, formfeed, or
;; carriage return.
(let ((end (length s)))
(loop for left = 0 then (+ right 1)
for right = (or
(position-if #'(lambda (c)
(member c
'(#\space #\newline #\tab #\ff #\cr)))
s
:start left)
end)
;; Collect the word bounded by left and right in a list.
unless (and (= right left))
collect (subseq s left right) into subseqs
;; Keep going until we reach the end of the string.
until (>= right end)
finally (return subseqs)))))
(dolist (s (sort *legal-cmd-line-switches* #'string<
:key #'car))
(destructuring-bind (name doc arg)
s
(format t " -~A ~@[~A~]~%" name (if arg (intl:gettext arg)))
;; Poor man's formatting of the help string
(with-input-from-string (stream (intl:gettext doc))
(loop for line = (read-line stream nil nil)
while line
do (format t "~8T~A~%" line)))))
(let ((*print-right-margin* 80))
;; Extract all the words from the string and print them out
;; one by one with a space between each, wrapping the output
;; if needed. Each line is indented by 8 spaces.
;;
;; "~@< ~@;"
;; per-line prefix of spaces and pass the whole arg list
;; to this directive.
;;
;; "~{~A~^ ~}"
;; loop over each word and print out the word followed by
;; a space.
;;
;; "~:@>"
;; No suffix, and insert conditional newline after each
;; group of blanks if needed.
(format t "~@< ~@;~{~A~^ ~}~:@>"
(get-words (intl:gettext doc))))
(terpri))))
(ext:quit))
(defswitch "help" #'help-switch-demon
......@@ -356,3 +394,17 @@
(defswitch "-help" #'help-switch-demon
"Same as -help.")
(defun version-switch-demon (switch)
(declare (ignore switch))
(format t "~A~%" (lisp-implementation-version))
(ext:quit))
(defswitch "version" #'version-switch-demon
"Prints the cmucl version and exits")
;; Make --version work for the benefit of those who are accustomed to
;; GNU software.
(defswitch "-version" #'version-switch-demon
"Prints the cmucl version and exits; same as -version")
......@@ -2329,10 +2329,11 @@
"DOUBLE-FLOAT-EXPONENT"
"DOUBLE-FLOAT-BITS"
"DOUBLE-FLOAT-HIGH-BITS"
"DOUBLE-FLOAT-INT-EXPONENT"
"DOUBLE-FLOAT-LOW-BITS" "DOUBLE-FLOAT-P" "FLOAT-WAIT"
"DYNAMIC-SPACE-FREE-POINTER" "ERROR-NUMBER-OR-LOSE" "FILENAME"
"FLOAT-DIGITS" "FLOAT-EXPONENT" "FLOAT-FORMAT-DIGITS"
"FLOAT-FORMAT-MAX" "FLOAT-RADIX" "FORM" "FUNCALLABLE-INSTANCE-P"
"FLOAT-FORMAT-MAX" "FLOAT-INT-EXPONENT" "FLOAT-RADIX" "FORM" "FUNCALLABLE-INSTANCE-P"
"FUNCTION-CODE-HEADER" "FUNCTION-TYPE" "FUNCTION-TYPE-ALLOWP"
"FUNCTION-TYPE-KEYP" "FUNCTION-TYPE-KEYWORDS"
"FUNCTION-TYPE-NARGS" "FUNCTION-TYPE-OPTIONAL" "FUNCTION-TYPE-P"
......@@ -2426,6 +2427,7 @@
"SIMPLE-ARRAY-SIGNED-BYTE-16-P" "SIMPLE-ARRAY-SIGNED-BYTE-30-P"
"SIMPLE-ARRAY-SIGNED-BYTE-32-P" "SIMPLE-ARRAY-SIGNED-BYTE-8-P"
"SIMPLE-UNBOXED-ARRAY" "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT"
"SINGLE-FLOAT-INT-EXPONENT"
"SINGLE-FLOAT-P" "SINGLE-VALUE-TYPE" "SPECIFIER-TYPE" "STACK-REF"
"STD-COMPUTE-CLASS-PRECEDENCE-LIST"
"STREAMLIKE" "SIMPLE-STREAM-BUFFER" "STRINGABLE" "STRINGLIKE"
......
......@@ -22,7 +22,7 @@
describe-external-format))
(defvar *default-external-format*
:iso8859-1
:utf-8
"The default external format to use if no other external format is
specified")
......@@ -370,8 +370,10 @@
#() '())))))
(defun load-external-format-aliases ()
;; Set filename encoding to NIL to bypass any encoding; it's not
;; needed to open the aliases file. NIL means the pathname string is passed as is where only the low 8 bits of the
(let ((*package* (find-package "KEYWORD"))
(unix::*filename-encoding* :iso8859-1))
(unix::*filename-encoding* :null))
(with-open-file (stm "ext-formats:aliases" :if-does-not-exist nil
:external-format :iso8859-1)
(when stm
......@@ -486,8 +488,13 @@
(and (consp name) (find-external-format name))
(and (with-standard-io-syntax
;; Use standard IO syntax so that changes by the user
;; don't mess up compiling the external format.
(let ((*package* (find-package "STREAM"))
;; don't mess up compiling the external format, but we
;; don't need to print readably. Also, set filename
;; encoding to NIL because we don't need any special
;; encoding to open the format files.
(let* ((*print-readably* nil)
(unix::*filename-encoding* :null)
(*package* (find-package "STREAM"))
(lisp::*enable-package-locked-errors* nil)
(s (open (format nil "ext-formats:~(~A~).lisp" name)
:if-does-not-exist nil :external-format :iso8859-1)))
......@@ -1150,7 +1157,7 @@ character and illegal outputs are replaced by a question mark.")
(unless (find-external-format filenames)
(error (intl:gettext "Can't find external-format ~S.") filenames))
(setq filenames (ef-name (find-external-format filenames)))
(when (and unix::*filename-encoding*
(when (and (not (eq unix::*filename-encoding* :null))
(not (eq unix::*filename-encoding* filenames)))
(cerror (intl:gettext "Change it anyway.")
(intl:gettext "The external-format for encoding filenames is already set.")))
......
......@@ -2397,10 +2397,10 @@
(setf *available-buffers* nil)
(setf *stdin*
(make-fd-stream 0 :name "Standard Input" :input t :buffering :line
:external-format :iso8859-1))
:external-format :utf-8))
(setf *stdout*
(make-fd-stream 1 :name "Standard Output" :output t :buffering :line
:external-format :iso8859-1))
:external-format :utf-8))
(setf *stderr*
(make-fd-stream 2 :name "Standard Error" :output t :buffering :line
:external-format :iso8859-1))
......@@ -2410,7 +2410,7 @@
(if tty
(make-fd-stream tty :name "the Terminal" :input t :output t
:buffering :line :auto-close t
:external-format :iso8859-1)
:external-format :utf-8)
(make-two-way-stream *stdin* *stdout*))))
nil)
......
......@@ -399,7 +399,8 @@
(form new-directives)
(expand-directive (car remaining-directives)
(cdr remaining-directives))
(push form results)
(when form
(push form results))
(setf remaining-directives new-directives)))
(reverse results)))
......
......@@ -105,7 +105,7 @@
(defun find-encoding (domain)
(when (null (domain-entry-encoding domain))
(setf (domain-entry-encoding domain) :iso-8859-1)
(setf (domain-entry-encoding domain) :iso8859-1)
;; Domain lookup can call the compiler, so set the locale to "C"
;; so things work.
(let* ((*locale* "C")
......@@ -520,10 +520,7 @@
(defun setlocale (&optional locale)
(setf *locale* (or locale
(getenv "LANGUAGE")
(getenv "LC_ALL")
(getenv "LC_MESSAGES")
(getenv "LANG")
(unix::unix-get-lc-messages)
*locale*)))
(defmacro textdomain (domain)
......
......@@ -343,7 +343,7 @@
#-gengc (setf unix::*interrupt-pending* nil)
(setf *type-system-initialized* nil)
(setf *break-on-signals* nil)
(setf unix::*filename-encoding* nil)
(setf unix::*filename-encoding* :null)
#+gengc (setf conditions::*handler-clusters* nil)
(setq intl::*default-domain* "cmucl")
(setq intl::*locale* "C")
......
......@@ -1837,6 +1837,125 @@ When annotations are present, invoke them at the right positions."
(funcall (formatter "~:<~W~^~3I ~:_~W~I~@:_~@{ ~W~^~_~}~:>")
stream list))
(defun pprint-define-vop (stream list &rest noise)
(declare (ignore noise))
(pprint-logical-block (stream list :prefix "(" :suffix ")")
;; Output "define-vop"
(output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(write-char #\space stream)
;; Output vop name
(output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(pprint-newline :mandatory stream)
(pprint-indent :block 0 stream)
;; Print out each option starting on a new line
(loop
(write-char #\space stream)
(let ((vop-option (pprint-pop)))
;; Figure out what option we have and print it neatly
(case (car vop-option)
((:args :results)
;; :args and :results print out each arg/result indented neatly
(pprint-logical-block (stream vop-option :prefix "(" :suffix ")")
;; Output :args/:results
(output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(write-char #\space stream)
(pprint-indent :current 0 stream)
;; Print each value indented the same amount so the line
;; up neatly.
(loop
(output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(pprint-newline :mandatory stream))))
((:generator)
(pprint-logical-block (stream vop-option :prefix "(" :suffix ")")
;; Output :generator
(output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(write-char #\space stream)
;; Output cost
(output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
;; Newline and then the body of the generator
(pprint-newline :mandatory stream)
(write-char #\space stream)
(pprint-indent :current 0 stream)
(loop
(output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(pprint-newline :mandatory stream))))
(t
;; Everything else just get printed as usual.
(output-object vop-option stream))))
(pprint-exit-if-list-exhausted)
(pprint-newline :linear stream))))
(defun pprint-sc-case (stream list &rest noise)
(declare (ignore noise))
(pprint-logical-block (stream list :prefix "(" :suffix ")")
;; Output "sc-case"
(output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(write-char #\space stream)
;; Output variable name
(output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
;; Start the cases on a new line, indented.
(pprint-newline :mandatory stream)
(pprint-indent :block 0 stream)
;; Print out each case.
(loop
(write-char #\space stream)
(pprint-logical-block (stream (pprint-pop) :prefix "(" :suffix ")")
;; Output the case item
(output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(pprint-newline :mandatory stream)
;; Output everything else, starting on a new line.
(loop
(output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(pprint-newline :mandatory stream)))
(pprint-exit-if-list-exhausted)
(pprint-newline :mandatory stream))))
(defun pprint-define-assembly (stream list &rest noise)
(declare (ignore noise))
(pprint-logical-block (stream list :prefix "(" :suffix ")")
;; Output "define-assembly-routine"
(output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(write-char #\space stream)
;; Output routine name and options.
(pprint-logical-block (stream (pprint-pop) :prefix "(" :suffix ")")
;; Output the routine name
(output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(pprint-newline :mandatory stream)
(pprint-indent :block 0 stream)
;; Output options, one per line, neatly lined up and indented
;; below the routine name.
(loop
(output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(pprint-newline :mandatory stream)))
;; Now output the args, results, and temps used by the assembly
;; routine. Instead of lining up with the routine name, let's
;; just indent it 4 spaces from the "define-assembly-routine" so
;; it doesn't look so top-heavy.
(pprint-indent :block 4 stream)
(pprint-newline :mandatory stream)
(pprint-logical-block (stream (pprint-pop) :prefix "(" :suffix ")")
(loop
(output-object (pprint-pop) stream)
(pprint-exit-if-list-exhausted)
(pprint-newline :mandatory stream)))
;; Now print out the assembly code as if it were a tagbody. Then
;; labels are outdented by one to make them easy to see.
(pprint-newline :mandatory stream)
(pprint-tagbody-guts stream)))
;;;; Interface seen by regular (ugly) printer and initialization routines.
......@@ -1952,7 +2071,10 @@ When annotations are present, invoke them at the right positions."
(vm::with-fixed-allocation pprint-with-like)
(kernel::number-dispatch pprint-with-like)
(stream::with-stream-class pprint-with-like)
(lisp::with-array-data pprint-with-like)))
(lisp::with-array-data pprint-with-like)
(c:define-vop pprint-define-vop)
(c:sc-case pprint-sc-case)
(c:define-assembly-routine pprint-define-assembly)))
(defun pprint-init ()
(setf *initial-pprint-dispatch* (make-pprint-dispatch-table))
......
......@@ -142,6 +142,57 @@
(file c-call:c-string)
(initial-function (alien:unsigned #.vm:word-bits)))
(defun set-up-locale-external-format ()
"Add external format alias for :locale to the format specified by
the locale as set by setlocale(3C)."
(let ((codeset (unix::unix-get-locale-codeset))
(external-format nil))
(cond ((zerop (length codeset))
(setq external-format *default-external-format*))
(t
(let ((name (intern codeset "KEYWORD")))
(setq external-format
(stream::ef-name (stream::find-external-format name nil))))))
(cond (external-format
(setf (gethash :locale stream::*external-format-aliases*)
external-format))
(t
(warn "No external format found for codeset \"~S\"; using ~S instead"
codeset
*default-external-format*)
(setf (gethash :locale stream::*external-format-aliases*)
*default-external-format*))))
(values))
(defun decode-runtime-strings (locale file-locale)
;; The C runtime can initialize the following strings from the
;; command line or the environment. We need to decode these into
;; the utf-16 strings that Lisp uses.
(setf lisp-command-line-list
(mapcar #'(lambda (s)
(stream:string-decode s locale))
lisp-command-line-list))
(setf lisp-environment-list
(mapcar #'(lambda (s)
(stream:string-decode s locale))
lisp-environment-list))
;; This needs more work.. *cmucl-lib* could be set from the the envvar
;; "CMUCLLIB" or from the "-lib" command-line option, and thus
;; should use the LOCALE to decode the string.
(when *cmucl-lib*
(setf *cmucl-lib*
(stream:string-decode *cmucl-lib* file-locale)))
;; This also needs more work since the core path could come from the
;; "-core" command-line option and should thus use LOCALE to decode
;; the string. It could also come from the "CMUCLCORE" envvar.
(setf *cmucl-core-path*
(stream:string-decode *cmucl-core-path* file-locale))
;; *unidata-path* defaults to a pathname object, but the user can
;; specify a path, so we need to decode the string path if given.
(when (and *unidata-path* (stringp *unidata-path*))
(setf *unidata-path*
(stream:string-decode *unidata-path* file-locale))))
(defun save-lisp (core-file-name &key
(purify t)
(root-structures ())
......@@ -249,6 +300,23 @@
(reinit)
(environment-init)
(dolist (f *after-save-initializations*) (funcall f))
;; Set the runtime locale
(unless (zerop (unix::unix-setlocale))
(warn "os_setlocale failed"))
;; Load external format aliases now so we can aliases to
;; specify the external format.
(stream::load-external-format-aliases)
;; Set up :locale format
(set-up-locale-external-format)
;; Set terminal encodings to :locale and filename encoding to :utf-8.
;; (This needs more work on Darwin.)
(set-system-external-format :locale :utf-8)
(decode-runtime-strings :locale :utf-8)
;; Need to reinitialize the environment again because
;; we've possibly changed the environment variables and
;; pathnames.
(environment-init)
;; Set the locale for lisp
(intl::setlocale)
(ext::process-command-strings process-command-line)
(setf *editor-lisp-p* nil)
......@@ -268,8 +336,12 @@
*gc-verbose* nil))
(when (and process-command-line
(or (find-switch "help")
(find-switch "-help")))
;; Don't load any init files if -help or --help is given
(find-switch "-help")
(find-switch "version")
(find-switch "-version")))
;; Don't load any init files if -help, --help,
;; -version, or --version is given. These exit right
;; away, so loading the init file is wasteful.
(setf site-init nil)
(setf load-init-file nil))
(when (and site-init
......
......@@ -290,13 +290,21 @@
(stream-dispatch stream
;; simple-stream
(stream::%stream-external-format stream)
;; lisp-stream
(typecase stream
;; lisp-stream. For unsupported streams, signal a type error.
(etypecase stream
#+unicode
(fd-stream (fd-stream-external-format stream))
(synonym-stream (stream-external-format
(symbol-value (synonym-stream-symbol stream))))
(t :default))
(broadcast-stream
;; See http://www.lispworks.com/documentation/HyperSpec/Body/t_broadc.htm
(let ((components (broadcast-stream-streams stream)))
(if (null components)
:default
(stream-external-format (car (last components))))))
(synonym-stream
;; Not defined by CLHS. What should happen if
;; (synonym-stream-symbol stream) is unbound?
(stream-external-format
(symbol-value (synonym-stream-symbol stream)))))
;; fundamental-stream
:default))
......
......@@ -25,17 +25,22 @@
;; it must be set to :iso8859-1 (or left as NIL), making files with
;; non-Latin-1 characters "mojibake", but otherwise they'll be inaccessible.
;; Must be set to NIL initially to enable building Lisp!
(defvar *filename-encoding* nil)
(defvar *filename-encoding* :null
"The encoding to use for converting a namestring to a string that can
be used by the operations system. It must be a valid
external-format name or :NULL. :NULL means the string
is passed as is to the operating system. The operating system will
get the low 8 bits of each UTF-16 code unit of the string.")
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro %name->file (string)
`(if *filename-encoding*
(string-encode ,string *filename-encoding*)
,string))
`(if (eql *filename-encoding* :null)
,string
(string-encode ,string *filename-encoding*)))
(defmacro %file->name (string)
`(if *filename-encoding*
(string-decode ,string *filename-encoding*)
,string)))
`(if (eql *filename-encoding* :null)
,string
(string-decode ,string *filename-encoding*))))
;;;; Common machine independent structures.
......@@ -2893,3 +2898,32 @@
of the child in the parent if it works, or NIL and an error number if it
doesn't work."
(int-syscall ("fork")))
(defun unix-setlocale ()
_N"Call setlocale(3c) with fixed args. Returns 0 on success."
(alien:alien-funcall
(alien:extern-alien "os_setlocale"
(function c-call:int))))
(defun unix-get-lc-messages ()
_N"Get LC_MESSAGES from the current locale. If we can't, return
NIL. A call to UNIX-SETLOCALE must have been done previously before
calling this so that the correct locale is returned."
(with-alien ((buf (array c-call:char 256)))
(let ((result
(alien-funcall
(extern-alien "os_get_lc_messages"
(function c-call:int
(* c-call:char)
c-call:int))
(cast buf (* c-call:char))
256)))
(when (zerop result)
(cast buf c-call:c-string)))))
(defun unix-get-locale-codeset ()
_N"Get the codeset from the locale"
(cast (alien-funcall
(extern-alien "os_get_locale_codeset"
(function (* char))))
c-string))
......@@ -347,25 +347,25 @@
;;;
(deftype single-float-exponent ()
`(integer ,(- vm:single-float-normal-exponent-min vm:single-float-bias
vm:single-float-digits)
`(integer (,(- vm:single-float-normal-exponent-min vm:single-float-bias
vm:single-float-digits))
,(- vm:single-float-normal-exponent-max vm:single-float-bias)))
(deftype double-float-exponent ()
`(integer ,(- vm:double-float-normal-exponent-min vm:double-float-bias
vm:double-float-digits)
`(integer (,(- vm:double-float-normal-exponent-min vm:double-float-bias
vm:double-float-digits))
,(- vm:double-float-normal-exponent-max vm:double-float-bias)))
(deftype single-float-int-exponent ()
`(integer ,(- vm:single-float-normal-exponent-min vm:single-float-bias
(* vm:single-float-digits 2))
`(integer (,(- vm:single-float-normal-exponent-min vm:single-float-bias
(* vm:single-float-digits 2)))
,(- vm:single-float-normal-exponent-max vm:single-float-bias
vm:single-float-digits)))
(deftype double-float-int-exponent ()
`(integer ,(- vm:double-float-normal-exponent-min vm:double-float-bias
(* vm:double-float-digits 2))
`(integer (,(- vm:double-float-normal-exponent-min vm:double-float-bias
(* vm:double-float-digits 2)))
,(- vm:double-float-normal-exponent-max vm:double-float-bias
vm:double-float-digits)))
......
......@@ -319,7 +319,7 @@
(defknown (float-digits float-precision) (float) float-digits
(movable foldable flushable explicit-check))
(defknown integer-decode-float (float)
(values integer float-exponent (member -1 1))
(values integer float-int-exponent (member -1 1))
(movable foldable flushable explicit-check))
(defknown complex (real &optional real) number
......
......@@ -50,6 +50,8 @@
(deftype float-exponent ()
#-long-float 'double-float-exponent
#+long-float 'long-float-exponent)
(deftype float-int-exponent ()
'double-float-int-exponent)
(deftype float-digits ()
#-long-float `(integer 0 ,vm:double-float-digits)
#+long-float `(integer 0 ,vm:long-float-digits))
......
......@@ -901,27 +901,36 @@
;;; comiss and comisd can cope with one or other arg in memory: we
;;; could (should, indeed) extend these to cope with descriptor args
;;; and stack args
(macrolet
((frob (name sc ptype)
`(define-vop (,name float-compare)
(:args (x :scs (,sc))
(y :scs (,sc descriptor-reg)))
(:arg-types ,ptype ,ptype))))
(frob single-float-compare single-reg single-float)
(frob double-float-compare double-reg double-float))
(define-vop (single-float-compare float-compare)
(:args (x :scs (single-reg)) (y :scs (single-reg descriptor-reg)))
(:conditional)
(:arg-types single-float single-float))
(define-vop (double-float-compare float-compare)
(:args (x :scs (double-reg)) (y :scs (double-reg descriptor-reg)))
(:conditional)
(:arg-types double-float double-float))
(define-vop (=/single-float single-float-compare)
(macrolet
((frob (size inst)
(let ((ea (ecase size
(single
'ea-for-sf-desc)
(double
'ea-for-df-desc)))
(name (symbolicate "=/" size "-FLOAT"))
(sc-type (symbolicate size "-REG"))
(inherit (symbolicate size "-FLOAT-COMPARE")))
`(define-vop (,name ,inherit)
(:translate =)
(:info target not-p)
(:vop-var vop)
(:generator 3
(note-this-location vop :internal-error)
(sc-case y
(single-reg
(inst ucomiss x y))
(,sc-type
(inst ,inst x y))
(descriptor-reg
(inst ucomiss x (ea-for-sf-desc y))))
(inst ,inst x (,ea y))))
;; if PF&CF, there was a NaN involved => not equal
;; otherwise, ZF => equal
(cond (not-p
......@@ -931,100 +940,41 @@
(let ((not-lab (gen-label)))
(inst jmp :p not-lab)
(inst jmp :e target)
(emit-label not-lab))))))
(emit-label not-lab)))))))))
(frob single ucomiss)
(frob double ucomisd))
(define-vop (=/double-float double-float-compare)
(:translate =)
(:info target not-p)
(:vop-var vop)
(:generator 3
(note-this-location vop :internal-error)
(sc-case y
(double-reg
(inst ucomisd x y))
(descriptor-reg
(inst ucomisd x (ea-for-df-desc y))))
(cond (not-p
(inst jmp :p target)
(inst jmp :ne target))
(t
(let ((not-lab (gen-label)))
(inst jmp :p not-lab)
(inst jmp :e target)
(emit-label not-lab))))))
(define-vop (</double-float double-float-compare)
(:translate <)
(:info target not-p)
(:generator 3
(sc-case y
(double-reg
(inst comisd x y))
(descriptor-reg
(inst comisd x (ea-for-df-desc y))))
(cond (not-p
(inst jmp :p target)
(inst jmp :nc target))
(t
(let ((not-lab (gen-label)))
(inst jmp :p not-lab)
(inst jmp :c target)
(emit-label not-lab))))))
(define-vop (</single-float single-float-compare)
(:translate <)
(:info target not-p)
(:generator 3
(sc-case y
(single-reg
(inst comiss x y))
(descriptor-reg
(inst comiss x (ea-for-sf-desc y))))
(cond (not-p
(inst jmp :p target)
(inst jmp :nc target))
(t
(let ((not-lab (gen-label)))
(inst jmp :p not-lab)
(inst jmp :c target)
(emit-label not-lab))))))
(define-vop (>/double-float double-float-compare)
(:translate >)
(:info target not-p)
(:generator 3
(sc-case y
(double-reg
(inst comisd x y))
(descriptor-reg
(inst comisd x (ea-for-df-desc y))))
(cond (not-p
(inst jmp :p target)
(inst jmp :na target))
(t
(let ((not-lab (gen-label)))
(inst jmp :p not-lab)
(inst jmp :a target)
(emit-label not-lab))))))
(define-vop (>/single-float single-float-compare)
(:translate >)
(macrolet
((frob (op size inst yep nope)
(let ((ea (ecase size
(single
'ea-for-sf-desc)
(double
'ea-for-df-desc)))
(name (symbolicate op "/" size "-FLOAT"))
(sc-type (symbolicate size "-REG"))
(inherit (symbolicate size "-FLOAT-COMPARE")))
`(define-vop (,name ,inherit)
(:translate ,op)
(:info target not-p)
(:generator 3
(sc-case y
(single-reg
(inst comiss x y))
(,sc-type
(inst ,inst x y))
(descriptor-reg
(inst comiss x (ea-for-sf-desc y))))
(inst ,inst x (,ea y))))
(cond (not-p
(inst jmp :p target)
(inst jmp :na target))
(inst jmp ,nope target))
(t
(let ((not-lab (gen-label)))
(inst jmp :p not-lab)
(inst jmp :a target)
(emit-label not-lab))))))
(inst jmp ,yep target)
(emit-label not-lab)))))))))
(frob < single comiss :b :nb)
(frob > single comiss :a :na)
(frob < double comisd :b :nb)
(frob > double comisd :a :na))
;;;; Conversion:
......