mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
0.6.12.49:
made verbose GC output report GET-INTERNAL-RUN-TIME when each GC happens, so that when you reading a log containing many verbose GC messages, you have a better chance of grokking what happened fixed POSIX-GETENV doc string after Alexey Dejneka pointed out that it was wrong 0.6.12.50: removed some #+OpenBSD stubifications, since FILE-LENGTH is no longer completely broken on OpenBSD now fixed the skip-trailing-whitespace logic in READ so it no longer requires a second Ctrl-D char to return EOF 0.6.12.51: merged MNA HANDLER-CASE patch: Since the compiler seems to be smart enough to handle it now, use lexical scoping again instead of the previous dynamic scoping workaround; and also do #+X86 (FLOAT-WAIT). 0.6.12.52: quasimerged MNA fix-GCC-warnings patch (sbcl-devel 2001-07-17), editing the source by hand also made other tweaks to fix GCC warnings fixed memory leak in wrapped_readlink() 0.6.12.53: merged MNA port of rtoy COERCE and ARRAY-ELEMENT-TYPE DEFOPTIMIZERs from CMU CL (sbcl-devel 2001-07-16) merged MNA port of rtoy irrational math fixes (sbcl-devel 2001-07-16) added MNA regression tests of irrational functions 0.6.12.54: merged MNA port of cachopo COPY-READTABLE fix (sbcl-devel 2001-07-17) merged MNA port of mai DESCRIBE-a-class fix (sbcl-devel 2001-07-17) 0.6.12.55: added distclean.sh to remove stuff like customize-target-features.lisp DEFCONSTANT *FOO* now issues a STYLE-WARNING. factored out LOOKS-LIKE-NAME-OF-SPECIAL-VAR-P to support this removed call to no-longer-defined OUTPUT-INTERPRETED-FUNCTION in PRINT-OBJECT method for INTERPRETED-FUNCTION (which will hopefully go away real soon anyway) 0.6.12.56: fixed bug 26: ARRAY-DISPLACEMENT now returns (VALUES NIL 0) for undisplaced arrays. fixed bug 55: DEFMACRO-MUNDANELY no longer ignores DOC. DEFMACRO-MUNDANELY should be in SB-INT. 0.6.12.57: set default for *DERIVE-FUNCTION-TYPES* to NIL (i.e. ANSI behavior) overrode the default within the cross-compiler, so that SBCL itself is still built the old static efficient way 0.6.12.58: fixed the DCONSING carry case in PROFILE ported CMU CL fix to FILL-POINTER-OUCH (Tim Moore's fix to Janne Rinta-Manty's bug report) added MNA fix for FIX-CORE-SOURCE-INFO
This commit is contained in:
William Harold Newman
parent
a1a2c079c7
commit
3bd7a97d1b
40
BUGS
40
BUGS
|
|
@ -183,21 +183,6 @@ WORKAROUND:
|
|||
munge12egnum
|
||||
NIL
|
||||
|
||||
23:
|
||||
When too many files are opened, OPEN will fail with an
|
||||
uninformative error message
|
||||
error in function OPEN: error opening #P"/tmp/foo.lisp": NIL
|
||||
instead of saying that too many files are open.
|
||||
|
||||
26:
|
||||
reported by Sam Steingold on the cmucl-imp mailing list 12 May 2000:
|
||||
Also, there is another bug: `array-displacement' should return an
|
||||
array or nil as first value (as per ANSI CL), while CMUCL declares
|
||||
it as returning an array as first value always.
|
||||
(Actually, I think the old CMU CL version in SBCL never returns NIL,
|
||||
i.e. it's not just a declaration problem, but the definition doesn't
|
||||
behave ANSIly.)
|
||||
|
||||
27:
|
||||
Sometimes (SB-EXT:QUIT) fails with
|
||||
Argh! maximum interrupt nesting depth (4096) exceeded, exiting
|
||||
|
|
@ -281,6 +266,8 @@ WORKAROUND:
|
|||
that arbitrary functions check their argument types. (It might
|
||||
make sense to add another flag (CHECKED?) to DEFKNOWN to
|
||||
identify functions which *do* check their argument types.)
|
||||
(Also, verify that the compiler handles declared function
|
||||
return types as assertions.)
|
||||
|
||||
38:
|
||||
DEFMETHOD doesn't check the syntax of &REST argument lists properly,
|
||||
|
|
@ -466,11 +453,6 @@ SBCL: (("blah") ("blah2"))
|
|||
The implementation of #'+ returns its single argument without
|
||||
type checking, e.g. (+ "illegal") => "illegal".
|
||||
|
||||
55:
|
||||
In sbcl-0.6.7, there is no doc string for CL:PUSH, probably
|
||||
because it's defined with the DEFMACRO-MUNDANELY macro and something
|
||||
is wrong with doc string setting in that macro.
|
||||
|
||||
56:
|
||||
Attempting to use COMPILE on something defined by DEFMACRO fails:
|
||||
(DEFMACRO FOO (X) (CONS X X))
|
||||
|
|
@ -1088,6 +1070,12 @@ Error in function C::GET-LAMBDA-TO-COMPILE:
|
|||
internal error, failed AVER:
|
||||
"(COMMON-LISP:EQ (SB!C::TN-ENVIRONMENT SB!C:TN) SB!C::TN-ENV)"
|
||||
|
||||
116:
|
||||
The error message from compiling
|
||||
(LAMBDA (X) (LET ((NIL 1)) X))
|
||||
is
|
||||
|
||||
|
||||
KNOWN BUGS RELATED TO THE IR1 INTERPRETER
|
||||
|
||||
(Note: At some point, the pure interpreter (actually a semi-pure
|
||||
|
|
@ -1160,3 +1148,15 @@ IR1-4:
|
|||
EVAL-WHEN is rewritten, which won't happen until after the IR1
|
||||
interpreter is gone, the system's notion of what's a top-level form
|
||||
and what's not will remain too confused to fix this problem.]
|
||||
|
||||
IR1-5:
|
||||
(not really a bug, just a wishlist thing which might be easy
|
||||
when EVAL-WHEN is rewritten..) It might be good for the cross-compiler
|
||||
to warn about nested EVAL-WHENs. (In ordinary compilation, they're
|
||||
quite likely to be OK, but in cross-compiled code EVAL-WHENs
|
||||
are a great source of confusion, so a style warning about anything
|
||||
unusual could be helpful.)
|
||||
|
||||
IR1-6:
|
||||
(another wishlist thing..) Reimplement DEFMACRO to be basically
|
||||
like DEFMACRO-MUNDANELY, just using EVAL-WHEN.
|
||||
|
|
|
|||
19
NEWS
19
NEWS
|
|
@ -751,17 +751,36 @@ changes in sbcl-0.6.13 relative to sbcl-0.6.12:
|
|||
is now a supported extension again, since the consensus on
|
||||
sbcl-devel was that it can be useful for ordinary development
|
||||
work, not just for debugging SBCL itself.
|
||||
* The default for SB-EXT:*DERIVE-FUNCTION-TYPES* has changed to
|
||||
NIL, i.e. ANSI behavior, i.e. the compiler now recognizes
|
||||
that currently-defined functions might be redefined later with
|
||||
different return types.
|
||||
* Hash tables can be printed readably, as inspired by CMU CL code
|
||||
of Eric Marsden and SBCL code of Martin Atzmueller.
|
||||
* better error handling in CLOS method combination, thanks to
|
||||
Martin Atzmueller porting Pierre Mai's CMU CL patches
|
||||
* more overflow fixes for >16Mbyte I/O buffers
|
||||
* A bug in READ has been fixed, so that now a single Ctrl-D
|
||||
character suffices to cause end-of-file on character streams.
|
||||
In particular, now you only need one Ctrl-D at the command
|
||||
line (not two) to exit SBCL.
|
||||
* fixed bug 26: ARRAY-DISPLACEMENT now returns (VALUES NIL 0) for
|
||||
undisplaced arrays.
|
||||
* fixed bug 107 (reported as a CMU CL bug by Erik Naggum on
|
||||
comp.lang.lisp 2001-06-11): (WRITE #*101 :RADIX T :BASE 36) now
|
||||
does the right thing.
|
||||
* The implementation of some type tests, especially for CONDITION
|
||||
types, is now tidier and maybe faster, due to CMU CL code
|
||||
originally by Douglas Crosher, ported by Martin Atzmueller.
|
||||
* Some math functions have been fixed, and there are new
|
||||
optimizers for deriving the types of COERCE and ARRAY-ELEMENT-TYPE,
|
||||
thanks to Raymond Toy's work on CMU CL, ported by Martin Atzmueller.
|
||||
* A bug in COPY-READTABLE was fixed. (Joao Cachopo's patch to CMU
|
||||
CL, ported to SBCL by Martin Atzmueller)
|
||||
* DESCRIBE now gives more information in some cases. (Pierre Mai's
|
||||
patch to CMU CL, ported to SBCL by Martin Atzmueller)
|
||||
* The code in the SB-PROFILE package has been substantially
|
||||
improved, although it's still unstable.
|
||||
* There's a new slam.sh hack to shorten the edit/compile/debug
|
||||
cycle for low-level changes to SBCL itself, and a new
|
||||
:SB-AFTER-XC-CORE target feature to control the generation of
|
||||
|
|
|
|||
8
distclean.sh
Normal file
8
distclean.sh
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
#!/bin/sh
|
||||
|
||||
# a superset of clean.sh, cleaning up not only automatically
|
||||
# generated files but other things (e.g. customization files)
|
||||
# which shouldn't be in the distribution
|
||||
|
||||
rm customize-target-features.lisp
|
||||
sh clean.sh
|
||||
|
|
@ -64,9 +64,18 @@ $SBCL_XC_HOST <<-'EOF' || exit 1
|
|||
(let (;; Life is simpler at genesis/cold-load time if we
|
||||
;; needn't worry about byte-compiled code.
|
||||
(sb!ext:*byte-compile-top-level* nil)
|
||||
;; In order to increase microefficiency of the target Lisp,
|
||||
;; enable old CMU CL defined-function-types-never-change
|
||||
;; optimizations. (ANSI says users aren't supposed to
|
||||
;; redefine our functions anyway; and developers can
|
||||
;; fend for themselves.)
|
||||
#!-sb-fluid (sb!ext:*derive-function-types* t)
|
||||
;; In order to reduce peak memory usage during GENESIS,
|
||||
;; it helps to stuff several toplevel forms together
|
||||
;; into the same function.
|
||||
;; into the same function. (This can't be the compiler
|
||||
;; default in general since it's non-ANSI in the case
|
||||
;; of e.g. some package-side-effecting forms, but it's
|
||||
;; safe in all the code we cross-compile.)
|
||||
(sb!c::*top-level-lambda-max* 10)
|
||||
;; Let the target know that we're the cross-compiler.
|
||||
(*features* (cons :sb-xc *features*))
|
||||
|
|
|
|||
|
|
@ -548,7 +548,7 @@ like *STACK-TOP-HINT*"
|
|||
"*USE-IMPLEMENTATION-TYPES*"
|
||||
"*BYTE-COMPILE-TOP-LEVEL*"
|
||||
"*BYTE-COMPILE-DEFAULT*"
|
||||
"*DERIVE-FUNCTION-TYPES*" ; FIXME FIXME FIXME FIXME..
|
||||
"*DERIVE-FUNCTION-TYPES*"
|
||||
|
||||
;; a special form for breaking out of our "declarations
|
||||
;; are assertions" default
|
||||
|
|
@ -685,6 +685,11 @@ retained, possibly temporariliy, because it might be used internally."
|
|||
;; in the cross-compiler's environment
|
||||
"DEF!MACRO" "DEF!METHOD" "DEF!STRUCT" "DEF!TYPE"
|
||||
|
||||
;; other variations on DEFFOO stuff useful for bootstrapping
|
||||
;; and cross-compiling
|
||||
"DEFMACRO-MUNDANELY"
|
||||
"DEFCONSTANT-EQX"
|
||||
|
||||
;; messing with PATHNAMEs
|
||||
"MAKE-TRIVIAL-DEFAULT-PATHNAME"
|
||||
"PHYSICALIZE-PATHNAME"
|
||||
|
|
@ -821,9 +826,9 @@ retained, possibly temporariliy, because it might be used internally."
|
|||
"FEATUREP"
|
||||
"FLUSH-STANDARD-OUTPUT-STREAMS"
|
||||
"MAKE-GENSYM-LIST"
|
||||
"DEFCONSTANT-EQX"
|
||||
"ABOUT-TO-MODIFY"
|
||||
"PRINT-PRETTY-ON-STREAM-P"
|
||||
"LOOKS-LIKE-NAME-OF-SPECIAL-VAR-P"
|
||||
|
||||
;; These could be moved back into SB!EXT if someone has
|
||||
;; compelling reasons, but hopefully we can get by
|
||||
|
|
@ -889,7 +894,7 @@ retained, possibly temporariliy, because it might be used internally."
|
|||
:doc
|
||||
"private: Theoretically this 'hides state and types used for package
|
||||
integration' (said CMU CL architecture.tex) and that probably was and
|
||||
is a good idea, but see SB-SYS for blurring of boundaries."
|
||||
is a good idea, but see SB-SYS re. blurring of boundaries."
|
||||
:use ("CL" "SB!ALIEN" "SB!ALIEN-INTERNALS" "SB!BIGNUM"
|
||||
"SB!EXT" "SB!FASL" "SB!INT" "SB!SYS" "SB!GRAY")
|
||||
:import-from (("SB!C-CALL" "VOID"))
|
||||
|
|
@ -1004,7 +1009,7 @@ is a good idea, but see SB-SYS for blurring of boundaries."
|
|||
"DOUBLE-FLOAT-INT-EXPONENT" "DOUBLE-FLOAT-LOW-BITS"
|
||||
"DOUBLE-FLOAT-SIGNIFICAND"
|
||||
"DOUBLE-FLOAT-P" "FLOAT-WAIT"
|
||||
"DYNAMIC-SPACE-FREE-POINTER"
|
||||
"DYNAMIC-SPACE-FREE-POINTER" "DYNAMIC-USAGE"
|
||||
"!DEFUN-FROM-COLLECTED-COLD-INIT-FORMS"
|
||||
"ERROR-NUMBER-OR-LOSE" "FDEFINITION-OBJECT"
|
||||
"FDOCUMENTATION" "FILENAME"
|
||||
|
|
@ -1069,7 +1074,7 @@ is a good idea, but see SB-SYS for blurring of boundaries."
|
|||
"MAKE-VALUES-TYPE"
|
||||
"MAYBE-GC" "MEMBER-TYPE" "MEMBER-TYPE-MEMBERS"
|
||||
"MEMBER-TYPE-P" "MERGE-BITS" "MODIFIED-NUMERIC-TYPE"
|
||||
"DEFMACRO-MUNDANELY" "MUTATOR-SELF"
|
||||
"MUTATOR-SELF"
|
||||
"NAMED-TYPE" "NAMED-TYPE-NAME" "NAMED-TYPE-P"
|
||||
"NATIVE-BYTE-ORDER" "NEGATE"
|
||||
"NEVER-SUBTYPEP" "NIL-FUNCTION-RETURNED-ERROR"
|
||||
|
|
|
|||
|
|
@ -17,8 +17,8 @@
|
|||
|
||||
;;;; miscellaneous accessor functions
|
||||
|
||||
;;; These functions are needed by the interpreter, 'cause the compiler
|
||||
;;; inlines them.
|
||||
;;; These functions are only needed by the interpreter, 'cause the
|
||||
;;; compiler inlines them.
|
||||
(macrolet ((def-frob (name)
|
||||
`(progn
|
||||
(defun ,name (array)
|
||||
|
|
@ -558,14 +558,14 @@
|
|||
|
||||
(defun array-rank (array)
|
||||
#!+sb-doc
|
||||
"Returns the number of dimensions of the Array."
|
||||
"Return the number of dimensions of ARRAY."
|
||||
(if (array-header-p array)
|
||||
(%array-rank array)
|
||||
1))
|
||||
|
||||
(defun array-dimension (array axis-number)
|
||||
#!+sb-doc
|
||||
"Returns length of dimension Axis-Number of the Array."
|
||||
"Returns the length of dimension AXIS-NUMBER of ARRAY."
|
||||
(declare (array array) (type index axis-number))
|
||||
(cond ((not (array-header-p array))
|
||||
(unless (= axis-number 0)
|
||||
|
|
@ -579,7 +579,7 @@
|
|||
|
||||
(defun array-dimensions (array)
|
||||
#!+sb-doc
|
||||
"Returns a list whose elements are the dimensions of the array"
|
||||
"Return a list whose elements are the dimensions of the array"
|
||||
(declare (array array))
|
||||
(if (array-header-p array)
|
||||
(do ((results nil (cons (array-dimension array index) results))
|
||||
|
|
@ -589,7 +589,7 @@
|
|||
|
||||
(defun array-total-size (array)
|
||||
#!+sb-doc
|
||||
"Returns the total number of elements in the Array."
|
||||
"Return the total number of elements in the Array."
|
||||
(declare (array array))
|
||||
(if (array-header-p array)
|
||||
(%array-available-elements array)
|
||||
|
|
@ -597,14 +597,17 @@
|
|||
|
||||
(defun array-displacement (array)
|
||||
#!+sb-doc
|
||||
"Returns values of :displaced-to and :displaced-index-offset options to
|
||||
make-array, or the defaults nil and 0 if not a displaced array."
|
||||
(declare (array array))
|
||||
(values (%array-data-vector array) (%array-displacement array)))
|
||||
"Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset
|
||||
options to MAKE-ARRAY, or NIL and 0 if not a displaced array."
|
||||
(declare (type array array))
|
||||
(if (and (array-header-p array) ; if unsimple and
|
||||
(%array-displaced-p array)) ; displaced
|
||||
(values (%array-data-vector array) (%array-displacement array))
|
||||
(values nil 0)))
|
||||
|
||||
(defun adjustable-array-p (array)
|
||||
#!+sb-doc
|
||||
"Returns T if (adjust-array array...) would return an array identical
|
||||
"Return T if (ADJUST-ARRAY ARRAY...) would return an array identical
|
||||
to the argument, this happens for complex arrays."
|
||||
(declare (array array))
|
||||
(not (typep array 'simple-array)))
|
||||
|
|
|
|||
|
|
@ -194,7 +194,11 @@
|
|||
(setf (info :function :assumed-type name) nil)))
|
||||
(:declared)
|
||||
(:defined
|
||||
(setf (info :function :type name) (extract-function-type def))))
|
||||
(setf (info :function :type name)
|
||||
(extract-function-type def))
|
||||
;; We shouldn't need to clear this here because it should be clear
|
||||
;; already (cleared when the last definition was processed).
|
||||
(aver (null (info :function :assumed-type name)))))
|
||||
(sb!c::%%defun name def doc))
|
||||
|
||||
;;;; DEFVAR and DEFPARAMETER
|
||||
|
|
|
|||
|
|
@ -77,23 +77,18 @@
|
|||
;;; DEFMACRO-MUNDANELY is like SB!XC:DEFMACRO, except that it doesn't
|
||||
;;; have any EVAL-WHEN or IR1 magic associated with it, so it only
|
||||
;;; takes effect in :LOAD-TOPLEVEL or :EXECUTE situations.
|
||||
;;;
|
||||
;;; KLUDGE: Currently this is only used for various special
|
||||
;;; circumstances in bootstrapping, but it seems to me that it might
|
||||
;;; be a good basis for reimplementation of DEFMACRO in terms of
|
||||
;;; EVAL-WHEN, which might be easier to understand than the current
|
||||
;;; approach based on IR1 magic. -- WHN 19990811
|
||||
(def!macro defmacro-mundanely (name lambda-list &body body)
|
||||
`(progn
|
||||
(setf (sb!xc:macro-function ',name)
|
||||
,(let ((whole (gensym "WHOLE-"))
|
||||
(let ((whole (gensym "WHOLE-"))
|
||||
(environment (gensym "ENVIRONMENT-")))
|
||||
(multiple-value-bind (new-body local-decs doc)
|
||||
(parse-defmacro lambda-list whole body name 'defmacro
|
||||
:environment environment)
|
||||
(declare (ignore doc))
|
||||
`(lambda (,whole ,environment)
|
||||
`(progn
|
||||
(setf (sb!xc:macro-function ',name)
|
||||
(lambda (,whole ,environment)
|
||||
,@local-decs
|
||||
(block ,name
|
||||
,new-body)))))
|
||||
',name))
|
||||
,new-body)))
|
||||
(setf (fdocumentation ',name 'macro)
|
||||
,doc)
|
||||
',name))))
|
||||
|
|
|
|||
|
|
@ -326,7 +326,7 @@
|
|||
(%describe-function (fdefinition x) s :function x)))
|
||||
|
||||
;; FIXME: Print out other stuff from the INFO database:
|
||||
;; * Does it name a type or class?
|
||||
;; * Does it name a type?
|
||||
;; * Is it a structure accessor? (This is important since those are
|
||||
;; magical in some ways, e.g. blasting the structure if you
|
||||
;; redefine them.)
|
||||
|
|
@ -335,8 +335,15 @@
|
|||
(%describe-doc x s 'structure "Structure")
|
||||
(%describe-doc x s 'type "Type")
|
||||
(%describe-doc x s 'setf "Setf macro")
|
||||
|
||||
(dolist (assoc (info :random-documentation :stuff x))
|
||||
(format s
|
||||
"~@:_Documentation on the ~(~A~):~@:_~A"
|
||||
(car assoc)
|
||||
(cdr assoc))))
|
||||
(cdr assoc)))
|
||||
|
||||
;; Describe the associated class, if any.
|
||||
(let ((symbol-named-class (cl:find-class x nil)))
|
||||
(when symbol-named-class
|
||||
(format t "~&It names a class ~A." symbol-named-class)
|
||||
(describe symbol-named-class))))
|
||||
|
|
|
|||
|
|
@ -322,13 +322,12 @@
|
|||
;;;; HANDLER-CASE and IGNORE-ERRORS
|
||||
|
||||
(defmacro handler-case (form &rest cases)
|
||||
#!+sb-doc
|
||||
"(HANDLER-CASE form
|
||||
{ (type ([var]) body) }* )
|
||||
Executes form in a context with handlers established for the condition
|
||||
Execute FORM in a context with handlers established for the condition
|
||||
types. A peculiar property allows type to be :no-error. If such a clause
|
||||
occurs, and form returns normally, all its values are passed to this clause
|
||||
as if by MULTIPLE-VALUE-CALL. The :no-error clause accepts more than one
|
||||
as if by MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one
|
||||
var specification."
|
||||
(let ((no-error-clause (assoc ':no-error cases)))
|
||||
(if no-error-clause
|
||||
|
|
@ -340,52 +339,53 @@
|
|||
(return-from ,error-return
|
||||
(handler-case (return-from ,normal-return ,form)
|
||||
,@(remove no-error-clause cases)))))))
|
||||
(let ((var (gensym))
|
||||
(outer-tag (gensym))
|
||||
(inner-tag (gensym))
|
||||
(tag-var (gensym))
|
||||
(let ((tag (gensym))
|
||||
(var (gensym))
|
||||
(annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
|
||||
cases)))
|
||||
`(let ((,outer-tag (cons nil nil))
|
||||
(,inner-tag (cons nil nil))
|
||||
,var ,tag-var)
|
||||
;; FIXME: should be (DECLARE (IGNORABLE ,VAR))
|
||||
,var ;ignoreable
|
||||
(catch ,outer-tag
|
||||
(catch ,inner-tag
|
||||
(throw ,outer-tag
|
||||
`(block ,tag
|
||||
(let ((,var nil))
|
||||
(declare (ignorable ,var))
|
||||
(tagbody
|
||||
(handler-bind
|
||||
,(mapcar #'(lambda (annotated-case)
|
||||
`(,(cadr annotated-case)
|
||||
#'(lambda (temp)
|
||||
(list (cadr annotated-case)
|
||||
`#'(lambda (temp)
|
||||
,(if (caddr annotated-case)
|
||||
`(setq ,var temp)
|
||||
'(declare (ignore temp)))
|
||||
(setf ,tag-var
|
||||
',(car annotated-case))
|
||||
(throw ,inner-tag nil))))
|
||||
(go ,(car annotated-case)))))
|
||||
annotated-cases)
|
||||
,form)))
|
||||
(case ,tag-var
|
||||
,@(mapcar #'(lambda (annotated-case)
|
||||
(let ((body (cdddr annotated-case))
|
||||
(varp (caddr annotated-case)))
|
||||
`(,(car annotated-case)
|
||||
,@(if varp
|
||||
`((let ((,(car varp) ,var))
|
||||
(return-from ,tag
|
||||
#-x86 ,form
|
||||
#+x86 (multiple-value-prog1 ,form
|
||||
;; Need to catch FP errors here!
|
||||
(float-wait))))
|
||||
,@(mapcan
|
||||
#'(lambda (annotated-case)
|
||||
(list (car annotated-case)
|
||||
(let ((body (cdddr annotated-case)))
|
||||
`(return-from
|
||||
,tag
|
||||
,(cond ((caddr annotated-case)
|
||||
`(let ((,(caaddr annotated-case)
|
||||
,var))
|
||||
,@body))
|
||||
body))))
|
||||
((not (cdr body))
|
||||
(car body))
|
||||
(t
|
||||
`(progn ,@body)))))))
|
||||
annotated-cases))))))))
|
||||
|
||||
(defmacro ignore-errors (&rest forms)
|
||||
#!+sb-doc
|
||||
"Executes forms after establishing a handler for all error conditions that
|
||||
returns from this form NIL and the condition signalled."
|
||||
"Execute FORMS handling ERROR conditions, returning the result of the last
|
||||
form, or (VALUES NIL the-ERROR-that-was-caught) if an ERROR was handled."
|
||||
`(handler-case (progn ,@forms)
|
||||
(error (condition) (values nil condition))))
|
||||
|
||||
;;;; helper functions for restartable error handling which couldn't be defined
|
||||
;;;; 'til now 'cause they use the RESTART-CASE macro
|
||||
;;;; helper functions for restartable error handling which couldn't be
|
||||
;;;; defined 'til now 'cause they use the RESTART-CASE macro
|
||||
|
||||
(defun assert-error (assertion places datum &rest arguments)
|
||||
(let ((cond (if datum
|
||||
|
|
|
|||
|
|
@ -538,6 +538,13 @@
|
|||
(t
|
||||
(error "not legal as a function name: ~S" function-name))))
|
||||
|
||||
(defun looks-like-name-of-special-var-p (x)
|
||||
(and (symbolp x)
|
||||
(let ((name (symbol-name x)))
|
||||
(and (> (length name) 2) ; to exclude '* and '**
|
||||
(char= #\* (aref name 0))
|
||||
(char= #\* (aref name (1- (length name))))))))
|
||||
|
||||
;;; ANSI guarantees that some symbols are self-evaluating. This
|
||||
;;; function is to be called just before a change which would affect
|
||||
;;; that. (We don't absolutely have to call this function before such
|
||||
|
|
|
|||
|
|
@ -23,20 +23,24 @@
|
|||
(defun ,lisp-fun ()
|
||||
(sb!alien:extern-alien ,c-var-name (sb!alien:unsigned 32))))))
|
||||
|
||||
#!+(or cgc gencgc) (progn
|
||||
#!-sb-fluid (declaim (inline dynamic-usage))
|
||||
(def-c-var-frob dynamic-usage "bytes_allocated"))
|
||||
#!-gencgc
|
||||
(progn
|
||||
;; This is called once per PROFILEd function call, so it's worth a
|
||||
;; little possible space cost to reduce its time cost.
|
||||
#!-sb-fluid
|
||||
(declaim (inline current-dynamic-space-start))
|
||||
(def-c-var-frob current-dynamic-space-start "current_dynamic_space"))
|
||||
|
||||
#!-sb-fluid
|
||||
(declaim (inline dynamic-usage)) ; to reduce PROFILEd call overhead
|
||||
#!+(or cgc gencgc)
|
||||
(def-c-var-frob dynamic-usage "bytes_allocated")
|
||||
#!-(or cgc gencgc)
|
||||
(defun dynamic-usage ()
|
||||
(the (unsigned-byte 32)
|
||||
(- (sb!sys:sap-int (sb!c::dynamic-space-free-pointer))
|
||||
(current-dynamic-space-start))))
|
||||
|
||||
#!-gencgc (progn
|
||||
#!-sb-fluid (declaim (inline current-dynamic-space-start))
|
||||
(def-c-var-frob current-dynamic-space-start "current_dynamic_space"))
|
||||
|
||||
(defun static-space-usage ()
|
||||
(- (* sb!vm:*static-space-free-pointer* sb!vm:word-bytes)
|
||||
sb!vm:static-space-start))
|
||||
|
|
@ -191,7 +195,7 @@ and submit it as a patch."
|
|||
(defun default-gc-notify-before (notify-stream bytes-in-use)
|
||||
(declare (type stream notify-stream))
|
||||
(format notify-stream
|
||||
"~&; GC is beginning with ~:D bytes in use at internal runtime ~D.~%"
|
||||
"~&; GC is beginning with ~:D bytes in use at internal runtime ~:D.~%"
|
||||
bytes-in-use
|
||||
(get-internal-run-time))
|
||||
(finish-output notify-stream))
|
||||
|
|
@ -209,7 +213,7 @@ and submit it as a patch."
|
|||
(declare (type stream notify-stream))
|
||||
(format notify-stream
|
||||
"~&; GC has finished with ~:D bytes in use (~:D bytes freed)~@
|
||||
; at internal runtime ~D. The new GC trigger is ~:D bytes.~%"
|
||||
; at internal runtime ~:D. The new GC trigger is ~:D bytes.~%"
|
||||
bytes-retained
|
||||
bytes-freed
|
||||
(get-internal-run-time)
|
||||
|
|
|
|||
|
|
@ -1148,7 +1148,7 @@
|
|||
|
||||
;;;; the ADDR macro
|
||||
|
||||
(sb!kernel:defmacro-mundanely addr (expr &environment env)
|
||||
(defmacro-mundanely addr (expr &environment env)
|
||||
#!+sb-doc
|
||||
"Return an Alien pointer to the data addressed by Expr, which must be a call
|
||||
to SLOT or DEREF, or a reference to an Alien variable."
|
||||
|
|
|
|||
|
|
@ -458,7 +458,7 @@
|
|||
|
||||
(defun cis (theta)
|
||||
#!+sb-doc
|
||||
"Return cos(Theta) + i sin(Theta), AKA exp(i Theta)."
|
||||
"Return cos(Theta) + i sin(Theta), i.e. exp(i Theta)."
|
||||
(declare (type real theta))
|
||||
(complex (cos theta) (sin theta)))
|
||||
|
||||
|
|
@ -532,12 +532,6 @@
|
|||
;; error. These bad definitions also mean that sin and cos for
|
||||
;; complex numbers can also lose big.
|
||||
|
||||
#+nil
|
||||
(defun sinh (number)
|
||||
#!+sb-doc
|
||||
"Return the hyperbolic sine of NUMBER."
|
||||
(/ (- (exp number) (exp (- number))) 2))
|
||||
|
||||
(defun sinh (number)
|
||||
#!+sb-doc
|
||||
"Return the hyperbolic sine of NUMBER."
|
||||
|
|
@ -549,12 +543,6 @@
|
|||
(complex (* (sinh x) (cos y))
|
||||
(* (cosh x) (sin y)))))))
|
||||
|
||||
#+nil
|
||||
(defun cosh (number)
|
||||
#!+sb-doc
|
||||
"Return the hyperbolic cosine of NUMBER."
|
||||
(/ (+ (exp number) (exp (- number))) 2))
|
||||
|
||||
(defun cosh (number)
|
||||
#!+sb-doc
|
||||
"Return the hyperbolic cosine of NUMBER."
|
||||
|
|
@ -617,8 +605,11 @@
|
|||
((complex)
|
||||
(complex-atanh number))))
|
||||
|
||||
;;; HP-UX does not supply a C version of log1p, so
|
||||
;;; use the definition.
|
||||
;;; HP-UX does not supply a C version of log1p, so use the definition.
|
||||
;;;
|
||||
;;; FIXME: This is really not a good definition. As per Raymond Toy
|
||||
;;; working on CMU CL, "The definition really loses big-time in
|
||||
;;; roundoff as x gets small."
|
||||
#!+hpux
|
||||
#!-sb-fluid (declaim (inline %log1p))
|
||||
#!+hpux
|
||||
|
|
@ -627,7 +618,7 @@
|
|||
(optimize (speed 3) (safety 0)))
|
||||
(the double-float (log (the (double-float 0d0) (+ number 1d0)))))
|
||||
|
||||
;;;; OLD-SPECFUN stuff
|
||||
;;;; not-OLD-SPECFUN stuff
|
||||
;;;;
|
||||
;;;; (This was conditional on #-OLD-SPECFUN in the CMU CL sources,
|
||||
;;;; but OLD-SPECFUN was mentioned nowhere else, so it seems to be
|
||||
|
|
@ -691,10 +682,8 @@
|
|||
;;; should be used instead?
|
||||
|
||||
(declaim (inline square))
|
||||
(declaim (ftype (function (double-float) (double-float 0d0)) square))
|
||||
(defun square (x)
|
||||
(declare (double-float x)
|
||||
(values (double-float 0d0)))
|
||||
(declare (double-float x))
|
||||
(* x x))
|
||||
|
||||
;;; original CMU CL comment, apparently re. SCALB and LOGB and
|
||||
|
|
@ -711,6 +700,18 @@
|
|||
(type double-float-exponent n))
|
||||
(scale-float x n))
|
||||
|
||||
;;; This is like LOGB, but X is not infinity and non-zero and not a
|
||||
;;; NaN, so we can always return an integer.
|
||||
(declaim (inline logb-finite))
|
||||
(defun logb-finite (x)
|
||||
(declare (type double-float x))
|
||||
(multiple-value-bind (signif exponent sign)
|
||||
(decode-float x)
|
||||
(declare (ignore signif sign))
|
||||
;; DECODE-FLOAT is almost right, except that the exponent is off
|
||||
;; by one.
|
||||
(1- exponent)))
|
||||
|
||||
;;; Compute an integer N such that 1 <= |2^N * x| < 2.
|
||||
;;; For the special cases, the following values are used:
|
||||
;;; x logb
|
||||
|
|
@ -725,17 +726,11 @@
|
|||
sb!ext:double-float-positive-infinity)
|
||||
((zerop x)
|
||||
;; The answer is negative infinity, but we are supposed to
|
||||
;; signal divide-by-zero.
|
||||
;; (error 'division-by-zero :operation 'logb :operands (list x))
|
||||
;; signal divide-by-zero, so do the actual division
|
||||
(/ -1.0d0 x)
|
||||
)
|
||||
(t
|
||||
(multiple-value-bind (signif expon sign)
|
||||
(decode-float x)
|
||||
(declare (ignore signif sign))
|
||||
;; DECODE-FLOAT is almost right, except that the exponent
|
||||
;; is off by one.
|
||||
(1- expon)))))
|
||||
(logb-finite x))))
|
||||
|
||||
;;; This function is used to create a complex number of the
|
||||
;;; appropriate type:
|
||||
|
|
@ -751,46 +746,47 @@
|
|||
(if (subtypep (type-of (realpart z)) 'double-float)
|
||||
(complex x y)
|
||||
;; Convert anything that's not a DOUBLE-FLOAT to a SINGLE-FLOAT.
|
||||
(complex (float x 1.0)
|
||||
(float y 1.0))))
|
||||
(complex (float x 1f0)
|
||||
(float y 1f0))))
|
||||
|
||||
;;; Compute |(x+i*y)/2^k|^2 scaled to avoid over/underflow. The
|
||||
;;; result is r + i*k, where k is an integer.
|
||||
#!+long-float (eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(error "needs work for long float support"))
|
||||
(defun cssqs (z)
|
||||
;; Save all FP flags
|
||||
(let ((x (float (realpart z) 1d0))
|
||||
(y (float (imagpart z) 1d0))
|
||||
(k 0)
|
||||
(rho 0d0))
|
||||
(declare (double-float x y)
|
||||
(type (double-float 0d0) rho)
|
||||
(fixnum k))
|
||||
(y (float (imagpart z) 1d0)))
|
||||
;; Would this be better handled using an exception handler to
|
||||
;; catch the overflow or underflow signal? For now, we turn all
|
||||
;; traps off and look at the accrued exceptions to see if any
|
||||
;; signal would have been raised.
|
||||
(with-float-traps-masked (:underflow :overflow)
|
||||
(setf rho (+ (square x) (square y)))
|
||||
(let ((rho (+ (square x) (square y))))
|
||||
(declare (optimize (speed 3) (space 0)))
|
||||
(cond ((and (or (float-nan-p rho)
|
||||
(float-infinity-p rho))
|
||||
(or (float-infinity-p (abs x))
|
||||
(float-infinity-p (abs y))))
|
||||
(setf rho sb!ext:double-float-positive-infinity))
|
||||
(values sb!ext:double-float-positive-infinity 0))
|
||||
((let ((threshold #.(/ least-positive-double-float
|
||||
double-float-epsilon))
|
||||
(traps (ldb sb!vm::float-sticky-bits
|
||||
(sb!vm:floating-point-modes))))
|
||||
;; overflow raised or (underflow raised and rho < lambda/eps)
|
||||
;; Overflow raised or (underflow raised and rho <
|
||||
;; lambda/eps)
|
||||
(or (not (zerop (logand sb!vm:float-overflow-trap-bit traps)))
|
||||
(and (not (zerop (logand sb!vm:float-underflow-trap-bit
|
||||
traps)))
|
||||
(< rho threshold))))
|
||||
(setf k (logb (max (abs x) (abs y))))
|
||||
(setf rho (+ (square (scalb x (- k)))
|
||||
(square (scalb y (- k))))))))
|
||||
(values rho k)))
|
||||
;; If we're here, neither x nor y are infinity and at
|
||||
;; least one is non-zero.. Thus logb returns a nice
|
||||
;; integer.
|
||||
(let ((k (- (logb-finite (max (abs x) (abs y))))))
|
||||
(values (+ (square (scalb x k))
|
||||
(square (scalb y k)))
|
||||
(- k))))
|
||||
(t
|
||||
(values rho 0)))))))
|
||||
|
||||
;;; principal square root of Z
|
||||
;;;
|
||||
|
|
@ -799,14 +795,18 @@
|
|||
(declare (number z))
|
||||
(multiple-value-bind (rho k)
|
||||
(cssqs z)
|
||||
(declare (type (double-float 0d0) rho)
|
||||
(fixnum k))
|
||||
(declare (type (or (member 0d0) (double-float 0d0)) rho)
|
||||
(type fixnum k))
|
||||
(let ((x (float (realpart z) 1.0d0))
|
||||
(y (float (imagpart z) 1.0d0))
|
||||
(eta 0d0)
|
||||
(nu 0d0))
|
||||
(declare (double-float x y eta nu))
|
||||
|
||||
(locally
|
||||
;; space 0 to get maybe-inline functions inlined.
|
||||
(declare (optimize (speed 3) (space 0)))
|
||||
|
||||
(if (not (float-nan-p x))
|
||||
(setf rho (+ (scalb (abs x) (- k)) (sqrt rho))))
|
||||
|
||||
|
|
@ -827,7 +827,7 @@
|
|||
(when (< x 0d0)
|
||||
(setf eta (abs nu))
|
||||
(setf nu (float-sign y rho))))
|
||||
(coerce-to-complex-type eta nu z))))
|
||||
(coerce-to-complex-type eta nu z)))))
|
||||
|
||||
;;; Compute log(2^j*z).
|
||||
;;;
|
||||
|
|
@ -848,23 +848,21 @@
|
|||
(y (float (imagpart z) 1.0d0)))
|
||||
(multiple-value-bind (rho k)
|
||||
(cssqs z)
|
||||
(declare (type (double-float 0d0) rho)
|
||||
(fixnum k))
|
||||
(declare (optimize (speed 3)))
|
||||
(let ((beta (max (abs x) (abs y)))
|
||||
(theta (min (abs x) (abs y))))
|
||||
(declare (type (double-float 0d0) beta theta))
|
||||
(if (and (zerop k)
|
||||
(coerce-to-complex-type (if (and (zerop k)
|
||||
(< t0 beta)
|
||||
(or (<= beta t1)
|
||||
(< rho t2)))
|
||||
(setf rho (/ (%log1p (+ (* (- beta 1.0d0)
|
||||
(/ (%log1p (+ (* (- beta 1.0d0)
|
||||
(+ beta 1.0d0))
|
||||
(* theta theta)))
|
||||
2d0))
|
||||
(setf rho (+ (/ (log rho) 2d0)
|
||||
(* (+ k j) ln2))))
|
||||
(setf theta (atan y x))
|
||||
(coerce-to-complex-type rho theta z)))))
|
||||
2d0)
|
||||
(+ (/ (log rho) 2d0)
|
||||
(* (+ k j) ln2)))
|
||||
(atan y x)
|
||||
z)))))
|
||||
|
||||
;;; log of Z = log |Z| + i * arg Z
|
||||
;;;
|
||||
|
|
@ -881,20 +879,22 @@
|
|||
(defun complex-atanh (z)
|
||||
(declare (number z))
|
||||
(let* (;; constants
|
||||
(theta #.(/ (sqrt most-positive-double-float) 4.0d0))
|
||||
(rho #.(/ 4.0d0 (sqrt most-positive-double-float)))
|
||||
(half-pi #.(/ pi 2.0d0))
|
||||
(theta (/ (sqrt most-positive-double-float) 4.0d0))
|
||||
(rho (/ 4.0d0 (sqrt most-positive-double-float)))
|
||||
(half-pi (/ pi 2.0d0))
|
||||
(rp (float (realpart z) 1.0d0))
|
||||
(beta (float-sign rp 1.0d0))
|
||||
(x (* beta rp))
|
||||
(y (* beta (- (float (imagpart z) 1.0d0))))
|
||||
(eta 0.0d0)
|
||||
(nu 0.0d0))
|
||||
(declare (double-float theta rho half-pi rp beta y eta nu)
|
||||
(type (double-float 0d0) x))
|
||||
;; Shouldn't need this declare.
|
||||
(declare (double-float x y))
|
||||
(locally
|
||||
(declare (optimize (speed 3)))
|
||||
(cond ((or (> x theta)
|
||||
(> (abs y) theta))
|
||||
;; to avoid overflow...
|
||||
;; To avoid overflow...
|
||||
(setf eta (float-sign y half-pi))
|
||||
;; nu is real part of 1/(x + iy). This is x/(x^2+y^2),
|
||||
;; which can cause overflow. Arrange this computation so
|
||||
|
|
@ -902,7 +902,6 @@
|
|||
(setf nu (let* ((x-bigger (> x (abs y)))
|
||||
(r (if x-bigger (/ y x) (/ x y)))
|
||||
(d (+ 1.0d0 (* r r))))
|
||||
(declare (double-float r d))
|
||||
(if x-bigger
|
||||
(/ (/ x) d)
|
||||
(/ (/ r y) d)))))
|
||||
|
|
@ -912,19 +911,14 @@
|
|||
;; tanh(176) is 1.0d0 within working precision.
|
||||
(let ((t1 (+ 4d0 (square y)))
|
||||
(t2 (+ (abs y) rho)))
|
||||
(declare (type (double-float 0d0) t1 t2))
|
||||
#+nil
|
||||
(setf eta (log (/ (sqrt (sqrt t1)))
|
||||
(sqrt t2)))
|
||||
(setf eta (* 0.5d0 (log (the (double-float 0.0d0)
|
||||
(/ (sqrt t1) t2)))))
|
||||
(setf nu (* 0.5d0
|
||||
(float-sign y
|
||||
(+ half-pi (atan (* 0.5d0 t2))))))))
|
||||
(t
|
||||
(let ((t1 (+ (abs y) rho)))
|
||||
(declare (double-float t1))
|
||||
;; normal case using log1p(x) = log(1 + x)
|
||||
;; Normal case using log1p(x) = log(1 + x)
|
||||
(setf eta (* 0.25d0
|
||||
(%log1p (/ (* 4.0d0 x)
|
||||
(+ (square (- 1.0d0 x))
|
||||
|
|
@ -936,29 +930,28 @@
|
|||
(square t1))))))))
|
||||
(coerce-to-complex-type (* beta eta)
|
||||
(- (* beta nu))
|
||||
z)))
|
||||
z))))
|
||||
|
||||
;;; Compute tanh z = sinh z / cosh z.
|
||||
(defun complex-tanh (z)
|
||||
(declare (number z))
|
||||
(let ((x (float (realpart z) 1.0d0))
|
||||
(y (float (imagpart z) 1.0d0)))
|
||||
(declare (double-float x y))
|
||||
(locally
|
||||
;; space 0 to get maybe-inline functions inlined
|
||||
(declare (optimize (speed 3) (space 0)))
|
||||
(cond ((> (abs x)
|
||||
#-(or linux hpux) #.(/ (asinh most-positive-double-float) 4d0)
|
||||
;; This is more accurate under linux.
|
||||
#+(or linux hpux) #.(/ (+ (log 2.0d0)
|
||||
(log most-positive-double-float))
|
||||
4d0))
|
||||
(complex (float-sign x)
|
||||
(float-sign y 0.0d0)))
|
||||
(log most-positive-double-float)) 4d0))
|
||||
(coerce-to-complex-type (float-sign x)
|
||||
(float-sign y) z))
|
||||
(t
|
||||
(let* ((tv (%tan y))
|
||||
(beta (+ 1.0d0 (* tv tv)))
|
||||
(s (sinh x))
|
||||
(rho (sqrt (+ 1.0d0 (* s s)))))
|
||||
(declare (double-float tv s)
|
||||
(type (double-float 0.0d0) beta rho))
|
||||
(if (float-infinity-p (abs tv))
|
||||
(coerce-to-complex-type (/ rho s)
|
||||
(/ tv)
|
||||
|
|
@ -967,7 +960,7 @@
|
|||
(coerce-to-complex-type (/ (* beta rho s)
|
||||
den)
|
||||
(/ tv den)
|
||||
z))))))))
|
||||
z)))))))))
|
||||
|
||||
;;; Compute acos z = pi/2 - asin z.
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -328,15 +328,8 @@
|
|||
;; don't. (CMU CL did, but implemented it in a non-ANSI way, and I
|
||||
;; just disabled that instead of rewriting it.) -- WHN 20000131
|
||||
(declare (ignore print))
|
||||
|
||||
;; FIXME: In sbcl-0.6.12.8 the OpenBSD implementation of FILE-LENGTH
|
||||
;; broke because changed handling of Unix stat(2) stuff couldn't
|
||||
;; deal with OpenBSD's 64-bit size slot. Once that's fixed, this
|
||||
;; code can be restored.
|
||||
#!-openbsd
|
||||
(when (zerop (file-length stream))
|
||||
(error "attempt to load an empty FASL file:~% ~S" (namestring stream)))
|
||||
|
||||
(do-load-verbose stream verbose)
|
||||
(let* ((*fasl-input-stream* stream)
|
||||
(*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000)))
|
||||
|
|
|
|||
|
|
@ -156,13 +156,13 @@
|
|||
|
||||
;;;; list collection macrology
|
||||
|
||||
(sb!kernel:defmacro-mundanely with-loop-list-collection-head
|
||||
(sb!int:defmacro-mundanely with-loop-list-collection-head
|
||||
((head-var tail-var &optional user-head-var) &body body)
|
||||
(let ((l (and user-head-var (list (list user-head-var nil)))))
|
||||
`(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l)
|
||||
,@body)))
|
||||
|
||||
(sb!kernel:defmacro-mundanely loop-collect-rplacd
|
||||
(sb!int:defmacro-mundanely loop-collect-rplacd
|
||||
(&environment env (head-var tail-var &optional user-head-var) form)
|
||||
(setq form (sb!xc:macroexpand form env))
|
||||
(flet ((cdr-wrap (form n)
|
||||
|
|
@ -208,7 +208,7 @@
|
|||
(setq ,user-head-var (cdr ,head-var)))))
|
||||
answer))))
|
||||
|
||||
(sb!kernel:defmacro-mundanely loop-collect-answer (head-var
|
||||
(sb!int:defmacro-mundanely loop-collect-answer (head-var
|
||||
&optional user-head-var)
|
||||
(or user-head-var
|
||||
`(cdr ,head-var)))
|
||||
|
|
@ -266,7 +266,7 @@ constructed.
|
|||
(loop-gentemp 'loop-maxmin-flag-)))
|
||||
operation)
|
||||
|
||||
(sb!kernel:defmacro-mundanely with-minimax-value (lm &body body)
|
||||
(sb!int:defmacro-mundanely with-minimax-value (lm &body body)
|
||||
(let ((init (loop-typed-init (loop-minimax-type lm)))
|
||||
(which (car (loop-minimax-operations lm)))
|
||||
(infinity-data (loop-minimax-infinity-data lm))
|
||||
|
|
@ -285,9 +285,7 @@ constructed.
|
|||
(declare (type ,type ,answer-var ,temp-var))
|
||||
,@body))))
|
||||
|
||||
(sb!kernel:defmacro-mundanely loop-accumulate-minimax-value (lm
|
||||
operation
|
||||
form)
|
||||
(sb!int:defmacro-mundanely loop-accumulate-minimax-value (lm operation form)
|
||||
(let* ((answer-var (loop-minimax-answer-variable lm))
|
||||
(temp-var (loop-minimax-temp-variable lm))
|
||||
(flag-var (loop-minimax-flag-variable lm))
|
||||
|
|
@ -335,7 +333,7 @@ code to be loaded.
|
|||
(and (symbolp loop-token)
|
||||
(values (gethash (symbol-name loop-token) table))))
|
||||
|
||||
(sb!kernel:defmacro-mundanely loop-store-table-data (symbol table datum)
|
||||
(sb!int:defmacro-mundanely loop-store-table-data (symbol table datum)
|
||||
`(setf (gethash (symbol-name ,symbol) ,table) ,datum))
|
||||
|
||||
(defstruct (loop-universe
|
||||
|
|
@ -419,7 +417,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
|
|||
(defvar *loop-desetq-temporary*
|
||||
(make-symbol "LOOP-DESETQ-TEMP"))
|
||||
|
||||
(sb!kernel:defmacro-mundanely loop-really-desetq (&environment env
|
||||
(sb!int:defmacro-mundanely loop-really-desetq (&environment env
|
||||
&rest var-val-pairs)
|
||||
(labels ((find-non-null (var)
|
||||
;; see whether there's any non-null thing here
|
||||
|
|
@ -618,7 +616,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
|
|||
(space 1))
|
||||
(+ 40 (* (- speed space) 10))))
|
||||
|
||||
(sb!kernel:defmacro-mundanely loop-body (&environment env
|
||||
(sb!int:defmacro-mundanely loop-body (&environment env
|
||||
prologue
|
||||
before-loop
|
||||
main-body
|
||||
|
|
@ -2031,12 +2029,12 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.
|
|||
(let ((tag (gensym)))
|
||||
`(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag))))))
|
||||
|
||||
(sb!kernel:defmacro-mundanely loop (&environment env &rest keywords-and-forms)
|
||||
(sb!int:defmacro-mundanely loop (&environment env &rest keywords-and-forms)
|
||||
(loop-standard-expansion keywords-and-forms env *loop-ansi-universe*))
|
||||
|
||||
(sb!kernel:defmacro-mundanely loop-finish ()
|
||||
(sb!int:defmacro-mundanely loop-finish ()
|
||||
#!+sb-doc
|
||||
"Causes the iteration to terminate \"normally\", the same as implicit
|
||||
"Cause the iteration to terminate \"normally\", the same as implicit
|
||||
termination by an iteration driving clause, or by use of WHILE or
|
||||
UNTIL -- the epilogue code (if any) will be run, and any implicitly
|
||||
collected result will be returned as the value of the LOOP."
|
||||
|
|
|
|||
|
|
@ -93,6 +93,10 @@
|
|||
(unless (symbolp name)
|
||||
(error "The constant name is not a symbol: ~S" name))
|
||||
(about-to-modify name)
|
||||
(when (looks-like-name-of-special-var-p name)
|
||||
(style-warn "defining ~S as a constant, even though the name follows~@
|
||||
the usual naming convention (names like *FOO*) for special variables"
|
||||
name))
|
||||
(let ((kind (info :variable :kind name)))
|
||||
(case kind
|
||||
(:constant
|
||||
|
|
|
|||
|
|
@ -94,6 +94,7 @@
|
|||
(total (required-argument) :type single-float :read-only t))
|
||||
(defvar *overhead*)
|
||||
(declaim (type overhead *overhead*))
|
||||
(makunbound '*overhead*) ; in case we reload this file when tweaking
|
||||
|
||||
;;;; profile encapsulations
|
||||
|
||||
|
|
@ -176,26 +177,34 @@
|
|||
;; that as long as we only cons small amounts,
|
||||
;; we'll almost always just do fixnum arithmetic.
|
||||
;; (And for encapsulated functions which cons
|
||||
;; large amounts, then we don't much care about a
|
||||
;; single extra consed bignum.)
|
||||
(start-consing-integer (pcounter-integer nbf-pcounter))
|
||||
(start-consing-fixnum (pcounter-fixnum nbf-pcounter)))
|
||||
;; large amounts, then a single extra consed
|
||||
;; bignum tends to be proportionally negligible.)
|
||||
(nbf0-integer (pcounter-integer nbf-pcounter))
|
||||
(nbf0-fixnum (pcounter-fixnum nbf-pcounter))
|
||||
(dynamic-usage-0 (sb-kernel:dynamic-usage)))
|
||||
(declare (inline pcounter-or-fixnum->integer))
|
||||
(multiple-value-prog1
|
||||
(multiple-value-call encapsulated-fun
|
||||
(sb-c:%more-arg-values arg-context
|
||||
0
|
||||
arg-count))
|
||||
(let ((*computing-profiling-data-for* encapsulated-fun))
|
||||
(let ((*computing-profiling-data-for* encapsulated-fun)
|
||||
(dynamic-usage-1 (sb-kernel:dynamic-usage)))
|
||||
(setf dticks (fastbig- (get-internal-ticks) start-ticks))
|
||||
(setf dconsing
|
||||
(if (eq (pcounter-integer nbf-pcounter)
|
||||
start-consing-integer)
|
||||
(- (pcounter-fixnum nbf-pcounter)
|
||||
start-consing-fixnum)
|
||||
(if (and (eq (pcounter-integer nbf-pcounter)
|
||||
nbf0-integer)
|
||||
(eq (pcounter-fixnum nbf-pcounter)
|
||||
nbf0-fixnum))
|
||||
;; common special case where we can avoid
|
||||
;; bignum arithmetic
|
||||
(- dynamic-usage-1
|
||||
dynamic-usage-0)
|
||||
;; general case
|
||||
(- (get-bytes-consed)
|
||||
(+ (pcounter-integer nbf-pcounter)
|
||||
(pcounter-fixnum nbf-pcounter)))))
|
||||
nbf0-integer
|
||||
nbf0-fixnum
|
||||
dynamic-usage-0)))
|
||||
(setf inner-enclosed-profiles
|
||||
(pcounter-or-fixnum->integer *enclosed-profiles*))
|
||||
(let ((net-dticks (fastbig- dticks *enclosed-ticks*)))
|
||||
|
|
@ -445,7 +454,7 @@ Lisp process."
|
|||
;;; that I (WHN) use for my own experimentation, but it might
|
||||
;;; become supported someday. Comments?)
|
||||
(declaim (type unsigned-byte *timer-overhead-iterations*))
|
||||
(defvar *timer-overhead-iterations*
|
||||
(defparameter *timer-overhead-iterations*
|
||||
500000)
|
||||
|
||||
;;; a dummy function that we profile to find profiling overhead
|
||||
|
|
|
|||
|
|
@ -164,6 +164,8 @@
|
|||
(mapcar #'(lambda (pair) (cons (car pair)
|
||||
(copy-seq (cdr pair))))
|
||||
(dispatch-tables really-from-readtable)))
|
||||
(setf (readtable-case to-readtable)
|
||||
(readtable-case from-readtable))
|
||||
to-readtable))
|
||||
|
||||
(defun set-syntax-from-char (to-char from-char &optional
|
||||
|
|
@ -374,10 +376,9 @@
|
|||
(eof-value nil)
|
||||
(recursivep nil))
|
||||
#!+sb-doc
|
||||
"Reads from stream and returns the object read, preserving the whitespace
|
||||
"Read from STREAM and return the value read, preserving any whitespace
|
||||
that followed the object."
|
||||
(cond
|
||||
(recursivep
|
||||
(if recursivep
|
||||
;; a loop for repeating when a macro returns nothing
|
||||
(loop
|
||||
(let ((char (read-char stream eof-error-p *eof-object*)))
|
||||
|
|
@ -388,42 +389,46 @@
|
|||
(result (multiple-value-list
|
||||
(funcall macrofun stream char))))
|
||||
;; Repeat if macro returned nothing.
|
||||
(if result (return (car result)))))))))
|
||||
(t
|
||||
(if result (return (car result))))))))
|
||||
(let ((*sharp-equal-alist* nil))
|
||||
(read-preserving-whitespace stream eof-error-p eof-value t)))))
|
||||
(read-preserving-whitespace stream eof-error-p eof-value t))))
|
||||
|
||||
;;; Return NIL or a list with one thing, depending.
|
||||
;;;
|
||||
;;; for functions that want comments to return so that they can look
|
||||
;;; past them. Assumes char is not whitespace.
|
||||
;;; past them. We assume CHAR is not whitespace.
|
||||
(defun read-maybe-nothing (stream char)
|
||||
(let ((retval (multiple-value-list
|
||||
(funcall (get-cmt-entry char *readtable*) stream char))))
|
||||
(if retval (rplacd retval nil))))
|
||||
|
||||
(defun read (&optional (stream *standard-input*) (eof-error-p t)
|
||||
(eof-value ()) (recursivep ()))
|
||||
(defun read (&optional (stream *standard-input*)
|
||||
(eof-error-p t)
|
||||
(eof-value ())
|
||||
(recursivep ()))
|
||||
#!+sb-doc
|
||||
"Reads in the next object in the stream, which defaults to
|
||||
*standard-input*. For details see the I/O chapter of
|
||||
the manual."
|
||||
(prog1
|
||||
(read-preserving-whitespace stream eof-error-p eof-value recursivep)
|
||||
(let ((whitechar (read-char stream nil *eof-object*)))
|
||||
(if (and (not (eofp whitechar))
|
||||
(or (not (whitespacep whitechar))
|
||||
recursivep))
|
||||
(unread-char whitechar stream)))))
|
||||
"Read the next Lisp value from STREAM, and return it."
|
||||
(let ((result (read-preserving-whitespace stream
|
||||
eof-error-p
|
||||
eof-value
|
||||
recursivep)))
|
||||
;; (This function generally discards trailing whitespace. If you
|
||||
;; don't want to discard trailing whitespace, call
|
||||
;; CL:READ-PRESERVING-WHITESPACE instead.)
|
||||
(unless (or (eql result eof-value) recursivep)
|
||||
(let ((next-char (read-char stream nil nil)))
|
||||
(unless (or (null next-char)
|
||||
(whitespacep next-char))
|
||||
(unread-char next-char stream))))
|
||||
result))
|
||||
|
||||
;;; (This is a COMMON-LISP exported symbol.)
|
||||
(defun read-delimited-list (endchar &optional
|
||||
(input-stream *standard-input*)
|
||||
recursive-p)
|
||||
#!+sb-doc
|
||||
"Reads objects from input-stream until the next character after an
|
||||
object's representation is endchar. A list of those objects read
|
||||
is returned."
|
||||
"Read Lisp values from INPUT-STREAM until the next character after a
|
||||
value's representation is ENDCHAR, and return the objects as a list."
|
||||
(declare (ignore recursive-p))
|
||||
(do ((char (flush-whitespace input-stream)
|
||||
(flush-whitespace input-stream))
|
||||
|
|
@ -433,8 +438,8 @@
|
|||
|
||||
;;;; basic readmacro definitions
|
||||
;;;;
|
||||
;;;; Large, hairy subsets of readmacro definitions (backquotes and sharp
|
||||
;;;; macros) are not here, but in their own source files.
|
||||
;;;; Some large, hairy subsets of readmacro definitions (backquotes
|
||||
;;;; and sharp macros) are not here, but in their own source files.
|
||||
|
||||
(defun read-quote (stream ignore)
|
||||
(declare (ignore ignore))
|
||||
|
|
|
|||
|
|
@ -1295,7 +1295,7 @@
|
|||
(let ((offset-current (+ start current)))
|
||||
(declare (fixnum offset-current))
|
||||
(if (= offset-current end)
|
||||
(let* ((new-length (* current 2))
|
||||
(let* ((new-length (1+ (* current 2)))
|
||||
(new-workspace (make-string new-length)))
|
||||
(declare (simple-string new-workspace))
|
||||
(%byte-blt workspace start
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@
|
|||
(:print-object
|
||||
(lambda (x stream)
|
||||
(print-unreadable-object (x stream :identity t)
|
||||
(sb!impl::output-interpreted-function x stream)))))
|
||||
(interpreted-function-%name x)))))
|
||||
;; The name of this interpreted function, or NIL if none specified.
|
||||
(%name nil)
|
||||
;; This function's debug arglist.
|
||||
|
|
|
|||
|
|
@ -179,7 +179,7 @@
|
|||
(trace-table-entry trace-table-normal)))
|
||||
|
||||
;;; Allocate a partial frame for passing stack arguments in a full
|
||||
;;; call. Nargs is the number of arguments passed. If no stack
|
||||
;;; call. NARGS is the number of arguments passed. If no stack
|
||||
;;; arguments are passed, then we don't have to do anything.
|
||||
(define-vop (allocate-full-call-frame)
|
||||
(:info nargs)
|
||||
|
|
@ -189,8 +189,6 @@
|
|||
(move csp-tn res)
|
||||
(inst lda csp-tn (* nargs word-bytes) csp-tn))))
|
||||
|
||||
|
||||
|
||||
;;; Emit code needed at the return-point from an unknown-values call
|
||||
;;; for a fixed number of values. Values is the head of the TN-Ref
|
||||
;;; list for the locations that the values are to be received into.
|
||||
|
|
@ -565,7 +563,7 @@ default-value-8
|
|||
(trace-table-entry trace-table-normal)))
|
||||
|
||||
|
||||
;;;; Full call:
|
||||
;;;; full call:
|
||||
;;;;
|
||||
;;;; There is something of a cross-product effect with full calls.
|
||||
;;;; Different versions are used depending on whether we know the
|
||||
|
|
@ -1046,7 +1044,7 @@ default-value-8
|
|||
(move lexenv closure)))
|
||||
|
||||
;;; Copy a &MORE arg from the argument area to the end of the current
|
||||
;;; frame. FIXED is the number of non-more arguments.
|
||||
;;; frame. FIXED is the number of non-&MORE arguments.
|
||||
(define-vop (copy-more-arg)
|
||||
(:temporary (:sc any-reg :offset nl0-offset) result)
|
||||
(:temporary (:sc any-reg :offset nl1-offset) count)
|
||||
|
|
@ -1059,8 +1057,9 @@ default-value-8
|
|||
(do-regs (gen-label))
|
||||
(done (gen-label)))
|
||||
(when (< fixed register-arg-count)
|
||||
;; Save a pointer to the results so we can fill in register args.
|
||||
;; We don't need this if there are more fixed args than reg args.
|
||||
;; Save a pointer to the results so we can fill in register
|
||||
;; args. We don't need this if there are more fixed args than
|
||||
;; reg args.
|
||||
(move csp-tn result))
|
||||
;; Allocate the space on the stack.
|
||||
(cond ((zerop fixed)
|
||||
|
|
@ -1071,14 +1070,14 @@ default-value-8
|
|||
(inst ble count done)
|
||||
(inst addq csp-tn count csp-tn)))
|
||||
(when (< fixed register-arg-count)
|
||||
;; We must stop when we run out of stack args, not when we run out of
|
||||
;; more args.
|
||||
;; We must stop when we run out of stack args, not when we run
|
||||
;; out of &MORE args.
|
||||
(inst subq nargs-tn (fixnumize register-arg-count) count))
|
||||
;; Initialize dst to be end of stack.
|
||||
(move csp-tn dst)
|
||||
;; Everything of interest in registers.
|
||||
(inst ble count do-regs)
|
||||
;; Initialize src to be end of args.
|
||||
;; Initialize SRC to be end of args.
|
||||
(inst addq cfp-tn nargs-tn src)
|
||||
|
||||
(emit-label loop)
|
||||
|
|
@ -1092,9 +1091,9 @@ default-value-8
|
|||
|
||||
(emit-label do-regs)
|
||||
(when (< fixed register-arg-count)
|
||||
;; Now we have to deposit any more args that showed up in registers.
|
||||
;; We know there is at least one more arg, otherwise we would have
|
||||
;; branched to done up at the top.
|
||||
;; Now we have to deposit any more args that showed up in
|
||||
;; registers. We know there is at least one &MORE arg,
|
||||
;; otherwise we would have branched to DONE up at the top.
|
||||
(inst subq nargs-tn (fixnumize (1+ fixed)) count)
|
||||
(do ((i fixed (1+ i)))
|
||||
((>= i register-arg-count))
|
||||
|
|
@ -1106,7 +1105,7 @@ default-value-8
|
|||
(inst subq count (fixnumize 1) count)))
|
||||
(emit-label done))))
|
||||
|
||||
;;; &More args are stored consecutively on the stack, starting
|
||||
;;; &MORE args are stored consecutively on the stack, starting
|
||||
;;; immediately at the context pointer. The context pointer is not
|
||||
;;; typed, so the lowtag is 0.
|
||||
(define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg)
|
||||
|
|
@ -1154,7 +1153,7 @@ default-value-8
|
|||
;; Store the value in the car (in delay slot)
|
||||
(storew temp dst 0 list-pointer-type)
|
||||
|
||||
;; Dec count, and if != zero, go back for more.
|
||||
;; Decrement count, and if != zero, go back for more.
|
||||
(inst subq count (fixnumize 1) count)
|
||||
(inst bne count loop)
|
||||
|
||||
|
|
@ -1163,11 +1162,11 @@ default-value-8
|
|||
(emit-label done))))
|
||||
|
||||
;;; Return the location and size of the &MORE arg glob created by
|
||||
;;; Copy-More-Arg. Supplied is the total number of arguments supplied
|
||||
;;; COPY-MORE-ARG. Supplied is the total number of arguments supplied
|
||||
;;; (originally passed in NARGS.) Fixed is the number of non-&rest
|
||||
;;; arguments.
|
||||
;;;
|
||||
;;; We must duplicate some of the work done by Copy-More-Arg, since at
|
||||
;;; We must duplicate some of the work done by COPY-MORE-ARG, since at
|
||||
;;; that time the environment is in a pretty brain-damaged state,
|
||||
;;; preventing this info from being returned as values. What we do is
|
||||
;;; compute supplied - fixed, and return a pointer that many words
|
||||
|
|
@ -1186,8 +1185,7 @@ default-value-8
|
|||
(inst subq supplied (fixnumize fixed) count)
|
||||
(inst subq csp-tn count context)))
|
||||
|
||||
|
||||
;;; Signal wrong argument count error if Nargs isn't equal to Count.
|
||||
;;; Signal wrong argument count error if NARGS isn't equal to COUNT.
|
||||
(define-vop (verify-argument-count)
|
||||
(:policy :fast-safe)
|
||||
(:translate sb!c::%verify-argument-count)
|
||||
|
|
|
|||
|
|
@ -116,7 +116,6 @@
|
|||
;;; to be called when a variable is lexically bound
|
||||
(declaim (ftype (function (symbol) (values)) note-lexical-binding))
|
||||
(defun note-lexical-binding (symbol)
|
||||
(let ((name (symbol-name symbol)))
|
||||
;; This check is intended to protect us from getting silently
|
||||
;; burned when we define
|
||||
;; foo.lisp:
|
||||
|
|
@ -127,10 +126,9 @@
|
|||
;; (LET ((*FOO* X))
|
||||
;; (FOO 14)))
|
||||
;; and then we happen to compile bar.lisp before foo.lisp.
|
||||
(when (and (char= #\* (aref name 0))
|
||||
(char= #\* (aref name (1- (length name)))))
|
||||
(when (looks-like-name-of-special-var-p symbol)
|
||||
;; FIXME: should be COMPILER-STYLE-WARNING?
|
||||
(style-warn "using the lexical binding of the symbol ~S, not the~@
|
||||
dynamic binding, even though the symbol name follows the usual naming~@
|
||||
convention (names like *FOO*) for special variables" symbol)))
|
||||
convention (names like *FOO*) for special variables" symbol))
|
||||
(values))
|
||||
|
|
|
|||
|
|
@ -89,7 +89,7 @@
|
|||
;;; Backpatch all the DEBUG-INFOs dumped so far with the specified
|
||||
;;; SOURCE-INFO list. We also check that there are no outstanding forward
|
||||
;;; references to functions.
|
||||
(defun fix-core-source-info (info object source-info)
|
||||
(defun fix-core-source-info (info object &optional source-info)
|
||||
(declare (type source-info info) (type core-object object))
|
||||
(aver (zerop (hash-table-count (core-object-patch-table object))))
|
||||
(let ((res (debug-source-for-info info)))
|
||||
|
|
|
|||
|
|
@ -1015,15 +1015,13 @@
|
|||
:type-spec t)
|
||||
|
||||
;;; where this information came from:
|
||||
;;; :DECLARED = from a declaration.
|
||||
;;; :ASSUMED = from uses of the object.
|
||||
;;; :DEFINED = from examination of the definition.
|
||||
;;; FIXME: The :DEFINED assumption that the definition won't change
|
||||
;;; isn't ANSI. KLUDGE: CMU CL uses function type information in a way
|
||||
;;; which violates its "type declarations are assertions" principle,
|
||||
;;; and SBCL has inherited that behavior. It would be really good to
|
||||
;;; fix the compiler so that it tests the return types of functions..
|
||||
;;; -- WHN ca. 19990801
|
||||
;;; :ASSUMED = from uses of the object
|
||||
;;; :DEFINED = from examination of the definition
|
||||
;;; :DECLARED = from a declaration
|
||||
;;; :DEFINED trumps :ASSUMED, and :DECLARED trumps :DEFINED.
|
||||
;;; :DEFINED and :ASSUMED are useful for issuing compile-time warnings,
|
||||
;;; and :DECLARED is useful for ANSIly specializing code which
|
||||
;;; implements the function, or which uses the function's return values.
|
||||
(define-info-type
|
||||
:class :function
|
||||
:type :where-from
|
||||
|
|
@ -1117,7 +1115,7 @@
|
|||
|
||||
(define-info-class :variable)
|
||||
|
||||
;;; The kind of variable-like thing described.
|
||||
;;; the kind of variable-like thing described
|
||||
(define-info-type
|
||||
:class :variable
|
||||
:type :kind
|
||||
|
|
@ -1127,21 +1125,21 @@
|
|||
:constant
|
||||
:global))
|
||||
|
||||
;;; The declared type for this variable.
|
||||
;;; the declared type for this variable
|
||||
(define-info-type
|
||||
:class :variable
|
||||
:type :type
|
||||
:type-spec ctype
|
||||
:default *universal-type*)
|
||||
|
||||
;;; Where this type and kind information came from.
|
||||
;;; where this type and kind information came from
|
||||
(define-info-type
|
||||
:class :variable
|
||||
:type :where-from
|
||||
:type-spec (member :declared :assumed :defined)
|
||||
:default :assumed)
|
||||
|
||||
;;; The lisp object which is the value of this constant, if known.
|
||||
;;; the Lisp object which is the value of this constant, if known
|
||||
(define-info-type
|
||||
:class :variable
|
||||
:type :constant-value
|
||||
|
|
@ -1164,15 +1162,15 @@
|
|||
|
||||
(define-info-class :type)
|
||||
|
||||
;;; The kind of type described. We return :INSTANCE for standard types that
|
||||
;;; are implemented as structures.
|
||||
;;; the kind of type described. We return :INSTANCE for standard types
|
||||
;;; that are implemented as structures.
|
||||
(define-info-type
|
||||
:class :type
|
||||
:type :kind
|
||||
:type-spec (member :primitive :defined :instance nil)
|
||||
:default nil)
|
||||
|
||||
;;; Expander function for a defined type.
|
||||
;;; the expander function for a defined type
|
||||
(define-info-type
|
||||
:class :type
|
||||
:type :expander
|
||||
|
|
|
|||
|
|
@ -48,19 +48,12 @@
|
|||
(defvar *converting-for-interpreter* nil)
|
||||
;;; FIXME: Rename to *IR1-FOR-INTERPRETER-NOT-COMPILER-P*.
|
||||
|
||||
;;; FIXME: This nastiness was one of my original motivations to start
|
||||
;;; hacking CMU CL. The non-ANSI behavior can be useful, but it should
|
||||
;;; be made not the default, and perhaps should be controlled by
|
||||
;;; DECLAIM instead of a variable like this. And whether or not this
|
||||
;;; kind of checking is on, declarations should be assertions to the
|
||||
;;; extent practical, and code which can't be compiled efficiently
|
||||
;;; while adhering to that principle should give warnings.
|
||||
(defvar *derive-function-types* t
|
||||
#!+sb-doc
|
||||
"(Caution: Soon, this might change its semantics somewhat, or even go away.)
|
||||
If true, argument and result type information derived from compilation of
|
||||
DEFUNs is used when compiling calls to that function. If false, only
|
||||
information from FTYPE proclamations will be used.")
|
||||
(defvar *derive-function-types* nil
|
||||
"Should the compiler assume that function types will never change,
|
||||
so that it can use type information inferred from current definitions
|
||||
to optimize code which uses those definitions? Setting this true
|
||||
gives non-ANSI, early-CMU-CL behavior. It can be useful for improving
|
||||
the efficiency of stable code.")
|
||||
|
||||
;;;; namespace management utilities
|
||||
|
||||
|
|
|
|||
|
|
@ -514,7 +514,10 @@
|
|||
;; :DECLARED, from a declaration.
|
||||
;; :ASSUMED, from uses of the object.
|
||||
;; :DEFINED, from examination of the definition.
|
||||
;; FIXME: This should be a named type. (LEAF-WHERE-FROM?)
|
||||
;; FIXME: This should be a named type. (LEAF-WHERE-FROM? Or
|
||||
;; perhaps just WHERE-FROM, since it's not just used in LEAF,
|
||||
;; but also in various DEFINE-INFO-TYPEs in globaldb.lisp,
|
||||
;; and very likely elsewhere too.)
|
||||
(where-from :assumed :type (member :declared :assumed :defined))
|
||||
;; list of the REF nodes for this leaf
|
||||
(refs () :type list)
|
||||
|
|
@ -573,7 +576,7 @@
|
|||
;;; defined in the same compilation block, or that have inline
|
||||
;;; expansions, or have a non-NIL INLINEP value. Whenever we change
|
||||
;;; the INLINEP state (i.e. an inline proclamation) we copy the
|
||||
;;; structure so that former inlinep values are preserved.
|
||||
;;; structure so that former INLINEP values are preserved.
|
||||
(def!struct (defined-function (:include global-var
|
||||
(where-from :defined)
|
||||
(kind :global-function)))
|
||||
|
|
|
|||
|
|
@ -3435,6 +3435,112 @@
|
|||
(declare (ignore tee))
|
||||
(funcall control *standard-output* ,@arg-names)
|
||||
nil)))
|
||||
|
||||
(defoptimizer (coerce derive-type) ((value type))
|
||||
(let ((value-type (continuation-type value))
|
||||
(type-type (continuation-type type)))
|
||||
#!+sb-show (format t "~&coerce-derive-type value-type ~A type-type ~A~%"
|
||||
value-type type-type)
|
||||
(labels
|
||||
((good-cons-type-p (cons-type)
|
||||
;; Make sure the cons-type we're looking at is something
|
||||
;; we're prepared to handle which is basically something
|
||||
;; that array-element-type can return.
|
||||
(or (and (member-type-p cons-type)
|
||||
(null (rest (member-type-members cons-type)))
|
||||
(null (first (member-type-members cons-type))))
|
||||
(let ((car-type (cons-type-car-type cons-type)))
|
||||
(and (member-type-p car-type)
|
||||
(null (rest (member-type-members car-type)))
|
||||
(or (symbolp (first (member-type-members car-type)))
|
||||
(numberp (first (member-type-members car-type)))
|
||||
(and (listp (first (member-type-members car-type)))
|
||||
(numberp (first (first (member-type-members
|
||||
car-type))))))
|
||||
(good-cons-type-p (cons-type-cdr-type cons-type))))))
|
||||
(unconsify-type (good-cons-type)
|
||||
;; Convert the "printed" respresentation of a cons
|
||||
;; specifier into a type specifier. That is, the specifier
|
||||
;; (cons (eql signed-byte) (cons (eql 16) null)) is
|
||||
;; converted to (signed-byte 16).
|
||||
(cond ((or (null good-cons-type)
|
||||
(eq good-cons-type 'null))
|
||||
nil)
|
||||
((and (eq (first good-cons-type) 'cons)
|
||||
(eq (first (second good-cons-type)) 'member))
|
||||
`(,(second (second good-cons-type))
|
||||
,@(unconsify-type (caddr good-cons-type))))))
|
||||
(coerceable-p (c-type)
|
||||
;; Can the value be coerced to the given type? Coerce is
|
||||
;; complicated, so we don't handle every possible case
|
||||
;; here---just the most common and easiest cases:
|
||||
;;
|
||||
;; o Any real can be coerced to a float type.
|
||||
;; o Any number can be coerced to a complex single/double-float.
|
||||
;; o An integer can be coerced to an integer.
|
||||
(let ((coerced-type c-type))
|
||||
(or (and (subtypep coerced-type 'float)
|
||||
(csubtypep value-type (specifier-type 'real)))
|
||||
(and (subtypep coerced-type
|
||||
'(or (complex single-float)
|
||||
(complex double-float)))
|
||||
(csubtypep value-type (specifier-type 'number)))
|
||||
(and (subtypep coerced-type 'integer)
|
||||
(csubtypep value-type (specifier-type 'integer))))))
|
||||
(process-types (type)
|
||||
;; FIXME
|
||||
;; This needs some work because we should be able to derive
|
||||
;; the resulting type better than just the type arg of
|
||||
;; coerce. That is, if x is (integer 10 20), the (coerce x
|
||||
;; 'double-float) should say (double-float 10d0 20d0)
|
||||
;; instead of just double-float.
|
||||
(cond ((member-type-p type)
|
||||
(let ((members (member-type-members type)))
|
||||
(if (every #'coerceable-p members)
|
||||
(specifier-type `(or ,@members))
|
||||
*universal-type*)))
|
||||
((and (cons-type-p type)
|
||||
(good-cons-type-p type))
|
||||
(let ((c-type (unconsify-type (type-specifier type))))
|
||||
(if (coerceable-p c-type)
|
||||
(specifier-type c-type)
|
||||
*universal-type*)))
|
||||
(t
|
||||
*universal-type*))))
|
||||
(cond ((union-type-p type-type)
|
||||
(apply #'type-union (mapcar #'process-types
|
||||
(union-type-types type-type))))
|
||||
((or (member-type-p type-type)
|
||||
(cons-type-p type-type))
|
||||
(process-types type-type))
|
||||
(t
|
||||
*universal-type*)))))
|
||||
|
||||
(defoptimizer (array-element-type derive-type) ((array))
|
||||
(let* ((array-type (continuation-type array)))
|
||||
#!+sb-show
|
||||
(format t "~& defoptimizer array-elt-derive-type - array-element-type ~~
|
||||
~A~%" array-type)
|
||||
(labels ((consify (list)
|
||||
(if (endp list)
|
||||
'(eql nil)
|
||||
`(cons (eql ,(car list)) ,(consify (rest list)))))
|
||||
(get-element-type (a)
|
||||
(let ((element-type (type-specifier
|
||||
(array-type-specialized-element-type a))))
|
||||
(cond ((symbolp element-type)
|
||||
(make-member-type :members (list element-type)))
|
||||
((consp element-type)
|
||||
(specifier-type (consify element-type)))
|
||||
(t
|
||||
(error "Can't grok type ~A~%" element-type))))))
|
||||
(cond ((array-type-p array-type)
|
||||
(get-element-type array-type))
|
||||
((union-type-p array-type)
|
||||
(apply #'type-union
|
||||
(mapcar #'get-element-type (union-type-types array-type))))
|
||||
(t
|
||||
*universal-type*)))))
|
||||
|
||||
;;;; debuggers' little helpers
|
||||
|
||||
|
|
|
|||
|
|
@ -15,12 +15,13 @@
|
|||
*/
|
||||
|
||||
#include <stdio.h>
|
||||
#include <sys/types.h>
|
||||
#include <stdlib.h>
|
||||
#include <sys/file.h>
|
||||
#include <sys/types.h>
|
||||
#include <unistd.h>
|
||||
|
||||
#ifdef irix
|
||||
#include <fcntl.h>
|
||||
#include <stdlib.h>
|
||||
#endif
|
||||
|
||||
#include "os.h"
|
||||
|
|
@ -32,7 +33,7 @@
|
|||
#include "sbcl.h"
|
||||
|
||||
static void
|
||||
process_directory(int fd, long *ptr, int count)
|
||||
process_directory(int fd, u32 *ptr, int count)
|
||||
{
|
||||
struct ndir_entry *entry;
|
||||
|
||||
|
|
@ -67,16 +68,17 @@ process_directory(int fd, long *ptr, int count)
|
|||
case DYNAMIC_SPACE_ID:
|
||||
#ifdef GENCGC
|
||||
if (addr != (os_vm_address_t)DYNAMIC_SPACE_START) {
|
||||
fprintf(stderr, "in core: 0x%x - in runtime: 0x%x \n",
|
||||
addr, (os_vm_address_t)DYNAMIC_SPACE_START);
|
||||
fprintf(stderr, "in core: 0x%lx; in runtime: 0x%lx \n",
|
||||
(long)addr, (long)DYNAMIC_SPACE_START);
|
||||
lose("core/runtime address mismatch: DYNAMIC_SPACE_START");
|
||||
}
|
||||
#else
|
||||
if ((addr != (os_vm_address_t)DYNAMIC_0_SPACE_START) &&
|
||||
(addr != (os_vm_address_t)DYNAMIC_1_SPACE_START)) {
|
||||
fprintf(stderr, "in core: 0x%x - in runtime: 0x%x or 0x%x\n",
|
||||
addr, (os_vm_address_t)DYNAMIC_0_SPACE_START,
|
||||
(os_vm_address_t)DYNAMIC_1_SPACE_START);
|
||||
fprintf(stderr, "in core: 0x%lx; in runtime: 0x%lx or 0x%lx\n",
|
||||
(long)addr,
|
||||
(long)DYNAMIC_0_SPACE_START,
|
||||
(long)DYNAMIC_1_SPACE_START);
|
||||
lose("warning: core/runtime address mismatch: DYNAMIC_SPACE_START");
|
||||
}
|
||||
#endif
|
||||
|
|
@ -96,15 +98,15 @@ process_directory(int fd, long *ptr, int count)
|
|||
break;
|
||||
case STATIC_SPACE_ID:
|
||||
if (addr != (os_vm_address_t)STATIC_SPACE_START) {
|
||||
fprintf(stderr, "in core: 0x%p - in runtime: 0x%x\n",
|
||||
addr, (os_vm_address_t)STATIC_SPACE_START);
|
||||
fprintf(stderr, "in core: 0x%lx - in runtime: 0x%lx\n",
|
||||
(long)addr, (long)STATIC_SPACE_START);
|
||||
lose("core/runtime address mismatch: STATIC_SPACE_START");
|
||||
}
|
||||
break;
|
||||
case READ_ONLY_SPACE_ID:
|
||||
if (addr != (os_vm_address_t)READ_ONLY_SPACE_START) {
|
||||
fprintf(stderr, "in core: 0x%x - in runtime: 0x%x\n",
|
||||
addr, (os_vm_address_t)READ_ONLY_SPACE_START);
|
||||
fprintf(stderr, "in core: 0x%lx - in runtime: 0x%lx\n",
|
||||
(long)addr, (long)READ_ONLY_SPACE_START);
|
||||
lose("core/runtime address mismatch: READ_ONLY_SPACE_START");
|
||||
}
|
||||
break;
|
||||
|
|
|
|||
|
|
@ -5369,7 +5369,7 @@ garbage_collect_generation(int generation, int raise)
|
|||
{
|
||||
unsigned long bytes_freed;
|
||||
unsigned long i;
|
||||
unsigned long read_only_space_size, static_space_size;
|
||||
unsigned long static_space_size;
|
||||
|
||||
gc_assert(generation <= (NUM_GENERATIONS-1));
|
||||
|
||||
|
|
@ -5460,7 +5460,7 @@ garbage_collect_generation(int generation, int raise)
|
|||
* please submit a patch. */
|
||||
#if 0
|
||||
if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
|
||||
read_only_space_size =
|
||||
unsigned long read_only_space_size =
|
||||
(lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) -
|
||||
(lispobj*)READ_ONLY_SPACE_START;
|
||||
FSHOW((stderr,
|
||||
|
|
|
|||
|
|
@ -160,7 +160,7 @@ lispobj debug_print(lispobj string)
|
|||
that %primitive print is used (it's only a debugging aid anyway)
|
||||
we just put guarantee our safety by putting an unused buffer on
|
||||
the stack before doing anything else here */
|
||||
char untouched[32];
|
||||
char untouched[32]; /* GCC warns about not using this, but that's the point.. */
|
||||
fprintf(stderr, "%s\n",
|
||||
(char *)(((struct vector *)native_pointer(string))->data),untouched);
|
||||
return NIL;
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@
|
|||
*/
|
||||
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
|
||||
#include <signal.h>
|
||||
#ifdef mach /* KLUDGE: #ifdef on lowercase symbols? Ick. -- WHN 19990904 */
|
||||
|
|
@ -624,12 +625,13 @@ undoably_install_low_level_interrupt_handler (int signal,
|
|||
sigaddset_blockable(&sa.sa_mask);
|
||||
sa.sa_flags = SA_SIGINFO | SA_RESTART;
|
||||
|
||||
/* In the case of interrupt handlers which are modified
|
||||
* more than once, we only save the original unmodified
|
||||
* copy. */
|
||||
/* In the case of interrupt handlers which are modified more than
|
||||
* once, we only save the original unmodified copy. */
|
||||
if (!old_low_level_signal_handler_state->was_modified) {
|
||||
struct sigaction *old_handler =
|
||||
(struct sigaction*) &old_low_level_signal_handler_state->handler;
|
||||
old_low_level_signal_handler_state->was_modified = 1;
|
||||
sigaction(signal, &sa, &old_low_level_signal_handler_state->handler);
|
||||
sigaction(signal, &sa, old_handler);
|
||||
} else {
|
||||
sigaction(signal, &sa, NULL);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -26,6 +26,7 @@
|
|||
#include <sys/types.h>
|
||||
#include <dirent.h>
|
||||
#include <sys/stat.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <unistd.h>
|
||||
|
||||
|
|
@ -50,17 +51,17 @@ is_lispy_filename(const char *filename)
|
|||
char**
|
||||
alloc_directory_lispy_filenames(const char *directory_name)
|
||||
{
|
||||
DIR *dir_ptr;
|
||||
DIR *dir_ptr = opendir(directory_name);
|
||||
char **result = 0;
|
||||
|
||||
if (dir_ptr = opendir(directory_name)) { /* if opendir success */
|
||||
if (dir_ptr) { /* if opendir success */
|
||||
|
||||
struct voidacc va;
|
||||
|
||||
if (0 == voidacc_ctor(&va)) { /* if voidacc_ctor success */
|
||||
struct dirent *dirent_ptr;
|
||||
|
||||
while (dirent_ptr = readdir(dir_ptr)) { /* until end of data */
|
||||
while ( (dirent_ptr = readdir(dir_ptr)) ) { /* until end of data */
|
||||
char* original_name = dirent_ptr->d_name;
|
||||
if (is_lispy_filename(original_name)) {
|
||||
/* strdup(3) is in Linux and *BSD. If you port
|
||||
|
|
@ -112,17 +113,16 @@ free_directory_lispy_filenames(char** directory_lispy_filenames)
|
|||
/* a wrapped version of readlink(2):
|
||||
* -- If path isn't a symlink, or is a broken symlink, return 0.
|
||||
* -- If path is a symlink, return a newly allocated string holding
|
||||
* the thing it's linked to.
|
||||
*/
|
||||
* the thing it's linked to. */
|
||||
char *
|
||||
wrapped_readlink(char *path)
|
||||
{
|
||||
int strlen_path = strlen(path);
|
||||
int bufsiz = strlen(path) + 16;
|
||||
while (1) {
|
||||
char *result = malloc(bufsiz);
|
||||
int n_read = readlink(path, result, n_read);
|
||||
if (n_read < 0) {
|
||||
free(result);
|
||||
return 0;
|
||||
} else if (n_read < bufsiz) {
|
||||
result[n_read] = 0;
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@
|
|||
#include "interrupt.h"
|
||||
#include "interr.h"
|
||||
#include "breakpoint.h"
|
||||
#include "monitor.h"
|
||||
|
||||
#define BREAKPOINT_INST 0xcc /* INT3 */
|
||||
|
||||
|
|
|
|||
|
|
@ -77,4 +77,27 @@
|
|||
(0 "GMT" . "GDT") (-2 "MET" . "MET DST"))
|
||||
"*The string representations of the time zones.")
|
||||
|
||||
;;; The old CMU CL Python compiler assumed that it was safe to infer
|
||||
;;; function types (including return types) from function definitions
|
||||
;;; and then use them to optimize code later. This is of course bad
|
||||
;;; when functions are redefined. The problem was fixed in
|
||||
;;; sbcl-0.6.12.57.
|
||||
(defun foo (x)
|
||||
(if (plusp x)
|
||||
1.0
|
||||
0))
|
||||
(defun bar (x)
|
||||
(typecase (foo x)
|
||||
(fixnum :fixnum)
|
||||
(real :real)
|
||||
(string :string)
|
||||
(t :t)))
|
||||
(assert (eql (bar 11) :real))
|
||||
(assert (eql (bar -11) :fixnum))
|
||||
(setf (symbol-function 'foo) #'identity)
|
||||
(assert (eql (bar 11) :fixnum))
|
||||
(assert (eql (bar -11.0) :real))
|
||||
(assert (eql (bar "this is a test") :string))
|
||||
(assert (eql (bar (make-hash-table)) :t))
|
||||
|
||||
(sb-ext:quit :unix-status 104) ; success
|
||||
|
|
|
|||
|
|
@ -66,5 +66,3 @@
|
|||
;;; FIXME: It would probably be good to require here that every
|
||||
;;; external symbol either has a doc string or has some good excuse
|
||||
;;; (like being an accessor for a structure which has a doc string).
|
||||
|
||||
(print "done with interface.pure.lisp")
|
||||
|
|
|
|||
77
tests/irrat.pure.lisp
Normal file
77
tests/irrat.pure.lisp
Normal file
|
|
@ -0,0 +1,77 @@
|
|||
;;;; tests of irrational floating point functions
|
||||
|
||||
;;;; This software is part of the SBCL system. See the README file for
|
||||
;;;; more information.
|
||||
;;;;
|
||||
;;;; While most of SBCL is derived from the CMU CL system, the test
|
||||
;;;; files (like this one) were written from scratch after the fork
|
||||
;;;; from CMU CL.
|
||||
;;;;
|
||||
;;;; This software is in the public domain and is provided with
|
||||
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
||||
;;;; more information.
|
||||
|
||||
(in-package :cl-user)
|
||||
|
||||
;;;; old bugs
|
||||
|
||||
;;; This used to fail with
|
||||
;;; The value -0.44579905382680446d0 is not of type (DOUBLE-FLOAT 0.0d0).
|
||||
;;; MNA's port of Raymond Toy work on CMU CL fixed this in sbcl-0.6.12.53.
|
||||
(assert (equal (log #c(0.4 0.5)) #C(-0.44579905 0.8960554)))
|
||||
|
||||
;;;; other tests
|
||||
|
||||
;;; expt
|
||||
(assert (equal (expt #c(0 1) 2) -1))
|
||||
(assert (equal (prin1-to-string (expt 2 #c(0 1))) "#C(0.7692389 0.63896126)"))
|
||||
|
||||
;;; log
|
||||
(assert (equal (prin1-to-string (log -3 10)) "#C(0.47712126 1.3643764)"))
|
||||
(assert (= (log 3 0) 0))
|
||||
|
||||
;;; sqrt, isqrt
|
||||
(assert (= (sqrt 9) 3.0))
|
||||
(assert (= (sqrt -9.0) #c(0.0 3.0)))
|
||||
(assert (= (isqrt 9) 3))
|
||||
(assert (= (isqrt 26) 5))
|
||||
|
||||
|
||||
;;; sin, sinh, asin, asinh
|
||||
(assert (equal (prin1-to-string (sin (* 8 (/ pi 2)))) "-4.898425415289509d-16"))
|
||||
(assert (equal (prin1-to-string (sin (expt 10 3))) "0.82687956"))
|
||||
(assert (= (sinh 0) 0.0))
|
||||
(assert (equal (prin1-to-string (sinh #c(5.0 -9.6)))
|
||||
"#C(-73.06699 12.936809)"))
|
||||
(assert (= (sin (* #c(0 1) 5)) (* #c(0 1) (sinh 5))))
|
||||
(assert (= (sinh (* #c(0 1) 5)) (* #c(0 1) (sin 5))))
|
||||
(assert (equal (prin1-to-string (asin -1)) "-1.5707964"))
|
||||
(assert (= (asin 0) 0.0))
|
||||
(assert (= (asin 2) #c(1.5707964 -1.3169578)))
|
||||
(assert (equal (prin1-to-string (asinh 0.5)) "0.4812118"))
|
||||
(assert (equal (prin1-to-string (asinh 3/7)) "0.41643077"))
|
||||
|
||||
;;; cos, cosh, acos, acosh
|
||||
(assert (= (cos 0) 1.0))
|
||||
(assert (equal (prin1-to-string (cos (/ pi 2))) "6.123031769111886d-17"))
|
||||
(assert (= (cosh 0) 1.0))
|
||||
(assert (equal (prin1-to-string (cosh 1)) "1.5430807"))
|
||||
(assert (= (cos (* #c(0 1) 5)) (cosh 5)))
|
||||
(assert (= (cosh (* #c(0 1) 5)) (cos 5)))
|
||||
(assert (equal (prin1-to-string (acos 0)) "1.5707964"))
|
||||
(assert (equal (prin1-to-string (acos -1)) "3.1415927"))
|
||||
(assert (equal (prin1-to-string (acos 2)) "#C(0.0 1.3169578)"))
|
||||
(assert (= (acos 1.00001) #c(0.0 0.0044751678)))
|
||||
(assert (= (acosh 0) #c(0 1.5707964)))
|
||||
(assert (= (acosh 1) 0))
|
||||
(assert (= (acosh -1) #c(0 3.1415927)))
|
||||
|
||||
;;; tan, tanh
|
||||
(assert (equal (prin1-to-string (tan 1)) "1.5574077"))
|
||||
(assert (equal (prin1-to-string (tan (/ pi 2))) "1.6331778728383844d+16"))
|
||||
(assert (equal (prin1-to-string (tanh 0.00753)) "0.0075298576"))
|
||||
(assert (= (tanh 50) 1.0))
|
||||
(assert (= (tan (* #c(0 1) 5)) (* #c(0 1) (tanh 5))))
|
||||
(assert (= (atan 1) 0.7853982))
|
||||
(assert (equal (prin1-to-string (atanh 0.5) ) "0.54930615"))
|
||||
(assert (equal (prin1-to-string (atanh 3/7)) "0.45814538"))
|
||||
|
|
@ -16,4 +16,4 @@
|
|||
;;; four numeric fields, is used for versions which aren't released
|
||||
;;; but correspond only to CVS tags or snapshots.
|
||||
|
||||
"0.6.12.49"
|
||||
"0.6.12.58"
|
||||
|
|
|
|||
Loading…
Reference in a new issue