hacking on 0.6.11.5 patches..
..Various FIXNUM things in ASH DERIVE-TYPE need to be
TARGET-FIXNUM things.
..tweaked ASH DERIVE-TYPE to make it fit in 80 columns
..defined BECOME-DEFINED-FUNCTION-NAME and
PRINT-PRETTY-ON-STREAM? to reduce cut/paste
..deleted unused %FUNCTION-HEADER-ARGLIST-SLOT and
%FUNCTION-HEADER-NAME-SLOT
"MAKE-GENSYM-LIST"
"DEFCONSTANT-EQX"
"ABOUT-TO-MODIFY"
+ "PRINT-PRETTY-ON-STREAM-P"
;; These could be moved back into SB!EXT if someone has
;; compelling reasons, but hopefully we can get by
"%CLOSURE-INDEX-REF" "%COS" "%COS-QUICK"
"%COSH" "%DEPOSIT-FIELD"
"%DOUBLE-FLOAT" "%DPB" "%EXP" "%EXPM1"
-;;; MNA: cmucl-commit: Mon, 4 Dec 2000 13:50:25 -0800 (PST)
-;;; No need to export the unused symbols %function-header-arglist
-;;; %function-header-name %function-header-type.
-;;; "%FUNCTION-HEADER-ARGLIST"
-;;; "%FUNCTION-HEADER-NAME" "%FUNCTION-HEADER-TYPE"
"%HYPOT" "%INSTANCE-SET-CONDITIONAL" "%LDB"
"%LOG" "%LOGB" "%LOG10" "%LOG1P" "%LONG-FLOAT"
"%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE" "%MAKE-RATIO"
"STRUCTURE-CLASS-P" "DSD-INDEX"
"%INSTANCE-LAYOUT" "LAYOUT-CLOS-HASH"
"%FUNCTION-TYPE" "PROCLAIM-AS-FUNCTION-NAME"
+ "BECOME-DEFINED-FUNCTION-NAME"
"%%COMPILER-DEFSTRUCT" "%NUMERATOR" "CLASS-TYPEP"
"STRUCTURE-CLASS-PRINT-FUNCTION" "DSD-READ-ONLY"
"LAYOUT-INHERITS" "DD-LENGTH" "%CODE-ENTRY-POINTS"
"FUNCALLABLE-INSTANCE-HEADER-TYPE"
"FUNCALLABLE-INSTANCE-INFO-OFFSET"
"FUNCTION-ARGLIST-SLOT" "FUNCTION-CODE-OFFSET"
- "FUNCTION-END-BREAKPOINT-TRAP" "FUNCTION-HEADER-ARGLIST-SLOT"
- "FUNCTION-HEADER-CODE-OFFSET" "FUNCTION-HEADER-NAME-SLOT"
+ "FUNCTION-END-BREAKPOINT-TRAP"
+ "FUNCTION-HEADER-CODE-OFFSET"
"FUNCTION-HEADER-NEXT-SLOT" "FUNCTION-HEADER-SELF-SLOT"
"FUNCTION-HEADER-TYPE" "FUNCTION-HEADER-TYPE-SLOT"
"FUNCTION-NAME-SLOT" "FUNCTION-NEXT-SLOT" "FUNCTION-POINTER-TYPE"
;;; XXX Should probably check whether it has reached the bottom of the
;;; stack.
;;;
-;;; XXX Should handle interrupted frames, both Lisp and C. At present it
-;;; manages to find a fp trail, see linux hack below.
-
-;;; MNA: cmucl-commit: Mon, 6 Nov 2000 10:08:39 -0800 (PST)
-;;; Upon a stack trace ambiguity in x86-call-context, choose the lisp
-;;; frame in preference to the C frame as this is frame of interest.
-
-;;; MNA: cmucl-commit: Mon, 6 Nov 2000 09:48:00 -0800 (PST)
-;;; Limit the stack trace failure warning in x86-call-context to fails for the
-;;; immediate frame rather failures deeper within the search.
-
+;;; XXX Should handle interrupted frames, both Lisp and C. At present
+;;; it manages to find a fp trail, see linux hack below.
(defun x86-call-context (fp &key (depth 0))
(declare (type system-area-pointer fp)
(fixnum depth))
(if (and (consp name) (eq (first name) 'setf))
(setf (fdocumentation (second name) 'setf) doc)
(setf (fdocumentation name 'function) doc)))
- (sb!c::proclaim-as-function-name name)
- (if (eq (info :function :where-from name) :assumed)
- (progn
- (setf (info :function :where-from name) :defined)
- (if (info :function :assumed-type name)
- (setf (info :function :assumed-type name) nil))))
+ (become-defined-function-name name)
(when (or inline-expansion
(info :function :inline-expansion name))
(setf (info :function :inline-expansion name)
;;;; DEFSETF
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
- ;;; Assign setf macro information for NAME, making all appropriate checks.
+ ;;; Assign SETF macro information for NAME, making all appropriate checks.
(defun assign-setf-macro (name expander inverse doc)
(cond ((gethash name sb!c:*setf-assumed-fboundp*)
(warn
(warn "defining SETF macro for DEFSTRUCT slot ~
accessor; redefining as a normal function: ~S"
name)
- (sb!c::proclaim-as-function-name name))
+ (proclaim-as-function-name name))
((not (eq (symbol-package name) (symbol-package 'aref)))
(style-warn "defining setf macro for ~S when ~S is fbound"
name `(setf ,name))))
(if (eq val *empty-condition-slot*)
(let ((actual-initargs (condition-actual-initargs condition))
(slot (find-condition-class-slot class name)))
- ;; MNA: cmucl-commit: Mon, 8 Jan 2001 21:21:23 -0800 (PST)
- ;; Catch missing slots in condition-reader-function, and signal an error.
(unless slot
- (error "Slot ~S of ~S missing." name condition))
+ (error "missing slot ~S of ~S" name condition))
(dolist (initarg (condition-slot-initargs slot))
(let ((val (getf actual-initargs
initarg
(declare (type posn posn) (type pretty-stream stream)
(values posn))
(index-column (posn-index posn stream) stream))
+
+;;; Is it OK to do pretty printing on this stream at this time?
+(defun print-pretty-on-stream-p (stream)
+ (and (pretty-stream-p stream)
+ *print-pretty*))
\f
;;;; stream interface routines
\f
;;;; user interface to the pretty printer
-;;; MNA: cmucl-commit: Wed, 27 Dec 2000 07:42:40 -0800 (PST)
-;;; pprint-newline, pprint-indent, and pprint-tab should do nothing if
-;;; *print-pretty* is not true.
-
(defun pprint-newline (kind &optional stream)
#!+sb-doc
"Output a conditional newline to STREAM (which defaults to
((t) *terminal-io*)
((nil) *standard-output*)
(t stream))))
- (when (and (pretty-stream-p stream) *print-pretty*)
+ (when (print-pretty-on-stream-p stream)
(enqueue-newline stream kind)))
nil)
((t) *terminal-io*)
((nil) *standard-output*)
(t stream))))
- (when (and (pretty-stream-p stream) *print-pretty*)
+ (when (print-pretty-on-stream-p stream)
(enqueue-indent stream relative-to n)))
nil)
((t) *terminal-io*)
((nil) *standard-output*)
(t stream))))
- (when (and (pretty-stream-p stream) *print-pretty*)
+ (when (print-pretty-on-stream-p stream)
(enqueue-tab stream kind colnum colinc)))
nil)
,expr-tmp))
(error "already bound differently: ~S")))
(t
- ;;; MNA: CMU CL does not like DEFCONSTANT-EQX,
- ;;; at least it does not like using EXPR-TMP-<X>,
- ;;; below.
(defconstant ,symbol
- ;; MNA:
- ;; FIXME: this is a very ugly hack,
- ;; to be able to build SBCL with CMU CL (2.4.19),
- ;; because there seems to be some confusion in
- ;; CMU CL about ,expr-temp at EVAL-WHEN time ...
+ ;; KLUDGE: This is a very ugly hack, to be able to
+ ;; build SBCL with CMU CL (2.4.19), because there
+ ;; seems to be some confusion in CMU CL about
+ ;; ,EXPR-TEMP at EVAL-WHEN time ... -- MNA 2000-02-23
#-cmu ,expr-tmp
#+cmu ,expr
,@(when doc `(,doc)))))))
\f
;;;; support for the PRINT-UNREADABLE-OBJECT macro
-;;; MNA: cmucl-commit: Mon, 1 Jan 2001 01:30:53 -0800 (PST)
-;;; Correct the pretty printing by print-unreadable-object. Only attempt
-;;; to print pretty when the stream is a pretty-stream (and when *print-pretty*)
-;;; to ensure that all output goes to the same stream.
-
-;;; MNA: cmucl-commit: Wed, 27 Dec 2000 05:24:30 -0800 (PST)
-;;; Have print-unreadable-object respect *print-pretty*.
-
-;;; Guts of print-unreadable-object.
-;;;
-;;; When *print-pretty* and the stream is a pretty-stream, format the object
-;;; within a logical block - pprint-logical-block does not rebind the stream
-;;; when it is already a pretty stream so output from the body will go to the
-;;; same stream.
-;;;
+;;; guts of PRINT-UNREADABLE-OBJECT
(defun %print-unreadable-object (object stream type identity body)
(when *print-readably*
(error 'print-not-readable :object object))
(write (get-lisp-obj-address object) :stream stream
:radix nil :base 16)
(write-char #\} stream))))
- (cond ((and (sb!pretty:pretty-stream-p stream) *print-pretty*)
- (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
- (print-description)))
+ (cond ((print-pretty-on-stream-p stream)
+ ;; Since we're printing prettily on STREAM, format the
+ ;; object within a logical block. PPRINT-LOGICAL-BLOCK does
+ ;; not rebind the stream when it is already a pretty stream
+ ;; so output from the body will go to the same stream.
+ (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
+ (print-description)))
(t
(write-string "#<" stream)
(print-description)
\f
;;;; other leaf objects
-;;; MNA: cmucl-commit: Mon, 1 Jan 2001 03:41:18 -0800 (PST)
-;;; Fix output-character to escape the char-name. Reworking quote-string
-;;; to not write the delimiting quotes so that is can be used by
-;;; output-character.
-
-
-;;; If *PRINT-ESCAPE* is false, just do a WRITE-CHAR, otherwise output the
-;;; character name or the character in the #\char format.
+;;; If *PRINT-ESCAPE* is false, just do a WRITE-CHAR, otherwise output
+;;; the character name or the character in the #\char format.
(defun output-character (char stream)
(if (or *print-escape* *print-readably*)
(let ((name (char-name char)))
\f
;;;; the DEREF operator
-;;; Does most of the work of the different DEREF methods. Returns two values:
-;;; the type and the offset (in bits) of the refered to alien.
+;;; This function does most of the work of the different DEREF
+;;; methods. It returns two values: the type and the offset (in bits)
+;;; of the referred-to alien.
(defun deref-guts (alien indices)
(declare (type alien-value alien)
(type list indices)
(output-push-constant segment (leaf-name leaf))
(output-do-inline-function segment 'symbol-value))))
(clambda
- (let* ((refered-env (lambda-environment leaf))
- (closure (environment-closure refered-env)))
+ (let* ((referred-env (lambda-environment leaf))
+ (closure (environment-closure referred-env)))
(if (null closure)
(output-push-load-time-constant segment :entry leaf)
(let ((my-env (node-environment ref)))
((:special :global)
(output-push-constant segment (global-var-name leaf))
(output-do-inline-function segment 'setf-symbol-value))))
- ;;; MNA: cmucl-commit: Tue, 26 Sep 2000 09:41:00 -0700 (PDT)
- ;;; Within generate-byte-code-for-set, avoid trying to set a lexical
- ;;; variable with no refs since the compiler deletes such variables.
(lambda-var
+ ;; Note: It's important to test for whether there are any
+ ;; references to the variable before we actually try to set it.
+ ;; (Setting a lexical variable with no refs caused bugs ca. CMU
+ ;; CL 18c, because the compiler deletes such variables.)
(cond ((leaf-refs leaf)
- (unless (eql values 0)
- ;; Someone wants the value, so copy it.
- (output-do-xop segment 'dup))
- (output-set-lambda-var segment leaf (node-environment set)))
- ;; If no-one wants the value then pop it else leave it for them.
- ((eql values 0)
- (output-byte-with-operand segment byte-pop-n 1)))))
+ (unless (eql values 0)
+ ;; Someone wants the value, so copy it.
+ (output-do-xop segment 'dup))
+ (output-set-lambda-var segment leaf (node-environment set)))
+ ;; If no one wants the value, then pop it, else leave it
+ ;; for them.
+ ((eql values 0)
+ (output-byte-with-operand segment byte-pop-n 1)))))
(unless (eql values 0)
(checked-canonicalize-values segment cont 1)))
(values))
;;; sequence.)
;;; ASSEMBLY-UNIT-BITS -- the number of bits in the minimum assembly
-;;; unit, (also refered to as a ``byte''). Hopefully, different
+;;; unit, (also referred to as a ``byte''). Hopefully, different
;;; instruction sets won't require changing this.
(defconstant assembly-unit-bits 8)
(defconstant assembly-unit-mask (1- (ash 1 assembly-unit-bits)))
(sb!c::global-var
(setf (symbol-value (sb!c::global-var-name var)) value)))))
-;;; This does SET-LEAF-VALUE for a lambda-var leaf. The debugger tools'
+;;; This does SET-LEAF-VALUE for a LAMBDA-VAR leaf. The debugger tools'
;;; internals uses this also to set interpreted local variables.
-
-;;; MNA: cmucl-commit: Tue, 26 Sep 2000 09:40:37 -0700 (PDT)
-;;; Within set-leaf-value-lambda-var, avoid trying to set a lexical
-;;; variable with no refs since the compiler deletes such variables.
(defun set-leaf-value-lambda-var (node var frame-ptr closure value)
+ ;; Note: We avoid trying to set a lexical variable with no refs
+ ;; because the compiler deletes such variables.
(when (sb!c::leaf-refs var)
(let ((env (sb!c::node-environment node)))
(cond ((not (eq (sb!c::lambda-environment (sb!c::lambda-var-home var))
(frob :source-transform)
(frob :assumed-type)))
(values))
+
+;;; part of what happens with DEFUN, also with some PCL stuff:
+;;; Make NAME known to be a function definition.
+(defun become-defined-function-name (name)
+ (proclaim-as-function-name name)
+ (when (eq (info :function :where-from name) :assumed)
+ (setf (info :function :where-from name) :defined)
+ (if (info :function :assumed-type name)
+ (setf (info :function :assumed-type name) nil))))
\f
;;;; ANSI Common Lisp functions which are defined in terms of the info
;;;; database
) ; PROGN
-;;; MNA: cmucl-commit: Wed, 3 Jan 2001 21:49:12 -0800 (PST)
-;;; Rework the 'ash derive-type optimizer so better handle large negative bounds.
-;;; Based on suggestions from Raymond Toy.
-;;; 'ash derive type optimizer.
+;;; ASH derive type optimizer
;;;
-;;; Large resulting bounds are easy to generate but are not particularly
-;;; useful, so an open outer bound is returned for a shift greater than 64 -
-;;; the largest word size of any of the ports. Large negative shifts are also
-;;; problematic as the 'ash implementation only accepts shifts greater than
-;;; the most-negative-fixnum. These issues are handled by two local functions:
+;;; Large resulting bounds are easy to generate but are not
+;;; particularly useful, so an open outer bound is returned for a
+;;; shift greater than 64 - the largest word size of any of the ports.
+;;; Large negative shifts are also problematic as the ASH
+;;; implementation only accepts shifts greater than
+;;; MOST-NEGATIVE-FIXNUM. These issues are handled by two local
+;;; functions:
+;;; ASH-OUTER: Perform the shift when within an acceptable range,
+;;; otherwise return an open bound.
+;;; ASH-INNER: Perform the shift when within range, limited to a
+;;; maximum of 64, otherwise returns the inner limit.
;;;
-;;; ash-outer: performs the shift when within an acceptable range, otherwise
-;;; returns an open bound.
-;;;
-;;; ash-inner: performs the shift when within range, limited to a maximum of
-;;; 64, otherwise returns the inner limit.
-;;;
-
;;; KLUDGE: All this ASH optimization is suppressed under CMU CL
;;; because as of version 2.4.6 for Debian, CMU CL blows up on (ASH
;;; 1000000000 -100000000000) (i.e. ASH of two bignums yielding zero)
#!-propagate-fun-type
(defoptimizer (ash derive-type) ((n shift))
(flet ((ash-outer (n s)
- (when (and (fixnump s)
+ (when (and (target-fixnump s)
(<= s 64)
- (> s most-negative-fixnum))
+ (> s sb!vm:*target-most-negative-fixnum*))
(ash n s)))
(ash-inner (n s)
- (if (and (fixnump s)
- (> s most-negative-fixnum))
+ (if (and (target-fixnump s)
+ (> s sb!vm:*target-most-negative-fixnum*))
(ash n (min s 64))
(if (minusp n) -1 0))))
(or (let ((n-type (continuation-type n)))
(n-high (numeric-type-high n-type)))
(if (constant-continuation-p shift)
(let ((shift (continuation-value shift)))
- (make-numeric-type :class 'integer :complexp :real
+ (make-numeric-type :class 'integer
+ :complexp :real
:low (when n-low (ash n-low shift))
:high (when n-high (ash n-high shift))))
(let ((s-type (continuation-type shift)))
(when (numeric-type-p s-type)
- (let ((s-low (numeric-type-low s-type))
- (s-high (numeric-type-high s-type)))
- (make-numeric-type :class 'integer :complexp :real
- :low (when n-low
- (if (minusp n-low)
- (ash-outer n-low s-high)
- (ash-inner n-low s-low)))
- :high (when n-high
- (if (minusp n-high)
- (ash-inner n-high s-low)
- (ash-outer n-high s-high)))))))))))
+ (let* ((s-low (numeric-type-low s-type))
+ (s-high (numeric-type-high s-type))
+ (low-slot (when n-low
+ (if (minusp n-low)
+ (ash-outer n-low s-high)
+ (ash-inner n-low s-low))))
+ (high-slot (when n-high
+ (if (minusp n-high)
+ (ash-inner n-high s-low)
+ (ash-outer n-high s-high)))))
+ (make-numeric-type :class 'integer
+ :complexp :real
+ :low low-slot
+ :high high-slot))))))))
*universal-type*))
(or (let ((n-type (continuation-type n)))
(when (numeric-type-p n-type)
(defun ash-derive-type-aux (n-type shift same-arg)
(declare (ignore same-arg))
(flet ((ash-outer (n s)
- (when (and (fixnump s)
+ (when (and (target-fixnump s)
(<= s 64)
- (> s most-negative-fixnum))
+ (> s sb!vm:*target-most-negative-fixnum*))
(ash n s)))
;; KLUDGE: The bare 64's here should be related to
;; symbolic machine word size values somehow.
(ash-inner (n s)
- (if (and (fixnump s)
- (> s most-negative-fixnum))
+ (if (and (target-fixnump s)
+ (> s sb!vm:*target-most-negative-fixnum*))
(ash n (min s 64))
(if (minusp n) -1 0))))
(or (and (csubtypep n-type (specifier-type 'integer))
;;;; functions into boolean operations when the size and position are constant
;;;; and the operands are fixnums.
-(macrolet (;; Evaluate body with Size-Var and Pos-Var bound to expressions that
- ;; evaluate to the Size and Position of the byte-specifier form
- ;; Spec. We may wrap a let around the result of the body to bind
+(macrolet (;; Evaluate body with SIZE-VAR and POS-VAR bound to expressions that
+ ;; evaluate to the SIZE and POSITION of the byte-specifier form
+ ;; SPEC. We may wrap a let around the result of the body to bind
;; some variables.
;;
- ;; If the spec is a Byte form, then bind the vars to the subforms.
- ;; otherwise, evaluate Spec and use the Byte-Size and Byte-Position.
+ ;; If the spec is a BYTE form, then bind the vars to the subforms.
+ ;; otherwise, evaluate SPEC and use the BYTE-SIZE and BYTE-POSITION.
;; The goal of this transformation is to avoid consing up byte
;; specifiers and then immediately throwing them away.
(with-byte-specifier ((size-var pos-var spec) &body body)
(deftransform %ldb ((size posn int)
(fixnum fixnum integer)
(unsigned-byte #.sb!vm:word-bits))
- "convert to inline logical ops"
+ "convert to inline logical operations"
`(logand (ash int (- posn))
(ash ,(1- (ash 1 sb!vm:word-bits))
(- size ,sb!vm:word-bits))))
(deftransform %mask-field ((size posn int)
(fixnum fixnum integer)
(unsigned-byte #.sb!vm:word-bits))
- "convert to inline logical ops"
+ "convert to inline logical operations"
`(logand int
(ash (ash ,(1- (ash 1 sb!vm:word-bits))
(- size ,sb!vm:word-bits))
(deftransform %dpb ((new size posn int)
*
(unsigned-byte #.sb!vm:word-bits))
- "convert to inline logical ops"
+ "convert to inline logical operations"
`(let ((mask (ldb (byte size 0) -1)))
(logior (ash (logand new mask) posn)
(logand int (lognot (ash mask posn))))))
(deftransform %dpb ((new size posn int)
*
(signed-byte #.sb!vm:word-bits))
- "convert to inline logical ops"
+ "convert to inline logical operations"
`(let ((mask (ldb (byte size 0) -1)))
(logior (ash (logand new mask) posn)
(logand int (lognot (ash mask posn))))))
(deftransform %deposit-field ((new size posn int)
*
(unsigned-byte #.sb!vm:word-bits))
- "convert to inline logical ops"
+ "convert to inline logical operations"
`(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand new mask)
(logand int (lognot mask)))))
(deftransform %deposit-field ((new size posn int)
*
(signed-byte #.sb!vm:word-bits))
- "convert to inline logical ops"
+ "convert to inline logical operations"
`(let ((mask (ash (ldb (byte size 0) -1) posn)))
(logior (logand new mask)
(logand int (lognot mask)))))
;;; Handle the case of a constant BOOLE-CODE.
(deftransform boole ((op x y) * * :when :both)
- "convert to inline logical ops"
+ "convert to inline logical operations"
(unless (constant-continuation-p op)
(give-up-ir1-transform "BOOLE code is not a constant."))
(let ((control (continuation-value op)))
;;; If X and Y are the same leaf, then the result is true. Otherwise, if
;;; there is no intersection between the types of the arguments, then the
;;; result is definitely false.
-(deftransform simple-equality-transform ((x y) * * :defun-only t
+(deftransform simple-equality-transform ((x y) * *
+ :defun-only t
:when :both)
(cond ((same-leaf-ref-p x y)
't)
(dolist (x '(eq char= equal))
(%deftransform x '(function * *) #'simple-equality-transform))
-;;; Similar to SIMPLE-EQUALITY-PREDICATE, except that we also try to convert
-;;; to a type-specific predicate or EQ:
-;;; -- If both args are characters, convert to CHAR=. This is better than just
-;;; converting to EQ, since CHAR= may have special compilation strategies
-;;; for non-standard representations, etc.
-;;; -- If either arg is definitely not a number, then we can compare with EQ.
-;;; -- Otherwise, we try to put the arg we know more about second. If X is
-;;; constant then we put it second. If X is a subtype of Y, we put it
-;;; second. These rules make it easier for the back end to match these
-;;; interesting cases.
-;;; -- If Y is a fixnum, then we quietly pass because the back end can handle
-;;; that case, otherwise give an efficency note.
+;;; Similar to SIMPLE-EQUALITY-PREDICATE, except that we also try to
+;;; convert to a type-specific predicate or EQ:
+;;; -- If both args are characters, convert to CHAR=. This is better than
+;;; just converting to EQ, since CHAR= may have special compilation
+;;; strategies for non-standard representations, etc.
+;;; -- If either arg is definitely not a number, then we can compare
+;;; with EQ.
+;;; -- Otherwise, we try to put the arg we know more about second. If X
+;;; is constant then we put it second. If X is a subtype of Y, we put
+;;; it second. These rules make it easier for the back end to match
+;;; these interesting cases.
+;;; -- If Y is a fixnum, then we quietly pass because the back end can
+;;; handle that case, otherwise give an efficency note.
(deftransform eql ((x y) * * :when :both)
"convert to simpler equality predicate"
(let ((x-type (continuation-type x))
(def-source-transform char-equal (&rest args) (multi-compare 'char-equal args nil))
(def-source-transform char-lessp (&rest args) (multi-compare 'char-lessp args nil))
-(def-source-transform char-greaterp (&rest args) (multi-compare 'char-greaterp args nil))
-(def-source-transform char-not-greaterp (&rest args) (multi-compare 'char-greaterp args t))
+(def-source-transform char-greaterp (&rest args)
+ (multi-compare 'char-greaterp args nil))
+(def-source-transform char-not-greaterp (&rest args)
+ (multi-compare 'char-greaterp args t))
(def-source-transform char-not-lessp (&rest args) (multi-compare 'char-lessp args t))
;;; This function does source transformation of N-arg inequality
;;; Do source transformations for transitive functions such as +.
;;; One-arg cases are replaced with the arg and zero arg cases with
-;;; the identity. If Leaf-Fun is true, then replace two-arg calls with
+;;; the identity. If LEAF-FUN is true, then replace two-arg calls with
;;; a call to that function.
(defun source-transform-transitive (fun args identity &optional leaf-fun)
(declare (symbol fun leaf-fun) (list args))
(def-source-transform + (&rest args) (source-transform-transitive '+ args 0))
(def-source-transform * (&rest args) (source-transform-transitive '* args 1))
-(def-source-transform logior (&rest args) (source-transform-transitive 'logior args 0))
-(def-source-transform logxor (&rest args) (source-transform-transitive 'logxor args 0))
-(def-source-transform logand (&rest args) (source-transform-transitive 'logand args -1))
+(def-source-transform logior (&rest args)
+ (source-transform-transitive 'logior args 0))
+(def-source-transform logxor (&rest args)
+ (source-transform-transitive 'logxor args 0))
+(def-source-transform logand (&rest args)
+ (source-transform-transitive 'logand args -1))
(def-source-transform logeqv (&rest args)
(if (evenp (length args))
\f
;;; routines to find things in the Lisp environment
+;;; an alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUNCTION-NAME) for slots
+;;; in a symbol object that we know about
(defparameter *grokked-symbol-slots*
(sort `((,sb!vm:symbol-value-slot . symbol-value)
(,sb!vm:symbol-plist-slot . symbol-plist)
(,sb!vm:symbol-name-slot . symbol-name)
(,sb!vm:symbol-package-slot . symbol-package))
#'<
- :key #'car)
- #!+sb-doc
- "An alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUNCTION-NAME) for slots in a
-symbol object that we know about.")
+ :key #'car))
+;;; Given ADDRESS, try and figure out if which slot of which symbol is
+;;; being referred to. Of course we can just give up, so it's not a
+;;; big deal... Return two values, the symbol and the name of the
+;;; access function of the slot.
(defun grok-symbol-slot-ref (address)
- #!+sb-doc
- "Given ADDRESS, try and figure out if which slot of which symbol is being
- refered to. Of course we can just give up, so it's not a big deal...
- Returns two values, the symbol and the name of the access function of the
- slot."
(declare (type address address))
(if (not (aligned-p address sb!vm:word-bytes))
(values nil nil)
(defvar *address-of-nil-object* (sb!kernel:get-lisp-obj-address nil))
+;;; Given a BYTE-OFFSET from NIL, try and figure out which slot of
+;;; which symbol is being referred to. Of course we can just give up,
+;;; so it's not a big deal... Return two values, the symbol and the
+;;; access function.
(defun grok-nil-indexed-symbol-slot-ref (byte-offset)
- #!+sb-doc
- "Given a BYTE-OFFSET from NIL, try and figure out if which slot of which
- symbol is being refered to. Of course we can just give up, so it's not a big
- deal... Returns two values, the symbol and the access function."
(declare (type offset byte-offset))
(grok-symbol-slot-ref (+ *address-of-nil-object* byte-offset)))
+;;; Return the Lisp object located BYTE-OFFSET from NIL.
(defun get-nil-indexed-object (byte-offset)
- #!+sb-doc
- "Returns the lisp object located BYTE-OFFSET from NIL."
(declare (type offset byte-offset))
(sb!kernel:make-lisp-obj (+ *address-of-nil-object* byte-offset)))
+;;; Return two values; the Lisp object located at BYTE-OFFSET in the
+;;; constant area of the code-object in the current segment and T, or
+;;; NIL and NIL if there is no code-object in the current segment.
(defun get-code-constant (byte-offset dstate)
#!+sb-doc
- "Returns two values; the lisp-object located at BYTE-OFFSET in the constant
- area of the code-object in the current segment and T, or NIL and NIL if
- there is no code-object in the current segment."
(declare (type offset byte-offset)
(type disassem-state dstate))
(let ((code (seg-code (dstate-segment dstate))))
(defvar *assembler-routines-by-addr* nil)
+;;; Return the name of the primitive Lisp assembler routine located at
+;;; ADDRESS, or NIL if there isn't one.
(defun find-assembler-routine (address)
- #!+sb-doc
- "Returns the name of the primitive lisp assembler routine located at
- ADDRESS, or NIL if there isn't one."
(declare (type address address))
(when (null *assembler-routines-by-addr*)
(setf *assembler-routines-by-addr* (make-hash-table))
(setq spec-ll (pop cdr-of-form))
(values name qualifiers spec-ll cdr-of-form)))
-;;; MNA: cmucl-commit: Tue, 19 Dec 2000 06:26:31 -0800 (PST)
-;;; Add a defensive declaration to PARSE-SPECIALIZERS.
-
(defun parse-specializers (specializers)
(declare (list specializers))
(flet ((parse (spec)
(sym (make-instance-function-symbol key)))
(push key *make-instance-function-keys*)
(when sym
- ;; MNA: cmucl-commit Sat, 27 Jan 2001 07:07:45 -0800 (PST)
- ;; Silence compiler warnings about undefined function
- ;; <hairy-make-instance-name>
- ;; when compiling a method containing a make-instance call.
- (progn ;; Lifted from c::%%defun.
- (sb-c::proclaim-as-function-name sym)
- (when (eq (sb-int:info :function :where-from sym) :assumed)
- (setf (sb-int:info :function :where-from sym) :defined)
- (when (sb-int:info :function :assumed-type sym)
- (setf (sb-int:info :function :assumed-type sym) nil))))
+ ;; (famous last words:
+ ;; 1. Don't worry, I know what I'm doing.
+ ;; 2. You and what army?
+ ;; 3. If you were as smart as you think you are, you
+ ;; wouldn't be a copy.
+ ;; This is case #1.:-) Even if SYM hasn't been defined yet,
+ ;; it must be an implementation function, or we we wouldn't
+ ;; have expanded into it. So declare SYM as defined, so that
+ ;; even if it hasn't been defined yet, the user doesn't get
+ ;; obscure warnings about undefined internal implementation
+ ;; functions like HAIRY-MAKE-instance-name.
+ (sb-kernel:become-defined-function-name sym)
`(,sym ',class (list ,@initargs)))))))
(defmacro expanding-make-instance-top-level (&rest forms &environment env)
static void print_obj(char *prefix, lispobj obj);
-#define NEWLINE if (continue_p(1)) newline(NULL); else return;
+#define NEWLINE_OR_RETURN if (continue_p(1)) newline(NULL); else return;
char *lowtag_Names[] = {
"even fixnum",
print_obj("header: ", header);
if (LowtagOf(header) != type_OtherImmediate0 && LowtagOf(header) != type_OtherImmediate1) {
- NEWLINE;
+ NEWLINE_OR_RETURN;
printf("(invalid header object)");
return;
}
switch (type) {
case type_Bignum:
ptr += count;
- NEWLINE;
+ NEWLINE_OR_RETURN;
printf("0x");
while (count-- > 0)
printf("%08lx", (unsigned long) *--ptr);
break;
case type_SingleFloat:
- NEWLINE;
+ NEWLINE_OR_RETURN;
printf("%g", ((struct single_float *)PTR(obj))->value);
break;
case type_DoubleFloat:
- NEWLINE;
+ NEWLINE_OR_RETURN;
printf("%g", ((struct double_float *)PTR(obj))->value);
break;
#ifdef type_LongFloat
case type_LongFloat:
- NEWLINE;
+ NEWLINE_OR_RETURN;
printf("%Lg", ((struct long_float *)PTR(obj))->value);
break;
#endif
#ifdef type_ComplexSingleFloat
case type_ComplexSingleFloat:
- NEWLINE;
+ NEWLINE_OR_RETURN;
printf("%g", ((struct complex_single_float *)PTR(obj))->real);
- NEWLINE;
+ NEWLINE_OR_RETURN;
printf("%g", ((struct complex_single_float *)PTR(obj))->imag);
break;
#endif
#ifdef type_ComplexDoubleFloat
case type_ComplexDoubleFloat:
- NEWLINE;
+ NEWLINE_OR_RETURN;
printf("%g", ((struct complex_double_float *)PTR(obj))->real);
- NEWLINE;
+ NEWLINE_OR_RETURN;
printf("%g", ((struct complex_double_float *)PTR(obj))->imag);
break;
#endif
#ifdef type_ComplexLongFloat
case type_ComplexLongFloat:
- NEWLINE;
+ NEWLINE_OR_RETURN;
printf("%Lg", ((struct complex_long_float *)PTR(obj))->real);
- NEWLINE;
+ NEWLINE_OR_RETURN;
printf("%Lg", ((struct complex_long_float *)PTR(obj))->imag);
break;
#endif
case type_SimpleString:
- NEWLINE;
+ NEWLINE_OR_RETURN;
cptr = (char *)(ptr+1);
putchar('"');
while (length-- > 0)
break;
case type_SimpleVector:
- NEWLINE;
+ NEWLINE_OR_RETURN;
printf("length = %ld", length);
ptr++;
index = 0;
}
break;
- /* MNA: cmucl-commit Tue, 9 Jan 2001 11:46:57 -0800 (PST)
- Correct the printing of instance objects for which the length was
- being incorrectly calculated. */
case type_InstanceHeader:
- NEWLINE;
+ NEWLINE_OR_RETURN;
printf("length = %ld", (long) count);
index = 0;
while (count-- > 0) {
break;
case type_Sap:
- NEWLINE;
+ NEWLINE_OR_RETURN;
#ifndef alpha
printf("0x%08lx", (unsigned long) *ptr);
#else
case type_BaseChar:
case type_UnboundMarker:
- NEWLINE;
+ NEWLINE_OR_RETURN;
printf("pointer to an immediate?");
break;
break;
default:
- NEWLINE;
+ NEWLINE_OR_RETURN;
printf("Unknown header object?");
break;
}
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.11.5"
+"0.6.11.6"
projects / sbcl.git / commitdiff