128:
READ-SEQUENCE doesn't work for Gray streams. (reported by Nathan
- Froyd sbcl-devel 2001-10-15)
-
+ Froyd sbcl-devel 2001-10-15) As per subsequent discussion on the
+ list, the Gray streams proposal doesn't mention READ-SEQUENCE and
+ WRITE-SEQUENCE because it predates them, generalizing it to
+ cover them is an obvious extension, ACL does it, and there's a
+ patch for for CMU CL which does it too.
+
+129:
+ insufficient syntax checking in MACROLET:
+ (defun foo (x)
+ (macrolet ((defmacro bar (z) `(+ z z)))
+ (bar x)))
+ shouldn't compile without error (because of the extra DEFMACRO symbol).
KNOWN BUGS RELATED TO THE IR1 INTERPRETER
advantage of the new EVAL-WHEN stuff and to clean them up in
general, and they are now more ANSI-compliant in a number of
ways. Martin Atzmueller is responsible for a lot of this.
-?? Inlining can now be controlled the ANSI way, without
- MAYBE-INLINE, since the idiom
- (DECLAIM (INLINE FOO))
- (DEFUN FOO (..) ..)
- (DECLAIM (NOTINLINE FOO))
- (DEFUN BAR (..) (FOO ..))
- (DEFUN BLETCH (..) (DECLARE (INLINE FOO)) (FOO ..))
- now does what ANSI says it should. The CMU-CL-style
- SB-EXT:MAYBE-INLINE declaration is now deprecated and ignored.
* A bug in LOOP operations on hash tables has been fixed, thanks
to a bug report and patch from Alexey Dejneka.
* PPRINT-LOGICAL-BLOCK now copies the *PRINT-LINES* value on entry
a number of bugs which came into existence in the pre7 branch
(internal to the CVS repository), so that they never showed
up in release versions.
-?? Old operator names in the style DEF-FOO are now deprecated in favor
- of new corresponding names DEFINE-FOO, for consistency with the
- naming convention used in the ANSI standard). This mostly affects
- internal symbols, but a few external symbols like
- SB-ALIEN:DEF-ALIEN-FUNCTION are also affected.
* :SB-CONSTRAIN-FLOAT-TYPE, :SB-PROPAGATE-FLOAT-TYPE, and
:SB-PROPAGATE-FUN-TYPE are no longer considered to be optional
features. Instead, the code that they used to control is always
built into the system.
-?? The value of INTERNAL-TIME-UNITS-PER-SECOND has been increased
- from 100 to 1000.
-* The default value of *BYTES-CONSED-BETWEEN-GCS* has been
- doubled, to 4 million. (If your application spends a lot of time
- GCing and you have a lot of RAM, you might want to experiment with
- increasing it even more.)
+?? minor incompatible change: The debugger prompt sequence now goes
+ "5]", "5[2]", "5[3]", etc. as you get deeper into recursive calls
+ to the debugger command loop, instead of the old "5]", "5]]",
+ "5]]]" sequence. (I was motivated to do this when squabbles between
+ ILISP and SBCL left me very deeply nested in the debugger. In the
+ short term, this change will probably provoke more ILISP/SBCL
+ squabbles, but hopefully it will be an improvement in the long run.)
+?? minor incompatible change: The default output representation for
+ unprintable ASCII characters which, unlike e.g. #\Newline, don't
+ have names defined in the ANSI Common Lisp standard, is now based
+ on their ASCII symbolic names: #\Nul, #\Soh, #\Stx, etc.
+?? Old operator names in the style DEF-FOO are now deprecated in
+ favor of new corresponding names DEFINE-FOO, for consistency with
+ the naming convention used in the ANSI standard (DEFSTRUCT, DEFVAR,
+ DEFINE-CONDITION, DEFINE-MODIFY-MACRO..). This mostly affects
+ internal symbols, but a few external symbols like
+ SB-ALIEN:DEF-ALIEN-FUNCTION are also affected.
* minor incompatible change: DEFINE-ALIEN-FUNCTION (also known by
the old deprecated name DEF-ALIEN-FUNCTION) now does DECLAIM FTYPE
for the defined function, since declaiming return types involving
to efficient compilation of code which calls such functions (and
since people writing calls-to-C code aren't likely to be bothered
by implicit assumptions of static typing).
+* The value of INTERNAL-TIME-UNITS-PER-SECOND has been increased
+ from 100 to 1000.
+* The default value of *BYTES-CONSED-BETWEEN-GCS* has been
+ doubled, to 4 million. (If your application spends a lot of time
+ GCing and you have a lot of RAM, you might want to experiment with
+ increasing it even more.)
* The interpreter, EVAL, has been rewritten. Now it calls the
native compiler for the difficult cases, where it used to call
the old specialized IR1 interpreter code.
are more systematic and consistent, converting C macros to inline
functions, systematizing indentation, making symbol packaging
more logical, and so forth
-* The fasl file version number changed again, for about a dozen
- reasons, some of which are apparent above.
+* The fasl file version number changed again, for dozens of reasons,
+ some of which are apparent above.
planned incompatible changes in 0.7.x:
-* The debugger prompt sequence now goes "5]", "5[2]", "5[3]", etc.
- as you get deeper into recursive calls to the debugger command loop,
- instead of the old "5]", "5]]", "5]]]" sequence. (I was motivated
- to do this when squabbles between ILISP and SBCL left me
- very deeply nested in the debugger.)
-* The default output representation for unprintable ASCII characters
- which, unlike e.g. #\Newline, don't have names defined in the
- ANSI Common Lisp standard, may change to their ASCII symbolic
- names: #\Nul, #\Soh, #\Stx, etc.
-* INTERNAL-TIME-UNITS-PER-SECOND might increase, e.g. to 1000.
-* FASL file extensions change to ".fasl", instead of the various
- CPU-dependent values (".x86f", ".axpf", etc.) inherited from CMU CL.
-* MAYBE-INLINE will probably go away at some point, maybe 0.7.x,
- maybe later, in favor of the ANSI-recommended idiom for making
- a function optionally inline.
* When the profiling interface settles down, maybe in 0.7.x, maybe
later, it might impact TRACE. They both encapsulate functions, and
it's not clear yet how e.g. UNPROFILE will interact with TRACE
and UNTRACE. (This shouldn't matter, though, unless you are
using profiling. If you never profile anything, TRACE should
continue to behave as before.)
-* The BYTE-COMPILE &KEY argument for COMPILE-FILE is deprecated,
- since this behavior can be controlled by (DECLAIM (OPTIMIZE (SPEED 0))).
- ("An ounce of orthogonality is worth a pound of features.")
+?? Inlining can now be controlled the ANSI way, without
+ MAYBE-INLINE, since the idiom
+ (DECLAIM (INLINE FOO))
+ (DEFUN FOO (..) ..)
+ (DECLAIM (NOTINLINE FOO))
+ (DEFUN BAR (..) (FOO ..))
+ (DEFUN BLETCH (..) (DECLARE (INLINE FOO)) (FOO ..))
+ now does what ANSI says it should. The CMU-CL-style
+ SB-EXT:MAYBE-INLINE declaration is now deprecated and ignored.
- Accumulation of half-understood design decisions eventually
- chokes a program as a water weed chokes a canal. By refactoring
- you can ensure that your full understanding of how the program
- should be designed is always reflected in the program. As a
- water weed quickly spreads its tendrils, partially understood
- design decisions quickly spread their effects throughout your
- program. No one or two or even ten individual actions will be
- enough to eradicate the problem.
- -- Martin Fowler, _Refactoring: Improving the Design
- of Existing Code_, p. 360
-===============================================================================
-some things that I'd like to do in 0.6.x, in no particular order:
--------------------------------------------------------------------------------
-PROBLEM:
- As long as I'm working on the batch-related command-line options,
- it would be reasonable to add one more option to "do what I'd want",
- testing standard input for non-TTY-ness and running in no-programmer
- mode if so.
-FIX:
- ?? Do it.
--------------------------------------------------------------------------------
-PROBLEM:
- I used CMU CL for years, and dozens of times I cursed the
- inadequate breakpoint-based TRACE facility which doesn't work on
- some functions, and I never realized that there's a wrapper-based
- facility too until I was wading through the source code for SBCL.
- Yes, I know I should have RTFM, but there is a lot of M..
- (By the way, it would also be nice to have tracing behave
- better with generic functions. TRACEing a generic function probably
- shouldn't prevent DEFMETHOD from being used to redefine its
- methods, and should perhaps trace each of its methods as well
- as the generic function itself.)
-FIX:
- ?? possibility 1: Add error-handling code in ntrace.lisp to
- catch failure to set breakpoints and retry using
- wrapper-based tracing.
- ?? possibility 2: Add error-handling code in ntrace.lisp to
- catch failure to catch failure to set breakpoints and output
- a message suggesting retrying with wrapper-based breakpoints
- ?? possibility 3: Fix the breakpoint-based TRACE facility so that
- it always works.
--------------------------------------------------------------------------------
-PROBLEM:
- My system of parallel build directories seems to add
- complexity without adding value.
-FIX:
- ?? Replace it with a system where fasl output files live in the
- same directories as the sources and have names a la
- "foo.fasl-from-host and "foo.fasl-from-xc".
- ?? (Perhaps something else will be required in order to port
- to Microsoft Windows, since its filesystem doesn't have
- symbolic links.)
--------------------------------------------------------------------------------
-PROBLEM:
- It might be good to use the syntax (DEBUGGER-SPECIAL *PRINT-LEVEL*)
- etc. to control the in-the-debug-context special variables. Then we
- wouldn't have to pick and choose which variables we shadow in the
- debugger.
- The shadowing values could also be made persistent between
- debugger invocations, so that entering the debugger, doing
- (SETF *PRINT-LEVEL* 2), and exiting the debugger would leave
- (DEBUGGER-SPECIAL *PRINT-LEVEL*) set to 2, and upon reentry to the
- debugger, *PRINT-LEVEL* would be set back to 2.
-FIX:
- ??
--------------------------------------------------------------------------------
-PROBLEM:
- I still haven't cleaned up the cut-and-paste programming in
- * DEF-BOOLEAN-ATTRIBUTE, DELETEF-IN, and PUSH-IN
- * SB!SYS:DEF!MACRO ASSEMBLE and SB!XC:DEFMACRO ASSEMBLE
-FIX:
- ??
--------------------------------------------------------------------------------
-PROBLEM:
- We be able to get rid of the IR1 interpreter, which would
- not only get rid of all the code in *eval*.lisp, but also allow us to
- reduce the number of special cases elsewhere in the system. (Try
- grepping for 'interpret' sometime.:-) Making this usable might
- require cleaning up %DEFSTRUCT, %DEFUN, etc. to use EVAL-WHEN
- instead of IR1 transform magic, which would be a good
- thing in itself, but might be a fair amount of work.)
-FIX:
- ?? Delete, delete, delete.
-===============================================================================
-other known issues with no particular target date:
+for 0.7.0:
-bugs listed on the man page
+* filed off the roughest edges (or, perhaps, at least hammered down the
+ protruding rusty nails and snipped off the trailing razor wire,
+ leaving some filing for later:-) from the monster
+ EVAL/EVAL-WHEN/%COMPILE/DEFUN/DEFSTRUCT cleanup:
+ ** substantially rewrote DEFSTRUCT implementation to work
+ cleanly with EVAL-WHEN, not sleazily use DEFUN for
+ structure functions, implement out-of-line structure
+ accessors as closures, reduce or eliminate non-ANSI
+ magicality of structure functions
+ *** made structure type tests work again
+ *** got rid of bogus warnings about "redefinition" of
+ structure accessors
+ ** made inlining DEFUN inside MACROLET work again
+ ** made %COMPILE set up debugging data more like the way the
+ debugger expects (and maybe even completely
+ correctly:-)
+* incompatible changes listed in NEWS:
+ ** changed debugger prompt to "5]", "5[2]", "5[3]", etc.
+ ** changed default output representation of *PRINT-ESCAPE*-ed
+ unprintable ASCII characters to #\Nul, #\Soh, etc.
+* some easy FIXMEs with high disruptive potential:
+ ** Search lists go away.
+ ** Grep for ~D and and change most of them to ~S.
+* more renaming in global external names:
+ ** used DEFINE-THE-FOO-THING and DEFFOO style consistently (and
+ deprecated supported extensions named in the DEF-FOO
+ style, e.g. SB-ALIEN:DEF-ALIEN-ROUTINE)
+ ** reserved DO-FOO-style names for iteration macros
+ ** finished s/FUNCTION/FUN/
+ ** s/VARIABLE/VAR/
+ ** s/TOPLEVEL/TOP-LEVEL/
+* global style systematization:
+ ** s/#'(lambda/(lambda/
+ ** four-space indentation in C
+=======================================================================
+for early 0.7.x:
-more regression tests
+* building with CLISP (or explaining why not)
+* faster bootstrapping (both make.sh and slam.sh)
+ ** added mechanisms for automatically finding dead code, and
+ used them to remove dead code
+ ** moved stuff from warm init into cold init where possible
+ (so that slam.sh will run faster and also just because
+ ideally everything would be in cold init)
+ ** profiled and tweaked
+* more EVAL/EVAL-WHEN/%COMPILE/DEFUN/DEFSTRUCT cleanup:
+ ** made %COMPILE understand magicality of DEFUN FOO
+ w.r.t. e.g. preexisting inlineness of FOO
+ ** used %COMPILE where COMPILE-TOP-LEVEL used to be used
+ ** removed now-redundant COMPILE-TOP-LEVEL and
+ FUNCTIONAL-KIND=:TOP-LEVEL stuff from the compiler
+ ** made FUNCTION-NAME logic work on closures, so that
+ various public functions like CL:PACKAGEP which
+ are now implemented as closures (because
+ they're structure slot accessors) won't be so
+ nasty in the debugger
+* rewrote long-standing confusing error restarts for redefining
+ DEFSTRUCTs
+* outstanding embarrassments
+ ** cut-and-pasted DEF-BOOLEAN-ATTRIBUTE (maybe easier to fix
+ now that EVAL-WHEN does what it should..)
+ ** incomplete manual
+ ** :IGNORE-ERRORS-P cruft in stems-and-flags.lisp-expr
+ ** weird double-loading (first in GENESIS, then in warm init)
+ of src/assembly/target/*.lisp stuff, and the associated
+ weirdness of the half-baked state (compiler almost but
+ not quite ready for prime time..) of the system after
+ cold init
+* fixups now feasible because of pre7 changes
+ ** ANSIfied DECLAIM INLINE stuff (deprecating MAYBE-INLINE)
+* miscellaneous simple refactoring
+ * belated renaming:
+ ** renamed %PRIMITIVE to %VOP
+ * These days ANSI C has inline functions, so..
+ ** redid many cpp macros as inline functions:
+ HeaderValue, Pointerp, CEILING, ALIGNED_SIZE,
+ GET_FREE_POINTER, SET_FREE_POINTER,
+ GET_GC_TRIGGER, SET_GC_TRIGGER, GetBSP, SetBSP,
+ os_trunc_foo(), os_round_up_foo()
+ ** removed various avoid-evaluating-C-macro-arg-twice
+ cruft
+* added mechanisms for automatically finding dead symbols is
+ package-data.lisp-expr (i.e. those symbols not bound,
+ fbound, defined as types, or whatever), and used them
+ to remove dead symbols
+* made system handle stack overflow safely unless SAFETY is dominated
+ by SPEED or SPACE
+=======================================================================
+for 1.0:
-byte compilation of appropriate parts of the system, so that the
-system core isn't so big
+* refactored in preparation for moving CLOS into cold init and merging
+ SB-PCL:FOO with CL:FOO (for FOO=CLASS, FOO=CLASS-OF, etc.)
+ ** systematized support for MOP (new regression tests, maybe
+ new SB-MOP package..) to try to make sure things don't
+ get mislaid in the upcoming CLOS restructuring
+ ** extracted type system from SB-KERNEL into new SB-TYPE
+ package
+ ** reimplemented GENERIC-FUNCTION as a primitive object (or
+ maybe made SB-MOP:FUNCALLABLE-STANDARD-OBJECT the
+ primitive object, and then let GENERIC-FUNCTIONs
+ inherit from that) instead of structures with
+ :ALTERNATE-METACLASS and funcallableness. Now
+ FUNCALLABLE-INSTANCE can go away. (And now the new
+ funcallable primitive objects need to go into
+ collections like *FUN-HEADER-WIDETAGS* where
+ FUNCALLABLE-INSTANCE objects used to be.)
+ ** reimplemented CONDITIONs as primitive objects instead of
+ structures with :ALTERNATE-METACLASS. Now (between
+ this and the change to GENERIC-FUNCTIONs)
+ DEFSTRUCT :ALTERNATE-METACLASS can go away.
+ ** (maybe) Now INSTANCE_POINTER_LOWTAG can become just
+ STRUCTURE_POINTER_LOWTAG, and the concept of
+ SB-KERNEL:INSTANCE (including INSTANCEP,
+ (SPECIFIER-TYPE 'INSTANCE), etc.) can go away.
+* moved CLOS into cold init, in order to allow CLOS to be used in the
+ implementation of the core system (e.g. the type system and the
+ compiler) and in order to support merger of CL:CLASS with
+ SB-PCL:CLASS
+* (maybe) eliminated warm init altogether in favor of cold init
+* (maybe, especially if warm init can be eliminated) rationalized
+ the build process, fixing miscellaneous pre-0.5.0 stuff that's
+ transparently not the right thing
+ ** removed separate build directories, now just building in
+ place with .sbclcoldfasl extensions
+* (maybe) more refactoring in preparation for merging SB-PCL:FOO
+ into CL:FOO: reimplemented type system OO dispatch
+ (!DEFINE-TYPE-METHOD, etc.) in terms of CLOS OO dispatch
+* merged SB-PCL:FOO into CL:FOO (and similarly CLASS-OF, etc.)
+* added some automatic tests for basic binary compatibility, in hopes
+ that it might be practical to maintain binary compatibility
+ between minor maintenance releases on the stable branch (but no
+ promises, sorry, since I've never tried to do this before, and
+ have no idea how much of a pain this'll be)
+=======================================================================
+other priorities, no particular time:
-Search for unused external symbols (ones which are not bound, fbound,
-types, or whatever, and also have no other uses as e.g. flags) and
-delete them. This should make the system core a little smaller, but
-is mostly useful just to make the source code smaller and simpler.
+* bug fixes, especially really annoying bugs (ANSI or not) and any
+ ANSI bugs (i.e. not just bugs in extras like the debugger or
+ "declarations are assertions", but violations of the standard)
+* better communication with the outside world (scratching WHN's
+ personal itch): I don't want socket-level stuff so much as I
+ want RPC-level or higher (CORBA?) interfaces and (possibly
+ through RPC or CORBA) GUI support
+=======================================================================
+important but out of scope (for WHN, anyway: Patches from other people
+are still welcome!) until after 1.0:
+ * DYNAMIC-EXTENT
+ * sadly deteriorated support for ANSI-style block compilation
+ (static linking of DEFUNs within a single file or
+ WITH-COMPILATION-UNIT)
+ * various GC issues (exuberant cut-and-paste coding,
+ possibly dangerously over-conservative handling
+ of neighbors of function objects, general GC efficiency)
+ * package issues other than SB!TYPE, SB!MOP, and dead exported
+ symbols
+ * Any systematic effort to fix compiler consistency checks is
+ out of scope. (However, it still might be possible to
+ determine that some or all of them are hopelessly stale
+ and delete them.)
+===============================================================================
+other known issues with no particular target date:
-adding new FOPs to provide something like CMU CL's FOP-SYMBOL-SAVE and
-FOP-SMALL-SYMBOL-SAVE functionality, so that fasl files will be more
-compact. (FOP-SYMBOL-SAVE used *PACKAGE*, which was concise but allowed
-obscure bugs. Something like FOP-LAST-PACKAGE-SYMBOL-SAVE could have
-much of the same conciseness advantage without the bugs.)
+bugs listed on the man page
hundreds of FIXME notes in the sources from WHN
(Things marked as KLUDGE are in general things which are ugly or
confusing, but that, for whatever reason, may stay that way
indefinitely.)
+=======================================================================
+"There's nothing an agnostic can't do as long as he doesn't know
+whether he believes in anything or not."
+ -- Monty Python.
+
+"God grant me serenity to accept the code I cannot change, courage to
+change the code I can, and wisdom to know the difference."
+ -- Erik Naggum
+
+"Accumulation of half-understood design decisions eventually chokes a
+program as a water weed chokes a canal. By refactoring you can ensure
+that your full understanding of how the program should be designed is
+always reflected in the program. As a water weed quickly spreads its
+tendrils, partially understood design decisions quickly spread their
+effects throughout your program. No one or two or even ten individual
+actions will be enough to eradicate the problem."
+ -- Martin Fowler, in _Refactoring: Improving the Design of Existing
+ Code_, p. 360
+
+"I wish I didn't know now what I didn't know then."
+ -- Bob Seger
;; anyone who wants to collect such statistics in the future.
; :sb-dyncount
- ;; Peter Van Eynde's increase-bulletproofness code
+ ;; Peter Van Eynde's increase-bulletproofness code for CMU CL
;;
- ;; This is not maintained or tested in current SBCL, but I haven't
- ;; gone out of my way to remove or break it, either.
+ ;; Some of the code which was #+high-security before the fork has now
+ ;; been either made unconditional, deleted, or rewritten into
+ ;; unrecognizability, but some remains. What remains is not maintained
+ ;; or tested in current SBCL, but I haven't gone out of my way to
+ ;; break it, either.
;;
; :high-security
; :high-security-support
;; Until PRINT-OBJECT and other machinery is set up,
;; we want limits on printing to avoid infinite output.
+ ;; (Don't forget to undo these tweaks after the printer
+ ;; is set up. It'd be cleaner to use LET to make sure
+ ;; that happens automatically, but LET is implemented
+ ;; in terms of the compiler, and the compiler isn't
+ ;; initialized yet.)
(setq *print-length* 10)
(setq *print-level* 5)
#-sb-fluid (sb-impl::!unintern-init-only-stuff)
;; Now that the whole system is built, we don't need to
- ;; hobble the printer any more.
+ ;; hobble the printer any more, so we can restore printer
+ ;; control variables to their ANSI defaults.
(setq *print-length* nil)
(setq *print-level* nil)
-\#!/bin/sh
+#!/bin/sh
# "When we build software, it's a good idea to have a reliable method
# for getting an executable from it. We want any two reconstructions
"LIST-WITH-LENGTH-P"
"READ-SEQUENCE-OR-DIE"
"RENAME-KEY-ARGS"
- "REQUIRED-ARGUMENT"
+ "MISSING-ARG"
"UNIX-NAMESTRING" ; FIXME: perhaps belongs in package SB!UNIX
"FEATUREP"
"FLUSH-STANDARD-OUTPUT-STREAMS"
"DATA-VECTOR-REF" "DATA-VECTOR-SET" "DECODE-DOUBLE-FLOAT"
"DECODE-LONG-FLOAT" "DECODE-SINGLE-FLOAT"
"DEFINED-FTYPE-MATCHES-DECLARED-FTYPE-P"
+ "!DEFSTRUCT-WITH-ALTERNATE-METACLASS"
"DESCEND-INTO"
"DIVISION-BY-ZERO-ERROR"
"DOUBLE-FLOAT-EXPONENT" "DOUBLE-FLOAT-HIGH-BITS"
"FUN-TYPE-RETURNS" "FUN-TYPE-WILD-ARGS"
"FUN-WORD-OFFSET" "GET-CLOSURE-LENGTH"
"GET-HEADER-DATA"
- "GET-LISP-OBJ-ADDRESS" "GET-LOWTAG"
- "GET-TYPE"
+ "GET-LISP-OBJ-ADDRESS" "LOWTAG-OF"
+ "WIDETAG-OF"
"HAIRY-DATA-VECTOR-REF" "HAIRY-DATA-VECTOR-SET" "HAIRY-TYPE"
"HAIRY-TYPE-CHECK-TEMPLATE-NAME" "HAIRY-TYPE-SPECIFIER"
"HANDLE-CIRCULARITY" "IGNORE-IT"
(defun array-element-type (array)
#!+sb-doc
"Return the type of the elements of the array"
- (let ((type (get-type array)))
+ (let ((widetag (widetag-of array)))
(macrolet ((pick-element-type (&rest stuff)
`(cond ,@(mapcar #'(lambda (stuff)
(cons
t)
((listp item)
(cons 'or
- (mapcar #'(lambda (x)
- `(= type ,x))
+ (mapcar (lambda (x)
+ `(= widetag ,x))
item)))
(t
- `(= type ,item))))
+ `(= widetag ,item))))
(cdr stuff)))
stuff))))
;; FIXME: The data here are redundant with
(clos-hash-6 (random-layout-clos-hash) :type index)
(clos-hash-7 (random-layout-clos-hash) :type index)
;; the class that this is a layout for
- (class (required-argument)
+ (class (missing-arg)
;; FIXME: Do we really know this is a CL:CLASS? Mightn't it
;; be a SB-PCL:CLASS under some circumstances? What goes here
;; when the LAYOUT is in fact a PCL::WRAPPER?
ARGUMENTS. If the condition is not handled, NIL is returned. If
(TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked
before any signalling is done."
+ (/noshow0 "entering SIGNAL")
(let ((condition (coerce-to-condition datum
arguments
'simple-condition
(let ((old-bos *break-on-signals*)
(*break-on-signals* nil))
(when (typep condition old-bos)
+ (/noshow0 "doing BREAK in because of *BREAK-ON-SIGNALS*")
(break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* (now NIL)."
condition)))
(loop
- (unless *handler-clusters* (return))
+ (unless *handler-clusters*
+ (/noshow0 "leaving LOOP because of unbound *HANDLER-CLUSTERS*")
+ (return))
(let ((cluster (pop *handler-clusters*)))
+ (/noshow0 "got CLUSTER=..")
+ (/nohexstr cluster)
(dolist (handler cluster)
+ (/noshow0 "looking at HANDLER=..")
+ (/nohexstr handler)
(when (typep condition (car handler))
(funcall (cdr handler) condition)))))
+
+ (/noshow0 "returning from SIGNAL")
nil))
-;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and
-;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a
-;;; single argument that's directly usable by all the other routines.
+;;; a utility for SIGNAL, ERROR, CERROR, WARN, and INVOKE-DEBUGGER:
+;;; Parse the hairy argument conventions into a single argument that's
+;;; directly usable by all the other routines.
(defun coerce-to-condition (datum arguments default-type fun-name)
(cond ((typep datum 'condition)
(if arguments
(defun error (datum &rest arguments)
#!+sb-doc
- "Invoke the signal facility on a condition formed from datum and arguments.
- If the condition is not handled, the debugger is invoked."
+ "Invoke the signal facility on a condition formed from DATUM and ARGUMENTS.
+ If the condition is not handled, the debugger is invoked."
(/show0 "entering ERROR, argument list=..")
(/hexstr arguments)
- (/show0 "printing ERROR arguments one by one..")
+
+ (/show0 "cold-printing ERROR arguments one by one..")
#!+sb-show (dolist (argument arguments)
(sb!impl::cold-print argument))
+ (/show0 "done cold-printing ERROR arguments")
+
(sb!kernel:infinite-error-protect
(let ((condition (coerce-to-condition datum arguments
'simple-error 'error))
(sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
+ (/show0 "done coercing DATUM to CONDITION")
(let ((sb!debug:*stack-top-hint* nil))
+ (/show0 "signalling CONDITION from within ERROR")
(signal condition))
+ (/show0 "done signalling CONDITION within ERROR")
(invoke-debugger condition))))
(defun cerror (continue-string datum &rest arguments)
;;; like BREAK, but without rebinding *DEBUGGER-HOOK* to NIL, so that
;;; we can use it in system code (e.g. in SIGINT handling) without
;;; messing up --noprogrammer mode (which works by setting
-;;; *DEBUGGER-HOOK*)
+;;; *DEBUGGER-HOOK*); or for that matter, without messing up ordinary
+;;; applications which try to do similar things with *DEBUGGER-HOOK*
(defun %break (what &optional (datum "break") &rest arguments)
(sb!kernel:infinite-error-protect
(with-simple-restart (continue "Return from ~S." what)
"Warn about a situation by signalling a condition formed by DATUM and
ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
exists that causes WARN to immediately return NIL."
- (/noshow0 "entering WARN")
+ (/show0 "entering WARN")
;; KLUDGE: The current cold load initialization logic causes several calls
;; to WARN, so we need to be able to handle them without dying. (And calling
;; FORMAT or even PRINC in cold load is a good way to die.) Of course, the
#!+sb-show (dolist (argument arguments)
(sb!impl::cold-print argument)))
(sb!kernel:infinite-error-protect
+ (/show0 "doing COERCE-TO-CONDITION")
(let ((condition (coerce-to-condition datum arguments
'simple-warning 'warn)))
+ (/show0 "back from COERCE-TO-CONDITION, doing ENFORCE-TYPE")
(enforce-type condition warning)
+ (/show0 "back from ENFORCE-TYPE, doing RESTART-CASE MUFFLE-WARNING")
(restart-case (signal condition)
(muffle-warning ()
:report "Skip warning."
(return-from warn nil)))
+ (/show0 "back from RESTART-CASE MUFFLE-WARNING (i.e. normal return)")
+
(let ((badness (etypecase condition
(style-warning 'style-warning)
(warning 'warning))))
+ (/show0 "got BADNESS, calling FORMAT")
(format *error-output*
"~&~@<~S: ~3i~:_~A~:>~%"
badness
- condition)))))
+ condition)
+ (/show0 "back from FORMAT, voila!")))))
nil)
\f
;;;; the CONDITION class
-(/show0 "late-target-error.lisp 20")
+(/show0 "condition.lisp 20")
(eval-when (:compile-toplevel :load-toplevel :execute)
+(/show0 "condition.lisp 24")
+
(def!struct (condition-class (:include slot-class)
(:constructor bare-make-condition-class))
;; list of CONDITION-SLOT structures for the direct slots of this
(report nil :type (or function null))
;; list of alternating initargs and initforms
(default-initargs () :type list)
- ;; class precedence list as a list of class objects, with all
- ;; non-condition classes removed
+ ;; class precedence list as a list of CLASS objects, with all
+ ;; non-CONDITION classes removed
(cpl () :type list)
;; a list of all the effective instance allocation slots of this
;; class that have a non-constant initform or default-initarg.
;; environment of MAKE-CONDITION.
(hairy-slots nil :type list))
+(/show0 "condition.lisp 49")
+
(defun make-condition-class (&rest rest)
(apply #'bare-make-condition-class
(rename-key-args '((:name :%name)) rest)))
+(/show0 "condition.lisp 53")
+
) ; EVAL-WHEN
-(defstruct (condition
- (:constructor make-condition-object (actual-initargs))
- (:alternate-metaclass instance
- condition-class
- make-condition-class)
- (:copier nil))
- ;; actual initargs supplied to MAKE-CONDITION
- (actual-initargs (required-argument) :type list)
- ;; a plist mapping slot names to any values that were assigned or
- ;; defaulted after creation
- (assigned-slots () :type list))
+(!defstruct-with-alternate-metaclass condition
+ :slot-names (actual-initargs assigned-slots)
+ :boa-constructor %make-condition-object
+ :superclass-name instance
+ :metaclass-name condition-class
+ :metaclass-constructor make-condition-class
+ :dd-type structure)
+
+(defun make-condition-object (actual-initargs)
+ (%make-condition-object actual-initargs nil))
(defstruct (condition-slot (:copier nil))
- (name (required-argument) :type symbol)
+ (name (missing-arg) :type symbol)
;; list of all applicable initargs
- (initargs (required-argument) :type list)
+ (initargs (missing-arg) :type list)
;; names of reader and writer functions
- (readers (required-argument) :type list)
- (writers (required-argument) :type list)
+ (readers (missing-arg) :type list)
+ (writers (missing-arg) :type list)
;; true if :INITFORM was specified
- (initform-p (required-argument) :type (member t nil))
+ (initform-p (missing-arg) :type (member t nil))
;; If this is a function, call it with no args. Otherwise, it's the
;; actual value.
- (initform (required-argument) :type t)
+ (initform (missing-arg) :type t)
;; allocation of this slot, or NIL until defaulted
(allocation nil :type (member :instance :class nil))
;; If ALLOCATION is :CLASS, this is a cons whose car holds the value.
;;; from CMU CL, and didn't seem to be explained there, and I haven't
;;; figured out whether it's right. -- WHN 19990612
(eval-when (:compile-toplevel :load-toplevel :execute)
+ (/show0 "condition.lisp 103")
(let ((condition-class (locally
;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for
;; constant class names which creates fast but
(declare (notinline sb!xc:find-class))
(sb!xc:find-class 'condition))))
(setf (condition-class-cpl condition-class)
- (list condition-class))))
+ (list condition-class)))
+ (/show0 "condition.lisp 103"))
(setf (condition-class-report (locally
;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM
"Transfer control and VALUE to a restart named USE-VALUE, or return NIL if
none exists."))
-(/show0 "late-target-error.lisp end of file")
+(/show0 "condition.lisp end of file")
;;; a problem, there are possible workarounds involving portable
;;; representations for target floating point numbers, like
;;; (DEFSTRUCT TARGET-SINGLE-FLOAT
-;;; (SIGN (REQUIRED-ARGUMENT) :TYPE BIT)
-;;; (EXPONENT (REQUIRED-ARGUMENT) :TYPE UNSIGNED-BYTE)
-;;; (MANTISSA (REQUIRED-ARGUMENT) :TYPE UNSIGNED-BYTE))
+;;; (SIGN (MISSING-ARG) :TYPE BIT)
+;;; (EXPONENT (MISSING-ARG) :TYPE UNSIGNED-BYTE)
+;;; (MANTISSA (MISSING-ARG) :TYPE UNSIGNED-BYTE))
;;; with some sort of MAKE-LOAD-FORM-ish magic to cause them to be
;;; written out in the appropriate target format. (And yes, those
;;; workarounds *do* look messy to me, which is why I just went
#-sb-xc-host (:pure t))
;; The name of this function. If from a DEFUN, etc., then this is the
;; function name, otherwise it is a descriptive string.
- (name (required-argument) :type (or simple-string cons symbol))
+ (name (missing-arg) :type (or simple-string cons symbol))
;; The kind of function (same as FUNCTIONAL-KIND):
(kind nil :type (member nil :optional :external :top-level :cleanup))
;; a description of variable locations for this function, in alphabetical
;; in order to save space, we elected not to store a vector.
(returns :fixed :type (or (simple-array * (*)) (member :standard :fixed)))
;; SC-Offsets describing where the return PC and return FP are kept.
- (return-pc (required-argument) :type sc-offset)
- (old-fp (required-argument) :type sc-offset)
+ (return-pc (missing-arg) :type sc-offset)
+ (old-fp (missing-arg) :type sc-offset)
;; SC-Offset for the number stack FP in this function, or NIL if no NFP
;; allocated.
(nfp nil :type (or sc-offset null))
;; The earliest PC in this function at which the environment is properly
;; initialized (arguments moved from passing locations, etc.)
- (start-pc (required-argument) :type index)
+ (start-pc (missing-arg) :type index)
;; The start of elsewhere code for this function (if any.)
- (elsewhere-pc (required-argument) :type index))
+ (elsewhere-pc (missing-arg) :type index))
\f
;;;; minimal debug function
;; This slot indicates where the definition came from:
;; :FILE - from a file (i.e. COMPILE-FILE)
;; :LISP - from Lisp (i.e. COMPILE)
- (from (required-argument) :type (member :file :lisp))
+ (from (missing-arg) :type (member :file :lisp))
;; If :FILE, the file name, if :LISP or :STREAM, then a vector of
;; the top-level forms. When from COMPILE, form 0 is #'(LAMBDA ...).
(name nil)
;; unavailable
(created nil :type (or unsigned-byte null))
;; the universal time that the source was compiled
- (compiled (required-argument) :type unsigned-byte)
+ (compiled (missing-arg) :type unsigned-byte)
;; the source path root number of the first form read from this
;; source (i.e. the total number of forms converted previously in
;; this compilation)
(def!struct debug-info
;; Some string describing something about the code in this component.
- (name (required-argument) :type simple-string)
+ (name (missing-arg) :type simple-string)
;; A list of DEBUG-SOURCE structures describing where the code for this
;; component came from, in the order that they were read.
;;
;; always careful to put our code in low memory. Is that how it
;; works? Would this break if we used a more general memory map? --
;; WHN 20000120
- (fun-map (required-argument) :type simple-vector :read-only t))
+ (fun-map (missing-arg) :type simple-vector :read-only t))
(defstruct (debug-var (:constructor nil)
(:copier nil))
;; the name of the variable
- (symbol (required-argument) :type symbol)
+ (symbol (missing-arg) :type symbol)
;; a unique integer identification relative to other variables with the same
;; symbol
(id 0 :type index)
(if (functionp object)
(or (fun-code-header object)
:undefined-function)
- (let ((lowtag (get-lowtag object)))
+ (let ((lowtag (lowtag-of object)))
(if (= lowtag sb!vm:other-pointer-lowtag)
- (let ((type (get-type object)))
- (cond ((= type sb!vm:code-header-widetag)
+ (let ((widetag (widetag-of object)))
+ (cond ((= widetag sb!vm:code-header-widetag)
object)
- ((= type sb!vm:return-pc-header-widetag)
+ ((= widetag sb!vm:return-pc-header-widetag)
(lra-code-header object))
(t
nil))))))))
;;; Return a DEBUG-FUN that represents debug information for FUN.
(defun fun-debug-fun (fun)
(declare (type function fun))
- (ecase (get-type fun)
+ (ecase (widetag-of fun)
(#.sb!vm:closure-header-widetag
(fun-debug-fun (%closure-fun fun)))
(#.sb!vm:funcallable-instance-header-widetag
;;; this to determine if the value stored is the actual value or an
;;; indirection cell.
(defun indirect-value-cell-p (x)
- (and (= (get-lowtag x) sb!vm:other-pointer-lowtag)
- (= (get-type x) sb!vm:value-cell-header-widetag)))
+ (and (= (lowtag-of x) sb!vm:other-pointer-lowtag)
+ (= (widetag-of x) sb!vm:value-cell-header-widetag)))
;;; Return three values reflecting the validity of DEBUG-VAR's value
;;; at BASIC-CODE-LOCATION:
;;; info about a made breakpoint
(defstruct (breakpoint-info (:copier nil))
;; where we are going to stop
- (place (required-argument)
- :type (or sb!di:code-location sb!di:debug-fun))
+ (place (missing-arg) :type (or sb!di:code-location sb!di:debug-fun))
;; the breakpoint returned by sb!di:make-breakpoint
- (breakpoint (required-argument) :type sb!di:breakpoint)
+ (breakpoint (missing-arg) :type sb!di:breakpoint)
;; the function returned from SB!DI:PREPROCESS-FOR-EVAL. If result is
;; non-NIL, drop into the debugger.
(break #'identity :type function)
(print nil :type list)
;; the number used when listing the possible breakpoints within a
;; function. Could also be a symbol such as start or end.
- (code-location-number (required-argument) :type (or symbol integer))
+ (code-location-number (missing-arg) :type (or symbol integer))
;; the number used when listing the breakpoints active and to delete
;; breakpoints
- (breakpoint-number (required-argument) :type integer))
+ (breakpoint-number (missing-arg) :type integer))
;;; Return a new BREAKPOINT-INFO structure with the info passed.
(defun create-breakpoint-info (place breakpoint code-location-number
;; a description of the DEF!MACRO call to be stored until we get enough
;; of the system running to finish processing it
(defstruct delayed-def!macro
- (args (required-argument) :type cons)
+ (args (missing-arg) :type cons)
(package (sane-package) :type package))
;; a list of DELAYED-DEF!MACROs stored until we get DEF!MACRO working fully
;; so that we can apply it to them. After DEF!MACRO is made to work, this
;; a description of a DEF!STRUCT call to be stored until we get
;; enough of the system running to finish processing it
(defstruct delayed-def!struct
- (args (required-argument) :type cons)
+ (args (missing-arg) :type cons)
(package (sane-package) :type package))
;; a list of DELAYED-DEF!STRUCTs stored until we get DEF!STRUCT
;; working fully so that we can apply it to them then. After
;;; Return the compiler layout for NAME. (The class referred to by
;;; NAME must be a structure-like class.)
(defun compiler-layout-or-lose (name)
+ #+sb-xc (/show0 "entering COMPILER-LAYOUT-OR-LOSE")
(let ((res (info :type :compiler-layout name)))
(cond ((not res)
(error "Class is not yet defined or was undefined: ~S" name))
(t res))))
;;; Delay looking for compiler-layout until the constructor is being
-;;; compiled, since it doesn't exist until after the eval-when
-;;; (compile) is compiled.
+;;; compiled, since it doesn't exist until after the EVAL-WHEN (COMPILE)
+;;; stuff is compiled.
(sb!xc:defmacro %delayed-get-compiler-layout (name)
`',(compiler-layout-or-lose name))
#-sb-xc-host (:pure t)
(:constructor make-defstruct-description (name)))
;; name of the structure
- (name (required-argument) :type symbol)
+ (name (missing-arg) :type symbol)
;; documentation on the structure
(doc nil :type (or string null))
;; prefix for slot names. If NIL, none.
;; the arguments to the :INCLUDE option, or NIL if no included
;; structure
(include nil :type list)
- ;; The arguments to the :ALTERNATE-METACLASS option (an extension
- ;; used to define structure-like objects with an arbitrary
- ;; superclass and that may not have STRUCTURE-CLASS as the
- ;; metaclass.) Syntax is:
+ ;; properties used to define structure-like classes with an
+ ;; arbitrary superclass and that may not have STRUCTURE-CLASS as the
+ ;; metaclass. Syntax is:
;; (superclass-name metaclass-name metaclass-constructor)
(alternate-metaclass nil :type list)
;; a list of DEFSTRUCT-SLOT-DESCRIPTION objects for all slots
;; string name of slot
%name
;; its position in the implementation sequence
- (index (required-argument) :type fixnum)
+ (index (missing-arg) :type fixnum)
;; the name of the accessor function
;;
;; (CMU CL had extra complexity here ("..or NIL if this accessor has
(list 'list)
(vector `(simple-array ,(dd-element-type defstruct) (*)))))
\f
-;;;; checking structure types
-
-;;; Check that X is an instance of the named structure type.
-(defmacro %check-structure-type-from-name (x name)
- `(%check-structure-type-from-layout ,x ,(compiler-layout-or-lose name)))
-
-;;; Check that X is a structure of the type described by DD.
-(defmacro %check-structure-type-from-dd (x dd)
- (declare (type defstruct-description dd))
- (let ((class-name (dd-name dd)))
- (ecase (dd-type dd)
- ((structure funcallable-instance)
- `(%check-structure-type-from-layout
- ,x
- ,(compiler-layout-or-lose class-name)))
- ((vector)
- (let ((xx (gensym "X")))
- `(let ((,xx ,x))
- (declare (type vector ,xx))
- ,@(when (dd-named dd)
- `((unless (eql (aref ,xx 0) ',class-name)
- (error
- 'simple-type-error
- :datum (aref ,xx 0)
- :expected-type `(member ,class-name)
- :format-control
- "~@<missing name in instance of ~
- VECTOR-typed structure ~S: ~2I~_S~:>"
- :format-arguments (list ',class-name ,xx)))))))
- (values))
- ((list)
- (let ((xx (gensym "X")))
- `(let ((,xx ,x))
- (declare (type list ,xx))
- ,@(when (dd-named dd)
- `((unless (eql (first ,xx) ',class-name)
- (error
- 'simple-type-error
- :datum (aref ,xx 0)
- :expected-type `(member ,class-name)
- :format-control
- "~@<missing name in instance of LIST-typed structure ~S: ~
- ~2I~_S~:>"
- :format-arguments (list ',class-name ,xx)))))
- (values)))))))
-
-;;; Check that X is an instance of the structure class with layout LAYOUT.
-(defun %check-structure-type-from-layout (x layout)
- (unless (typep-to-layout x layout)
- (error 'simple-type-error
- :datum x
- :expected-type (sb!xc:class-name (layout-class layout))))
- (values))
-\f
;;;; shared machinery for inline and out-of-line slot accessor functions
;;; an alist mapping from raw slot type to the operator used to access
\f
;;;; generating out-of-line slot accessor functions
-;;; code generators for cases of DEFUN SLOT-ACCESSOR-FUNS
-;;;
-;;; (caution: These macros are sleazily specialized for use only in
-;;; DEFUN SLOT-ACCESSOR-FUNS, not anywhere near fully parameterized:
-;;; they grab symbols like INSTANCE and DSD-FOO automatically.
-;;; Logically they probably belong in a MACROLET inside the DEFUN, but
-;;; separating them like this makes it easier to experiment with them
-;;; in the interpreter and reduces indentation hell.)
-;;;
;;; FIXME: Ideally, the presence of the type checks in the functions
;;; here would be conditional on the optimization policy at the point
;;; of expansion of DEFSTRUCT. (For now we're just doing the simpler
;;; thing, putting in the type checks unconditionally.)
-(eval-when (:compile-toplevel)
-
- ;; code shared between funcallable instance case and the ordinary
- ;; STRUCTURE-OBJECT case: Handle native structures with LAYOUTs and
- ;; (possibly) raw slots.
- (defmacro %native-slot-accessor-funs (dd-ref-fun-name)
- (let ((instance-type-check-form '(%check-structure-type-from-layout
- instance layout)))
- `(let ((layout (dd-layout-or-lose dd))
- (dsd-raw-type (dsd-raw-type dsd)))
- ;; Map over all the possible RAW-TYPEs, compiling a different
- ;; closure-function for each one, so that once the COND over
- ;; RAW-TYPEs happens (at the time closure is allocated) there
- ;; are no more decisions to be made and things execute
- ;; reasonably efficiently.
- (cond
- ;; nonraw slot case
- ((eql (dsd-raw-type dsd) t)
- (%slotplace-accessor-funs (,dd-ref-fun-name instance dsd-index)
- ,instance-type-check-form))
- ;; raw slot cases
- ,@(mapcar (lambda (raw-type-and-rawref-fun-name)
- (destructuring-bind (raw-type . rawref-fun-name)
- raw-type-and-rawref-fun-name
- `((equal dsd-raw-type ',raw-type)
- (let ((raw-index (dd-raw-index dd)))
- (%slotplace-accessor-funs
- (,rawref-fun-name (,dd-ref-fun-name instance
- raw-index)
- dsd-index)
- ,instance-type-check-form)))))
- *raw-type->rawref-fun-name*)))))
-
- ;; code shared between DEFSTRUCT :TYPE LIST and
- ;; DEFSTRUCT :TYPE VECTOR cases: Handle the "typed structure" case,
- ;; with no LAYOUTs and no raw slots.
- (defmacro %colontyped-slot-accessor-funs () (error "stub"))
-
- ;; the common structure of the raw-slot and not-raw-slot cases,
- ;; defined in terms of the writable SLOTPLACE. All possible flavors
- ;; of slot access should be able to pass through here.
- (defmacro %slotplace-accessor-funs (slotplace instance-type-check-form)
- (cl-user:/show slotplace instance-type-check-form)
- `(values (lambda (instance)
- ,instance-type-check-form
- ,slotplace)
- (let ((typecheckfun (typespec-typecheckfun dsd-type)))
- (lambda (new-value instance)
- ,instance-type-check-form
- (funcall typecheckfun new-value)
- (setf ,slotplace new-value))))))
;;; Return (VALUES SLOT-READER-FUN SLOT-WRITER-FUN).
(defun slot-accessor-funs (dd dsd)
- (let ((dsd-index (dsd-index dsd))
- (dsd-type (dsd-type dsd)))
+ #+sb-xc (/show0 "entering SLOT-ACCESSOR-FUNS")
+
+ ;; various code generators
+ ;;
+ ;; Note: They're only minimally parameterized, and cavalierly grab
+ ;; things like INSTANCE and DSD-INDEX from the namespace they're
+ ;; expanded in.
+ (macrolet (;; code shared between funcallable instance case and the
+ ;; ordinary STRUCTURE-OBJECT case: Handle native
+ ;; structures with LAYOUTs and (possibly) raw slots.
+ (%native-slot-accessor-funs (dd-ref-fun-name)
+ (let ((instance-type-check-form
+ '(%check-structure-type-from-layout instance layout)))
+ (/show "macroexpanding %NATIVE-SLOT-ACCESSOR-FUNS" dd-ref-fun-name instance-type-check-form)
+ `(let ((layout (dd-layout-or-lose dd))
+ (dsd-raw-type (dsd-raw-type dsd)))
+ #+sb-xc (/show0 "in %NATIVE-SLOT-ACCESSOR-FUNS macroexpanded code")
+ ;; Map over all the possible RAW-TYPEs, compiling
+ ;; a different closure-function for each one, so
+ ;; that once the COND over RAW-TYPEs happens (at
+ ;; the time closure is allocated) there are no
+ ;; more decisions to be made and things execute
+ ;; reasonably efficiently.
+ (cond
+ ;; nonraw slot case
+ ((eql dsd-raw-type t)
+ #+sb-xc (/show0 "in nonraw slot case")
+ (%slotplace-accessor-funs
+ (,dd-ref-fun-name instance dsd-index)
+ ,instance-type-check-form))
+ ;; raw slot cases
+ ,@(mapcar (lambda (raw-type-and-rawref-fun-name)
+ (destructuring-bind (raw-type
+ . rawref-fun-name)
+ raw-type-and-rawref-fun-name
+ `((equal dsd-raw-type ',raw-type)
+ #+sb-xc (/show0 "in raw slot case")
+ (let ((raw-index (dd-raw-index dd)))
+ (%slotplace-accessor-funs
+ (,rawref-fun-name (,dd-ref-fun-name
+ instance
+ raw-index)
+ dsd-index)
+ ,instance-type-check-form)))))
+ *raw-type->rawref-fun-name*)
+ ;; oops
+ (t
+ (error "internal error: unexpected DSD-RAW-TYPE ~S"
+ dsd-raw-type))))))
+ ;; code shared between DEFSTRUCT :TYPE LIST and
+ ;; DEFSTRUCT :TYPE VECTOR cases: Handle the "typed
+ ;; structure" case, with no LAYOUTs and no raw slots.
+ (%colontyped-slot-accessor-funs () (error "stub"))
+ ;; the common structure of the raw-slot and not-raw-slot
+ ;; cases, defined in terms of the writable SLOTPLACE. All
+ ;; possible flavors of slot access should be able to pass
+ ;; through here.
+ (%slotplace-accessor-funs (slotplace instance-type-check-form)
+ (/show "macroexpanding %SLOTPLACE-ACCESSOR-FUNS" slotplace instance-type-check-form)
+ `(values (lambda (instance)
+ (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader")
+ ,instance-type-check-form
+ (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
+ ,slotplace)
+ (let ((typecheckfun (typespec-typecheckfun dsd-type)))
+ (lambda (new-value instance)
+ (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined writer")
+ ,instance-type-check-form
+ (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
+ (funcall typecheckfun new-value)
+ (/noshow0 "back from TYPECHECKFUN")
+ (setf ,slotplace new-value))))))
+
+ (let ((dsd-index (dsd-index dsd))
+ (dsd-type (dsd-type dsd)))
+ #+sb-xc (/show0 "got DSD-TYPE=..")
+ #+sb-xc (/hexstr dsd-type)
(ecase (dd-type dd)
;; native structures
- (structure (%native-slot-accessor-funs %instance-ref))
- (funcallable-structure (%native-slot-accessor-funs
- %funcallable-instance-info))
+ (structure
+ #+sb-xc (/show0 "case of DSD-TYPE = STRUCTURE")
+ (%native-slot-accessor-funs %instance-ref))
;; structures with the :TYPE option
;; layout completely, so that raw slots are impossible.
(list
(dd-type-slot-accessor-funs nth-but-with-sane-arg-order
- `(%check-structure-type-from-dd
- :maybe-raw-p nil))
+ `(%check-structure-type-from-dd
+ :maybe-raw-p nil))
(vector
(dd-type-slot-accessor-funs aref
- :maybe-raw-p nil)))
+ :maybe-raw-p nil)))
|#
- )))
+ ))))
\f
-;;;; REMOVEME: baby steps for the new out-of-line slot accessor functions
+;;;; baby steps for the new out-of-line slot accessor functions
+;;;;
+;;;; REMOVEME after new structure code works
#|
(in-package :sb-kernel)
;; non-compact code. In this context, we'd rather have
;; compact, cold-loadable code. -- WHN 19990928
(declare (notinline sb!xc:find-class))
+ #+sb-xc (/show0 "beginning CLASS-METHOD-DEFINITIONS forms")
,@(let ((pf (dd-print-function defstruct))
(po (dd-print-object defstruct))
(x (gensym))
,@(let ((def-con (dd-default-constructor defstruct)))
(when (and def-con (not (dd-alternate-metaclass defstruct)))
`((setf (structure-class-constructor (sb!xc:find-class ',name))
- #',def-con))))))))
+ #',def-con))))
+ #+sb-xc (/show0 "done with CLASS-METHOD-DEFINITIONS forms")))))
;;; FIXME: I really would like to make structure accessors less
;;; special, just ordinary inline functions. (Or perhaps inline
;;; functions with special compact implementations of their
(if (dd-class-p dd)
(let ((inherits (inherits-for-structure dd)))
`(progn
+ (/show0 "beginning macroexpanded DEFSTRUCT code")
(eval-when (:compile-toplevel :load-toplevel :execute)
(%compiler-defstruct ',dd ',inherits))
+ (/show0 "back from %COMPILER-DEFSTRUCT")
(%defstruct ',dd ',inherits)
+ (/show0 "back from %DEFSTRUCT")
,@(unless expanding-into-code-for-xc-host-p
(append (raw-accessor-definitions dd)
(predicate-definitions dd)
;(copier-definition dd)
(constructor-definitions dd)
(class-method-definitions dd)))
+ (/show0 "done with macroexpanded DEFSTRUCT code")
',name))
`(progn
+ (/show0 "beginning macroexpanded typed DEFSTRUCT code")
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (info :typed-structure :info ',name) ',dd))
,@(unless expanding-into-code-for-xc-host-p
(typed-predicate-definitions dd)
(typed-copier-definitions dd)
(constructor-definitions dd)))
+ (/show0 "done with macroexpanded typed DEFSTRUCT code")
',name)))))
(sb!xc:defmacro defstruct (name-and-options &rest slot-descriptions)
\f
;;;; functions to generate code for various parts of DEFSTRUCT definitions
-;;; Catch requests to mess up definitions in COMMON-LISP.
-#-sb-xc-host
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun protect-cl (symbol)
- (when (and *cold-init-complete-p*
- (eq (symbol-package symbol) *cl-package*))
- (cerror "Go ahead and patch the system."
- "attempting to modify a symbol in the COMMON-LISP package: ~S"
- symbol))))
-
;;; Return forms to define readers and writers for raw slots as inline
;;; functions.
(defun raw-accessor-definitions (dd)
;; When accessor exists and is raw
(when (and accessor-name
(not (eq accessor-name '%instance-ref)))
+ (res `(/show0 "doing one slot, ACCESSOR-NAME=.."))
+ (res `(/hexstr ',accessor-name))
(res `(declaim (inline ,accessor-name)))
+ (res `(/show0 "done with reader DECLAIM INLINE"))
(res `(declaim (ftype (function (,dtype) ,slot-type)
,accessor-name)))
+ (res `(/show0 "done with reader DECLAIM FTYPE, doing DEFUN"))
(res `(defun ,accessor-name (,argname)
;; Note: The DECLARE here might seem redundant
;; with the DECLAIM FTYPE above, but it's not:
(declare (type ,dtype ,argname))
(truly-the ,slot-type (,accessor ,data ,offset))))
(unless (dsd-read-only slot)
+ (res `(/show0 "doing writer DECLAIM INLINE"))
(res `(declaim (inline (setf ,accessor-name))))
+ (res `(/show0 "doing writer DECLAIM FTYPE"))
(res `(declaim (ftype (function (,slot-type ,dtype) ,slot-type)
(setf ,accessor-name))))
;; FIXME: I rewrote this somewhat from the CMU CL definition.
;; Do some basic tests to make sure that reading and writing
;; raw slots still works correctly.
+ (res `(/show0 "doing writer DEFUN"))
(res `(defun (setf ,accessor-name) (,nvname ,argname)
(declare (type ,dtype ,argname))
(setf (,accessor ,data ,offset) ,nvname)
- ,nvname)))))))
- (res))))
+ ,nvname)))
+ (res `(/show0 "done with one slot"))))))
+ `((/show0 "beginning RAW-ACCESSOR-DEFINITIONS forms")
+ ,@(res)
+ (/show0 "done with RAW-ACCESSOR-DEFINITIONS forms")))))
;;; Return a list of forms which create a predicate for an untyped DEFSTRUCT.
(defun predicate-definitions (dd)
(let ((pred (dd-predicate-name dd))
- (argname (gensym)))
- (when pred
- (if (eq (dd-type dd) 'funcallable-structure)
- ;; FIXME: Why does this need to be special-cased for
- ;; FUNCALLABLE-STRUCTURE? CMU CL did it, but without explanation.
- ;; Could we do without it? What breaks if we do? Or could we
- ;; perhaps get by with no predicates for funcallable structures?
- `((declaim (inline ,pred))
- (defun ,pred (,argname) (typep ,argname ',(dd-name dd))))
- `((protect-cl ',pred)
- (declaim (inline ,pred))
- (defun ,pred (,argname)
- (declare (optimize (speed 3) (safety 0)))
- (typep-to-layout ,argname
- (compile-time-find-layout ,(dd-name dd)))))))))
+ (argname (gensym "ARG")))
+ (and pred
+ `((/show0 "beginning PREDICATE-DEFINITIONS forms")
+ (protect-cl ',pred)
+ (declaim (inline ,pred))
+ (defun ,pred (,argname)
+ (declare (optimize (speed 3) (safety 0)))
+ (typep-to-layout ,argname
+ (compile-time-find-layout ,(dd-name dd))))
+ (/show0 "done with PREDICATE-DEFINITIONS forms")))))
;;; Return a list of forms which create a predicate function for a typed
;;; DEFSTRUCT.
#|
;;; Return the copier definition for an untyped DEFSTRUCT.
(defun copier-definition (dd)
- (when (and (dd-copier dd)
- ;; FUNCALLABLE-STRUCTUREs don't need copiers, and this
- ;; implementation wouldn't work for them anyway, since
- ;; COPY-STRUCTURE returns a STRUCTURE-OBJECT and they're not.
- (not (eq (dd-type info) 'funcallable-structure)))
+ (when (dd-copier dd)
(let ((argname (gensym)))
`(progn
(protect-cl ',(dd-copier dd))
(when (dd-include dd)
(error "more than one :INCLUDE option"))
(setf (dd-include dd) args))
- (:alternate-metaclass
- (setf (dd-alternate-metaclass dd) args))
(:print-function
(require-no-print-options-so-far dd)
(setf (dd-print-function dd)
(the (or symbol cons) args)))
(:type
(destructuring-bind (type) args
- (cond ((eq type 'funcallable-structure)
- (setf (dd-type dd) type))
- ((member type '(list vector))
+ (cond ((member type '(list vector))
(setf (dd-element-type dd) t)
(setf (dd-type dd) type))
((and (consp type) (eq (first type) 'vector))
(aver name) ; A null name doesn't seem to make sense here.
(let ((dd (make-defstruct-description name)))
(dolist (option options)
- (cond ((consp option)
- (parse-1-dd-option option dd))
- ((eq option :named)
+ (cond ((eq option :named)
(setf (dd-named dd) t))
- ((member option '(:constructor :copier :predicate :named))
+ ((consp option)
+ (parse-1-dd-option option dd))
+ ((member option '(:conc-name :constructor :copier :predicate))
(parse-1-dd-option (list option) dd))
(t
(error "unrecognized DEFSTRUCT option: ~S" option))))
(when (dd-offset dd)
(error ":OFFSET can't be specified unless :TYPE is specified."))
(unless (dd-include dd)
+ ;; FIXME: It'd be cleaner to treat no-:INCLUDE as defaulting
+ ;; to :INCLUDE STRUCTURE-OBJECT, and then let the general-case
+ ;; (INCF (DD-LENGTH DD) (DD-LENGTH included-DD)) logic take
+ ;; care of this. (Except that the :TYPE VECTOR and :TYPE
+ ;; LIST cases, with their :NAMED and un-:NAMED flavors,
+ ;; make that messy, alas.)
(incf (dd-length dd))))
- (funcallable-structure)
(t
(require-no-print-options-so-far dd)
(when (dd-named dd)
(style-warn
"~@<The structure accessor name ~S is the same as the name of the ~
structure type predicate. ANSI doesn't specify what to do in ~
- this case; this implementation chooses to overwrite the type ~
- predicate with the slot accessor.~@:>"
+ this case. We'll overwrite the type predicate with the slot ~
+ accessor, but you can't rely on this behavior, so it'd be wise to ~
+ remove the ambiguity in your code.~@:>"
accessor-name)
(setf (dd-predicate-name defstruct) nil)))
;;; yet for the raw data vector, then do it. Raw objects are aligned
;;; on the unit of their size.
(defun allocate-1-slot (dd dsd)
+ #+sb-xc (/show0 "entering ALLOCATE-1-SLOT")
(multiple-value-bind (raw? raw-type words)
(if (eq (dd-type dd) 'structure)
(structure-raw-slot-type-and-size (dsd-type dsd))
(setf (dsd-raw-type dsd) raw-type)
(setf (dsd-index dsd) (dd-raw-length dd))
(incf (dd-raw-length dd) words))))
+ #+sb-xc (/show0 "leaving ALLOCATE-1-SLOT")
(values))
(defun typed-structure-info-or-lose (name)
(if (dd-class-p dd)
(layout-info (compiler-layout-or-lose included-name))
(typed-structure-info-or-lose included-name))))
+
+ ;; checks on legality
(unless (and (eq type (dd-type included-structure))
(type= (specifier-type (dd-element-type included-structure))
(specifier-type (dd-element-type dd))))
(error ":TYPE option mismatch between structures ~S and ~S"
(dd-name dd) included-name))
+ (let ((included-class (sb!xc:find-class included-name nil)))
+ (when included-class
+ ;; It's not particularly well-defined to :INCLUDE any of the
+ ;; CMU CL INSTANCE weirdosities like CONDITION or
+ ;; GENERIC-FUNCTION, and it's certainly not ANSI-compliant.
+ (let* ((included-layout (class-layout included-class))
+ (included-dd (layout-info included-layout)))
+ (when (and (dd-alternate-metaclass included-dd)
+ ;; As of sbcl-0.pre7.73, anyway, STRUCTURE-OBJECT
+ ;; is represented with an ALTERNATE-METACLASS. But
+ ;; it's specifically OK to :INCLUDE (and PCL does)
+ ;; so in this one case, it's OK to include
+ ;; something with :ALTERNATE-METACLASS after all.
+ (not (eql included-name 'structure-object)))
+ (error "can't :INCLUDE class ~S (has alternate metaclass)"
+ included-name)))))
(incf (dd-length dd) (dd-length included-structure))
(when (dd-class-p dd)
;;; Do miscellaneous (LOAD EVAL) time actions for the structure
;;; described by DD. Create the class & LAYOUT, checking for
-;;; incompatible redefinition. Define setters, accessors, copier,
-;;; predicate, documentation, instantiate definition in load-time
-;;; environment.
+;;; incompatible redefinition. Define those functions which are
+;;; sufficiently stereotyped that we can implement them as standard
+;;; closures.
(defun %defstruct (dd inherits)
(declare (type defstruct-description dd))
- (remhash (dd-name dd) *typecheckfuns*)
+
+ #+sb-xc (/show0 "entering %DEFSTRUCT")
+
+ ;; We set up LAYOUTs even in the cross-compilation host.
(multiple-value-bind (class layout old-layout)
(ensure-structure-class dd inherits "current" "new")
(cond ((not old-layout)
(unless (eq (class-layout class) layout)
(register-layout layout)))
(t
- (let ((old-dd (layout-dd old-layout)))
+ (let ((old-dd (layout-info old-layout)))
(when (defstruct-description-p old-dd)
(dolist (slot (dd-slots old-dd))
(fmakunbound (dsd-accessor-name slot))
(fmakunbound `(setf ,(dsd-accessor-name slot)))))))
(%redefine-defstruct class old-layout layout)
(setq layout (class-layout class))))
-
(setf (sb!xc:find-class (dd-name dd)) class)
- ;; Set FDEFINITIONs for structure accessors, setters, predicates,
- ;; and copiers.
+ ;; It doesn't make sense to do these in the cross-compilation host.
#-sb-xc-host
- (unless (eq (dd-type dd) 'funcallable-structure)
-
- (dolist (slot (dd-slots dd))
- (let ((dsd slot))
- (when (and (dsd-accessor-name slot)
- (eq (dsd-raw-type slot) t))
- (protect-cl (dsd-accessor-name slot))
- (setf (symbol-function (dsd-accessor-name slot))
- (structure-slot-getter layout dsd))
- (unless (dsd-read-only slot)
- (setf (fdefinition `(setf ,(dsd-accessor-name slot)))
- (structure-slot-setter layout dsd))))))
-
- ;; FIXME: Someday it'd probably be good to go back to using
- ;; closures for the out-of-line forms of structure accessors.
- #|
- (when (dd-predicate dd)
- (protect-cl (dd-predicate dd))
- (setf (symbol-function (dd-predicate dd))
- #'(lambda (object)
- (declare (optimize (speed 3) (safety 0)))
- (typep-to-layout object layout))))
- |#
-
- (when (dd-copier-name dd)
- (protect-cl (dd-copier-name dd))
- (setf (symbol-function (dd-copier-name dd))
- #'(lambda (structure)
- (declare (optimize (speed 3) (safety 0)))
- (flet ((layout-test (structure)
- (typep-to-layout structure layout)))
- (unless (layout-test structure)
- (error 'simple-type-error
- :datum structure
- :expected-type '(satisfies layout-test)
- :format-control
- "Structure for copier is not a ~S:~% ~S"
- :format-arguments
- (list (sb!xc:class-name (layout-class layout))
- structure))))
- (copy-structure structure))))))
-
- (when (dd-doc dd)
- (setf (fdocumentation (dd-name dd) 'type)
- (dd-doc dd)))
-
+ (progn
+ #+sb-xc (/show0 "doing #+SB-XC stuff in %DEFSTRUCT")
+ (remhash (dd-name dd) *typecheckfuns*)
+ (%target-defstruct dd layout)
+ (when (dd-doc dd)
+ (setf (fdocumentation (dd-name dd) 'type)
+ (dd-doc dd)))
+ #+sb-xc (/show0 "done with #+SB-XC stuff in %DEFSTRUCT")
+ ))
+
+ #+sb-xc (/show0 "leaving %DEFSTRUCT")
(values))
-
+\f
;;; Return a form describing the writable place used for this slot
;;; in the instance named INSTANCE-NAME.
(defun %accessor-place-form (dd dsd instance-name)
;; the case of a raw slot, to read the vector of raw slots
(ref (ecase (dd-type dd)
(structure '%instance-ref)
- (funcallable-structure '%funcallable-instance-info)
(list 'nth-but-with-sane-arg-order)
(vector 'aref)))
(raw-type (dsd-raw-type dsd)))
(declare (type ,(dd-name dd) structure-object))
(setf ,(%accessor-place-form dd dsd 'instance) new-value)))))
-;;; Do (COMPILE LOAD EVAL)-time actions for the defstruct described by DD.
-(defun %compiler-defstruct (dd inherits)
- (declare (type defstruct-description dd))
+;;; core compile-time setup of any class with a LAYOUT, used even by
+;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities
+(defun %compiler-set-up-layout (dd
+ &optional
+ ;; Several special cases (STRUCTURE-OBJECT
+ ;; itself, and structures with alternate
+ ;; metaclasses) call this function directly,
+ ;; and they're all at the base of the
+ ;; instance class structure, so this is
+ ;; a handy default.
+ (inherits (vector (find-layout t)
+ (find-layout 'instance))))
+
+ (/show "entering %COMPILER-SET-UP-LAYOUT for" (dd-name dd))
+
(multiple-value-bind (class layout old-layout)
(multiple-value-bind (clayout clayout-p)
(info :type :compiler-layout (dd-name dd))
"compiled"
:compiler-layout clayout))
(cond (old-layout
+ (/show "non-NIL" old-layout)
(undefine-structure (layout-class old-layout))
(when (and (class-subclasses class)
(not (eq layout old-layout)))
(register-layout layout :invalidate nil))
(setf (sb!xc:find-class (dd-name dd)) class)))
+ ;; At this point the class should be set up in the INFO database.
+ ;; But the logic that enforces this is a little tangled and
+ ;; scattered, so it's not obvious, so let's check.
+ (aver (sb!xc:find-class (dd-name dd) nil))
+
(setf (info :type :compiler-layout (dd-name dd)) layout))
+ (/show0 "leaving %COMPILER-SET-UP-LAYOUT")
+
+ (values))
+
+;;; Do (COMPILE LOAD EVAL)-time actions for the normal (not
+;;; ALTERNATE-LAYOUT) DEFSTRUCT described by DD.
+(defun %compiler-defstruct (dd inherits)
+ (declare (type defstruct-description dd))
+ #+sb-xc (/show0 "entering %COMPILER-DEFSTRUCT")
+
+ (%compiler-set-up-layout dd inherits)
+
(let* ((dd-name (dd-name dd))
(dtype (dd-declarable-type dd))
(class (sb!xc:find-class dd-name)))
(info :function :inlinep setf-accessor-name)
:inline))))))))
+ #+sb-xc (/show0 "leaving %COMPILER-DEFSTRUCT")
(values))
\f
;;;; redefinition stuff
;;; be used.
(defun %redefine-defstruct (class old-layout new-layout)
(declare (type sb!xc:class class) (type layout old-layout new-layout))
+ #+sb-xc (/show0 "entering %REDEFINE-DEFSTRUCT")
(let ((name (class-proper-name class)))
(restart-case
(error "redefining class ~S incompatibly with the current definition"
name)
(register-layout new-layout :invalidate nil
:destruct-layout old-layout))))
+ #+sb-xc (/show0 "leaving %REDEFINE-DEFSTRUCT")
(values))
;;; This is called when we are about to define a structure class. It
;;; over this type, clearing the compiler structure type info, and
;;; undefining all the associated functions.
(defun undefine-structure (class)
+ #+sb-xc (/show0 "entering UNDEFINE-STRUCTURE")
(let ((info (layout-info (class-layout class))))
(when (defstruct-description-p info)
(let ((type (dd-name info)))
+ (remhash type *typecheckfuns*)
(setf (info :type :compiler-layout type) nil)
(undefine-fun-name (dd-copier-name info))
(undefine-fun-name (dd-predicate-name info))
;; Clear out the SPECIFIER-TYPE cache so that subsequent
;; references are unknown types.
(values-specifier-type-cache-clear)))
+ #+sb-xc (/show0 "leaving UNDEFINE-STRUCTURE")
(values))
\f
;;; Return a list of pairs (name . index). Used for :TYPE'd
#!+long-float
(complex-long-float '%raw-ref-complex-long)
(unsigned-byte 'aref)
- ((t)
- (if (eq (dd-type defstruct) 'funcallable-structure)
- '%funcallable-instance-info
- '%instance-ref)))
+ ((t) '%instance-ref))
(case rtype
#!+long-float
(complex-long-float
;;; These functions are called to actually make a constructor after we
;;; have processed the arglist. The correct variant (according to the
;;; DD-TYPE) should be called. The function is defined with the
-;;; specified name and arglist. Vars and Types are used for argument
-;;; type declarations. Values are the values for the slots (in order.)
+;;; specified name and arglist. VARS and TYPES are used for argument
+;;; type declarations. VALUES are the values for the slots (in order.)
;;;
-;;; This is split four ways because:
-;;; 1] list & vector structures need "name" symbols stuck in at
-;;; various weird places, whereas STRUCTURE structures have
-;;; a LAYOUT slot.
-;;; 2] We really want to use LIST to make list structures, instead of
-;;; MAKE-LIST/(SETF ELT).
-;;; 3] STRUCTURE structures can have raw slots that must also be
-;;; allocated and indirectly referenced. We use SLOT-ACCESSOR-FORM
-;;; to compute how to set the slots, which deals with raw slots.
-;;; 4] Funcallable structures are weird.
-(defun create-vector-constructor
- (defstruct cons-name arglist vars types values)
+;;; This is split three ways because:
+;;; * LIST & VECTOR structures need "name" symbols stuck in at
+;;; various weird places, whereas STRUCTURE structures have
+;;; a LAYOUT slot.
+;;; * We really want to use LIST to make list structures, instead of
+;;; MAKE-LIST/(SETF ELT).
+;;; * STRUCTURE structures can have raw slots that must also be
+;;; allocated and indirectly referenced. We use SLOT-ACCESSOR-FORM
+;;; to compute how to set the slots, which deals with raw slots.
+(defun create-vector-constructor (dd cons-name arglist vars types values)
(let ((temp (gensym))
- (etype (dd-element-type defstruct)))
+ (etype (dd-element-type dd)))
`(defun ,cons-name ,arglist
(declare ,@(mapcar #'(lambda (var type) `(type (and ,type ,etype) ,var))
vars types))
- (let ((,temp (make-array ,(dd-length defstruct)
- :element-type ',(dd-element-type defstruct))))
+ (let ((,temp (make-array ,(dd-length dd)
+ :element-type ',(dd-element-type dd))))
,@(mapcar #'(lambda (x)
`(setf (aref ,temp ,(cdr x)) ',(car x)))
- (find-name-indices defstruct))
+ (find-name-indices dd))
,@(mapcar #'(lambda (dsd value)
`(setf (aref ,temp ,(dsd-index dsd)) ,value))
- (dd-slots defstruct) values)
+ (dd-slots dd) values)
,temp))))
-(defun create-list-constructor
- (defstruct cons-name arglist vars types values)
- (let ((vals (make-list (dd-length defstruct) :initial-element nil)))
- (dolist (x (find-name-indices defstruct))
+(defun create-list-constructor (dd cons-name arglist vars types values)
+ (let ((vals (make-list (dd-length dd) :initial-element nil)))
+ (dolist (x (find-name-indices dd))
(setf (elt vals (cdr x)) `',(car x)))
- (loop for dsd in (dd-slots defstruct) and val in values do
+ (loop for dsd in (dd-slots dd) and val in values do
(setf (elt vals (dsd-index dsd)) val))
`(defun ,cons-name ,arglist
(declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
vars types))
(list ,@vals))))
-(defun create-structure-constructor
- (defstruct cons-name arglist vars types values)
+(defun create-structure-constructor (dd cons-name arglist vars types values)
(let* ((temp (gensym))
- (raw-index (dd-raw-index defstruct))
+ (raw-index (dd-raw-index dd))
(n-raw-data (when raw-index (gensym))))
`(defun ,cons-name ,arglist
(declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
vars types))
- (let ((,temp (truly-the ,(dd-name defstruct)
- (%make-instance ,(dd-length defstruct))))
+ (let ((,temp (truly-the ,(dd-name dd)
+ (%make-instance ,(dd-length dd))))
,@(when n-raw-data
`((,n-raw-data
- (make-array ,(dd-raw-length defstruct)
+ (make-array ,(dd-raw-length dd)
:element-type '(unsigned-byte 32))))))
(setf (%instance-layout ,temp)
- (%delayed-get-compiler-layout ,(dd-name defstruct)))
+ (%delayed-get-compiler-layout ,(dd-name dd)))
,@(when n-raw-data
`((setf (%instance-ref ,temp ,raw-index) ,n-raw-data)))
,@(mapcar (lambda (dsd value)
(multiple-value-bind (accessor index data)
- (slot-accessor-form defstruct dsd temp n-raw-data)
+ (slot-accessor-form dd dsd temp n-raw-data)
`(setf (,accessor ,data ,index) ,value)))
- (dd-slots defstruct)
+ (dd-slots dd)
values)
,temp))))
-(defun create-fin-constructor
- (defstruct cons-name arglist vars types values)
- (let ((temp (gensym)))
- `(defun ,cons-name ,arglist
- (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
- vars types))
- (let ((,temp (truly-the
- ,(dd-name defstruct)
- (%make-funcallable-instance
- ,(dd-length defstruct)
- (%delayed-get-compiler-layout ,(dd-name defstruct))))))
- ,@(mapcar #'(lambda (dsd value)
- `(setf (%funcallable-instance-info
- ,temp ,(dsd-index dsd))
- ,value))
- (dd-slots defstruct) values)
- ,temp))))
;;; Create a default (non-BOA) keyword constructor.
(defun create-keyword-constructor (defstruct creator)
(defaults ())
(creator (ecase (dd-type defstruct)
(structure #'create-structure-constructor)
- (funcallable-structure #'create-fin-constructor)
(vector #'create-vector-constructor)
(list #'create-list-constructor))))
(dolist (constructor (dd-constructors defstruct))
(dolist (boa boas)
(res (create-boa-constructor defstruct boa creator)))
- (res))))
+ `((/show0 "beginning CONSTRUCTOR-DEFINITIONS forms")
+ ,@(res)
+ (/show0 "done with CONSTRUCTOR-DEFINITIONS forms")))))
+\f
+;;;; instances with ALTERNATE-METACLASS
+;;;;
+;;;; The CMU CL support for structures with ALTERNATE-METACLASS was a
+;;;; fairly general extension embedded in the main DEFSTRUCT code, and
+;;;; the result was an fairly impressive mess as ALTERNATE-METACLASS
+;;;; extension mixed with ANSI CL generality (e.g. :TYPE and :INCLUDE)
+;;;; and CMU CL implementation hairiness (esp. raw slots). This SBCL
+;;;; version is much less ambitious, noticing that ALTERNATE-METACLASS
+;;;; is only used to implement CONDITION, STANDARD-INSTANCE, and
+;;;; GENERIC-FUNCTION, and defining a simple specialized
+;;;; separate-from-DEFSTRUCT macro to provide only enough
+;;;; functionality to support those.
+;;;;
+;;;; KLUDGE: The defining macro here is so specialized that it's ugly
+;;;; in its own way. It also violates once-and-only-once by knowing
+;;;; much about structures and layouts that is already known by the
+;;;; main DEFSTRUCT macro. Hopefully it will go away presently
+;;;; (perhaps when CL:CLASS and SB-PCL:CLASS meet) as per FIXME below.
+;;;; -- WHN 2001-10-28
+;;;;
+;;;; FIXME: There seems to be no good reason to shoehorn CONDITION,
+;;;; STANDARD-INSTANCE, and GENERIC-FUNCTION into mutated structures
+;;;; instead of just implementing them as primitive objects. (This
+;;;; reduced-functionality macro seems pretty close to the
+;;;; functionality of DEFINE-PRIMITIVE-OBJECT..)
+
+(defun make-dd-with-alternate-metaclass (&key (class-name (missing-arg))
+ (superclass-name (missing-arg))
+ (metaclass-name (missing-arg))
+ (dd-type (missing-arg))
+ metaclass-constructor
+ slot-names)
+ (let* ((dd (make-defstruct-description class-name))
+ (conc-name (concatenate 'string (symbol-name class-name) "-"))
+ (dd-slots (let ((reversed-result nil)
+ ;; The index starts at 1 for ordinary
+ ;; named slots because slot 0 is
+ ;; magical, used for LAYOUT in
+ ;; CONDITIONs or for something (?) in
+ ;; funcallable instances.
+ (index 1))
+ (dolist (slot-name slot-names)
+ (push (make-defstruct-slot-description
+ :%name (symbol-name slot-name)
+ :index index
+ :accessor-name (symbolicate conc-name slot-name))
+ reversed-result)
+ (incf index))
+ (nreverse reversed-result))))
+ (setf (dd-alternate-metaclass dd) (list superclass-name
+ metaclass-name
+ metaclass-constructor)
+ (dd-slots dd) dd-slots
+ (dd-length dd) (1+ (length slot-names))
+ (dd-type dd) dd-type)
+ dd))
+
+(sb!xc:defmacro !defstruct-with-alternate-metaclass
+ (class-name &key
+ (slot-names (missing-arg))
+ (boa-constructor (missing-arg))
+ (superclass-name (missing-arg))
+ (metaclass-name (missing-arg))
+ (metaclass-constructor (missing-arg))
+ (dd-type (missing-arg))
+ predicate
+ (runtime-type-checks-p t))
+
+ (declare (type (and list (not null)) slot-names))
+ (declare (type (and symbol (not null))
+ boa-constructor
+ superclass-name
+ metaclass-name
+ metaclass-constructor))
+ (declare (type symbol predicate))
+ (declare (type (member structure funcallable-structure) dd-type))
+
+ (/show "entering !DEFSTRUCT-WITH-ALTERNATE-METACLASS expander" class-name)
+ (let* ((dd (make-dd-with-alternate-metaclass
+ :class-name class-name
+ :slot-names slot-names
+ :superclass-name superclass-name
+ :metaclass-name metaclass-name
+ :metaclass-constructor metaclass-constructor
+ :dd-type dd-type))
+ (conc-name (concatenate 'string (symbol-name class-name) "-"))
+ (dd-slots (dd-slots dd))
+ (dd-length (1+ (length slot-names)))
+ (object-gensym (gensym "OBJECT"))
+ (new-value-gensym (gensym "NEW-VALUE-"))
+ (delayed-layout-form `(%delayed-get-compiler-layout ,class-name)))
+ (multiple-value-bind (raw-maker-form raw-reffer-operator)
+ (ecase dd-type
+ (structure
+ (values `(let ((,object-gensym (%make-instance ,dd-length)))
+ (setf (%instance-layout ,object-gensym)
+ ,delayed-layout-form)
+ ,object-gensym)
+ '%instance-ref))
+ (funcallable-structure
+ (values `(%make-funcallable-instance ,dd-length
+ ,delayed-layout-form)
+ '%funcallable-instance-info)))
+ (/show dd raw-maker-form raw-reffer-operator)
+ `(progn
+
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (%compiler-set-up-layout ',dd))
+
+ ;; slot readers and writers
+ (declaim (inline ,@(mapcar #'dsd-accessor-name dd-slots)))
+ ,@(mapcar (lambda (dsd)
+ `(defun ,(dsd-accessor-name dsd) (,object-gensym)
+ ,@(when runtime-type-checks-p
+ `((declare (type ,class-name ,object-gensym))))
+ (,raw-reffer-operator ,object-gensym
+ ,(dsd-index dsd))))
+ dd-slots)
+ (declaim (inline ,@(mapcar (lambda (dsd)
+ `(setf ,(dsd-accessor-name dsd)))
+ dd-slots)))
+ ,@(mapcar (lambda (dsd)
+ `(defun (setf ,(dsd-accessor-name dsd)) (,new-value-gensym
+ ,object-gensym)
+ ,@(when runtime-type-checks-p
+ `((declare (type ,class-name ,object-gensym))))
+ (setf (,raw-reffer-operator ,object-gensym
+ ,(dsd-index dsd))
+ ,new-value-gensym)))
+ dd-slots)
+
+ ;; constructor
+ (defun ,boa-constructor ,slot-names
+ (let ((,object-gensym ,raw-maker-form))
+ ,@(mapcar (lambda (slot-name)
+ (let ((dsd (find (symbol-name slot-name) dd-slots
+ :key #'dsd-%name
+ :test #'string=)))
+ `(setf (,(dsd-accessor-name dsd) ,object-gensym)
+ ,slot-name)))
+ slot-names)
+ ,object-gensym))
+
+ ;; predicate
+ ,@(when predicate
+ ;; Just delegate to the compiler's type optimization
+ ;; code, which knows how to generate inline type tests
+ ;; for the whole CMU CL INSTANCE menagerie.
+ `(defun ,predicate (,object-gensym)
+ (typep ,object-gensym ',class-name)))))))
\f
;;;; finalizing bootstrapping
-;;; early structure placeholder definitions: Set up layout and class
-;;; data for structures which are needed early.
+;;; Set up DD and LAYOUT for STRUCTURE-OBJECT class itself.
+;;;
+;;; Ordinary structure classes effectively :INCLUDE STRUCTURE-OBJECT
+;;; when they have no explicit :INCLUDEs, so (1) it needs to be set up
+;;; before we can define ordinary structure classes, and (2) it's
+;;; special enough (and simple enough) that we just build it by hand
+;;; instead of trying to generalize the ordinary DEFSTRUCT code.
+(defun !set-up-structure-object-class ()
+ (/show0 "entering !SET-UP-STRUCTURE-OBJECT-CLASS")
+ (let ((dd (make-defstruct-description 'structure-object)))
+ (setf
+ ;; Note: This has an ALTERNATE-METACLASS only because of blind
+ ;; clueless imitation of the CMU CL code -- dunno if or why it's
+ ;; needed. -- WHN
+ (dd-alternate-metaclass dd) '(instance)
+ (dd-slots dd) nil
+ (dd-length dd) 1
+ (dd-type dd) 'structure)
+ (/show0 "about to %COMPILER-SET-UP-LAYOUT")
+ (%compiler-set-up-layout dd))
+ (/show0 "leaving !SET-UP-STRUCTURE-OBJECT-CLASS"))
+(!set-up-structure-object-class)
+
+;;; early structure predeclarations: Set up DD and LAYOUT for ordinary
+;;; (non-ALTERNATE-METACLASS) structures which are needed early.
(dolist (args
'#.(sb-cold:read-from-file
"src/code/early-defstruct-args.lisp-expr"))
(:macro (format s "Macro-function: ~S" x))
(:function (format s "Function: ~S" x))
((nil) (format s "~S is a function." x)))
- (case (get-type x)
+ (case (widetag-of x)
(#.sb-vm:closure-header-widetag
(%describe-function-compiled (%closure-fun x) s kind name)
(format s "~@:_Its closure environment is:")
(:constructor %make-vop-stats (name))
(:constructor make-vop-stats-key)
(:copier nil))
- (name (required-argument) :type simple-string)
+ (name (missing-arg) :type simple-string)
(data (make-array 2 :element-type 'double-float) :type count-vector))
(defmacro vop-stats-count (x) `(aref (vop-stats-data ,x) 0))
-;;;; descriptions of DEFSTRUCTs which are to be handled before any others
+;;;; descriptions of ordinary (non-ALTERNATE-METACLASS) DEFSTRUCTs
+;;;; which are to be handled before any others
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(;; Define the STRUCTURE-OBJECT class as a subclass of
- ;; INSTANCE. This has to be handled early because the design of the
- ;; DEFSTRUCT system, dating back to pre-1999 CMU CL, requires that
- ;; STRUCTURE-OBJECT be the first DEFSTRUCT executed.
- ;;
- ;; (The #|DEF|# here is to help find this definition with lexical search.)
- (#|def|# (structure-object (:alternate-metaclass sb!kernel:instance)
- (:copier nil))
- ;; (There are no slots.)
- )
-
- ;; The target ALIEN-VALUE class must be defined early in the cross-compiler
+(;; The target ALIEN-VALUE class must be defined early in the cross-compiler
;; build sequence in order to set up superclass relationships involving it.
;;
;; FIXME: Since this definition refers to SB!ALIEN:ALIEN-TYPE, which is also
;;
;; (The #|DEF|# here is to help find this definition with lexical search.)
(#|def|# (sb!alien-internals:alien-value)
- (sap (required-argument) :type sb!sys:system-area-pointer)
- (type (required-argument) :type sb!alien::alien-type)))
+ (sap (missing-arg) :type sb!sys:system-area-pointer)
+ (type (missing-arg) :type sb!alien::alien-type)))
(/show0 "entering early-defstructs.lisp")
+(!set-up-structure-object-class)
+
#.`(progn
,@(mapcar (lambda (args)
`(defstruct ,@args))
;;; error indicating that a required &KEY argument was not supplied.
;;; This function is also useful for DEFSTRUCT slot defaults
;;; corresponding to required arguments.
-(declaim (ftype (function () nil) required-argument))
-(defun required-argument ()
+(declaim (ftype (function () nil) required-arg))
+(defun required-arg ()
#!+sb-doc
- (/show0 "entering REQUIRED-ARGUMENT")
+ (/show0 "entering REQUIRED-ARG")
(error "A required &KEY or &OPTIONAL argument was not supplied."))
;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
(wild-args nil :type boolean)
;; type describing the return values. This is a values type
;; when multiple values were specified for the return.
- (returns (required-argument) :type ctype))
+ (returns (missing-arg) :type ctype))
;;; The CONSTANT-TYPE structure represents a use of the
;;; CONSTANT-ARGUMENT "type specifier", which is only meaningful in
(:copier nil))
;; The type which the argument must be a constant instance of for this type
;; specifier to win.
- (type (required-argument) :type ctype))
+ (type (missing-arg) :type ctype))
;;; The NAMED-TYPE is used to represent *, T and NIL. These types must be
;;; super- or sub-types of all types, not just classes and * and NIL aren't
;; Is this not a simple array type? (:MAYBE means that we don't know.)
(complexp :maybe :type (member t nil :maybe))
;; the element type as originally specified
- (element-type (required-argument) :type ctype)
+ (element-type (missing-arg) :type ctype)
;; the element type as it is specialized in this implementation
(specialized-element-type *wild-type* :type ctype))
;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types)
;;
;; FIXME: Most or all other type structure slots could also be :READ-ONLY.
- (car-type (required-argument) :type ctype :read-only t)
- (cdr-type (required-argument) :type ctype :read-only t))
+ (car-type (missing-arg) :type ctype :read-only t)
+ (cdr-type (missing-arg) :type ctype :read-only t))
;;; Note that the type NAME has been (re)defined, updating the
;;; undefined warnings and VALUES-SPECIFIER-TYPE cache.
;;; not sure this is the right place, but where else?
(defun style-warn (format-control &rest format-arguments)
+ (/show0 "entering STYLE-WARN")
+ (/show format-control format-arguments)
(warn 'simple-style-warning
:format-control format-control
:format-arguments format-arguments))
((progn)
(eval-progn-body (rest exp)))
((eval-when)
- ;; FIXME: DESTRUCTURING-BIND returns
- ;; DEFMACRO-LL-ARG-COUNT-ERROR instead of PROGRAM-ERROR
- ;; when there's something wrong with the syntax here (e.g.
- ;; missing SITUATIONS). This could be fixed by
- ;; hand-crafting clauses to catch and report each
- ;; possibility, but it would probably be cleaner to write
- ;; a new macro DESTRUCTURING-BIND-PROGRAM-SYNTAX which
- ;; does DESTRUCTURING-BIND and promotes any mismatch to
+ ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR
+ ;; instead of PROGRAM-ERROR when there's something wrong
+ ;; with the syntax here (e.g. missing SITUATIONS). This
+ ;; could be fixed by hand-crafting clauses to catch and
+ ;; report each possibility, but it would probably be
+ ;; cleaner to write a new macro
+ ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does
+ ;; DESTRUCTURING-BIND and promotes any mismatch to
;; PROGRAM-ERROR, then to use it here and in (probably
;; dozens of) other places where the same problem arises.
(destructuring-bind (eval-when situations &rest body) exp
;;; Find the encapsulation info that has been closed over.
(defun encapsulation-info (fun)
(and (functionp fun)
- (= (get-type fun) sb!vm:closure-header-widetag)
+ (= (widetag-of fun) sb!vm:closure-header-widetag)
(find-if-in-closure #'encapsulation-info-p fun)))
;;; When removing an encapsulation, we must remember that
nil)))
(:copier nil)
(:constructor make-logical-hostname (name)))
- (name (required-argument) :type simple-string))
+ (name (missing-arg) :type simple-string))
(defun maybe-extract-logical-hostname (namestr start end)
(declare (type simple-base-string namestr)
(sb!xc:defstruct (hash-table (:constructor %make-hash-table))
;; The type of hash table this is. Only used for printing and as
;; part of the exported interface.
- (test (required-argument) :type symbol :read-only t)
+ (test (missing-arg) :type symbol :read-only t)
;; The function used to compare two keys. Returns T if they are the
;; same and NIL if not.
- (test-fun (required-argument) :type function :read-only t)
+ (test-fun (missing-arg) :type function :read-only t)
;; The function used to compute the hashing of a key. Returns two
;; values: the index hashing and T if that might change with the
;; next GC.
- (hash-fun (required-argument) :type function :read-only t)
+ (hash-fun (missing-arg) :type function :read-only t)
;; how much to grow the hash table by when it fills up. If an index,
;; then add that amount. If a floating point number, then multiply
;; it by that.
- (rehash-size (required-argument) :type (or index (single-float (1.0)))
+ (rehash-size (missing-arg) :type (or index (single-float (1.0)))
:read-only t)
;; how full the hash table has to get before we rehash
- (rehash-threshold (required-argument) :type (single-float (0.0) 1.0)
- :read-only t)
+ (rehash-threshold (missing-arg) :type (single-float (0.0) 1.0) :read-only t)
;; The number of entries before a rehash, just one less than the
;; size of the next-vector, hash-vector, and half the size of the
;; kv-vector.
- (rehash-trigger (required-argument) :type index)
+ (rehash-trigger (missing-arg) :type index)
;; The current number of entries in the table.
(number-entries 0 :type index)
;; The Key-Value pair vector.
- (table (required-argument) :type simple-vector)
+ (table (missing-arg) :type simple-vector)
;; True if this is a weak hash table, meaning that key->value
;; mappings will disappear if there are no other references to the
;; key. Note: this only matters if the hash function indicates that
(next-free-kv 0 :type index)
;; The index vector. This may be larger than the hash size to help
;; reduce collisions.
- (index-vector (required-argument)
- :type (simple-array (unsigned-byte 32) (*)))
+ (index-vector (missing-arg) :type (simple-array (unsigned-byte 32) (*)))
;; This table parallels the KV vector, and is used to chain together
;; the hash buckets, the free list, and the values needing rehash, a
;; slot will only ever be in one of these lists.
- (next-vector (required-argument) :type (simple-array (unsigned-byte 32) (*)))
+ (next-vector (missing-arg) :type (simple-array (unsigned-byte 32) (*)))
;; This table parallels the KV table, and can be used to store the
;; hash associated with the key, saving recalculation. Could be
;; useful for EQL, and EQUAL hash tables. This table is not needed
(def!struct (heap-alien-info
(:make-load-form-fun sb!kernel:just-dump-it-normally))
;; The type of this alien.
- (type (required-argument) :type alien-type)
+ (type (missing-arg) :type alien-type)
;; The form to evaluate to produce the SAP pointing to where in the heap
;; it is.
- (sap-form (required-argument)))
+ (sap-form (missing-arg)))
(def!method print-object ((info heap-alien-info) stream)
(print-unreadable-object (info stream :type t)
(funcall (formatter "~S ~S")
;;;; the FLOAT types
(def-alien-type-class (float)
- (type (required-argument) :type symbol))
+ (type (missing-arg) :type symbol))
(def-alien-type-method (float :unparse) (type)
(alien-float-type-type type))
;;;; the ARRAY type
(def-alien-type-class (array :include mem-block)
- (element-type (required-argument) :type alien-type)
- (dimensions (required-argument) :type list))
+ (element-type (missing-arg) :type alien-type)
+ (dimensions (missing-arg) :type list))
(def-alien-type-translator array (ele-type &rest dims &environment env)
(def!struct (alien-record-field
(:make-load-form-fun sb!kernel:just-dump-it-normally))
- (name (required-argument) :type symbol)
- (type (required-argument) :type alien-type)
+ (name (missing-arg) :type symbol)
+ (type (missing-arg) :type alien-type)
(bits nil :type (or unsigned-byte null))
(offset 0 :type unsigned-byte))
(def!method print-object ((field alien-record-field) stream)
(defvar *values-type-okay* nil)
(def-alien-type-class (fun :include mem-block)
- (result-type (required-argument) :type alien-type)
- (arg-types (required-argument) :type list)
+ (result-type (missing-arg) :type alien-type)
+ (arg-types (missing-arg) :type list)
(stub nil :type (or null function)))
(def-alien-type-translator function (result-type &rest arg-types
(alien-fun-type-arg-types type2))))
(def-alien-type-class (values)
- (values (required-argument) :type list))
+ (values (missing-arg) :type list))
(def-alien-type-translator values (&rest values &environment env)
(unless *values-type-okay*
(:constructor make-local-alien-info
(&key type force-to-memory-p)))
;; the type of the local alien
- (type (required-argument) :type alien-type)
- ;; T if this local alien must be forced into memory. Using the ADDR macro
+ (type (missing-arg) :type alien-type)
+ ;; Must this local alien be forced into memory? Using the ADDR macro
;; on a local alien will set this.
- (force-to-memory-p (or (alien-array-type-p type) (alien-record-type-p type))
+ (force-to-memory-p (or (alien-array-type-p type)
+ (alien-record-type-p type))
:type (member t nil)))
(def!method print-object ((info local-alien-info) stream)
(print-unreadable-object (info stream :type t)
(inspected-structure-elements object)))
(defmethod inspected-parts ((object function))
- (let* ((type (sb-kernel:get-type object))
+ (let* ((type (sb-kernel:widetag-of object))
(object (if (= type sb-vm:closure-header-widetag)
(sb-kernel:%closure-fun object)
object)))
(defun set-header-data (x val)
(set-header-data x val))
-;;; Return the length of the closure X. This is one more than the
-;;; number of variables closed over.
+;;; the length of the closure X, i.e. one more than the
+;;; number of variables closed over
(defun get-closure-length (x)
(get-closure-length x))
-;;; Return the three-bit lowtag for the object X.
-(defun get-lowtag (x)
- (get-lowtag x))
+(defun lowtag-of (x)
+ (lowtag-of x))
-;;; Return the 8-bit header type for the object X.
-(defun get-type (x)
- (get-type x))
+(defun widetag-of (x)
+ (widetag-of x))
;;; Return a System-Area-Pointer pointing to the data for the vector
;;; X, which must be simple.
;;;
-;;; FIXME: so it should be SIMPLE-VECTOR-SAP, right?
+;;; FIXME: So it should be SIMPLE-VECTOR-SAP, right? (or UNHAIRY-VECTOR-SAP,
+;;; if the meaning is (SIMPLE-ARRAY * 1) instead of SIMPLE-VECTOR)
+;;; (or maybe SIMPLE-VECTOR-DATA-SAP or UNHAIRY-VECTOR-DATA-SAP?)
(defun vector-sap (x)
(declare (type (simple-unboxed-array (*)) x))
(vector-sap x))
(format-error-offset condition)))
\f
(def!struct format-directive
- (string (required-argument) :type simple-string)
- (start (required-argument) :type (and unsigned-byte fixnum))
- (end (required-argument) :type (and unsigned-byte fixnum))
- (character (required-argument) :type base-char)
+ (string (missing-arg) :type simple-string)
+ (start (missing-arg) :type (and unsigned-byte fixnum))
+ (end (missing-arg) :type (and unsigned-byte fixnum))
+ (character (missing-arg) :type base-char)
(colonp nil :type (member t nil))
(atsignp nil :type (member t nil))
(params nil :type list))
;;; the description of a &KEY argument
(defstruct (key-info #-sb-xc-host (:pure t)
(:copier nil))
- ;; the key (not necessarily a keyword in ANSI)
- (name (required-argument) :type symbol)
+ ;; the key (not necessarily a keyword in ANSI Common Lisp)
+ (name (missing-arg) :type symbol)
;; the type of the argument value
- (type (required-argument) :type ctype))
+ (type (missing-arg) :type ctype))
(!define-type-method (values :simple-subtypep :complex-subtypep-arg1)
(type1 type2)
-;;;; the STREAM structure
+;;;; the abstract class LISP-STREAM
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(deftype in-buffer-type ()
`(simple-array (unsigned-byte 8) (,+in-buffer-length+)))
+;;; base class for ANSI standard streams (as opposed to the Gray streams
+;;; extension)
(defstruct (lisp-stream (:constructor nil)
(:copier nil))
- ;; Buffered input.
+ ;; buffered input
(in-buffer nil :type (or in-buffer-type null))
(in-index +in-buffer-length+ :type index) ; index into IN-BUFFER
(in #'ill-in :type function) ; READ-CHAR function
||#
(defun loop-hash-table-iteration-path (variable data-type prep-phrases
- &key (which (required-argument)))
+ &key (which (missing-arg)))
(declare (type (member :hash-key :hash-value) which))
(cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of))))
(loop-error "too many prepositions!"))
(values (fdefinition x) t))))
(function x)
(t (values (fdefinition x) t)))
- (case (sb-kernel:get-type res)
+ (case (sb-kernel:widetag-of res)
(#.sb-vm:closure-header-widetag
(values (sb-kernel:%closure-fun res)
named-p
(sb!xc:defstruct (package-hashtable (:constructor %make-package-hashtable ())
(:copier nil))
;; The g-vector of symbols.
- ;; FIXME: could just be type SIMPLE-VECTOR, with REQUIRED-ARGUMENT
+ ;; FIXME: could just be type SIMPLE-VECTOR, with REQUIRED-ARG
(table nil :type (or simple-vector null))
;; The i-vector of pname hash values.
- ;; FIXME: could just be type HASH-VECTOR, with REQUIRED-ARGUMENT
+ ;; FIXME: could just be type HASH-VECTOR, with REQUIRED-ARG
(hash nil :type (or hash-vector null))
;; The total number of entries allowed before resizing.
;;
;; packages that use this package
(%used-by-list () :type list)
;; PACKAGE-HASHTABLEs of internal & external symbols
- (internal-symbols (required-argument) :type package-hashtable)
- (external-symbols (required-argument) :type package-hashtable)
+ (internal-symbols (missing-arg) :type package-hashtable)
+ (external-symbols (missing-arg) :type package-hashtable)
;; shadowing symbols
(%shadowing-symbols () :type list)
;; documentation string for this package
;;;; error-handling machinery for PARSE-DEFMACRO, separated from
;;;; PARSE-DEFMACRO code itself because the happy path can be handled
-;;;; earlier in the bootstrap sequence than DEFINE-CONDITION can be,
-;;;; and because some of the error handling depends on SBCL
-;;;; extensions, while PARSE-DEFMACRO needs to run in the
-;;;; cross-compiler on the host Common Lisp
+;;;; earlier in the bootstrap sequence than DEFINE-CONDITION can be
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(in-package "SB!KERNEL")
;;; We save space in macro definitions by calling this function.
-(defun do-arg-count-error (error-kind name arg lambda-list minimum maximum)
- (multiple-value-bind (fname sb!debug:*stack-top-hint*)
- (find-caller-name-and-frame)
- (declare (ignorable fname))
- (error 'defmacro-ll-arg-count-error
+(defun arg-count-error (error-kind name arg lambda-list minimum maximum)
+ (let (#-sb-xc-host
+ (sb!debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
+ (error 'arg-count-error
:kind error-kind
:name name
:argument arg
(defmacro-bogus-sublist-error-object condition)
(defmacro-bogus-sublist-error-lambda-list condition)))))
-(define-condition defmacro-ll-arg-count-error (defmacro-lambda-list-bind-error)
- ((argument :reader defmacro-ll-arg-count-error-argument :initarg :argument)
- (lambda-list :reader defmacro-ll-arg-count-error-lambda-list
+(define-condition arg-count-error (defmacro-lambda-list-bind-error)
+ ((argument :reader arg-count-error-argument :initarg :argument)
+ (lambda-list :reader arg-count-error-lambda-list
:initarg :lambda-list)
- (minimum :reader defmacro-ll-arg-count-error-minimum :initarg :minimum)
- (maximum :reader defmacro-ll-arg-count-error-maximum :initarg :maximum))
+ (minimum :reader arg-count-error-minimum :initarg :minimum)
+ (maximum :reader arg-count-error-maximum :initarg :maximum))
(:report
(lambda (condition stream)
(print-defmacro-ll-bind-error-intro condition stream)
(format stream
"invalid number of elements in:~% ~:S~%~
- to satisfy lambda-list:~% ~:S~%"
- (defmacro-ll-arg-count-error-argument condition)
- (defmacro-ll-arg-count-error-lambda-list condition))
- (cond ((null (defmacro-ll-arg-count-error-maximum condition))
+ to satisfy lambda list:~% ~:S~%"
+ (arg-count-error-argument condition)
+ (arg-count-error-lambda-list condition))
+ (cond ((null (arg-count-error-maximum condition))
(format stream "at least ~D expected"
- (defmacro-ll-arg-count-error-minimum condition)))
- ((= (defmacro-ll-arg-count-error-minimum condition)
- (defmacro-ll-arg-count-error-maximum condition))
+ (arg-count-error-minimum condition)))
+ ((= (arg-count-error-minimum condition)
+ (arg-count-error-maximum condition))
(format stream "exactly ~D expected"
- (defmacro-ll-arg-count-error-minimum condition)))
+ (arg-count-error-minimum condition)))
(t
(format stream "between ~D and ~D expected"
- (defmacro-ll-arg-count-error-minimum condition)
- (defmacro-ll-arg-count-error-maximum condition))))
+ (arg-count-error-minimum condition)
+ (arg-count-error-maximum condition))))
(format stream ", but ~D found"
- (length (defmacro-ll-arg-count-error-argument condition))))))
+ (length (arg-count-error-argument condition))))))
(define-condition defmacro-ll-broken-key-list-error
(defmacro-lambda-list-bind-error)
`(list-of-length-at-least-p ,path-0 ,minimum)
`(proper-list-of-length-p ,path-0 ,minimum ,maximum))
,(if (eq error-fun 'error)
- `(do-arg-count-error ',error-kind ',name ,path-0
- ',lambda-list ,minimum
- ,(unless restp maximum))
- `(,error-fun 'defmacro-ll-arg-count-error
+ `(arg-count-error ',error-kind ',name ,path-0
+ ',lambda-list ,minimum
+ ,(unless restp maximum))
+ `(,error-fun 'arg-count-error
:kind ',error-kind
,@(when name `(:name ',name))
:argument ,path-0
;;; pathname information into structure slot entries, and after
;;; translation the inverse (unparse) functions.
(def!struct (host (:constructor nil))
- (parse (required-argument) :type function)
- (unparse (required-argument) :type function)
- (unparse-host (required-argument) :type function)
- (unparse-directory (required-argument) :type function)
- (unparse-file (required-argument) :type function)
- (unparse-enough (required-argument) :type function)
- (customary-case (required-argument) :type (member :upper :lower)))
+ (parse (missing-arg) :type function)
+ (unparse (missing-arg) :type function)
+ (unparse-host (missing-arg) :type function)
+ (unparse-directory (missing-arg) :type function)
+ (unparse-file (missing-arg) :type function)
+ (unparse-enough (missing-arg) :type function)
+ (customary-case (missing-arg) :type (member :upper :lower)))
(def!method print-object ((host host) stream)
(print-unreadable-object (host stream :type t :identity t)))
;;;; pretty streams
;;; There are three different units for measuring character positions:
-;;; COLUMN - offset (if characters) from the start of the current line.
-;;; INDEX - index into the output buffer.
-;;; POSN - some position in the stream of characters cycling through
-;;; the output buffer.
+;;; COLUMN - offset (if characters) from the start of the current line
+;;; INDEX - index into the output buffer
+;;; POSN - some position in the stream of characters cycling through
+;;; the output buffer
(deftype column ()
'(and fixnum unsigned-byte))
;;; The INDEX type is picked up from the kernel package.
(:constructor make-pretty-stream (target))
(:copier nil))
;; Where the output is going to finally go.
- (target (required-argument) :type stream)
+ (target (missing-arg) :type stream)
;; Line length we should format to. Cached here so we don't have to keep
;; extracting it from the target stream.
(line-length (or *print-right-margin*
(defstruct (newline (:include section-start)
(:copier nil))
- (kind (required-argument)
+ (kind (missing-arg)
:type (member :linear :fill :miser :literal :mandatory)))
(defun enqueue-newline (stream kind)
(defstruct (indentation (:include queued-op)
(:copier nil))
- (kind (required-argument) :type (member :block :current))
+ (kind (missing-arg) :type (member :block :current))
(amount 0 :type fixnum))
(defun enqueue-indent (stream kind amount)
(defvar *building-initial-table* nil)
(defstruct (pprint-dispatch-entry (:copier nil))
- ;; The type specifier for this entry.
- (type (required-argument) :type t)
- ;; A function to test to see whether an object is of this time. Pretty must
- ;; just (lambda (obj) (typep object type)) except that we handle the
- ;; CONS type specially so that (cons (member foo)) works. We don't
- ;; bother computing this for entries in the CONS hash table, because
- ;; we don't need it.
+ ;; the type specifier for this entry
+ (type (missing-arg) :type t)
+ ;; a function to test to see whether an object is of this time.
+ ;; Pretty must just (LAMBDA (OBJ) (TYPEP OBJECT TYPE)) except that
+ ;; we handle the CONS type specially so that (CONS (MEMBER FOO))
+ ;; works. We don't bother computing this for entries in the CONS
+ ;; hash table, because we don't need it.
(test-fn nil :type (or function null))
- ;; The priority for this guy.
+ ;; the priority for this guy
(priority 0 :type real)
;; T iff one of the original entries.
(initial-p *building-initial-table* :type (member t nil))
- ;; And the associated function.
- (function (required-argument) :type function))
+ ;; and the associated function
+ (function (missing-arg) :type function))
(def!method print-object ((entry pprint-dispatch-entry) stream)
(print-unreadable-object (entry stream :type t)
(format stream "type=~S, priority=~S~@[ [initial]~]"
*PRINT-ESCAPE*.")
(defvar *print-escape* T
#!+sb-doc
- "Flag which indicates that slashification is on. See the manual")
+ "Should we print in a reasonably machine-readable way? (possibly
+ overridden by *PRINT-READABLY*)")
(defvar *print-pretty* nil ; (set later when pretty-printer is initialized)
#!+sb-doc
- "Flag which indicates that pretty printing is to be used")
+ "Should pretty printing be used?")
(defvar *print-base* 10.
#!+sb-doc
- "The output base for integers and rationals.")
+ "the output base for RATIONALs (including integers)")
(defvar *print-radix* nil
#!+sb-doc
- "This flag requests to verify base when printing rationals.")
+ "Should base be verified when printing RATIONALs?")
(defvar *print-level* nil
#!+sb-doc
- "How many levels deep to print. Unlimited if null.")
+ "How many levels should be printed before abbreviating with \"#\"?")
(defvar *print-length* nil
#!+sb-doc
- "How many elements to print on each level. Unlimited if null.")
+ "How many elements at any level should be printed before abbreviating
+ with \"...\"?")
(defvar *print-circle* nil
#!+sb-doc
- "Whether to worry about circular list structures. See the manual.")
+ "Should we use #n= and #n# notation to preserve uniqueness in general (and
+ circularity in particular) when printing?")
(defvar *print-case* :upcase
#!+sb-doc
- "What kind of case the printer should use by default")
+ "What case should the printer should use default?")
(defvar *print-array* t
#!+sb-doc
- "Whether the array should print its guts out")
+ "Should the contents of arrays be printed?")
(defvar *print-gensym* t
#!+sb-doc
- "If true, symbols with no home package are printed with a #: prefix.
- If false, no prefix is printed.")
+ "Should #: prefixes be used when printing symbols with null SYMBOL-PACKAGE?")
(defvar *print-lines* nil
#!+sb-doc
- "The maximum number of lines to print. If NIL, unlimited.")
+ "the maximum number of lines to print per object")
(defvar *print-right-margin* nil
#!+sb-doc
- "The position of the right margin in ems. If NIL, try to determine this
- from the stream in use.")
+ "the position of the right margin in ems (for pretty-printing)")
(defvar *print-miser-width* nil
#!+sb-doc
"If the remaining space between the current column and the right margin
turned off. If NIL, never use miser mode.")
(defvar *print-pprint-dispatch* nil
#!+sb-doc
- "The pprint-dispatch-table that controls how to pretty print objects. See
- COPY-PPRINT-DISPATH, PPRINT-DISPATCH, and SET-PPRINT-DISPATCH.")
+ "the pprint-dispatch-table that controls how to pretty-print objects")
(defmacro with-standard-io-syntax (&body body)
#!+sb-doc
*READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT
*READ-EVAL* T
*READ-SUPPRESS* NIL
- *READTABLE* the standard readtable."
+ *READTABLE* the standard readtable"
`(%with-standard-io-syntax #'(lambda () ,@body)))
(defun %with-standard-io-syntax (function)
;;; marker, it is incremented.
(defvar *circularity-counter* nil)
-;;; Check to see whether OBJECT is a circular reference, and return something
-;;; non-NIL if it is. If ASSIGN is T, then the number to use in the #n= and
-;;; #n# noise is assigned at this time. Note: CHECK-FOR-CIRCULARITY must
-;;; be called *EXACTLY* once with ASSIGN T, or the circularity detection noise
-;;; will get confused about when to use #n= and when to use #n#. If this
-;;; returns non-NIL when ASSIGN is T, then you must call HANDLE-CIRCULARITY
-;;; on it. If you are not using this inside a WITH-CIRCULARITY-DETECTION,
-;;; then you have to be prepared to handle a return value of :INITIATE which
-;;; means it needs to initiate the circularity detection noise. See the
-;;; source for info on how to do that.
+;;; Check to see whether OBJECT is a circular reference, and return
+;;; something non-NIL if it is. If ASSIGN is T, then the number to use
+;;; in the #n= and #n# noise is assigned at this time.
+;;;
+;;; Note: CHECK-FOR-CIRCULARITY must be called *exactly* once with
+;;; ASSIGN true, or the circularity detection noise will get confused
+;;; about when to use #n= and when to use #n#. If this returns non-NIL
+;;; when ASSIGN is true, then you must call HANDLE-CIRCULARITY on it.
+;;; If you are not using this inside a WITH-CIRCULARITY-DETECTION,
+;;; then you have to be prepared to handle a return value of :INITIATE
+;;; which means it needs to initiate the circularity detection noise.
(defun check-for-circularity (object &optional assign)
(cond ((null *print-circle*)
;; Don't bother, nobody cares.
((null *circularity-counter*)
(ecase (gethash object *circularity-hash-table*)
((nil)
- ;; First encounter.
+ ;; first encounter
(setf (gethash object *circularity-hash-table*) t)
;; We need to keep looking.
nil)
((t)
- ;; Second encounter.
+ ;; second encounter
(setf (gethash object *circularity-hash-table*) 0)
;; It's a circular reference.
t)
(let ((value (gethash object *circularity-hash-table*)))
(case value
((nil t)
- ;; If NIL, we found an object that wasn't there the first time
- ;; around. If T, exactly one occurance of this object appears.
- ;; Either way, just print the thing without any special
- ;; processing. Note: you might argue that finding a new object
- ;; means that something is broken, but this can happen. If
- ;; someone uses the ~@<...~:> format directive, it conses a
- ;; new list each time though format (i.e. the &REST list), so
- ;; we will have different cdrs.
+ ;; If NIL, we found an object that wasn't there the
+ ;; first time around. If T, this object appears exactly
+ ;; once. Either way, just print the thing without any
+ ;; special processing. Note: you might argue that
+ ;; finding a new object means that something is broken,
+ ;; but this can happen. If someone uses the ~@<...~:>
+ ;; format directive, it conses a new list each time
+ ;; though format (i.e. the &REST list), so we will have
+ ;; different cdrs.
nil)
(0
(if assign
(let ((value (incf *circularity-counter*)))
- ;; First occurance of this object. Set the counter.
+ ;; first occurrence of this object: Set the counter.
(setf (gethash object *circularity-hash-table*) value)
value)
t))
(t
- ;; Second or later occurance.
+ ;; second or later occurrence
(- value)))))))
;;; Handle the results of CHECK-FOR-CIRCULARITY. If this returns T then
(cond ((or (not *print-circle*)
(numberp object)
(characterp object)
- (and (symbolp object) (symbol-package object) t))
- ;; If it a number, character, or interned symbol, we do not
- ;; want to check for circularity/sharing.
+ (and (symbolp object)
+ (symbol-package object)))
+ ;; If it's a number, character, or interned symbol, we
+ ;; don't want to check for circularity/sharing.
(print-it stream))
((or *circularity-hash-table*
(consp object)
(typep object 'instance)
(typep object '(array t *)))
;; If we have already started circularity detection, this
- ;; object might be a sharded reference. If we have not,
- ;; then if it is a cons, a instance, or an array of element
- ;; type t it might contain a circular reference to itself
+ ;; object might be a shared reference. If we have not, then
+ ;; if it is a cons, an instance, or an array of element
+ ;; type T it might contain a circular reference to itself
;; or multiple shared references.
(check-it stream))
(t
(defun output-random (object stream)
(print-unreadable-object (object stream :identity t)
- (let ((lowtag (get-lowtag object)))
+ (let ((lowtag (lowtag-of object)))
(case lowtag
(#.sb!vm:other-pointer-lowtag
- (let ((type (get-type object)))
- (case type
+ (let ((widetag (widetag-of object)))
+ (case widetag
(#.sb!vm:value-cell-header-widetag
(write-string "value cell " stream)
(output-object (value-cell-ref object) stream))
(t
- (write-string "unknown pointer object, type=" stream)
+ (write-string "unknown pointer object, widetag=" stream)
(let ((*print-base* 16) (*print-radix* t))
- (output-integer type stream))))))
+ (output-integer widetag stream))))))
((#.sb!vm:fun-pointer-lowtag
#.sb!vm:instance-pointer-lowtag
#.sb!vm:list-pointer-lowtag)
- (write-string "unknown pointer object, type=" stream))
+ (write-string "unknown pointer object, lowtag=" stream)
+ (let ((*print-base* 16) (*print-radix* t))
+ (output-integer lowtag stream)))
(t
- (case (get-type object)
+ (case (widetag-of object)
(#.sb!vm:unbound-marker-widetag
(write-string "unbound marker" stream))
(t
(write-string "unknown immediate object, lowtag=" stream)
(let ((*print-base* 2) (*print-radix* t))
(output-integer lowtag stream))
- (write-string ", type=" stream)
+ (write-string ", widetag=" stream)
(let ((*print-base* 16) (*print-radix* t))
- (output-integer (get-type object) stream)))))))))
+ (output-integer (widetag-of object) stream)))))))))
;;; closure which implements the encapsulation.
(defvar *profiled-fun-name->info* (make-hash-table))
(defstruct (profile-info (:copier nil))
- (name (required-argument) :read-only t)
- (encapsulated-fun (required-argument) :type function :read-only t)
- (encapsulation-fun (required-argument) :type function :read-only t)
- (read-stats-fun (required-argument) :type function :read-only t)
- (clear-stats-fun (required-argument) :type function :read-only t))
+ (name (missing-arg) :read-only t)
+ (encapsulated-fun (missing-arg) :type function :read-only t)
+ (encapsulation-fun (missing-arg) :type function :read-only t)
+ (read-stats-fun (missing-arg) :type function :read-only t)
+ (clear-stats-fun (missing-arg) :type function :read-only t))
;;; These variables are used to subtract out the time and consing for
;;; recursive and other dynamically nested profiled calls. The total
(defstruct (overhead (:copier nil))
;; the number of ticks a bare function call takes. This is
;; factored into the other overheads, but not used for itself.
- (call (required-argument) :type single-float :read-only t)
+ (call (missing-arg) :type single-float :read-only t)
;; the number of ticks that will be charged to a profiled
;; function due to the profiling code
- (internal (required-argument) :type single-float :read-only t)
+ (internal (missing-arg) :type single-float :read-only t)
;; the number of ticks of overhead for profiling that a single
;; profiled call adds to the total runtime for the program
- (total (required-argument) :type single-float :read-only t))
+ (total (missing-arg) :type single-float :read-only t))
(defvar *overhead*)
(declaim (type overhead *overhead*))
(makunbound '*overhead*) ; in case we reload this file when tweaking
(eval-when (:compile-toplevel :load-toplevel :execute)
(def!struct (room-info (:make-load-form-fun just-dump-it-normally))
- ;; The name of this type.
+ ;; the name of this type
(name nil :type symbol)
- ;; Kind of type (how we determine length).
- (kind (required-argument)
+ ;; kind of type (how we determine length)
+ (kind (missing-arg)
:type (member :lowtag :fixed :header :vector
:string :code :closure :instance))
- ;; Length if fixed-length, shift amount for element size if :VECTOR.
+ ;; length if fixed-length, shift amount for element size if :VECTOR
(length nil :type (or fixnum null))))
(eval-when (:compile-toplevel :execute)
;;; Set this to NIL to suppress output from /SHOW-related forms.
#!+sb-show (defvar */show* t)
-;;; shorthand for a common idiom in output statements used in debugging:
-;;; (/SHOW "Case 2:" X Y) becomes a pretty-printed version of
-;;; (FORMAT .. "~&/Case 2: X=~S Y=~S~%" X Y).
+(defun cannot-/show (string)
+ #+sb-xc-host (error "can't /SHOW: ~A" string)
+ ;; We end up in this situation when we execute /SHOW too early in
+ ;; cold init. That happens to me often enough that it's really
+ ;; annoying for it to cause a hard failure -- which at that point is
+ ;; hard to recover from -- instead of just diagnostic output.
+ #-sb-xc-host (sb!sys:%primitive
+ print
+ (concatenate 'string "/can't /SHOW: " string))
+ (values))
+
+;;; Should /SHOW output be suppressed at this point?
+;;;
+;;; Note that despite the connoting-no-side-effects-pure-predicate
+;;; name, we emit some error output if we're called at a point where
+;;; /SHOW is inherently invalid.
+(defun suppress-/show-p ()
+ (cond (;; protection against /SHOW too early in cold init for
+ ;; (FORMAT *TRACE-OUTPUT* ..) to work, part I: Obviously
+ ;; we need *TRACE-OUTPUT* bound.
+ (not (boundp '*trace-output*))
+ (cannot-/show "*TRACE-OUTPUT* isn't bound. (Try /SHOW0.)")
+ t)
+ (;; protection against /SHOW too early in cold init for
+ ;; (FORMAT *TRACE-OUTPUT* ..) to work, part II: In a virtuoso
+ ;; display of name mnemonicity, *READTABLE* is used by the
+ ;; printer to decide which case convention to use when
+ ;; writing symbols, so we need it bound.
+ (not (boundp '*readtable*))
+ (cannot-/show "*READTABLE* isn't bound. (Try /SHOW0.)")
+ t)
+ (;; more protection against /SHOW too early in cold init, part III
+ (not (boundp '*/show*))
+ (cannot-/show "*/SHOW* isn't bound. (Try initializing it earlier.)")
+ t)
+ (;; ordinary, healthy reason to suppress /SHOW, no error
+ ;; output needed
+ (not */show*)
+ t)
+ (t
+ ;; Let the /SHOW go on.
+ nil)))
+
+;;; shorthand for a common idiom in output statements used in
+;;; debugging: (/SHOW "Case 2:" X Y) becomes a pretty-printed version
+;;; of (FORMAT .. "~&/Case 2: X=~S Y=~S~%" X Y), conditional on */SHOW*.
(defmacro /show (&rest xlist)
#!-sb-show (declare (ignore xlist))
#!+sb-show
(format-rest (reverse format-reverse-rest)))
`(locally
(declare (optimize (speed 1) (space 2) (safety 3)))
- ;; For /SHOW to work, we need *TRACE-OUTPUT* of course, but
- ;; also *READTABLE* (used by the printer to decide what
- ;; case convention to use when outputting symbols).
- (if (every #'boundp '(*trace-output* *readtable*))
- (when */show*
- (format *trace-output*
- ,format-string
- #+ansi-cl (list ,@format-rest)
- #-ansi-cl ,@format-rest)) ; for CLISP (CLTL1-ish)
- #+sb-xc-host (error "can't /SHOW, unbound vars")
- ;; We end up in this situation when we execute /SHOW
- ;; too early in cold init. That happens often enough
- ;; that it's really annoying for it to cause a hard
- ;; failure -- which at that point is hard to recover
- ;; from -- instead of just diagnostic output.
- #-sb-xc-host (sb!sys:%primitive
- print
- "/(can't /SHOW, unbound vars)"))
+ (unless (suppress-/show-p)
+ (format *trace-output*
+ ,format-string
+ #+ansi-cl (list ,@format-rest)
+ #-ansi-cl ,@format-rest)) ; for CLISP (CLTL1-ish)
(values))))))
;;; a disabled-at-compile-time /SHOW, implemented as a macro instead
(:constructor make-unix-signal (%name %number))
(:copier nil))
;; signal keyword (e.g. :SIGINT for the Unix SIGINT signal)
- (%name (required-argument) :type keyword :read-only t)
+ (%name (missing-arg) :type keyword :read-only t)
;; signal number
- (%number (required-argument) :type integer :read-only t))
+ (%number (missing-arg) :type integer :read-only t))
;;; list of all defined UNIX-SIGNALs
(defvar *unix-signals* nil)
#!+high-security-support
%make-two-way-stream (input-stream output-stream))
(:copier nil))
- (input-stream (required-argument) :type stream :read-only t)
- (output-stream (required-argument) :type stream :read-only t))
+ (input-stream (missing-arg) :type stream :read-only t)
+ (output-stream (missing-arg) :type stream :read-only t))
(defprinter (two-way-stream) input-stream output-stream)
#!-high-security-support
(:misc #'case-frob-misc))
(:constructor %make-case-frob-stream (target out sout))
(:copier nil))
- (target (required-argument) :type stream))
+ (target (missing-arg) :type stream))
(defun make-case-frob-stream (target kind)
#!+sb-doc
\f
;;;; structure frobbing primitives
+;;; Allocate a new instance with LENGTH data slots.
(defun %make-instance (length)
- #!+sb-doc
- "Allocate a new instance with LENGTH data slots."
(declare (type index length))
(%make-instance length))
+;;; Given an instance, return its length.
(defun %instance-length (instance)
- #!+sb-doc
- "Given an instance, return its length."
(declare (type instance instance))
(%instance-length instance))
+;;; Return the value from the INDEXth slot of INSTANCE. This is SETFable.
(defun %instance-ref (instance index)
- #!+sb-doc
- "Return the value from the INDEXth slot of INSTANCE. This is SETFable."
(%instance-ref instance index))
+;;; Set the INDEXth slot of INSTANCE to NEW-VALUE.
(defun %instance-set (instance index new-value)
- #!+sb-doc
- "Set the INDEXth slot of INSTANCE to NEW-VALUE."
(setf (%instance-ref instance index) new-value))
(defun %raw-ref-single (vec index)
;;;
;;; The only loss is that if someone accesses the
;;; FUNCALLABLE-INSTANCE-FUN, then won't get a FIN back. This probably
-;;; doesn't matter, since PCL only sets the FIN function. And the only
-;;; reason that interpreted functions are FINs instead of bare
-;;; closures is for debuggability.
+;;; doesn't matter, since PCL only sets the FIN function.
(defun (setf funcallable-instance-fun) (new-value fin)
(setf (%funcallable-instance-fun fin)
(%closure-fun new-value))
(%funcallable-instance-lexenv new-value)
new-value)))
\f
+;;;; target-only parts of the DEFSTRUCT top-level code
+
+;;; Catch attempts to mess up definitions of symbols in the CL package.
+(defun protect-cl (symbol)
+ (/show0 "entering PROTECT-CL, SYMBOL=..")
+ (/hexstr symbol)
+ (when (and *cold-init-complete-p*
+ (eq (symbol-package symbol) *cl-package*))
+ (cerror "Go ahead and patch the system."
+ "attempting to modify a symbol in the COMMON-LISP package: ~S"
+ symbol))
+ (/show0 "leaving PROTECT-CL")
+ (values))
+
+;;; the part of %DEFSTRUCT which sets up out-of-line implementations
+;;; of those structure functions which are sufficiently similar
+;;; between structures that they can be closures
+;;;
+;;; (The "static" in the name is because it needs to be done not only
+;;; in ordinary toplevel %DEFSTRUCT, but also in cold init as early as
+;;; possible, to simulate static linking of structure functions as
+;;; nearly as possible.)
+(defun %target-defstruct (dd layout)
+ (declare (type defstruct-description dd))
+ (declare (type layout layout))
+
+ (/show0 "entering %TARGET-DEFSTRUCT")
+
+ ;; (Constructors aren't set up here, because constructors are
+ ;; varied enough (possibly parsing any specified argument list)
+ ;; that we can't reasonably implement them as closures, and so
+ ;; implement them with DEFUN instead.)
+
+ ;; Set FDEFINITIONs for slot accessors.
+ (dolist (dsd (dd-slots dd))
+ (/show0 "doing FDEFINITION for slot accessor")
+ (let ((accessor-name (dsd-accessor-name dsd)))
+ (/show0 "ACCESSOR-NAME=..")
+ (/hexstr accessor-name)
+ (protect-cl accessor-name)
+ (/hexstr "getting READER-FUN and WRITER-FUN")
+ (multiple-value-bind (reader-fun writer-fun) (slot-accessor-funs dd dsd)
+ (declare (type function reader-fun writer-fun))
+ (/show0 "got READER-FUN and WRITER-FUN=..")
+ (/hexstr reader-fun)
+ (setf (symbol-function accessor-name) reader-fun)
+ (unless (dsd-read-only dsd)
+ (/show0 "setting FDEFINITION for WRITER-FUN=..")
+ (/hexstr writer-fun)
+ (setf (fdefinition `(setf ,accessor-name)) writer-fun)))))
+
+ ;; Set FDEFINITION for copier.
+ (when (dd-copier-name dd)
+ (/show0 "doing FDEFINITION for copier")
+ (protect-cl (dd-copier-name dd))
+ ;; We can't use COPY-STRUCTURE for other kinds of objects, notably
+ ;; funcallable structures, since it returns a STRUCTURE-OBJECT.
+ ;; (And funcallable instances don't need copiers anyway.)
+ (aver (eql (dd-type dd) 'structure))
+ (setf (symbol-function (dd-copier-name dd))
+ ;; FIXME: should use a closure which checks arg type before copying
+ #'copy-structure))
+
+ ;; Set FDEFINITION for predicate.
+ (when (dd-predicate-name dd)
+ (/show0 "doing FDEFINITION for predicate")
+ (protect-cl (dd-predicate-name dd))
+ (setf (symbol-function (dd-predicate-name dd))
+ (ecase (dd-type dd)
+ ;; structures with LAYOUTs
+ ((structure funcallable-structure)
+ (/show0 "with-LAYOUT case")
+ (lambda (object)
+ (declare (optimize (speed 3) (safety 0)))
+ (/noshow0 "in with-LAYOUT structure predicate closure, OBJECT,LAYOUT=..")
+ (/nohexstr object)
+ (/nohexstr layout)
+ (typep-to-layout object layout)))
+ ;; structures with no LAYOUT (i.e. :TYPE VECTOR or :TYPE LIST)
+ ;;
+ ;; FIXME: should handle the :NAMED T case in these cases
+ (vector
+ (/show0 ":TYPE VECTOR case")
+ #'vectorp)
+ (list
+ (/show0 ":TYPE LIST case")
+ #'listp))))
+
+ (/show0 "leaving %TARGET-DEFSTRUCT")
+ (values))
+\f
;;; Copy any old kind of structure.
(defun copy-structure (structure)
#!+sb-doc
res))
\f
-;;; default PRINT and MAKE-LOAD-FORM methods
-
+;;; default PRINT-OBJECT and MAKE-LOAD-FORM methods
+
+(defun %default-structure-pretty-print (structure stream)
+ (let* ((layout (%instance-layout structure))
+ (name (sb!xc:class-name (layout-class layout)))
+ (dd (layout-info layout)))
+ (pprint-logical-block (stream nil :prefix "#S(" :suffix ")")
+ (prin1 name stream)
+ (let ((remaining-slots (dd-slots dd)))
+ (when remaining-slots
+ (write-char #\space stream)
+ ;; CMU CL had (PPRINT-INDENT :BLOCK 2 STREAM) here,
+ ;; but I can't see why. -- WHN 20000205
+ (pprint-newline :linear stream)
+ (loop
+ (pprint-pop)
+ (let ((slot (pop remaining-slots)))
+ (write-char #\: stream)
+ (output-symbol-name (dsd-%name slot) stream)
+ (write-char #\space stream)
+ (pprint-newline :miser stream)
+ (output-object (funcall (fdefinition (dsd-accessor-name slot))
+ structure)
+ stream)
+ (when (null remaining-slots)
+ (return))
+ (write-char #\space stream)
+ (pprint-newline :linear stream))))))))
+(defun %default-structure-ugly-print (structure stream)
+ (let* ((layout (%instance-layout structure))
+ (name (sb!xc:class-name (layout-class layout)))
+ (dd (layout-info layout)))
+ (descend-into (stream)
+ (write-string "#S(" stream)
+ (prin1 name stream)
+ (do ((index 0 (1+ index))
+ (remaining-slots (dd-slots dd) (cdr remaining-slots)))
+ ((or (null remaining-slots)
+ (and (not *print-readably*)
+ *print-length*
+ (>= index *print-length*)))
+ (if (null remaining-slots)
+ (write-string ")" stream)
+ (write-string " ...)" stream)))
+ (declare (type index index))
+ (write-char #\space stream)
+ (write-char #\: stream)
+ (let ((slot (first remaining-slots)))
+ (output-symbol-name (dsd-%name slot) stream)
+ (write-char #\space stream)
+ (output-object
+ (funcall (fdefinition (dsd-accessor-name slot))
+ structure)
+ stream))))))
(defun default-structure-print (structure stream depth)
(declare (ignore depth))
- (if (funcallable-instance-p structure)
- (print-unreadable-object (structure stream :identity t :type t))
- (let* ((type (%instance-layout structure))
- (name (sb!xc:class-name (layout-class type)))
- (dd (layout-info type)))
- (if *print-pretty*
- (pprint-logical-block (stream nil :prefix "#S(" :suffix ")")
- (prin1 name stream)
- (let ((slots (dd-slots dd)))
- (when slots
- (write-char #\space stream)
- ;; CMU CL had (PPRINT-INDENT :BLOCK 2 STREAM) here,
- ;; but I can't see why. -- WHN 20000205
- (pprint-newline :linear stream)
- (loop
- (pprint-pop)
- (let ((slot (pop slots)))
- (write-char #\: stream)
- (output-symbol-name (dsd-%name slot) stream)
- (write-char #\space stream)
- (pprint-newline :miser stream)
- (output-object
- (funcall (fdefinition (dsd-accessor-name slot))
- structure)
- stream)
- (when (null slots)
- (return))
- (write-char #\space stream)
- (pprint-newline :linear stream))))))
- (descend-into (stream)
- (write-string "#S(" stream)
- (prin1 name stream)
- (do ((index 0 (1+ index))
- (slots (dd-slots dd) (cdr slots)))
- ((or (null slots)
- (and (not *print-readably*)
- *print-length*
- (>= index *print-length*)))
- (if (null slots)
- (write-string ")" stream)
- (write-string " ...)" stream)))
- (declare (type index index))
- (write-char #\space stream)
- (write-char #\: stream)
- (let ((slot (first slots)))
- (output-symbol-name (dsd-%name slot) stream)
- (write-char #\space stream)
- (output-object
- (funcall (fdefinition (dsd-accessor-name slot))
- structure)
- stream))))))))
+ (cond ((funcallable-instance-p structure)
+ (print-unreadable-object (structure stream :identity t :type t)))
+ (*print-pretty*
+ (%default-structure-pretty-print structure stream))
+ (t
+ (%default-structure-ugly-print structure-stream))))
(def!method print-object ((x structure-object) stream)
(default-structure-print x stream *current-level*))
(error "stub: MAKE-LOAD-FORM-SAVING-SLOTS :SLOT-NAMES not implemented") ; KLUDGE
:just-dump-it-normally))
\f
+;;;; testing structure types
+
;;; Return true if OBJ is an object of the structure type
;;; corresponding to LAYOUT. This is called by the accessor closures,
-;;; which have a handle on the type's layout.
+;;; which have a handle on the type's LAYOUT.
;;;
;;; FIXME: This is fairly big, so it should probably become
;;; MAYBE-INLINE instead of INLINE. Or else we could fix things up so
#!-sb-fluid (declaim (inline typep-to-layout))
(defun typep-to-layout (obj layout)
(declare (type layout layout) (optimize (speed 3) (safety 0)))
+ (/noshow0 "entering TYPEP-TO-LAYOUT, OBJ,LAYOUT=..")
+ (/nohexstr obj)
+ (/nohexstr layout)
(when (layout-invalid layout)
(error "An obsolete structure accessor function was called."))
+ (/noshow0 "back from testing LAYOUT-INVALID LAYOUT")
;; FIXME: CMU CL used (%INSTANCEP OBJ) here. Check that
;; (TYPEP OBJ 'INSTANCE) is optimized to equally efficient code.
(and (typep obj 'instance)
(let ((obj-layout (%instance-layout obj)))
(cond ((eq obj-layout layout)
+ ;; (In this case OBJ-LAYOUT can't be invalid, because
+ ;; we determined LAYOUT is valid in the test above.)
+ (/noshow0 "EQ case")
t)
- ;; FIXME: Does the test for LAYOUT-INVALID really belong
- ;; after the test for EQ LAYOUT? Either explain why this
- ;; is, or change the order.
((layout-invalid obj-layout)
+ (/noshow0 "LAYOUT-INVALID case")
(error 'layout-invalid
:expected-type (layout-class obj-layout)
:datum obj))
(t
- (let ((depthoid (layout-depthoid layout)))
- (and (> (layout-depthoid obj-layout) depthoid)
- (eq (svref (layout-inherits obj-layout) depthoid)
- layout))))))))
+ (let ((depthoid (layout-depthoid layout)))
+ (/noshow0 "DEPTHOID case, DEPTHOID,LAYOUT-INHERITS=..")
+ (/nohexstr depthoid)
+ (/nohexstr layout-inherits)
+ (and (> (layout-depthoid obj-layout) depthoid)
+ (eq (svref (layout-inherits obj-layout) depthoid)
+ layout))))))))
\f
-;;;; implementing structure slot accessors as closures
-
-;;; In the normal case of structures that have a real type (i.e. no
-;;; :TYPE option was specified), we want to optimize things for space
-;;; as well as speed, since there can be thousands of defined slot
-;;; accessors.
-;;;
-;;; What we do is define the accessors and copier as closures over
-;;; general-case code. Since the compiler will normally open-code
-;;; accessors, the (minor) extra speed penalty for full calls is not a
-;;; concern.
-;;;
-;;; KLUDGE: This is a minor headache at cold init time, since genesis
-;;; doesn't know how to create the closures in the cold image, so the
-;;; function definitions aren't done until the appropriate top level
-;;; forms are executed, so any forward references to structure slots
-;;; (which are compiled into full calls) fail. The headache can be
-;;; treated by using SB!XC:DEFSTRUCT on the relevant structure at
-;;; build-the-cross-compiler time, so that the compiler is born
-;;; knowing how to inline accesses to the relevant structure, so no
-;;; full calls are made. This can be achieved by calling
-;;; SB!XC:DEFSTRUCT directly, or by using DEF!STRUCT, which (among
-;;; other things) calls SB!XC:DEFSTRUCT for you.
-
-;;; Return closures to do slot access according to Layout and DSD. We check
-;;; types, then do the access. This is only used for normal slots, not raw
-;;; slots.
-(defun structure-slot-getter (layout dsd)
- (let ((class (layout-class layout)))
- (if (typep class 'basic-structure-class)
- #'(lambda (structure)
- (declare (optimize (speed 3) (safety 0)))
- (flet ((structure-test (structure)
- (typep-to-layout structure layout)))
- (unless (structure-test structure)
- (error 'simple-type-error
- :datum structure
- :expected-type (class-name (layout-class layout))
- :format-control
- "Structure for accessor ~S is not a ~S:~% ~S"
- :format-arguments
- (list (dsd-accessor-name dsd)
- (sb!xc:class-name (layout-class layout))
- structure))))
- (%instance-ref structure (dsd-index dsd)))
- #'(lambda (structure)
- (declare (optimize (speed 3) (safety 0)))
- (unless (%typep structure class)
- (error 'simple-type-error
- :datum structure
- :expected-type 'class
+;;;; checking structure types
+
+;;; Check that X is an instance of the named structure type.
+(defmacro %check-structure-type-from-name (x name)
+ `(%check-structure-type-from-layout ,x ,(compiler-layout-or-lose name)))
+
+;;; Check that X is a structure of the type described by DD.
+(defmacro %check-structure-type-from-dd (x dd)
+ (declare (type defstruct-description dd))
+ (let ((class-name (dd-name dd)))
+ (ecase (dd-type dd)
+ ((structure funcallable-instance)
+ `(%check-structure-type-from-layout
+ ,x
+ ,(compiler-layout-or-lose class-name)))
+ ((vector)
+ (let ((xx (gensym "X")))
+ `(let ((,xx ,x))
+ (declare (type vector ,xx))
+ ,@(when (dd-named dd)
+ `((unless (eql (aref ,xx 0) ',class-name)
+ (error
+ 'simple-type-error
+ :datum (aref ,xx 0)
+ :expected-type `(member ,class-name)
:format-control
- "The structure for accessor ~S is not a ~S:~% ~S"
- :format-arguments
- (list (dsd-accessor-name dsd) class
- structure)))
- (%instance-ref structure (dsd-index dsd))))))
-(defun structure-slot-setter (layout dsd)
- (let ((class (layout-class layout)))
- (if (typep class 'basic-structure-class)
- #'(lambda (new-value structure)
- (declare (optimize (speed 3) (safety 0)))
- (flet ((structure-test (structure)
- (typep-to-layout structure layout))
- (typep-test (new-value)
- (%typep new-value (dsd-type dsd))))
- (unless (structure-test structure)
- (error 'simple-type-error
- :datum structure
- :expected-type (class-name (layout-class layout))
- :format-control
- "The structure for setter ~S is not a ~S:~% ~S"
- :format-arguments
- (list `(setf ,(dsd-accessor-name dsd))
- (sb!xc:class-name (layout-class layout))
- structure)))
- (unless (typep-test new-value)
- (error 'simple-type-error
- :datum new-value
- :expected-type (class-name (layout-class layout))
- :format-control
- "The new value for setter ~S is not a ~S:~% ~S"
- :format-arguments
- (list `(setf ,(dsd-accessor-name dsd))
- (dsd-type dsd)
- new-value))))
- (setf (%instance-ref structure (dsd-index dsd)) new-value))
- #'(lambda (new-value structure)
- (declare (optimize (speed 3) (safety 0)))
- (flet ((structure-test (structure)
- (sb!xc:typep structure class))
- (typep-test (new-value)
- (%typep new-value (dsd-type dsd))))
- (unless (structure-test structure)
- (error 'simple-type-error
- :datum structure
- :expected-type (class-name (layout-class layout))
- :format-control
- "The structure for setter ~S is not a ~S:~% ~S"
- :format-arguments
- (list `(setf ,(dsd-accessor-name dsd))
- (sb!xc:class-name class)
- structure)))
- (unless (typep-test new-value)
- (error 'simple-type-error
- :datum new-value
- :expected-type (class-name (layout-class layout))
- :format-control
- "The new value for setter ~S is not a ~S:~% ~S"
- :format-arguments
- (list `(setf ,(dsd-accessor-name dsd))
- (dsd-type dsd)
- new-value))))
- (setf (%instance-ref structure (dsd-index dsd)) new-value)))))
-
+ "~@<missing name in instance of ~
+ VECTOR-typed structure ~S: ~2I~_S~:>"
+ :format-arguments (list ',class-name ,xx)))))
+ (values))))
+ ((list)
+ (let ((xx (gensym "X")))
+ `(let ((,xx ,x))
+ (declare (type list ,xx))
+ ,@(when (dd-named dd)
+ `((unless (eql (first ,xx) ',class-name)
+ (error
+ 'simple-type-error
+ :datum (aref ,xx 0)
+ :expected-type `(member ,class-name)
+ :format-control
+ "~@<missing name in instance of LIST-typed structure ~S: ~
+ ~2I~_S~:>"
+ :format-arguments (list ',class-name ,xx)))))
+ (values)))))))
+
+;;; Check that X is an instance of the structure class with layout LAYOUT.
+(defun %check-structure-type-from-layout (x layout)
+ (unless (typep-to-layout x layout)
+ (error 'type-error
+ :datum x
+ :expected-type (class-name (layout-class layout))))
+ (values))
+\f
(/show0 "target-defstruct.lisp end of file")
;;; cobbled from stuff in describe.lisp.
(defun function-doc (x)
(let ((name
- (case (get-type x)
+ (case (widetag-of x)
(#.sb!vm:closure-header-widetag
(%simple-fun-name (%closure-fun x)))
((#.sb!vm:simple-fun-header-widetag
(!begin-collecting-cold-init-forms)
\f
-;;; Just call %TYPEP.
-;;;
-;;; Note that when cross-compiling, SB!XC:TYPEP is interpreted as
-;;; a test that the host Lisp object OBJECT translates to a target SBCL
-;;; type TYPE. (This behavior is needed e.g. to test for the validity of
-;;; numeric subtype bounds read when cross-compiling.)
-(defun typep (object type)
- #!+sb-doc
- "Return T iff OBJECT is of type TYPE."
- (%typep object type))
-
;;; If TYPE is a type that we can do a compile-time test on, then
;;; return whether the object is of that type as the first value and
;;; second value true. Otherwise return NIL, NIL.
;; time), we need to suppress a DEFTRANSFORM.. -- WHN 19991004
(declare (notinline sb!xc:find-class))
(class-layout (sb!xc:find-class 'null))))
- (t (svref *built-in-class-codes* (get-type x)))))
+ (t (svref *built-in-class-codes* (widetag-of x)))))
#!-sb-fluid (declaim (inline sb!xc:class-of))
(defun sb!xc:class-of (object)
(print-unreadable-object (x stream :type t)
(prin1 (type-class-name x) stream)))))
;; the name of this type class (used to resolve references at load time)
- (name nil :type symbol) ; FIXME: should perhaps be REQUIRED-ARGUMENT?
+ (name nil :type symbol) ; FIXME: should perhaps be REQUIRED-ARG?
;; Dyadic type methods. If the classes of the two types are EQ, then
;; we call the SIMPLE-xxx method. If the classes are not EQ, and
;; either type's class has a COMPLEX-xxx method, then we call it.
;; named TYPE-CLASS-INFO which is an accessor for the CTYPE structure
;; even though the TYPE-CLASS structure also exists in the system.
;; Rename this slot: TYPE-CLASS or ASSOCIATED-TYPE-CLASS or something.
- (class-info (required-argument) :type type-class)
+ (class-info (missing-arg) :type type-class)
;; True if this type has a fixed number of members, and as such
;; could possibly be completely specified in a MEMBER type. This is
;; used by the MEMBER type methods.
(in-package "SB!KERNEL")
+;;; (Note that when cross-compiling, SB!XC:TYPEP is interpreted as a
+;;; test that the host Lisp object OBJECT translates to a target SBCL
+;;; type TYPE. This behavior is needed e.g. to test for the validity
+;;; of numeric subtype bounds read when cross-compiling.)
+(defun typep (object type)
+ #!+sb-doc
+ "Is OBJECT of type TYPE?"
+ ;; Actually interpreting types at runtime is done by %TYPEP. The
+ ;; cost of the extra function call here should be negligible
+ ;; compared to the cost of interpreting types. (And the compiler
+ ;; tries hard to optimize away the interpretation of types at
+ ;; runtime, and when it succeeds, we never get here anyway.)
+ (%typep object type))
+
;;; the actual TYPEP engine. The compiler only generates calls to this
;;; function when it can't figure out anything more intelligent to do.
(defun %typep (object specifier)
((nil) nil)))
(numeric-type
(and (numberp object)
- (let ((num (if (complexp object) (realpart object) object)))
+ (let (;; I think this works because of an invariant of the
+ ;; two components of a COMPLEX are always coerced to
+ ;; be the same, e.g. (COMPLEX 1.0 3/2) => #C(1.0 1.5).
+ ;; Dunno why that holds, though -- ANSI? Python
+ ;; tradition? marsh faerie spirits? -- WHN 2001-10-27
+ (num (if (complexp object)
+ (realpart object)
+ object)))
(ecase (numeric-type-class type)
(integer (integerp num))
(rational (rationalp num))
(setf (code-header-ref code code-constants-offset)
new-fixups)))
(t
- (unless (or (eq (get-type fixups)
+ (unless (or (eq (widetag-of fixups)
unbound-marker-widetag)
(zerop fixups))
(format t "** Init. code FU = ~S~%" fixups)) ; FIXME
(setf (code-header-ref code code-constants-offset)
new-fixups)))
(t
- (unless (or (eq (get-type fixups)
+ (unless (or (eq (widetag-of fixups)
unbound-marker-widetag)
(zerop fixups))
(sb!impl::!cold-lose "Argh! can't process fixup"))
;;; KLUDGE..
;;;
-;;; CMU CL (as of 2.4.6 for Debian, anyway) issues warnings (and not just
-;;; STYLE-WARNINGs, either, alas) when it tries to interpret code containing
-;;; references to undefined functions. The most common problem is that
-;;; macroexpanded code refers to this function, which isn't defined until late.
+;;; CMU CL (as of 2.4.6 for Debian, anyway) issues warnings (and not
+;;; just STYLE-WARNINGs, either, alas) when it tries to interpret code
+;;; containing references to undefined functions. The most common
+;;; problem is that macroexpanded code refers to this function, which
+;;; isn't defined until late.
;;;
;;; This
-;;; #+cmu (defun sb!kernel::do-arg-count-error (&rest rest)
-;;; (error "stub version of do-arg-count-error, rest=~S" rest))
+;;; #+cmu (defun sb!kernel::arg-count-error (&rest rest)
+;;; (error "stub version of ARG-COUNT-ERROR, rest=~S" rest))
;;; doesn't work, with or without this
-;;; (compile 'sb!kernel::do-arg-count-error))
+;;; (compile 'sb!kernel::arg-count-error))
;;; so perhaps I should try
;;; (declaim (ftype ..) ..)
;;; instead?
-(declaim (ftype (function (&rest t) nil) sb!kernel::do-arg-count-error))
+(declaim (ftype (function (&rest t) nil) sb!kernel::arg-count-error))
(let ((reversed-target-object-file-names nil))
(do-stems-and-flags (stem flags)
\f
;;;; type frobbing VOPs
-(define-vop (get-lowtag)
- (:translate get-lowtag)
+(define-vop (lowtag-of)
+ (:translate lowtag-of)
(:policy :fast-safe)
(:args (object :scs (any-reg descriptor-reg)))
(:results (result :scs (unsigned-reg)))
(:generator 1
(inst and object lowtag-mask result)))
-(define-vop (get-type)
- (:translate get-type)
+(define-vop (widetag-of)
+ (:translate widetag-of)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:copier nil))
;; the element type, e.g. #<BUILT-IN-CLASS BASE-CHAR (sealed)> or
;; #<SB-KERNEL:NUMERIC-TYPE (UNSIGNED-BYTE 4)>
- (ctype (required-argument) :type ctype :read-only t)
+ (ctype (missing-arg) :type ctype :read-only t)
;; what we get when the low-level vector-creation logic zeroes all
;; the bits (which also serves as the default value of MAKE-ARRAY's
;; :INITIAL-ELEMENT keyword)
- (initial-element-default (required-argument) :read-only t)
+ (initial-element-default (missing-arg) :read-only t)
;; how many bits per element
- (n-bits (required-argument) :type index :read-only t)
+ (n-bits (missing-arg) :type index :read-only t)
;; the low-level type code
- (typecode (required-argument) :type index :read-only t)
+ (typecode (missing-arg) :type index :read-only t)
;; the number of extra elements we use at the end of the array for
;; low level hackery (e.g., one element for arrays of BASE-CHAR,
;; which is used for a fixed #\NULL so that when we call out to C
;; we don't need to cons a new copy)
- (n-pad-elements (required-argument) :type index :read-only t))
+ (n-pad-elements (missing-arg) :type index :read-only t))
(defparameter *specialized-array-element-type-properties*
(map 'simple-vector
(:copier nil))
;; The function to envoke to actually emit this instruction. Gets called
;; with the segment as its one argument.
- (emitter (required-argument) :type (or null function))
+ (emitter (missing-arg) :type (or null function))
;; The attributes of this instruction.
(attributes (instruction-attributes) :type sb!c:attributes)
;; Number of instructions or cycles of delay before additional
;; The keyword name of this argument. Although keyword names don't
;; have to be keywords, we only match on keywords when figuring an
;; approximate type.
- (name (required-argument) :type keyword)
+ (name (missing-arg) :type keyword)
;; The position at which this keyword appeared. 0 if it appeared as the
;; first argument, etc.
- (position (required-argument) :type fixnum)
+ (position (missing-arg) :type fixnum)
;; a list of all the argument types that have been used with this keyword
(types nil :type list)
;; true if this keyword has appeared only in calls with an obvious
;; disassembly functions
(prefilter nil :type (or null function))
(labeller nil :type (or null function))
- (printer (required-argument) :type (or null function))
+ (printer (missing-arg) :type (or null function))
(control nil :type (or null function))
;; instructions that are the same as this instruction but with more
(defstruct (inst-space-choice (:conc-name ischoice-)
(:copier nil))
(common-id dchunk-zero :type dchunk) ; applies to *parent's* mask
- (subspace (required-argument) :type (or inst-space instruction)))
+ (subspace (missing-arg) :type (or inst-space instruction)))
\f
;;;; These are the kind of values we can compute for an argument, and
;;;; how to compute them. The :CHECKER functions make sure that a given
(defstruct (arg-form-kind (:copier nil))
(names nil :type list)
- (producer (required-argument) :type function)
- (checker (required-argument) :type function))
+ (producer (missing-arg) :type function)
+ (checker (missing-arg) :type function))
(defun arg-form-kind-or-lose (kind)
(or (getf *arg-form-kinds* kind)
args
&key
constraint
- (stem (required-argument)))
+ (stem (missing-arg)))
&body defun-maker-forms)
(let ((cache-var (gensym))
(constraint-var (gensym)))
s))))
(:copier nil))
;; the stream we dump to
- (stream (required-argument) :type stream)
+ (stream (missing-arg) :type stream)
;; hashtables we use to keep track of dumped constants so that we
;; can get them from the table rather than dumping them again. The
;; EQUAL-TABLE is used for lists and strings, and the EQ-TABLE is
;;; This structure holds information about a circularity.
(defstruct (circularity (:copier nil))
;; the kind of modification to make to create circularity
- (type (required-argument) :type (member :rplaca :rplacd :svset :struct-set))
+ (type (missing-arg) :type (member :rplaca :rplacd :svset :struct-set))
;; the object containing circularity
object
;; index in object for circularity
- (index (required-argument) :type index)
+ (index (missing-arg) :type index)
;; the object to be stored at INDEX in OBJECT. This is that the key
;; that we were using when we discovered the circularity.
value
(def!struct (dyncount-info (:make-load-form-fun just-dump-it-normally))
for
- (costs (required-argument) :type (simple-array (unsigned-byte 32) (*)))
- (counts (required-argument) :type (simple-array (unsigned-byte 32) (*))))
+ (costs (missing-arg) :type (simple-array (unsigned-byte 32) (*)))
+ (counts (missing-arg) :type (simple-array (unsigned-byte 32) (*))))
(defprinter (dyncount-info)
for
(defknown %slot-accessor (t) t (flushable))
(defknown %slot-setter (t t) t (unsafe))
-(defknown sb!kernel::do-arg-count-error (t t t t t t) nil (unsafe))
+(defknown sb!kernel::arg-count-error (t t t t t t) nil (unsafe))
\f
;;;; SETF inverses
(defstruct (gspace (:constructor %make-gspace)
(:copier nil))
;; name and identifier for this GSPACE
- (name (required-argument) :type symbol :read-only t)
- (identifier (required-argument) :type fixnum :read-only t)
+ (name (missing-arg) :type symbol :read-only t)
+ (identifier (missing-arg) :type fixnum :read-only t)
;; the word address where the data will be loaded
- (word-address (required-argument) :type unsigned-byte :read-only t)
+ (word-address (missing-arg) :type unsigned-byte :read-only t)
;; the data themselves. (Note that in CMU CL this was a pair
;; of fields SAP and WORDS-ALLOCATED, but that wasn't very portable.)
(bytes (make-array target-space-alignment :element-type '(unsigned-byte 8))
(defknown vector-sap ((simple-unboxed-array (*))) system-area-pointer
(flushable))
-(defknown get-lowtag (t) (unsigned-byte #.sb!vm:n-lowtag-bits)
+(defknown lowtag-of (t) (unsigned-byte #.sb!vm:n-lowtag-bits)
(flushable movable))
-(defknown get-type (t) (unsigned-byte #.sb!vm:n-widetag-bits)
+(defknown widetag-of (t) (unsigned-byte #.sb!vm:n-widetag-bits)
(flushable movable))
(defknown (get-header-data get-closure-length) (t) (unsigned-byte 24)
(type-info-number x)))))
(:copier nil))
;; the name of this type
- (name (required-argument) :type keyword)
+ (name (missing-arg) :type keyword)
;; this type's class
- (class (required-argument) :type class-info)
+ (class (missing-arg) :type class-info)
;; a number that uniquely identifies this type (and implicitly its class)
- (number (required-argument) :type type-number)
+ (number (missing-arg) :type type-number)
;; a type specifier which info of this type must satisfy
(type nil :type t)
;; a function called when there is no information of this type
;;; calls to %DEFINE-INFO-TYPE must use the same type number.
(#+sb-xc-host defmacro
#-sb-xc-host sb!xc:defmacro
- define-info-type (&key (class (required-argument))
- (type (required-argument))
- (type-spec (required-argument))
+ define-info-type (&key (class (missing-arg))
+ (type (missing-arg))
+ (type-spec (missing-arg))
default)
(declare (type keyword class type))
`(progn
(:copier nil))
;; some string describing what is in this environment, for
;; printing/debugging purposes only
- (name (required-argument) :type string))
+ (name (missing-arg) :type string))
(def!method print-object ((x info-env) stream)
(print-unreadable-object (x stream :type t)
(prin1 (info-env-name x) stream)))
(cache-index nil :type (or compact-info-entries-index null))
;; hashtable of the names in this environment. If a bucket is
;; unused, it is 0.
- (table (required-argument) :type simple-vector)
+ (table (missing-arg) :type simple-vector)
;; an indirection vector parallel to TABLE, translating indices in
;; TABLE to the start of the ENTRIES for that name. Unused entries
;; are undefined.
- (index (required-argument)
- :type (simple-array compact-info-entries-index (*)))
+ (index (missing-arg) :type (simple-array compact-info-entries-index (*)))
;; a vector contining in contiguous ranges the values of for all the
;; types of info for each name.
- (entries (required-argument) :type simple-vector)
+ (entries (missing-arg) :type simple-vector)
;; a vector parallel to ENTRIES, indicating the type number for the
;; value stored in that location and whether this location is the
;; last type of info stored for this name. The type number is in the
;; low TYPE-NUMBER-BITS bits, and the next bit is set if this is the
;; last entry.
- (entries-info (required-argument)
- :type (simple-array compact-info-entry (*))))
+ (entries-info (missing-arg) :type (simple-array compact-info-entry (*))))
(defconstant compact-info-entry-type-mask (ldb (byte type-number-bits 0) -1))
(defconstant compact-info-entry-last (ash 1 type-number-bits))
(cache-types nil :type list)
;; vector of alists of alists of the form:
;; ((Name . ((Type-Number . Value) ...) ...)
- (table (required-argument) :type simple-vector)
+ (table (missing-arg) :type simple-vector)
;; the number of distinct names currently in this table. Each name
;; may have multiple entries, since there can be many types of info.
(count 0 :type index)
;; a list of stringified enclosing non-original source forms
(source nil :type list)
;; the stringified form in the original source that expanded into SOURCE
- (original-source (required-argument) :type simple-string)
+ (original-source (missing-arg) :type simple-string)
;; a list of prefixes of "interesting" forms that enclose original-source
(context nil :type list)
;; the FILE-INFO-NAME for the relevant FILE-INFO
- (file-name (required-argument)
- :type (or pathname (member :lisp :stream)))
+ (file-name (missing-arg) :type (or pathname (member :lisp :stream)))
;; the file position at which the top-level form starts, if applicable
(file-position nil :type (or index null))
;; the original source part of the source path
;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping
;;; errors which occur during the macroexpansion.
(defun careful-expand-macro (fun form)
- (handler-bind (;; When cross-compiling, we can get style warnings
- ;; about e.g. undefined functions. An unhandled
- ;; CL:STYLE-WARNING (as opposed to a
- ;; SB!C::COMPILER-NOTE) would cause FAILURE-P to be
- ;; set on the return from #'SB!XC:COMPILE-FILE, which
- ;; would falsely indicate an error sufficiently
- ;; serious that we should stop the build process. To
- ;; avoid this, we translate CL:STYLE-WARNING
- ;; conditions from the host Common Lisp into
- ;; cross-compiler SB!C::COMPILER-NOTE calls. (It
- ;; might be cleaner to just make Python use
- ;; CL:STYLE-WARNING internally, so that the
- ;; significance of any host Common Lisp
- ;; CL:STYLE-WARNINGs is understood automatically. But
- ;; for now I'm not motivated to do this. -- WHN
- ;; 19990412)
- (style-warning (lambda (c)
- (compiler-note "(during macroexpansion)~%~A"
- c)
- (muffle-warning-or-die)))
- ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for
- ;; Debian Linux, anyway) raises a CL:WARNING
- ;; condition (not a CL:STYLE-WARNING) for undefined
- ;; symbols when converting interpreted functions,
- ;; causing COMPILE-FILE to think the file has a real
- ;; problem, causing COMPILE-FILE to return FAILURE-P
- ;; set (not just WARNINGS-P set). Since undefined
- ;; symbol warnings are often harmless forward
- ;; references, and since it'd be inordinately painful
- ;; to try to eliminate all such forward references,
- ;; these warnings are basically unavoidable. Thus, we
- ;; need to coerce the system to work through them,
- ;; and this code does so, by crudely suppressing all
- ;; warnings in cross-compilation macroexpansion. --
- ;; WHN 19990412
- #+cmu
- (warning (lambda (c)
- (compiler-note
- "(during macroexpansion)~%~
- ~A~%~
- (KLUDGE: That was a non-STYLE WARNING.~%~
- Ordinarily that would cause compilation to~%~
- fail. However, since we're running under~%~
- CMU CL, and since CMU CL emits non-STYLE~%~
- warnings for safe, hard-to-fix things (e.g.~%~
- references to not-yet-defined functions)~%~
- we're going to have to ignore it and proceed~%~
- anyway. Hopefully we're not ignoring anything~%~
- horrible here..)~%"
- c)
- (muffle-warning-or-die)))
- (error (lambda (c)
- (compiler-error "(during macroexpansion)~%~A" c))))
- (funcall sb!xc:*macroexpand-hook*
- fun
- form
- *lexenv*)))
+ (let (;; a hint I (WHN) wish I'd known earlier
+ (hint "(hint: For more precise location, try *BREAK-ON-SIGNALS*.)"))
+ (flet (;; Return a string to use as a prefix in error reporting,
+ ;; telling something about which form caused the problem.
+ (wherestring ()
+ (let ((*print-pretty* nil)
+ ;; We rely on the printer to abbreviate FORM.
+ (*print-length* 3)
+ (*print-level* 1))
+ (format
+ nil
+ #-sb-xc-host "(in macroexpansion of ~S)"
+ ;; longer message to avoid ambiguity "Was it the xc host
+ ;; or the cross-compiler which encountered the problem?"
+ #+sb-xc-host "(in cross-compiler macroexpansion of ~S)"
+ form))))
+ (handler-bind (;; When cross-compiling, we can get style warnings
+ ;; about e.g. undefined functions. An unhandled
+ ;; CL:STYLE-WARNING (as opposed to a
+ ;; SB!C::COMPILER-NOTE) would cause FAILURE-P to be
+ ;; set on the return from #'SB!XC:COMPILE-FILE, which
+ ;; would falsely indicate an error sufficiently
+ ;; serious that we should stop the build process. To
+ ;; avoid this, we translate CL:STYLE-WARNING
+ ;; conditions from the host Common Lisp into
+ ;; cross-compiler SB!C::COMPILER-NOTE calls. (It
+ ;; might be cleaner to just make Python use
+ ;; CL:STYLE-WARNING internally, so that the
+ ;; significance of any host Common Lisp
+ ;; CL:STYLE-WARNINGs is understood automatically. But
+ ;; for now I'm not motivated to do this. -- WHN
+ ;; 19990412)
+ (style-warning (lambda (c)
+ (compiler-note "~@<~A~:@_~A~:@_~A~:>"
+ (wherestring) hint c)
+ (muffle-warning-or-die)))
+ ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for
+ ;; Debian Linux, anyway) raises a CL:WARNING
+ ;; condition (not a CL:STYLE-WARNING) for undefined
+ ;; symbols when converting interpreted functions,
+ ;; causing COMPILE-FILE to think the file has a real
+ ;; problem, causing COMPILE-FILE to return FAILURE-P
+ ;; set (not just WARNINGS-P set). Since undefined
+ ;; symbol warnings are often harmless forward
+ ;; references, and since it'd be inordinately painful
+ ;; to try to eliminate all such forward references,
+ ;; these warnings are basically unavoidable. Thus, we
+ ;; need to coerce the system to work through them,
+ ;; and this code does so, by crudely suppressing all
+ ;; warnings in cross-compilation macroexpansion. --
+ ;; WHN 19990412
+ #+cmu
+ (warning (lambda (c)
+ (compiler-note
+ "~@<~A~:@_~
+ ~A~:@_~
+ ~@<(KLUDGE: That was a non-STYLE WARNING. ~
+ Ordinarily that would cause compilation to ~
+ fail. However, since we're running under ~
+ CMU CL, and since CMU CL emits non-STYLE ~
+ warnings for safe, hard-to-fix things (e.g. ~
+ references to not-yet-defined functions) ~
+ we're going to have to ignore it and ~
+ proceed anyway. Hopefully we're not ~
+ ignoring anything horrible here..)~:@>~:>"
+ (wherestring)
+ c)
+ (muffle-warning-or-die)))
+ (error (lambda (c)
+ (compiler-error "~@<~A~:@_~A~@:_~A~:>"
+ (wherestring) hint c))))
+ (funcall sb!xc:*macroexpand-hook* fun form *lexenv*)))))
\f
;;;; conversion utilities
(defstruct (function-info #-sb-xc-host (:pure t))
;; Boolean attributes of this function.
- (attributes (required-argument) :type attributes)
+ (attributes (missing-arg) :type attributes)
;; A list of Transform structures describing transforms for this function.
(transforms () :type list)
;; A function which computes the derived type for a call to this function by
;; itself, are represented as BUILT-IN-TYPE, and at least as of
;; sbcl-0.pre7.54 or so, that's inconsistent with being a
;; FUN-TYPE.)
- (type (required-argument) :type ctype)
+ (type (missing-arg) :type ctype)
;; the transformation function. Takes the COMBINATION node and returns a
;; lambda, or throws out.
- (function (required-argument) :type function)
+ (function (missing-arg) :type function)
;; string used in efficiency notes
- (note (required-argument) :type string)
+ (note (missing-arg) :type string)
;; T if we should emit a failure note even if SPEED=INHIBIT-WARNINGS.
(important nil :type (member t nil))
;; usable for byte code, native code, or both?
(defun local-call-analyze-until-done (clambdas)
(loop
- (/show "at head of LOCAL-CALL-ANALYZE-UNTIL-DONE loop")
(let ((did-something nil))
(dolist (clambda clambdas)
(let* ((component (block-component (node-block (lambda-bind clambda))))
(defstruct (event-info (:copier nil))
;; The name of this event.
- (name (required-argument) :type symbol)
+ (name (missing-arg) :type symbol)
;; The string rescribing this event.
- (description (required-argument) :type string)
+ (description (missing-arg) :type string)
;; The name of the variable we stash this in.
- (var (required-argument) :type symbol)
+ (var (missing-arg) :type symbol)
;; The number of times this event has happened.
(count 0 :type fixnum)
;; The level of significance of this event.
- (level (required-argument) :type unsigned-byte)
+ (level (missing-arg) :type unsigned-byte)
;; If true, a function that gets called with the node that the event
;; happened to.
(action nil :type (or function null)))
(values))
(defun %compile-component (component)
- (/show "entering %COMPILE-COMPONENT")
(let ((*code-segment* nil)
(*elsewhere* nil))
(maybe-mumble "GTN ")
;; We're done, so don't bother keeping anything around.
(setf (component-info component) nil)
- (/show "leaving %COMPILE-COMPONENT")
(values))
;;; Delete components with no external entry points before we try to
(defstruct (file-info (:copier nil))
;; If a file, the truename of the corresponding source file. If from
;; a Lisp form, :LISP. If from a stream, :STREAM.
- (name (required-argument) :type (or pathname (member :lisp :stream)))
+ (name (missing-arg) :type (or pathname (member :lisp :stream)))
;; the defaulted, but not necessarily absolute file name (i.e. prior
;; to TRUENAME call.) Null if not a file. This is used to set
;; *COMPILE-FILE-PATHNAME*, and if absolute, is dumped in the
;;; Macroexpand FORM in the current environment with an error handler.
;;; We only expand one level, so that we retain all the intervening
;;; forms in the source path.
-(defun preprocessor-macroexpand (form)
+(defun preprocessor-macroexpand-1 (form)
(handler-case (sb!xc:macroexpand-1 form *lexenv*)
(error (condition)
- (compiler-error "(during macroexpansion)~%~A" condition))))
+ (compiler-error "(during macroexpansion of ~A)~%~A"
+ (let ((*print-level* 1)
+ (*print-length* 2))
+ (format nil "~S" form))
+ condition))))
;;; Process a PROGN-like portion of a top-level form. FORMS is a list of
;;; the forms, and PATH is the source path of the FORM they came out of.
;; I'd thought NIL should
;; work, but it doesn't.
;; -- WHN 2001-09-20
- (required-argument)))
+ (missing-arg)))
(let* ((*current-path* path)
(component (make-empty-component))
(*current-component* component))
;; nice default for things where we don't have a
;; real source path (as in e.g. inside CL:COMPILE).
'(original-source-start 0 0)))
- (/show "entering %COMPILE" name)
(unless (or (null name) (legal-fun-name-p name))
(error "not a legal function name: ~S" name))
(let* ((*lexenv* (make-lexenv :policy *policy*))
:name name
:path path)))
- (/noshow fun)
-
;; FIXME: The compile-it code from here on is sort of a
;; twisted version of the code in COMPILE-TOP-LEVEL. It'd be
;; better to find a way to share the code there; or
;; the :LOCALL-ONLY option to IR1-FOR-LAMBDA. Then maybe the
;; whole FUNCTIONAL-KIND=:TOP-LEVEL case could go away..)
- (/show "about to LOCAL-CALL-ANALYZE-UNTIL-DONE")
(local-call-analyze-until-done (list fun))
(multiple-value-bind (components-from-dfo top-components hairy-top)
(find-initial-dfo (list fun))
(let ((*all-components* (append components-from-dfo top-components)))
- (/noshow components-from-dfo top-components *all-components*)
(mapc #'preallocate-physenvs-for-top-levelish-lambdas
(append hairy-top top-components))
(dolist (component-from-dfo components-from-dfo)
- (/show "compiling a COMPONENT-FROM-DFO")
(compile-component component-from-dfo)
- (/show "about to REPLACE-TOP-LEVEL-XEPS")
(replace-top-level-xeps component-from-dfo)))
- (/show "about to go into PROG1")
(prog1
(let ((entry-table (etypecase *compile-object*
(fasl-output (fasl-output-entry-table
(aver found-p)
result))
(mapc #'clear-ir1-info components-from-dfo)
- (clear-stuff)
- (/show "returning from %COMPILE")))))
+ (clear-stuff)))))
(defun process-top-level-cold-fset (name lambda-expression path)
- (/show "entering PROCESS-TOP-LEVEL-COLD-FSET" name)
(unless (producing-fasl-file)
(error "can't COLD-FSET except in a fasl file"))
(unless (legal-fun-name-p name)
:name name
:path path)
*compile-object*)
- (/show "finished with PROCESS-TOP-LEVEL-COLD-FSET" name)
(values))
;;; Process a top-level FORM with the specified source PATH.
;; cross-compilation host.)
(slightly-uncrossed (cons (uncross (first form))
(rest form)))
- (expanded (preprocessor-macroexpand slightly-uncrossed)))
+ (expanded (preprocessor-macroexpand-1 slightly-uncrossed)))
(if (eq expanded slightly-uncrossed)
;; (Now that we're no longer processing toplevel
;; forms, and hence no longer need to worry about
;; Top Level Forms".
#-sb-xc-host
(t
- (let ((expanded (preprocessor-macroexpand form)))
+ (let ((expanded (preprocessor-macroexpand-1 form)))
(cond ((eq expanded form)
(when compile-time-too
(eval form))
(defmacro !def-primitive-type (name scs &key (type name))
(declare (type symbol name) (type list scs))
(let ((scns (mapcar #'meta-sc-number-or-lose scs))
- (get-type `(specifier-type ',type)))
+ (ctype-form `(specifier-type ',type)))
`(progn
(/show0 "doing !DEF-PRIMITIVE-TYPE, NAME=..")
(/primitive-print ,(symbol-name name))
(setf (gethash ',name *backend-meta-primitive-type-names*)
(make-primitive-type :name ',name
:scs ',scns
- :type ,get-type)))
+ :type ,ctype-form)))
,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*))
- (n-type get-type))
+ (n-type ctype-form))
`(progn
;; If the PRIMITIVE-TYPE structure already exists, we
;; destructively modify it so that existing references in
;; name of the operand (which we bind to the TN)
(name nil :type symbol)
;; the way this operand is used:
- (kind (required-argument)
+ (kind (missing-arg)
:type (member :argument :result :temporary
:more-argument :more-result))
;; If true, the name of an operand that this operand is targeted to.
(defstruct (block-annotation (:constructor nil)
(:copier nil))
;; The IR1 block that this block is in the INFO for.
- (block (required-argument) :type cblock)
+ (block (missing-arg) :type cblock)
;; the next and previous block in emission order (not DFO). This
;; determines which block we drop though to, and also used to chain
;; together overflow blocks that result from splitting of IR2 blocks
;;; change.
(defstruct (cleanup (:copier nil))
;; the kind of thing that has to be cleaned up
- (kind (required-argument)
+ (kind (missing-arg)
:type (member :special-bind :catch :unwind-protect :block :tagbody))
;; the node that messes things up. This is the last node in the
;; non-messed-up environment. Null only temporarily. This could be
;;; TNs, or eventually stack slots and registers). -- WHN 2001-09-29
(defstruct (physenv (:copier nil))
;; the function that allocates this physical environment
- (function (required-argument) :type clambda)
+ (function (missing-arg) :type clambda)
#| ; seems not to be used as of sbcl-0.pre7.51
;; a list of all the lambdas that allocate variables in this
;; physical environment
;; and not the cleanup for the escape block. The CLEANUP-KIND of
;; this thus provides a good indication of what kind of exit is
;; being done.
- (cleanup (required-argument) :type cleanup)
+ (cleanup (missing-arg) :type cleanup)
;; the continuation exited to (the CONT of the EXIT nodes). If this
;; exit is from an escape function (CATCH or UNWIND-PROTECT), then
;; physical environment analysis deletes the escape function and
;; For this purpose, the Entry must also be used to disambiguate,
;; since exits to different places may deliver their result to the
;; same continuation.
- (continuation (required-argument) :type continuation)
+ (continuation (missing-arg) :type continuation)
;; the entry stub inserted by physical environment analysis. This is
;; a block containing a call to the %NLX-Entry funny function that
;; has the original exit destination as its successor. Null only
;;; constant, but don't know what the value is at compile time.
(def!struct (global-var (:include basic-var))
;; kind of variable described
- (kind (required-argument)
+ (kind (missing-arg)
:type (member :special :global-function :constant :global)))
(defprinter (global-var :identity t)
name
(where-from :defined)
(kind :global-function)))
;; The description of the structure that this is an accessor for.
- (for (required-argument) :type sb!xc:class)
+ (for (missing-arg) :type sb!xc:class)
;; The slot description of the slot.
- (slot (required-argument)))
+ (slot (missing-arg)))
(defprinter (slot-accessor :identity t)
name
for
(specialp nil :type boolean)
;; the kind of argument being described. Required args only have arg
;; info structures if they are special.
- (kind (required-argument) :type (member :required :optional :keyword :rest
- :more-context :more-count))
+ (kind (missing-arg)
+ :type (member :required :optional :keyword :rest
+ :more-context :more-count))
;; If true, this is the VAR for SUPPLIED-P variable of a keyword or
;; optional arg. This is true for keywords with non-constant
;; defaults even when there is no user-specified supplied-p var.
(:constructor make-if)
(:copier copy-if))
;; CONTINUATION for the predicate
- (test (required-argument) :type continuation)
+ (test (missing-arg) :type continuation)
;; the blocks that we execute next in true and false case,
;; respectively (may be the same)
- (consequent (required-argument) :type cblock)
- (alternative (required-argument) :type cblock))
+ (consequent (missing-arg) :type cblock)
+ (alternative (missing-arg) :type cblock))
(defprinter (cif :conc-name if- :identity t)
(test :prin1 (continuation-use test))
consequent
(:constructor make-set)
(:copier copy-set))
;; descriptor for the variable set
- (var (required-argument) :type basic-var)
+ (var (missing-arg) :type basic-var)
;; continuation for the value form
- (value (required-argument) :type continuation))
+ (value (missing-arg) :type continuation))
(defprinter (cset :conc-name set- :identity t)
var
(value :prin1 (continuation-use value)))
(:constructor nil)
(:copier nil))
;; continuation for the function
- (fun (required-argument) :type continuation)
+ (fun (missing-arg) :type continuation)
;; list of CONTINUATIONs for the args. In a local call, an argument
;; continuation may be replaced with NIL to indicate that the
;; corresponding variable is unreferenced, and thus no argument
;; ir1tran.
(lambda nil :type (or clambda null))
;; the continuation which yields the value of the lambda
- (result (required-argument) :type continuation)
+ (result (missing-arg) :type continuation)
;; the union of the node-derived-type of all uses of the result
;; other than by a local call, intersected with the result's
;; asserted-type. If there are no non-call uses, this is
;; the name of the unknown thing
(name nil :type (or symbol list))
;; the kind of reference to NAME
- (kind (required-argument) :type (member :function :type :variable))
+ (kind (missing-arg) :type (member :function :type :variable))
;; the number of times this thing was used
(count 0 :type unsigned-byte)
;; a list of COMPILER-ERROR-CONTEXT structures describing places
decl-spec)))))
(defun sb!xc:proclaim (raw-form)
+ #+sb-xc (/show0 "entering PROCLAIM, RAW-FORM=..")
+ #+sb-xc (/hexstr raw-form)
(let* ((form (canonized-decl-spec raw-form))
(kind (first form))
(args (rest form)))
(t
(unless (info :declaration :recognized kind)
(compiler-warning "unrecognized declaration ~S" raw-form)))))
+ #+sb-xc (/show0 "returning from PROCLAIM")
(values))
\f
(defstruct (offs-hook (:copier nil))
(offset 0 :type offset)
- (function (required-argument) :type function)
+ (function (missing-arg) :type function)
(before-address nil :type (member t nil)))
(defstruct (segment (:conc-name seg-)
(:constructor %make-segment)
(:copier nil))
- (sap-maker (required-argument)
+ (sap-maker (missing-arg)
:type (function () sb!sys:system-area-pointer))
(length 0 :type length)
(virtual-location 0 :type address)
;; offset of next position
(next-offs 0 :type offset)
;; a sap pointing to our segment
- (segment-sap (required-argument) :type sb!sys:system-area-pointer)
+ (segment-sap (missing-arg) :type sb!sys:system-area-pointer)
;; the current segment
(segment nil :type (or null segment))
;; what to align to in most cases
(scs nil :type list)
;; the Lisp type equivalent to this type. If this type could never be
;; returned by PRIMITIVE-TYPE, then this is the NIL (or empty) type
- (type (required-argument) :type ctype)
+ (type (missing-arg) :type ctype)
;; the template used to check that an object is of this type. This is a
;; template of one argument and one result, both of primitive-type T. If
;; the argument is of the correct type, then it is delivered into the
;; The elements of this list correspond to the elements of the list
;; in the CLOSURE slot of the ENVIRONMENT object that links to us:
;; essentially this list is related to the CLOSURE list by MAPCAR.
- (environment (required-argument) :type list :read-only t)
+ (environment (missing-arg) :type list :read-only t)
;; the TNs that hold the OLD-FP and RETURN-PC within the function.
;; We always save these so that the debugger can do a backtrace,
;; even if the function has no return (and thus never uses them).
;; differently from the other arguments, since in some
;; implementations we may use a call instruction that requires the
;; return PC to be passed in a particular place.
- (return-pc-pass (required-argument) :type tn :read-only t)
+ (return-pc-pass (missing-arg) :type tn :read-only t)
;; True if this function has a frame on the number stack. This is
;; set by representation selection whenever it is possible that some
;; function in our tail set will make use of the number stack.
;; The return convention used:
;; -- If :UNKNOWN, we use the standard return convention.
;; -- If :FIXED, we use the known-values convention.
- (kind (required-argument) :type (member :fixed :unknown))
+ (kind (missing-arg) :type (member :fixed :unknown))
;; the number of values returned, or :UNKNOWN if we don't know.
;; COUNT may be known when KIND is :UNKNOWN, since we may choose the
;; standard return convention for other reasons.
- (count (required-argument) :type (or index (member :unknown)))
+ (count (missing-arg) :type (or index (member :unknown)))
;; If count isn't :UNKNOWN, then this is a list of the
;; primitive-types of each value.
(types () :type list)
;; unwind-block, so we leave this slot null.
(home nil :type (or tn null))
;; the saved control stack pointer
- (save-sp (required-argument) :type tn)
+ (save-sp (missing-arg) :type tn)
;; the list of dynamic state save TNs
(dynamic-state (list* (make-stack-pointer-tn)
(make-dynamic-state-tns))
;; VOP-Info structure containing static info about the operation
(info nil :type (or vop-info null))
;; the IR2-Block this VOP is in
- (block (required-argument) :type ir2-block)
+ (block (missing-arg) :type ir2-block)
;; VOPs evaluated after and before this one. Null at the
;; beginning/end of the block, and temporarily during IR2
;; translation.
(defstruct (tn-ref (:constructor make-tn-ref (tn write-p))
(:copier nil))
;; the TN referenced
- (tn (required-argument) :type tn)
+ (tn (missing-arg) :type tn)
;; Is this is a write reference? (as opposed to a read reference)
(write-p nil :type boolean)
;; the link for a list running through all TN-Refs for this TN of
;; the arg/result type restrictions. We compute this from the
;; PRIMITIVE-TYPE restrictions to make life easier for IR1 phases
;; that need to anticipate LTN's template selection.
- (type (required-argument) :type fun-type)
+ (type (missing-arg) :type fun-type)
;; lists of restrictions on the argument and result types. A
;; restriction may take several forms:
;; -- The restriction * is no restriction at all.
;; the policy under which this template is the best translation.
;; Note that LTN might use this template under other policies if it
;; can't figure out anything better to do.
- (ltn-policy (required-argument) :type ltn-policy)
+ (ltn-policy (missing-arg) :type ltn-policy)
;; the base cost for this template, given optimistic assumptions
;; such as no operand loading, etc.
- (cost (required-argument) :type index)
+ (cost (missing-arg) :type index)
;; If true, then this is a short noun-like phrase describing what
;; this VOP "does", i.e. the implementation strategy. This is for
;; use in efficiency notes.
;; Two values are returned: the first and last VOP emitted. This vop
;; sequence must be linked into the VOP Next/Prev chain for the
;; block. At least one VOP is always emitted.
- (emit-function (required-argument) :type function))
+ (emit-function (missing-arg) :type function))
(defprinter (template)
name
arg-types
(:make-load-form-fun ignore-it))
;; side-effects of this VOP and side-effects that affect the value
;; of this VOP
- (effects (required-argument) :type attributes)
- (affected (required-argument) :type attributes)
+ (effects (missing-arg) :type attributes)
+ (affected (missing-arg) :type attributes)
;; If true, causes special casing of TNs live after this VOP that
;; aren't results:
;; -- If T, all such TNs that are allocated in a SC with a defined
;; as :NORMAL, but then at the end merges the conflict info into
;; the original TN and replaces all uses of the alias with the
;; original TN. SAVE-TN holds the aliased TN.
- (kind (required-argument)
+ (kind (missing-arg)
:type (member :normal :environment :debug-environment
:save :save-once :specified-save :load :constant
:component :alias))
(:constructor make-global-conflicts (kind tn block number))
(:copier nil))
;; the IR2-Block that this structure represents the conflicts for
- (block (required-argument) :type ir2-block)
+ (block (missing-arg) :type ir2-block)
;; thread running through all the Global-Conflict for Block. This
;; thread is sorted by TN number
(next nil :type (or global-conflicts null))
:initial-element 0)
:type local-tn-bit-vector)
;; the TN we are recording conflicts for.
- (tn (required-argument) :type tn)
+ (tn (missing-arg) :type tn)
;; thread through all the Global-Conflicts for TN
(tn-next nil :type (or global-conflicts null))
;; TN's local TN number in Block. :Live TNs don't have local numbers.
\f
;;;; type frobbing VOPs
-(define-vop (get-lowtag)
- (:translate get-lowtag)
+(define-vop (lowtag-of)
+ (:translate lowtag-of)
(:policy :fast-safe)
(:args (object :scs (any-reg descriptor-reg control-stack)
:target result))
(move result object)
(inst and result lowtag-mask)))
-(define-vop (get-type)
- (:translate get-type)
+(define-vop (widetag-of)
+ (:translate widetag-of)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
\f
(defun allocate-standard-instance (wrapper
&optional (slots-init nil slots-init-p))
- (let ((instance (%%allocate-instance--class))
+ (let ((instance (%make-standard-instance nil))
(no-of-slots (wrapper-no-of-instance-slots wrapper)))
(setf (std-instance-wrapper instance) wrapper)
(setf (std-instance-slots instance)
(defun allocate-funcallable-instance (wrapper &optional
(slots-init nil slots-init-p))
- (let ((fin (allocate-funcallable-instance-1)))
+ (let ((fin (%make-pcl-funcallable-instance nil nil)))
(set-funcallable-instance-fun
fin
#'(sb-kernel:instance-lambda (&rest args)
(unless (boundp '*the-class-t*)
(setq *the-class-t* nil))
-;;; Note that for SBCL, as for CMU CL, the WRAPPER of a built-in or
-;;; structure class will be some other kind of SB-KERNEL:LAYOUT, but
-;;; this shouldn't matter, since the only two slots that WRAPPER adds
-;;; are meaningless in those cases.
-(defstruct (wrapper
- (:include sb-kernel:layout
- ;; KLUDGE: In CMU CL, the initialization default
- ;; for LAYOUT-INVALID was NIL. In SBCL, that has
- ;; changed to :UNINITIALIZED, but PCL code might
- ;; still expect NIL for the initialization
- ;; default of WRAPPER-INVALID. Instead of trying
- ;; to find out, I just overrode the LAYOUT
- ;; default here. -- WHN 19991204
- (invalid nil))
- (:conc-name %wrapper-)
- (:constructor make-wrapper-internal)
- (:copier nil))
- (instance-slots-layout nil :type list)
- (class-slots nil :type list))
-#-sb-fluid (declaim (sb-ext:freeze-type wrapper))
-
(defmacro wrapper-class (wrapper)
`(sb-kernel:class-pcl-class (sb-kernel:layout-class ,wrapper)))
(defmacro wrapper-no-of-instance-slots (wrapper)
(fix-super (car supers)))
(and (not (eq name 'structure-object))
*the-class-structure-object*)))
- (defstruct-form (make-structure-class-defstruct-form name
- slots
- include)))
+ (defstruct-form (make-structure-class-defstruct-form
+ name slots include)))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
,defstruct-form) ; really compile the defstruct-form
;;;; specification.
(in-package "SB-PCL")
+
+(/show "starting early-low.lisp")
\f
;;; FIXME: The PCL package is internal and is used by code in potential
;;; bottlenecks. Access to it might be faster through #.(find-package "SB-PCL")
(and class
(typep (sb-kernel:layout-info (sb-kernel:class-layout class))
'sb-kernel:defstruct-description)))))
+\f
+(/show "finished with early-low.lisp")
(in-package "SB-PCL")
\f
(eval-when (:compile-toplevel :load-toplevel :execute)
-(defvar *optimize-speed* '(optimize (speed 3) (safety 0)))
+(defvar *optimize-speed*
+ '(optimize (speed 3) (safety 0)))
) ; EVAL-WHEN
(defmacro dotimes-fixnum ((var count &optional (result nil)) &body body)
(declare (fixnum ,var))
,@body))
\f
+;;;; early definition of WRAPPER
+;;;;
+;;;; Most WRAPPER stuff is defined later, but the DEFSTRUCT itself
+;;;; is here early so that things like (TYPEP .. 'WRAPPER) can be
+;;;; compiled efficiently.
+
+;;; Note that for SBCL, as for CMU CL, the WRAPPER of a built-in or
+;;; structure class will be some other kind of SB-KERNEL:LAYOUT, but
+;;; this shouldn't matter, since the only two slots that WRAPPER adds
+;;; are meaningless in those cases.
+(defstruct (wrapper
+ (:include sb-kernel:layout
+ ;; KLUDGE: In CMU CL, the initialization default
+ ;; for LAYOUT-INVALID was NIL. In SBCL, that has
+ ;; changed to :UNINITIALIZED, but PCL code might
+ ;; still expect NIL for the initialization
+ ;; default of WRAPPER-INVALID. Instead of trying
+ ;; to find out, I just overrode the LAYOUT
+ ;; default here. -- WHN 19991204
+ (invalid nil))
+ (:conc-name %wrapper-)
+ (:constructor make-wrapper-internal)
+ (:copier nil))
+ (instance-slots-layout nil :type list)
+ (class-slots nil :type list))
+#-sb-fluid (declaim (sb-ext:freeze-type wrapper))
+\f
;;;; PCL's view of funcallable instances
-(defstruct (pcl-funcallable-instance
- (:alternate-metaclass sb-kernel:funcallable-instance
- sb-kernel:random-pcl-class
- sb-kernel:make-random-pcl-class)
- (:type sb-kernel:funcallable-structure)
- (:constructor allocate-funcallable-instance-1 ())
- (:copier nil)
- (:conc-name nil))
- ;; Note: The PCL wrapper is in the layout slot.
-
- ;; PCL data vector.
- (pcl-funcallable-instance-slots nil)
- ;; The debug-name for this function.
- (funcallable-instance-name nil))
+(sb-kernel:!defstruct-with-alternate-metaclass pcl-funcallable-instance
+ ;; KLUDGE: Note that neither of these slots is ever accessed by its
+ ;; accessor name as of sbcl-0.pre7.63. Presumably everything works
+ ;; by puns based on absolute locations. Fun fun fun.. -- WHN 2001-10-30
+ :slot-names (clos-slots name)
+ :boa-constructor %make-pcl-funcallable-instance
+ :superclass-name sb-kernel:funcallable-instance
+ :metaclass-name sb-kernel:random-pcl-class
+ :metaclass-constructor sb-kernel:make-random-pcl-class
+ :dd-type sb-kernel:funcallable-structure
+ ;; Only internal implementation code will access these, and these
+ ;; accesses (slot readers in particular) could easily be a
+ ;; bottleneck, so it seems reasonable to suppress runtime type
+ ;; checks.
+ ;;
+ ;; (Except note KLUDGE above that these accessors aren't used at all
+ ;; (!) as of sbcl-0.pre7.63, so for now it's academic.)
+ :runtime-type-checks-p nil)
(import 'sb-kernel:funcallable-instance-p)
(defun pcl-instance-p (x)
(typep (sb-kernel:layout-of x) 'wrapper))
-;;; We define this as STANDARD-INSTANCE, since we're going to clobber
-;;; the layout with some standard-instance layout as soon as we make
-;;; it, and we want the accessor to still be type-correct.
+;;; CMU CL comment:
+;;; We define this as STANDARD-INSTANCE, since we're going to
+;;; clobber the layout with some standard-instance layout as soon as
+;;; we make it, and we want the accessor to still be type-correct.
+#|
(defstruct (standard-instance
(:predicate nil)
(:constructor %%allocate-instance--class ())
(:copier nil)
- (:alternate-metaclass sb-kernel:instance cl:standard-class
+ (:alternate-metaclass sb-kernel:instance
+ cl:standard-class
sb-kernel:make-standard-class))
(slots nil))
+|#
+(sb-kernel:!defstruct-with-alternate-metaclass standard-instance
+ :slot-names (slots)
+ :boa-constructor %make-standard-instance
+ :superclass-name sb-kernel:instance
+ :metaclass-name cl:standard-class
+ :metaclass-constructor sb-kernel:make-standard-class
+ :dd-type structure
+ :runtime-type-checks-p nil)
;;; Both of these operations "work" on structures, which allows the above
;;; weakening of STD-INSTANCE-P.
;;;; This software is made available AS IS, and Xerox Corporation makes no
;;;; warranty about the software, its performance or its conformity to any
;;;; specification.
-\f
+
(in-package "SB-PCL")
+\f
+(/show "starting pcl/macros.lisp")
(declaim (declaration
;; These three nonstandard declarations seem to be used
;; information around, I'm not sure. -- WHN 2000-12-30
%variable-rebinding))
+(/show "done with DECLAIM DECLARATION")
+
;;; FIXME: This looks like SBCL's PARSE-BODY, and should be shared.
(eval-when (:compile-toplevel :load-toplevel :execute)
+
(defun extract-declarations (body &optional environment)
;;(declare (values documentation declarations body))
(let (documentation
- declarations
- form)
+ declarations
+ form)
(when (and (stringp (car body))
- (cdr body))
+ (cdr body))
(setq documentation (pop body)))
(block outer
(loop
- (when (null body) (return-from outer nil))
- (setq form (car body))
- (when (block inner
- (loop (cond ((not (listp form))
- (return-from outer nil))
- ((eq (car form) 'declare)
- (return-from inner t))
- (t
- (multiple-value-bind (newform macrop)
- (macroexpand-1 form environment)
- (if (or (not (eq newform form)) macrop)
- (setq form newform)
- (return-from outer nil)))))))
- (pop body)
- (dolist (declaration (cdr form))
- (push declaration declarations)))))
+ (when (null body) (return-from outer nil))
+ (setq form (car body))
+ (when (block inner
+ (loop (cond ((not (listp form))
+ (return-from outer nil))
+ ((eq (car form) 'declare)
+ (return-from inner t))
+ (t
+ (multiple-value-bind (newform macrop)
+ (macroexpand-1 form environment)
+ (if (or (not (eq newform form)) macrop)
+ (setq form newform)
+ (return-from outer nil)))))))
+ (pop body)
+ (dolist (declaration (cdr form))
+ (push declaration declarations)))))
(values documentation
- (and declarations `((declare ,.(nreverse declarations))))
- body)))
+ (and declarations `((declare ,.(nreverse declarations))))
+ body)))
) ; EVAL-WHEN
+(/show "done with EVAL-WHEN (..) DEFUN EXTRACT-DECLARATIONS")
+
(defun get-declaration (name declarations &optional default)
(dolist (d declarations default)
(dolist (form (cdr d))
(when (and (consp form) (eq (car form) name))
(return-from get-declaration (cdr form))))))
+(/show "pcl/macros.lisp 85")
+
(defmacro collecting-once (&key initial-value)
`(let* ((head ,initial-value)
(tail ,(and initial-value `(last head))))
(cdr (rplacd tail (list value)))))))
#'(lambda nil head))))
+(/show "pcl/macros.lisp 98")
+
(defmacro doplist ((key val) plist &body body &environment env)
(multiple-value-bind (doc decls bod)
(extract-declarations body env)
(setq ,val (pop .plist-tail.))
(progn ,@bod)))))
+(/show "pcl/macros.lisp 113")
+
(defmacro dolist-carefully ((var list improper-list-handler) &body body)
`(let ((,var nil)
(.dolist-carefully. ,list))
;;;; SBCL deviates from the spec by having CL:FIND-CLASS distinct from
;;;; PCL:FIND-CLASS, alas.
+(/show "pcl/macros.lisp 132")
+
(defvar *find-class* (make-hash-table :test 'eq))
(defmacro find-class-cell-class (cell)
(error "~S is not a legal class name." symbol))
(setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
+(/show "pcl/macros.lisp 157")
+
(defvar *create-classes-from-internal-structure-definitions-p* t)
(defun find-class-from-cell (symbol cell &optional (errorp t))
;;; (DECLAIM (TYPE (MEMBER NIL :EARLY :BRAID :COMPLETE) *BOOT-STATE*))
(defvar *boot-state* nil)
+(/show "pcl/macros.lisp 199")
+
;;; Note that in SBCL as in CMU CL,
;;; COMMON-LISP:FIND-CLASS /= SB-PCL:FIND-CLASS.
;;; (Yes, this is a KLUDGE!)
new-value)
(error "~S is not a legal class name." symbol)))
+(/show "pcl/macros.lisp 242")
+
(defun (setf find-class-predicate)
(new-value symbol)
(if (legal-class-name-p symbol)
value)))
#'(lambda () result))))
+(/show "pcl/macros.lisp 271")
+
;;; These are augmented definitions of LIST-ELEMENTS and LIST-TAILS from
;;; iterate.lisp. These versions provide the extra :BY keyword which can
;;; be used to specify the step function through the list.
(defmacro function-apply (form &rest args)
`(apply (the function ,form) ,@args))
-\f
+(/show "pcl/macros.lisp 299")
+\f
(defun get-setf-fun-name (name)
`(setf ,name))
(defsetf slot-value set-slot-value)
+
+(/show "finished with pcl/macros.lisp")
(define-condition unbound-slot (cell-error)
((instance :reader unbound-slot-instance :initarg :instance)
(slot :reader unbound-slot-slot :initarg :slot))
- (:report (lambda(condition stream)
+ (:report (lambda (condition stream)
(format stream "The slot ~S is unbound in the object ~S."
(unbound-slot-slot condition)
(unbound-slot-instance condition)))))
(unless (eq allocation :instance)
(error "Structure slots must have :INSTANCE allocation.")))
-(defun make-structure-class-defstruct-form
- (name direct-slots include)
+(defun make-structure-class-defstruct-form (name direct-slots include)
(let* ((conc-name (intern (format nil "~S structure class " name)))
(constructor (intern (format nil "~A constructor" conc-name)))
(defstruct `(defstruct (,name
;;; a list, which was not really an interpreted function.
;;; Instead this list was COERCEd to a #<FUNCTION ...>!
;;;
-;;; Instead, we now use a special sort of "function"-type for that information,
-;;; because the functions slot in SB-C::LEXENV is supposed to have a list of
-;;; <Name MACRO . #<function> elements.
-;;; So, now we hide our bits of interest in the walker-info slot in our new
-;;; BOGO-FUNCTION.
+;;; Instead, we now use a special sort of "function"-type for that
+;;; information, because the functions slot in SB-C::LEXENV is
+;;; supposed to have a list of <Name MACRO . #<function> elements.
+;;; So, now we hide our bits of interest in the walker-info slot in
+;;; our new BOGO-FUNCTION.
;;;
;;; MACROEXPAND-1 is the only SBCL function that gets called with the
;;; constructed environment argument.
+(/show "walk.lisp 108")
+
(defmacro with-augmented-environment
((new-env old-env &key functions macros) &body body)
`(let ((,new-env (with-augmented-environment-internal ,old-env
,macros)))
,@body))
-(defstruct (bogo-function
- (:alternate-metaclass sb-kernel:funcallable-instance
- sb-kernel:funcallable-structure-class
- sb-kernel:make-funcallable-structure-class)
- (:type sb-kernel:funcallable-structure)
- (:copier nil))
- (walker-info (required-argument) :type list))
-
-(defun walker-info-to-bogo-function (x)
- (make-bogo-function :walker-info x))
+;;; a unique tag to show that we're the intended caller of BOGO-FUNCTION
+(defvar *bogo-function-magic-tag*
+ '(:bogo-function-magic-tag))
-(defun bogo-function-to-walker-info (x)
- (bogo-function-walker-info x))
+;;; The interface of BOGO-FUNCTIONs (previously implemented as
+;;; FUNCALLABLE-INSTANCES) is just these two operations, so we can
+;;; do them with ordinary closures.
+;;;
+;;; KLUDGE: BOGO-FUNCTIONS are sorta weird, and MNA and I have both
+;;; hacked on this code without really figuring out what they're for.
+;;; (He changed them to work after some changes in the IR1 interpreter
+;;; made functions not be built lazily, and I changed them so that
+;;; they don't need FUNCALLABLE-INSTANCE stuff, so that the F-I stuff
+;;; can become less general.) There may be further simplifications or
+;;; clarifications which could be done. -- WHN 2001-10-19
+(defun walker-info-to-bogo-function (walker-info)
+ (lambda (magic-tag &rest rest)
+ (aver (not rest)) ; else someone is using me in an unexpected way
+ (aver (eql magic-tag *bogo-function-magic-tag*)) ; else ditto
+ walker-info))
+(defun bogo-function-to-walker-info (bogo-function)
+ (declare (type function bogo-function))
+ (funcall bogo-function *bogo-function-magic-tag*))
(defun with-augmented-environment-internal (env functions macros)
;; Note: In order to record the correct function definition, we
(list* (car m)
'sb-c::macro
(if (eq (car m) *key-to-walker-environment*)
- (walker-info-to-bogo-function (cadr m))
- (coerce (cadr m) 'function))))
+ (walker-info-to-bogo-function (cadr m))
+ (coerce (cadr m) 'function))))
macros)))))
(defun environment-function (env fn)
(and entry
(eq (cadr entry) 'sb-c::macro)
(if (eq macro *key-to-walker-environment*)
- (values (bogo-function-to-walker-info (cddr entry)))
- (values (function-lambda-expression (cddr entry))))))))
+ (values (bogo-function-to-walker-info (cddr entry)))
+ (values (function-lambda-expression (cddr entry))))))))
\f
;;;; other environment hacking, not so SBCL-specific as the
;;;; environment hacking in the previous section
;;;; -*- Lisp -*-
-;;;; build order
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;; the dependency information manually, and the brittleness of the
;;; package system would help make most violations of the declared
;;; dependencies obvious at build time. -- WHN 20000803
-;;;
-;;; FIXME: Perhaps now that a significant number of files are built
-;;; in warm load instead of cold load, this file should now be called
-;;; cold-stems-and-flags.lisp-expr? Also, perhaps this file should move
-;;; into the src/cold directory?
(
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; miscellaneous
;; of "code/class". Why?
("src/code/class")
- ;; The definitions for CONDITION and CONDITION-CLASS depend on
- ;; SLOT-CLASS, defined in classes.lisp.
+ ;; The definition of CONDITION-CLASS depends on SLOT-CLASS, defined
+ ;; in class.lisp.
("src/code/condition" :not-host)
("src/compiler/generic/primtype")
("src/code/late-type")
("src/code/deftypes-for-target")
- ;; The inline definition of TYPEP-TO-LAYOUT here needs inline
- ;; functions defined in classes.lisp, and is needed in turn by
- ;; the target version of "code/defstruct".
- ("src/code/target-defstruct" :not-host)
-
;; defines IR1-ATTRIBUTES macro, needed by proclaim.lisp
("src/compiler/knownfun")
;; and SPECIALIZE-ARRAY-TYPE, defined in "compiler/generic/vm-type",
;; and SB!XC:PROCLAIM, defined in "src/compiler/proclaim"
("src/code/defstruct")
+ ("src/code/target-defstruct" :not-host)
;; ALIEN-VALUE has to be defined as a class (done by DEFSTRUCT
;; machinery) before we can set its superclasses here.
;; CHECK-FUN-NAME defined in proclaim.lisp.
("src/code/force-delayed-defbangstructs")
- ("src/code/typep")
+ ("src/code/typep" :not-host)
("src/compiler/compiler-error")
("src/code/debug" :not-host)
- ;; These can't be compiled until CONDITION and DEFINE-CONDITION
- ;; are defined, and they also use SB-DEBUG:*STACK-TOP-HINT*.
- ("src/code/parse-defmacro-errors" :not-host)
+ ;; The code here can't be compiled until CONDITION and
+ ;; DEFINE-CONDITION are defined and SB!DEBUG:*STACK-TOP-HINT* is
+ ;; declared special.
+ ("src/code/parse-defmacro-errors")
("src/code/bit-bash" :not-host) ; needs %NEGATE from assembly/target/arith
(defun symbol+ (&rest rest)
(values (intern (apply #'string+ rest))))
-(defun accessor-name (concname slotname)
- (symbol+ concname slotname))
+(defun accessor-name (conc-name slot-name)
+ (symbol+ conc-name slot-name))
;;; Use the ordinary FDEFINITIONs of accessors (not inline expansions)
;;; to read and write a structure slot.
-(defun read-slot-notinline (concname slotname instance)
- (funcall (accessor-name concname slotname) instance))
-(defun write-slot-notinline (new-value concname slotname instance)
- (funcall (fdefinition `(setf ,(accessor-name concname slotname)))
+(defun read-slot-notinline (conc-name slot-name instance)
+ (funcall (accessor-name conc-name slot-name) instance))
+(defun write-slot-notinline (new-value conc-name slot-name instance)
+ (funcall (fdefinition `(setf ,(accessor-name conc-name slot-name)))
new-value instance))
;;; Use inline expansions of slot accessors, if possible, to read and
;;; write a structure slot.
-(defun read-slot-inline (concname slotname instance)
+(defun read-slot-inline (conc-name slot-name instance)
(funcall (compile nil
`(lambda (instance)
- (,(accessor-name concname slotname) instance)))
+ (,(accessor-name conc-name slot-name) instance)))
instance))
-(defun write-slot-inline (new-value concname slotname instance)
+(defun write-slot-inline (new-value conc-name slot-name instance)
(funcall (compile nil
`(lambda (new-value instance)
- (setf (,(accessor-name concname slotname) instance)
+ (setf (,(accessor-name conc-name slot-name) instance)
new-value)))
new-value
instance))
;;; Read a structure slot, checking that the inline and out-of-line
;;; accessors give the same result.
-(defun read-slot (concname slotname instance)
- (let ((inline-value (read-slot-inline concname slotname instance))
- (notinline-value (read-slot-notinline concname slotname instance)))
+(defun read-slot (conc-name slot-name instance)
+ (let ((inline-value (read-slot-inline conc-name slot-name instance))
+ (notinline-value (read-slot-notinline conc-name slot-name instance)))
(assert (eql inline-value notinline-value))
inline-value))
;;; Write a structure slot, using INLINEP argument to decide
;;; on inlineness of accessor used.
-(defun write-slot (new-value concname slotname instance inlinep)
+(defun write-slot (new-value conc-name slot-name instance inlinep)
(if inlinep
- (write-slot-inline new-value concname slotname instance)
- (write-slot-notinline new-value concname slotname instance)))
+ (write-slot-inline new-value conc-name slot-name instance)
+ (write-slot-notinline new-value conc-name slot-name instance)))
;;; bound during the tests so that we can get to it even if the
;;; debugger is having a bad day
(defun has-arglist-info-p (fun)
(declare (type function fun))
;; The Lisp-level type FUNCTION can conceal a multitude of sins..
- (case (sb-kernel:get-type fun)
+ (case (sb-kernel:widetag-of fun)
((#.sb-vm:simple-fun-header-widetag #.sb-vm:closure-fun-header-widetag)
(sb-kernel:%simple-fun-arglist fun))
(#.sb-vm:closure-header-widetag (has-arglist-info-p
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.73"
+"0.pre7.74"
projects / sbcl.git / commitdiff